Skip to content

Commit

Permalink
first pass at displaying comparisons
Browse files Browse the repository at this point in the history
  • Loading branch information
@emmamendelsohn
emmamendelsohn committed Jan 12, 2024
1 parent c0a7619 commit c954ac2
Show file tree
Hide file tree
Showing 2 changed files with 81 additions and 40 deletions.
99 changes: 65 additions & 34 deletions scripts/eda/app.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -132,7 +132,7 @@ ui <- fluidPage(
column(2, checkboxGroupInput("selected_period",
"",
choices = recorded_periods,
selected = recorded_periods)),
selected = recorded_periods[1])),

column(4, shinyWidgets::sliderTextInput("selected_date",
"",
Expand All @@ -148,7 +148,6 @@ ui <- fluidPage(
# server ----------------------------------------------------------------------
server <- function(input, output, session) {

# TODO tag updating isnt working as expected - maybe generate outside of render UI and feed it in
# TODO fill in comparison table - I guess this will take the form of some if statements in the renderUI
# TODO add explanatory text
# TODO check forecast colors
Expand All @@ -169,7 +168,7 @@ server <- function(input, output, session) {
}

updateRadioButtons(session, "selected_dataset", choices = dataset_choices, inline = FALSE)
updateCheckboxGroupInput(session, "selected_period", choices = period_choices, selected = period_choices)
updateCheckboxGroupInput(session, "selected_period", choices = period_choices, selected = period_choices[1])
})

# Connection to data
Expand Down Expand Up @@ -201,42 +200,74 @@ server <- function(input, output, session) {
# Render the maps
output$maps <- renderUI({

map_list <- purrr::map(input$selected_period, function(i) {
create_arrow_leaflet(
conn = get_conn(),
field = paste0("anomaly_", input$selected_dataset, "_", i),
selected_date = input$selected_date,
palette = get_pal(),
domain = get_dom(),
include_legend = TRUE
)
})
#TODO modify map_list when we're dealing with comparisons - side by side forecast, recorded, and difference


tag_list <- purrr::map(input$selected_period, function(i){
lab <- switch(input$data_options,
"recorded_data" = "previous",
"forecast_data" = "forecast",
"comparison" = "forecast")
period_choices <- switch(input$data_options,
"recorded_data" = "recorded",
"forecast_data" = "forecast",
"comparison" = "forecast")
period_choices <- get(glue::glue("{period_choices}_periods"))
# Iterate through each selected period and generate a map
if(input$data_options %in% c("recorded_data", "forecast_data")){
map_list <- purrr::map(input$selected_period, function(i) {
create_arrow_leaflet(
conn = get_conn(),
field = paste0("anomaly_", input$selected_dataset, "_", i),
selected_date = input$selected_date,
palette = get_pal(),
domain = get_dom(),
include_legend = TRUE
)
})

paste(names(period_choices[period_choices == i]), "days", lab)
})
} else if (input$data_options == "comparison"){
map_list <- purrr::map(input$selected_period, function(i) {

selected_dataset <- stringr::str_remove(input$selected_dataset, '_forecast')

list(create_arrow_leaflet(
conn = get_conn(),
field = paste0("anomaly_", selected_dataset, "_forecast_", i),
selected_date = input$selected_date,
palette = get_pal(),
domain = get_dom(),
include_legend = TRUE
),
create_arrow_leaflet(
conn = get_conn(),
field = paste0("anomaly_", selected_dataset, "_recorded_", i),
selected_date = input$selected_date,
palette = get_pal(),
domain = get_dom(),
include_legend = TRUE
),
create_arrow_leaflet(
conn = get_conn(),
field = paste0("anomaly_", selected_dataset, "_difference_", i),
selected_date = input$selected_date,
palette = get_pal(),
domain = get_dom(),
include_legend = TRUE
)
)
})
map_list <- unlist(map_list, recursive = FALSE)
}

# Create dynamic columns
columns <- purrr::map2(map_list, tag_list, function(map, tag) {
column(4, tags$h5(tag), map)
})
# Generate an associated tag for each map
# tag_list <- purrr::map(input$selected_period, function(i){
# lab <- switch(input$data_options,
# "recorded_data" = "previous",
# "forecast_data" = "forecast",
# "comparison" = "forecast")
# period_choices <- ifelse(lab == "previous", "recorded", lab)
# period_choices <- get(glue::glue("{period_choices}_periods"))
#
# paste(names(period_choices[period_choices == i]), "days", lab)
# })

# columns <- purrr::map(map_list, function(map) {
# column(4, map)
# Create dynamic columns
# columns <- purrr::map2(map_list, tag_list, function(map, tag) {
# column(4, tags$h5(tag), map)
# })

columns <- purrr::map(map_list, function(map) {
column(4, map)
})

# Combine columns into a single list of tags
do.call(tagList, columns)
})
Expand Down
22 changes: 16 additions & 6 deletions scripts/eda/app_testing_inputs.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,15 +2,23 @@
# useful for running the code within the app

input <- list()
input$selected_dataset <- "ndvi"
input$selected_dataset <- "temperature"
input$selected_date <- model_dates_selected[[4]]
input$selected_period <- c(30, 60, 90)
input$data_options <- "recorded_data"
input$selected_period <- c(29, 59, 89)
input$data_options <- "comparison"


get_conn <- function(){
arrow::open_dataset(augmented_data) |>
dplyr::filter(date == input$selected_date)
if(input$data_options %in% c("recorded_data", "forecast_data")){

arrow::open_dataset(augmented_data) |>
dplyr::filter(date == input$selected_date)

} else if (input$data_options == "comparison"){

arrow::open_dataset(forecasts_anomalies_validate) |>
dplyr::filter(date == input$selected_date)
}
}

get_dom <- function(){
Expand All @@ -19,4 +27,6 @@ get_dom <- function(){

get_pal <- function(){
get(glue::glue("pal_{stringr::str_remove(input$selected_dataset, '_forecast')}_anomalies"))
}
}


0 comments on commit c954ac2

Please sign in to comment.