From 43416c56eb0be6b195882a5796d2ad7495997c61 Mon Sep 17 00:00:00 2001 From: Hook Date: Mon, 20 Nov 2023 10:27:59 -0500 Subject: [PATCH] zip progress file --- R/app_server.R | 12 +- R/mod_TADA_summary.R | 167 ++++++++-------- R/mod_censored_data.R | 97 +++++----- R/mod_data_flagging.R | 132 +++++++------ R/mod_filtering.R | 85 +++++--- R/mod_query_data.R | 404 +++++++++++++++++++++++++++++---------- R/sandbox.R | 0 R/utils_flag_functions.R | 18 +- R/utils_track_progress.R | 246 +++++++++++++++++------- app.R | 2 +- 10 files changed, 768 insertions(+), 395 deletions(-) create mode 100644 R/sandbox.R diff --git a/R/app_server.R b/R/app_server.R index 546772431..cb1dd73cd 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -33,7 +33,11 @@ app_server <- function(input, output, session) { shinyjs::disable(selector = '.nav li a[data-value="Review"]') # switch that indicates when a file is being loaded - tadat$load_file = NA + tadat$load_progress_file = NA + tadat$save_progress_file = NA + job_id = paste0("ts", format(Sys.time(), "%y%m%d%H%M%S")) + tadat$default_outfile = paste0("tada_output_", job_id) + tadat$job_id = job_id # switch to overview tab when tadat$new changes and provide user with window letting them know how many records were automatically flagged for removal upon upload # move this to query_data? @@ -53,6 +57,12 @@ app_server <- function(input, output, session) { } }) + # Update the default switches if a progress file is uploaded. + shiny::observeEvent(tadat$selected_flags, { + switch_defaults = tadat$selected_flags + }) + + # this observes when the user switches tabs and adds the current tab they're on as a column to their dataset. shiny::observe({ shiny::req(tadat$raw) diff --git a/R/mod_TADA_summary.R b/R/mod_TADA_summary.R index 267be6ca2..39227a0df 100644 --- a/R/mod_TADA_summary.R +++ b/R/mod_TADA_summary.R @@ -41,19 +41,21 @@ mod_TADA_summary_ui <- function(id) { )))), shiny::fluidRow(column(6, shiny::uiOutput(ns( "dwn_ts" - )))), - shiny::fluidRow(column( - 6, - shiny::fileInput( - ns("up_ts"), - "", - multiple = TRUE, - accept = ".Rdata", - width = "100%" - ) - )) - ), - shiny::fluidRow(column(2, shiny::actionButton(ns("disclaimer"), "DISCLAIMER"))), + ))))#, + # shiny::fluidRow(column( + # 6, + # shiny::fileInput( + # ns("up_ts"), + # "", + # multiple = TRUE, + # accept = ".Rdata", + # width = "100%" + # ) + # )) + ), + shiny::fluidRow(column( + 2, shiny::actionButton(ns("disclaimer"), "DISCLAIMER") + )), htmltools::br(), htmltools::br() ), @@ -75,26 +77,23 @@ mod_TADA_summary_server <- function(id, tadat) { # reactive list to hold reactive objects specific to this module summary_things = shiny::reactiveValues() - # Read the tada file - shiny::observe({ - shiny::req(input$up_ts) - # user uploaded data - readFile(tadat, input$up_ts$datapath) - }) - - # calculate the stats needed to fill the summary box + # calculate the stats needed to fill the summary box shiny::observe({ shiny::req(tadat$raw) - summary_things$rem_rec <- length(tadat$raw$ResultIdentifier[tadat$raw$TADA.Remove == - TRUE]) - summary_things$clean_rec <- length(tadat$raw$ResultIdentifier[tadat$raw$TADA.Remove == - FALSE]) - clean_sites <- unique(tadat$raw$MonitoringLocationIdentifier[tadat$raw$TADA.Remove == - FALSE]) + summary_things$rem_rec <- + length(tadat$raw$ResultIdentifier[tadat$raw$TADA.Remove == + TRUE]) + summary_things$clean_rec <- + length(tadat$raw$ResultIdentifier[tadat$raw$TADA.Remove == + FALSE]) + clean_sites <- + unique(tadat$raw$MonitoringLocationIdentifier[tadat$raw$TADA.Remove == + FALSE]) summary_things$clean_site <- length(clean_sites) - summary_things$rem_site <- length(unique(tadat$raw$MonitoringLocationIdentifier[!tadat$raw$MonitoringLocationIdentifier %in% - clean_sites])) + summary_things$rem_site <- + length(unique(tadat$raw$MonitoringLocationIdentifier[!tadat$raw$MonitoringLocationIdentifier %in% + clean_sites])) summary_things$removals <- sort_removals(tadat$removals) }) summary_things$removals <- data.frame(matrix( @@ -102,7 +101,7 @@ mod_TADA_summary_server <- function(id, tadat) { nrow = 0, dimnames = list(NULL, c("Reason", "Count")) )) - + # output$removal_summary = DT::renderDataTable( # summary_things$removals, # escape = FALSE, @@ -113,7 +112,7 @@ mod_TADA_summary_server <- function(id, tadat) { # language = list(zeroRecords = "No records removed") # ) # ) - + # summary text = total records output$rec_tot <- shiny::renderText({ if (is.null(tadat$raw)) { @@ -127,10 +126,8 @@ mod_TADA_summary_server <- function(id, tadat) { if (is.null(tadat$raw)) { "Total Results Flagged for Removal: 0" } else { - paste0( - "Total Results Flagged for Removal: ", - scales::comma(summary_things$rem_rec) - ) + paste0("Total Results Flagged for Removal: ", + scales::comma(summary_things$rem_rec)) } }) # summary text = total records in clean @@ -138,10 +135,8 @@ mod_TADA_summary_server <- function(id, tadat) { if (is.null(tadat$raw)) { "Total Results Retained: 0" } else { - paste0( - "Total Results Retained: ", - scales::comma(summary_things$clean_rec) - ) + paste0("Total Results Retained: ", + scales::comma(summary_things$clean_rec)) } }) # summary text = total sites @@ -159,10 +154,8 @@ mod_TADA_summary_server <- function(id, tadat) { if (is.null(tadat$raw)) { "Total Sites Flagged for Removal: 0" } else { - paste0( - "Total Sites Flagged for Removal: ", - scales::comma(summary_things$rem_site) - ) + paste0("Total Sites Flagged for Removal: ", + scales::comma(summary_things$rem_site)) } }) # summary text = total sites in clean file @@ -170,53 +163,64 @@ mod_TADA_summary_server <- function(id, tadat) { if (is.null(tadat$raw)) { "Total Sites Retained: 0" } else { - paste0( - "Total Sites Retained: ", - scales::comma(summary_things$clean_site) - ) + paste0("Total Sites Retained: ", + scales::comma(summary_things$clean_site)) } }) - + # download dataset button - only appears if there exists data in the app already output$dwn_all <- shiny::renderUI({ shiny::req(tadat$raw) shiny::downloadButton(ns("download_all"), - "Download Working Dataset (.xlsx)", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + "Download Working Dataset (.xlsx)", + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") }) - + output$download_all <- shiny::downloadHandler( filename = function() { - paste("TADAShiny_datadownload_", tadat$tab, ".xlsx", sep = "") + paste0(tadat$default_outfile, ".zip") }, - content = function(file) { - writexl::write_xlsx(TADA::TADA_OrderCols(tadat$raw), path = file) - } + content = function(fname) { + fs <- c() + tmpdir <- tempdir() + setwd(tempdir()) + datafile_name = paste0(tadat$default_outfile, ".xlsx") + progress_file_name = paste0(tadat$default_outfile, "_prog.RData") + desc <- writeNarrativeDataFrame(tadat) + dfs <- + list(Data = TADA::TADA_OrderCols(tadat$raw), Parameterization = desc) + writeFile(tadat, progress_file_name) + writexl::write_xlsx(dfs, path = datafile_name) + zip(zipfile = fname, + files = c(datafile_name, progress_file_name)) + }, + contentType = "application/zip" ) - # Download TADA progress file - output$dwn_ts = shiny::renderUI({ - shiny::req(tadat$raw) - shiny::downloadButton(ns("download_ts_file"), - "Download Progress File (.Rdata)", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") - }) + # # Download TADA progress file + # output$dwn_ts = shiny::renderUI({ + # shiny::req(tadat$raw) + # shiny::downloadButton(ns("download_ts_file"), + # "Download Progress File (.Rdata)", + # style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") + # }) - output$download_ts_file = shiny::downloadHandler( - filename = function() { - paste0(tadat$job_id, '.Rdata') - }, - content = function(file) { - writeFile(tadat, file) - } - ) + # output$download_ts_file = shiny::downloadHandler( + # filename = function() { + # paste0(tadat$job_id, '.Rdata') + # }, + # content = function(file) { + # writeFile(tadat, file) + # } + # ) shiny::observeEvent(input$disclaimer, { - shiny::showModal(shiny::modalDialog( - title = "Disclaimer", - "This United States Environmental Protection Agency (EPA) GitHub project code is provided on an 'as is' basis and the user assumes responsibility for its use. EPA has relinquished control of the information and no longer has responsibility to protect the integrity, confidentiality, or availability of the information. Any reference to specific commercial products, processes, or services by service mark, trademark, manufacturer, or otherwise, does not constitute or imply their endorsement, recommendation or favoring by EPA. The EPA seal and logo shall not be used in any manner to imply endorsement of any commercial product or activity by EPA or the United States Government." - )) + shiny::showModal( + shiny::modalDialog( + title = "Disclaimer", + "This United States Environmental Protection Agency (EPA) GitHub project code is provided on an 'as is' basis and the user assumes responsibility for its use. EPA has relinquished control of the information and no longer has responsibility to protect the integrity, confidentiality, or availability of the information. Any reference to specific commercial products, processes, or services by service mark, trademark, manufacturer, or otherwise, does not constitute or imply their endorsement, recommendation or favoring by EPA. The EPA seal and logo shall not be used in any manner to imply endorsement of any commercial product or activity by EPA or the United States Government." + ) + ) }) }) } @@ -232,23 +236,26 @@ sort_removals <- function(removal_table) { )) colnames(results) <- prefixes results[is.na(results)] <- FALSE - + for (prefix in prefixes) { active_cols <- fields[dplyr::starts_with(prefix, vars = fields)] if (length(active_cols) > 0) { - results[prefix] <- apply(dplyr::select(removal_table, active_cols), 1, any) + results[prefix] <- + apply(dplyr::select(removal_table, active_cols), 1, any) } } totals <- rowSums(results) results["Flag only"] <- ((totals == 1) & results$Flag) results["Flag and Filter"] <- (results$Flag & results$Filter) results["Filter only"] <- ((totals == 1) & results$Filter) - results <- dplyr::select(results, -intersect(prefixes, colnames(results))) + results <- + dplyr::select(results,-intersect(prefixes, colnames(results))) results$Many <- rowSums(results) > 2 results$Retained <- !apply(results, 1, any) counts <- colSums(results) - counts <- data.frame(Reason = names(counts), Count = as.vector(counts)) - counts <- counts[(counts$Count > 0), ] + counts <- + data.frame(Reason = names(counts), Count = as.vector(counts)) + counts <- counts[(counts$Count > 0),] return(counts) } } diff --git a/R/mod_censored_data.R b/R/mod_censored_data.R index 58b5a762c..805105fff 100644 --- a/R/mod_censored_data.R +++ b/R/mod_censored_data.R @@ -36,22 +36,25 @@ mod_censored_data_ui <- function(id) { shiny::fluidRow( column( 3, - shiny::selectInput( + shiny::selectizeInput( ns("nd_method"), "Non-Detect Handling Method", choices = nd_method_options, - multiple = FALSE + selected = nd_method_options[1], + multiple = TRUE, + options = list(maxItems = 1) ) ), column(3, shiny::uiOutput(ns("nd_mult"))), column( 3, - shiny::selectInput( + shiny::selectizeInput( ns("od_method"), "Over-Detect Handling Method", choices = od_method_options, - selected = "No change", - multiple = FALSE + selected = od_method_options[2], + multiple = TRUE, + options = list(maxItems = 1) ) ), column(3, shiny::uiOutput(ns("od_mult"))) @@ -147,21 +150,30 @@ mod_censored_data_server <- function(id, tadat) { # this adds the multiplier numeric input next to the method selection if the nd method selected is to mult det limit by x + output$nd_mult <- shiny::renderUI({ - if (input$nd_method == "Multiply detection limit by x") { + init_val = tadat$nd_mult + if (is.null(init_val)){ + init_val = 0.5 + } + if (input$nd_method == nd_method_options[1]) { shiny::numericInput(ns("nd_mult"), "Multiplier (x)", - value = 0.5, + value = init_val, min = 0) } }) # this adds the multiplier numeric input next to the method selection if the od method selected is to mult det limit by x output$od_mult <- shiny::renderUI({ - if (input$od_method == "Multiply detection limit by x") { + init_val = tadat$od_mult + if (is.null(init_val)){ + init_val = 0.5 + } + if (input$od_method == od_method_options[1]) { shiny::numericInput(ns("od_mult"), "Multiplier (x)", - value = 1, + value = init_val, min = 0) } }) @@ -170,46 +182,39 @@ mod_censored_data_server <- function(id, tadat) { # initialize global variables for saving/loading tadat$censor_applied = FALSE - shiny::observe({ - print("Something changed") - checkStatus("Before") - tadat$nd_method = input$nd_method - tadat$od_method = input$od_method - tadat$nd_mult = input$nd_mult - tadat$od_mult = input$od_mult - checkStatus("After") - - }) - shiny::observeEvent(tadat$load_file, { - if (!is.na(tadat$load_file)) { - print("Loading from progress file") - checkStatus("Before") - shiny::updateSelectInput(session, - "nd_method", - choices = nd_method_options, - selected = tadat$nd_method) - shiny::updateSelectInput(session, - "od_method", - choices = nd_method_options, - selected = tadat$od_method) + shiny::observeEvent(tadat$load_progress_file, { + if (!is.na(tadat$load_progress_file)) { + shiny::updateSelectizeInput(session, + "nd_method", + choices = nd_method_options, + selected = tadat$nd_method) + shiny::updateSelectizeInput(session, + "od_method", + choices = od_method_options, + selected = tadat$od_method) shiny::updateNumericInput(session, "nd_mult", value = tadat$nd_mult) shiny::updateNumericInput(session, "od_mult", value = tadat$od_mult) - checkStatus("After") } }) - checkStatus <- function(label){ - print(paste0(label, " status:")) - print(paste0("tadat$nd_method: ", tadat$nd_method)) - print(paste0("input$nd_method: ", input$nd_method)) - print(paste0("tadat$od_method: ", tadat$od_method)) - print(paste0("input$od_method: ", input$od_method)) - print(paste0("tadat$nd_mult: ", tadat$nd_mult)) - print(paste0("input$nd_mult: ", input$nd_mult)) - print(paste0("tadat$od_mult: ", tadat$od_mult)) - print(paste0("input$od_mult: ", input$od_mult)) - } + # Make this part more concise? + shiny::observeEvent(input$nd_method, { + tadat$nd_method = input$nd_method + }) + + shiny::observeEvent(input$nd_mult, { + tadat$nd_mult = input$nd_mult + }) + + shiny::observeEvent(input$od_method, { + tadat$od_method = input$od_method + }) + + shiny::observeEvent(input$od_mult, { + tadat$od_mult = input$od_mult + }) + # Button to apply the simple methods to the nd and od results in the dataset. shiny::observeEvent(input$apply_methods, { @@ -225,11 +230,7 @@ mod_censored_data_server <- function(id, tadat) { subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) # keep the "goods" that will be run through the simpleCensoredMethods function trans <- data.frame( - input = c( - "Multiply detection limit by x", - "Random number between 0 and detection limit", - "No change" - ), + input = nd_method_options, actual = c("multiplier", "randombelowlimit", "as-is") ) if (is.null(input$nd_mult)) { diff --git a/R/mod_data_flagging.R b/R/mod_data_flagging.R index a77bfb332..7cd65d765 100644 --- a/R/mod_data_flagging.R +++ b/R/mod_data_flagging.R @@ -12,34 +12,48 @@ mod_data_flagging_ui <- function(id) { ns <- NS(id) tagList( - tags$div( - style = "display: none;", - shinyWidgets::prettySwitch("dummy", label = NULL) - ), + tags$div(style = "display: none;", + shinyWidgets::prettySwitch("dummy", label = NULL)), htmltools::h3("Flag data for potential issues"), - htmltools::HTML("Click the button below to run a series of tests that check for quality control issues or data formats not compatible with TADA. When the tests are finished running, a table will appear below. Each row describes an evaluation test, reports the number of results affected, and contains a switch users may toggle on/off to decide whether to flag results for removal. However, evaluation tests marked as Required have permanently 'ON' light blue switches that cannot be changed. Recommended tests are automatically switched 'ON' (darker blue), and Optional tests are automatically switched 'OFF' (gray)."), + htmltools::HTML( + "Click the button below to run a series of tests that check for quality control issues or data formats not compatible with TADA. When the tests are finished running, a table will appear below. Each row describes an evaluation test, reports the number of results affected, and contains a switch users may toggle on/off to decide whether to flag results for removal. However, evaluation tests marked as Required have permanently 'ON' light blue switches that cannot be changed. Recommended tests are automatically switched 'ON' (darker blue), and Optional tests are automatically switched 'OFF' (gray)." + ), htmltools::div(style = "margin-bottom:10px"), shiny::fluidRow(column( 3, shiny::actionButton(ns("runFlags"), - "Run Tests", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + "Run Tests", + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") )), htmltools::div(style = "margin-bottom:10px"), DT::DTOutput(ns("flagTable")), htmltools::br(), htmltools::h3("Convert depth units (Optional)"), - htmltools::HTML("Depth units in the dataset are automatically converted to meters upon data retrieval. Click the radio buttons below to convert depth units to feet, inches, or back to meters."), - shiny::fluidRow(column(6, shiny::radioButtons(ns("m2f"), label = "", choices = c("feet", "inches", "meters"), selected = character(0), inline = TRUE))) + htmltools::HTML( + "Depth units in the dataset are automatically converted to meters upon data retrieval. Click the radio buttons below to convert depth units to feet, inches, or back to meters." + ), + shiny::fluidRow(column( + 6, + shiny::radioButtons( + ns("m2f"), + label = "", + choices = c("feet", "inches", "meters"), + selected = character(0), + inline = TRUE + ) + )) ) } mod_data_flagging_server <- function(id, tadat) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns - flags <- shiny::reactiveValues() + values <- shiny::reactiveValues() + values$n_fails <- integer(length(n_switches)) + tadat$selected_flags <- character() + tadat$switch_defaults <- prompt_table$Level != "Optional" + switch_disabled <- prompt_table$Level == "Required" flagSwitch <- function(len) { inputs <- character(len) @@ -50,7 +64,7 @@ mod_data_flagging_server <- function(id, tadat) { shinyWidgets::prettySwitch( ns(switch_name), label = NULL, - value = switch_defaults[i], + value = tadat$switch_defaults[i], status = "primary", fill = TRUE ) @@ -61,7 +75,7 @@ mod_data_flagging_server <- function(id, tadat) { } inputs } - + shinyValue <- function(id, len) { unlist(lapply(seq_len(len), function(i) { value <- input[[paste0(id, i)]] @@ -72,13 +86,41 @@ mod_data_flagging_server <- function(id, tadat) { } })) } - - # Create a separate column in the raw data to indicate whether records - # were excluded during the first step - values <- shiny::reactiveValues() - values$n_fails <- integer(length(n_switches)) - tadat$selected_flags <- character() - + + + + + # Runs whenever selected flags are changed + shiny::observeEvent(tadat$selected_flags, { + prefix = "Flag: " + if (!is.null(tadat$removals)) { + tadat$removals = dplyr::select(tadat$removals,-(dplyr::starts_with(prefix))) + } + # Loop through the flags + for (flag in tadat$selected_flags) { + # If not all the values are NA, add the test results to removals + if (!is.null(tadat$removals)) { + if (!all(is.na(values$testResults[flag]))) { + tadat$removals[paste0(prefix, flag)] = values$testResults[flag] + } + } + # If the switch corresponding to this flag isn't on, switch it on + # Checking a random switch to make sure they've been initialized + pos = match(flag, prompts) + tadat$switch_defaults[pos] = TRUE + if (!is.null(input[[paste0("switch_", pos)]])) { + switch_name = paste0("switch_", pos) + if (is.na(pos)) { + invalidFile("flagging") + } else if (!isTRUE(input[[switch_name]])) { + # Turn the switch on if it isn't already + shinyWidgets::updatePrettySwitch(inputId = switch_name, + value = TRUE) + } + } + } + }) + # Runs when the flag button is clicked shiny::observeEvent(input$runFlags, { shinybusy::show_modal_spinner( @@ -92,17 +134,16 @@ mod_data_flagging_server <- function(id, tadat) { #tadat$raw <- applyFlags(tadat$raw, tadat$orgs) #write.csv(tadat$raw, "flagged.csv") tadat$raw = utils::read.csv("flagged.csv") # THIS IS TRIPS WORKING FILE FOR TESTING, COMMENT OUT WHEN COMMITTING TO DEVELOP - + # A table (raw rows, flags) indicating whether each record passes each test values$testResults <- flagCensus(tadat$raw) - + # The number of records failing each test values$n_fails <- colSums(values$testResults) - + # Remove progress bar and display instructions shinybusy::remove_modal_spinner(session = shiny::getDefaultReactiveDomain()) - - + # Runs when any of the flag switches are changed shiny::observe({ switch_id = "switch_" @@ -112,31 +153,6 @@ mod_data_flagging_server <- function(id, tadat) { } }) - # Runs whenever selected flags are changed - shiny::observeEvent(tadat$selected_flags, { - prefix = "Flag: " - tadat$removals = dplyr::select(tadat$removals,-(dplyr::starts_with(prefix))) - # Loop through the flags - for (flag in tadat$selected_flags) { - # If not all the values are NA, add the test results to removals - if (!all(is.na(values$testResults[flag]))) { - tadat$removals[paste0(prefix, flag)] = values$testResults[flag] - } - # If the switch corresponding to this flag isn't on, switch it on - if (!is.null(input[["switch_1"]])) { - pos = match(flag, prompts) - switch_name = paste0("switch_", pos) - if (is.na(pos)) { - invalidFile("flagging") - } else if (!isTRUE(input[[switch_name]])) { - # Turn the switch on - shinyWidgets::updatePrettySwitch(inputId = switch_name, - value = TRUE) - } - } - } - }) - switchTable <- shiny::reactive({ df <- data.frame( Reason = prompts, @@ -145,7 +161,7 @@ mod_data_flagging_server <- function(id, tadat) { Decision = flagSwitch(n_switches) ) }) - + output$flagTable <- DT::renderDT( shiny::isolate(switchTable()), escape = FALSE, @@ -175,10 +191,9 @@ mod_data_flagging_server <- function(id, tadat) { shinyjs::enable(selector = '.nav li a[data-value="Figures"]') shinyjs::enable(selector = '.nav li a[data-value="Review"]') }) - + shiny::observeEvent(tadat$m2f, { - print("tadat$m2f changed") - updateRadioButtons(session, "m2f", selected=tadat$m2f) + updateRadioButtons(session, "m2f", selected = tadat$m2f) }) shiny::observeEvent(input$m2f, { @@ -191,7 +206,8 @@ mod_data_flagging_server <- function(id, tadat) { text = "Converting depth units to feet...", session = shiny::getDefaultReactiveDomain() ) - tadat$raw <- TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "ft") + tadat$raw <- + TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "ft") } if (input$m2f == "inches") { shinybusy::show_modal_spinner( @@ -200,7 +216,8 @@ mod_data_flagging_server <- function(id, tadat) { text = "Converting depth units to inches...", session = shiny::getDefaultReactiveDomain() ) - tadat$raw <- TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "in") + tadat$raw <- + TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "in") } if (input$m2f == "meters") { shinybusy::show_modal_spinner( @@ -209,7 +226,8 @@ mod_data_flagging_server <- function(id, tadat) { text = "Converting depth units to meters...", session = shiny::getDefaultReactiveDomain() ) - tadat$raw <- TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "m") + tadat$raw <- + TADA::TADA_ConvertDepthUnits(tadat$raw, unit = "m") } shinybusy::remove_modal_spinner(session = shiny::getDefaultReactiveDomain()) }) diff --git a/R/mod_filtering.R b/R/mod_filtering.R index 6663c7e9d..51d0b87aa 100644 --- a/R/mod_filtering.R +++ b/R/mod_filtering.R @@ -14,15 +14,13 @@ mod_filtering_ui <- function(id) { column( 3, shiny::actionButton(ns("addOnlys"), "Include Only Selected Values", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ), column( 3, shiny::actionButton(ns("addExcludes"), "Exclude Selected Values", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ) ), htmltools::br(), @@ -38,15 +36,13 @@ mod_filtering_ui <- function(id) { 3, shiny::actionButton(ns("removeFilters"), "Reset Selected Filters", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ), column( 3, shiny::actionButton(ns("resetFilters"), "Reset All Filters", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ) ) ) @@ -69,8 +65,10 @@ mod_filtering_server <- function(id, tadat) { shiny::req(tadat$tab) if (tadat$tab == "Filter") { # only show unique values from data that have not been flagged for removal - tables$dat <- subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) - tables$filter_fields <- TADA::TADA_FieldCounts(tables$dat, display = "key") + tables$dat <- + subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) + tables$filter_fields <- + TADA::TADA_FieldCounts(tables$dat, display = "key") } }) @@ -90,9 +88,11 @@ mod_filtering_server <- function(id, tadat) { # When key column selected, get unique values for that column shiny::observeEvent(input$filterStep1_rows_selected, { # Get the name of the selected field - values$selected_field <- tables$filter_fields[input$filterStep1_rows_selected, ]$Field + values$selected_field <- + tables$filter_fields[input$filterStep1_rows_selected,]$Field applyLocks() - tables$filter_values <- data.frame(getValues(tables$dat, values$selected_field)) + tables$filter_values <- + data.frame(getValues(tables$dat, values$selected_field)) output$promptStep2 <- shiny::renderUI(HTML( paste0( "

Filter by '", @@ -105,6 +105,7 @@ mod_filtering_server <- function(id, tadat) { shinyjs::show("addExcludes") }) + # show unique values for selected column output$filterStep2 <- DT::renderDT( tables$filter_values, @@ -120,9 +121,10 @@ mod_filtering_server <- function(id, tadat) { # empty selected table on open tadat$selected_filters <- data.frame(matrix( - ncol = 4, + ncol = 3, + # 4 with count nrow = 0, - dimnames = list(NULL, c("Field", "Value", "Filter", "Count")) + dimnames = list(NULL, c("Field", "Value", "Filter")) # count )) # selected table at bottom @@ -170,7 +172,13 @@ mod_filtering_server <- function(id, tadat) { # reset all filters in bottom table shiny::observeEvent(input$resetFilters, { - tadat$selected_filters = tadat$selected_filters[0, ] + # empty selected table on open + tadat$selected_filters <- + data.frame(matrix( + ncol = 4, + nrow = 0, + dimnames = list(NULL, c("Field", "Value", "Filter", "Count")) + )) }) # reset selected filters in bottom table @@ -183,7 +191,7 @@ mod_filtering_server <- function(id, tadat) { ) ) } else{ - tadat$selected_filters = tadat$selected_filters[-input$selectedFilters_rows_selected, ] + tadat$selected_filters = tadat$selected_filters[-input$selectedFilters_rows_selected,] } }) @@ -195,14 +203,12 @@ mod_filtering_server <- function(id, tadat) { rows <- input$filterStep2_rows_selected Field <- values$selected_field Value <- tables$filter_values[rows, "Value"] - Count <- tables$filter_values[rows, "Count"] + Count <- rep(0, length(rows)) new_rows <- data.frame(Field, Value, Filter, Count) # Adds the newly selected field/vals to the Selected table tadat$selected_filters = rbind(tadat$selected_filters, new_rows) tadat$selected_filters = tadat$selected_filters %>% dplyr::distinct(Field, Value, .keep_all = TRUE) - # Locks the value of the selected field to "Include" or "Exclude" - #values$locked[values$selected_field] = Filter } ##### @@ -210,7 +216,8 @@ mod_filtering_server <- function(id, tadat) { # This is necessary because including ONLY certain values from a field # will inherently exclude all others, so there can't be mixing shiny::observeEvent(tables$selected, { - still_present <- intersect(names(values$locked), unique(tables$selected$Field)) + still_present <- + intersect(names(values$locked), unique(tables$selected$Field)) values$locked <- values$locked[still_present] }) @@ -231,6 +238,7 @@ mod_filtering_server <- function(id, tadat) { shinyjs::disable("addOnlys") shinyjs::disable("addExcludes") } + } shiny::observeEvent(values$locked, { @@ -240,20 +248,20 @@ mod_filtering_server <- function(id, tadat) { # This gets run whenever a change in selected filters happens shiny::observeEvent(tadat$selected_filters, { - - # Apply field locks + # Apply field locks field_filters = dplyr::distinct(tadat$selected_filters, Field, Filter) values$locked = field_filters$Filter names(values$locked) <- field_filters$Field - prefix = "Filter: " # Remove all the filter columns from the removals table (start fresh) if (!is.null(tadat$removals)) { - tadat$removals <- dplyr::select(tadat$removals, -(dplyr::starts_with(prefix))) + tadat$removals <- + dplyr::select(tadat$removals,-(dplyr::starts_with(prefix))) } # Only proceed if filters have been selected - if (nrow(tadat$selected_filters) > 0) { + if (!(is.null(tadat$raw)) & + (nrow(tadat$selected_filters) > 0)) { # Since filters have been added, enable the ability to reset them shinyjs::enable("resetFilters") shinyjs::enable("removeFilters") @@ -261,7 +269,8 @@ mod_filtering_server <- function(id, tadat) { # Loop through the filters field-by-field for (active_field in unique(tadat$selected_filters$Field)) { filter_type <- values$locked[active_field] - field_filters <- tadat$selected_filters[tadat$selected_filters == active_field, ] + field_filters <- + tadat$selected_filters[tadat$selected_filters == active_field,] results <- rep(FALSE, nrow(tadat$raw)) for (row in 1:nrow(field_filters)) { sel <- (tadat$raw[[active_field]] == field_filters[row, "Value"]) @@ -273,16 +282,34 @@ mod_filtering_server <- function(id, tadat) { results <- !results } all_vals <- paste(field_filters$Value, collapse = " or ") - label <- paste0(prefix, filter_type, " ", active_field, " is ", all_vals) + label <- + paste0(prefix, filter_type, " ", active_field, " is ", all_vals) tadat$removals[label] <- as.logical(results) } } + + # Get counts for the filters + if (!is.null(tables$dat) & nrow(tadat$selected_filters > 0)) { + # Refresh the 'count' field + new_selected_filters <- tadat$selected_filters + new_selected_filters$Count <- NULL + new_selected_filters <- cbind(new_selected_filters, Count=0) + for (i in 1:nrow(new_selected_filters)) { + row = new_selected_filters[i, ] + values = getValues(tables$dat, row$Field) + new_selected_filters[i, "Count"] = + sum(values[(values$Value == row$Value), "Count"], na.rm = TRUE) + } + tadat$selected_filters = new_selected_filters + } }) + getValues <- function(.data, field) { counts <- table(.data[[field]], useNA = "ifany") if (length(rownames(counts) > 0)) { - value_table <- data.frame(Value = names(counts), Count = as.vector(counts)) + value_table <- + data.frame(Value = names(counts), Count = as.vector(counts)) } else { value_table <- data.frame(Value = character(), Count = integer()) } @@ -290,3 +317,5 @@ mod_filtering_server <- function(id, tadat) { } }) } + + diff --git a/R/mod_query_data.R b/R/mod_query_data.R index 84c6676ad..ebc9bf106 100644 --- a/R/mod_query_data.R +++ b/R/mod_query_data.R @@ -30,65 +30,183 @@ mod_query_data_ui <- function(id) { tagList( shiny::fluidRow( htmltools::h3("Option A: Use example data"), - column(3, shiny::selectInput(ns("example_data"), "Use example data", choices = c("", "Nutrients Utah (15k results)", "Shepherdstown (34k results)", "Tribal (132k results)"))) + column(3, shiny::selectInput( + ns("example_data"), + "Use example data", + choices = c( + "", + "Nutrients Utah (15k results)", + "Shepherdstown (34k results)", + "Tribal (132k results)" + ) + )) ), - shiny::fluidRow(column(3, shiny::actionButton(ns("example_data_go"), "Load", shiny::icon("truck-ramp-box"), - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ))), + shiny::fluidRow(column( + 3, + shiny::actionButton( + ns("example_data_go"), + "Load", + shiny::icon("truck-ramp-box"), + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" + ) + )), htmltools::hr(), shiny::fluidRow( htmltools::h3("Option B: Query the Water Quality Portal (WQP)"), "Use the fields below to download a dataset directly from WQP. Fields with '(s)' in the label allow multiple selections. Hydrologic Units may be at any scale, from subwatershed to region. However, be mindful that large queries may time out." ), - htmltools::br(), # styling several fluid rows with columns to hold the input drop down widgets + htmltools::br(), + # styling several fluid rows with columns to hold the input drop down widgets htmltools::h4("Date Range"), - shiny::fluidRow( - column(4, shiny::dateInput(ns("startdate"), "Start Date", format = "yyyy-mm-dd", startview = "year")), - column(4, shiny::dateInput(ns("enddate"), "End Date", format = "yyyy-mm-dd", startview = "year")) + shiny::fluidRow(column( + 4, + shiny::dateInput( + ns("startdate"), + "Start Date", + format = "yyyy-mm-dd", + startview = "year" + ) ), + column( + 4, + shiny::dateInput( + ns("enddate"), + "End Date", + format = "yyyy-mm-dd", + startview = "year" + ) + )), htmltools::h4("Location Information"), shiny::fluidRow( column(4, shiny::selectizeInput(ns("state"), "State", choices = NULL)), - column(4, shiny::selectizeInput(ns("county"), "County (pick state first)", choices = NULL)), - column(4, shiny::textInput(ns("huc"), "Hydrologic Unit", placeholder = "e.g. 020700100103")) + column( + 4, + shiny::selectizeInput(ns("county"), "County (pick state first)", choices = NULL) + ), + column( + 4, + shiny::textInput(ns("huc"), "Hydrologic Unit", placeholder = "e.g. 020700100103") + ) ), - shiny::fluidRow(column(4, shiny::selectizeInput(ns("siteid"), "Monitoring Location ID(s)", choices = NULL, multiple = TRUE))), + shiny::fluidRow(column( + 4, + shiny::selectizeInput( + ns("siteid"), + "Monitoring Location ID(s)", + choices = NULL, + multiple = TRUE + ) + )), htmltools::h4("Metadata Filters"), shiny::fluidRow( - column(4, shiny::selectizeInput(ns("org"), "Organization(s)", choices = NULL, multiple = TRUE)), - column(4, shiny::selectizeInput(ns("proj"), "Project(s)", choices = NULL, multiple = TRUE)), - column(4, shiny::selectizeInput(ns("type"), "Site Type(s)", choices = c(sitetype), multiple = TRUE)) + column( + 4, + shiny::selectizeInput( + ns("org"), + "Organization(s)", + choices = NULL, + multiple = TRUE + ) + ), + column( + 4, + shiny::selectizeInput( + ns("proj"), + "Project(s)", + choices = NULL, + multiple = TRUE + ) + ), + column( + 4, + shiny::selectizeInput( + ns("type"), + "Site Type(s)", + choices = c(sitetype), + multiple = TRUE + ) + ) ), shiny::fluidRow( - column(4, shiny::selectizeInput(ns("media"), tags$span( - "Sample Media", - tags$i( - class = "glyphicon glyphicon-info-sign", - style = "color:#0072B2;", - title = "At present, TADA is only designed to work with water sample media" + column( + 4, + shiny::selectizeInput( + ns("media"), + tags$span( + "Sample Media", + tags$i( + class = "glyphicon glyphicon-info-sign", + style = "color:#0072B2;", + title = "At present, TADA is only designed to work with water sample media" + ) + ), + choices = c("", media), + selected = c("Water", "water"), + multiple = TRUE + ) + ), + column( + 4, + shiny::selectizeInput(ns("chargroup"), "Characteristic Group", choices = NULL) + ), + column( + 4, + shiny::selectizeInput( + ns("characteristic"), + "Characteristic(s)", + choices = NULL, + multiple = TRUE ) - ), choices = c("", media), selected = c("Water", "water"), multiple = TRUE)), - column(4, shiny::selectizeInput(ns("chargroup"), "Characteristic Group", choices = NULL)), - column(4, shiny::selectizeInput(ns("characteristic"), "Characteristic(s)", choices = NULL, multiple = TRUE)) + ) ), - shiny::fluidRow(column(4, shiny::actionButton(ns("querynow"), "Run Query", shiny::icon("cloud"), - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ))), + shiny::fluidRow(column( + 4, + shiny::actionButton(ns("querynow"), "Run Query", shiny::icon("cloud"), + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") + )), htmltools::hr(), shiny::fluidRow( htmltools::h3("Option C: Upload dataset"), - htmltools::HTML(("Select a file from your computer. This upload feature currently only accepts data in .xls and .xlsx formats. + htmltools::HTML(( + "Select a file from your computer. This upload feature currently only accepts data in .xls and .xlsx formats. The file can be a fresh TADA dataset or a working TADA dataset that you are returning to the app to iterate on. Data must also be formatted in the EPA Water Quality eXchange (WQX) schema to leverage this tool. You may reach out to the WQX helpdesk at WQX@epa.gov for assistance preparing and submitting your data - to the WQP through EPA's WQX.")), + to the WQP through EPA's WQX." + ) + ), # widget to upload WQP profile or WQX formatted spreadsheet - column(9, shiny::fileInput(ns("file"), "", - multiple = TRUE, - accept = c(".xlsx", ".xls"), - width = "100%" - )) - ) + column( + 9, + shiny::fileInput( + ns("file"), + "", + multiple = TRUE, + accept = c(".xlsx", ".xls"), + width = "100%" + ) + ) + ), + + htmltools::hr(), + shiny::fluidRow( + htmltools::h3("Upload Progress File"), + htmltools::HTML(( + "Upload a progress file. These files can be used to automatically parameterize the TADA Shiny app." + ) + ), + # widget to upload WQP profile or WQX formatted spreadsheet + column( + 9, + shiny::fileInput( + ns("progress_file"), + "", + multiple = TRUE, + accept = c(".RData"), + width = "100%" + ) + ) + ), ) } @@ -98,17 +216,29 @@ mod_query_data_ui <- function(id) { mod_query_data_server <- function(id, tadat) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns - + # read in the excel spreadsheet dataset if this input reactive object is populated via fileInput and define as tadat$raw shiny::observe({ shiny::req(input$file) # user uploaded data - raw <- suppressWarnings(readxl::read_excel(input$file$datapath, sheet = 1)) + raw <- + suppressWarnings(readxl::read_excel(input$file$datapath, sheet = 1)) initializeTable(tadat, raw) + if (!is.null(tadat$original_source)){ + tadat$original_source <- "Upload" + } }) - + + # Read the TADA progress file + shiny::observe({ + shiny::req(input$progress_file) + # user uploaded data + readFile(tadat, input$progress_file$datapath) + }) + # if user presses example data button, make tadat$raw the nutrients dataset contained within the TADA package. shiny::observeEvent(input$example_data_go, { + tadat$example_data <- input$example_data if (input$example_data == "Shepherdstown (34k results)") { raw <- TADA::Data_NCTCShepherdstown_HUC12 } @@ -120,99 +250,129 @@ mod_query_data_server <- function(id, tadat) { } initializeTable(tadat, raw) }) - + # this section has widget update commands for the selectizeinputs that have a lot of possible selections - shiny suggested hosting the choices server-side rather than ui-side - shiny::updateSelectizeInput(session, "state", - choices = c(unique(statecodes_df$STUSAB)), selected = character(0), - options = list(placeholder = "Select state", maxItems = 1), server = TRUE + shiny::updateSelectizeInput( + session, + "state", + choices = c(unique(statecodes_df$STUSAB)), + selected = character(0), + options = list(placeholder = "Select state", maxItems = 1), + server = TRUE ) - shiny::updateSelectizeInput(session, "org", choices = c(orgs), server = TRUE) - shiny::updateSelectizeInput(session, "chargroup", - choices = c(chargroup), selected = character(0), - options = list(placeholder = ""), server = TRUE + shiny::updateSelectizeInput(session, + "org", + choices = c(orgs), + server = TRUE) + shiny::updateSelectizeInput( + session, + "chargroup", + choices = c(chargroup), + selected = character(0), + options = list(placeholder = ""), + server = TRUE ) - shiny::updateSelectizeInput(session, "characteristic", choices = c(chars), server = TRUE) - shiny::updateSelectizeInput(session, "proj", choices = c(projects), server = TRUE) - shiny::updateSelectizeInput(session, "siteid", + shiny::updateSelectizeInput(session, + "characteristic", + choices = c(chars), + server = TRUE) + shiny::updateSelectizeInput(session, + "proj", + choices = c(projects), + server = TRUE) + shiny::updateSelectizeInput( + session, + "siteid", choices = c(mlids), - options = list(placeholder = "Start typing or use drop down menu"), server = TRUE + options = list(placeholder = "Start typing or use drop down menu"), + server = TRUE ) - + # this observes when the user inputs a state into the drop down and subsets the choices for counties to only those counties within that state. shiny::observeEvent(input$state, { state_counties <- subset(county, county$STUSAB == input$state) - shiny::updateSelectizeInput(session, "county", - choices = c(unique(state_counties$COUNTY_NAME)), selected = character(0), - options = list( - placeholder = "Select county", - maxItems = 1 - ), server = TRUE + shiny::updateSelectizeInput( + session, + "county", + choices = c(unique(state_counties$COUNTY_NAME)), + selected = character(0), + options = list(placeholder = "Select county", + maxItems = 1), + server = TRUE ) }) - + + # remove the modal once the dataset has been pulled + shinybusy::remove_modal_spinner(session = shiny::getDefaultReactiveDomain()) + + # this event observer is triggered when the user hits the "Query Now" button, and then runs the TADAdataRetrieval function shiny::observeEvent(input$querynow, { + tadat$original_source <- "Query" # convert to null when needed - if (input$state == "") { # changing inputs of "" or NULL to "null" - statecode <- "null" + if (input$state == "") { + # changing inputs of "" or NULL to "null" + tadat$statecode <- "null" } else { - statecode <- input$state + tadat$statecode <- input$state } if (input$county == "") { - countycode <- "null" + tadat$countycode <- "null" } else { - countycode <- input$county + tadat$countycode <- input$county } if (input$huc == "") { - huc <- "null" + tadat$huc <- "null" } else { - huc <- input$huc + tadat$huc <- input$huc } if (is.null(input$type)) { - siteType <- "null" + tadat$siteType <- "null" } else { - siteType <- input$type + tadat$siteType <- input$type } if (input$chargroup == "") { - characteristicType <- "null" + tadat$characteristicType <- "null" } else { - characteristicType <- input$chargroup + tadat$characteristicType <- input$chargroup } if (is.null(input$characteristic)) { - characteristicName <- "null" + tadat$characteristicName <- "null" } else { - characteristicName <- input$characteristic + tadat$characteristicName <- input$characteristic } if (is.null(input$media)) { - sampleMedia <- "null" + tadat$sampleMedia <- "null" } else { - sampleMedia <- input$media + tadat$sampleMedia <- input$media } if (is.null(input$proj)) { - project <- "null" + tadat$project <- "null" } else { - project <- input$proj + tadat$project <- input$proj } if (is.null(input$org)) { - organization <- "null" + tadat$organization <- "null" } else { - organization <- input$org + tadat$organization <- input$org } if (is.null(input$siteid)) { - siteid <- "null" + tadat$siteid <- "null" } else { - siteid <- input$siteid + tadat$siteid <- input$siteid # siteid = stringr::str_trim(unlist(strsplit(input$siteids,","))) } - if (length(input$enddate) == 0) { # ensure if date is empty, the query receives a proper input ("null") - enddate <- "null" + if (length(input$enddate) == 0) { + # ensure if date is empty, the query receives a proper input ("null") + tadat$enddate <- "null" } else { - enddate <- as.character(input$enddate) + tadat$enddate <- as.character(input$enddate) } - if (length(input$startdate) == 0) { # ensure if date is empty, the query receives a proper start date. Might want a warning message instead. - startdate <- "1800-01-01" + if (length(input$startdate) == 0) { + # ensure if date is empty, the query receives a proper start date. Might want a warning message instead. + tadat$startdate <- "1800-01-01" } else { - startdate <- as.character(input$startdate) + tadat$startdate <- as.character(input$startdate) } # a modal that pops up showing it's working on querying the portal shinybusy::show_modal_spinner( @@ -221,36 +381,71 @@ mod_query_data_server <- function(id, tadat) { text = "Querying WQP database...", session = shiny::getDefaultReactiveDomain() ) + # storing the output of TADAdataRetrieval with the user's input choices as a reactive object named "raw" in the tadat list. raw <- TADA::TADA_DataRetrieval( - statecode = statecode, - countycode = countycode, - huc = huc, - siteid = siteid, - siteType = siteType, - characteristicName = characteristicName, - characteristicType = characteristicType, - sampleMedia = sampleMedia, - project = project, - organization = organization, - startDate = startdate, - endDate = enddate, + statecode = tadat$statecode, + countycode = tadat$countycode, + huc = tadat$huc, + siteid = tadat$siteid, + siteType = tadat$siteType, + characteristicName = tadat$characteristicName, + characteristicType = tadat$characteristicType, + sampleMedia = tadat$sampleMedia, + project = tadat$project, + organization = tadat$organization, + startDate = tadat$startdate, + endDate = tadat$enddate, applyautoclean = TRUE ) + # remove the modal once the dataset has been pulled shinybusy::remove_modal_spinner(session = shiny::getDefaultReactiveDomain()) - + # show a modal dialog box when tadat$raw is empty and the query didn't return any records. # but if tadat$raw isn't empty, perform some initial QC of data that aren't media type water or have NA Resultvalue and no detection limit data if (dim(raw)[1] < 1) { - shiny::showModal(shiny::modalDialog( - title = "Empty Query", - "Your query returned zero results. Please adjust your search inputs and try again." - )) + shiny::showModal( + shiny::modalDialog( + title = "Empty Query", + "Your query returned zero results. Please adjust your search inputs and try again." + ) + ) } else { initializeTable(tadat, raw) } }) + + # Update the run parameters if example data is selected + shiny::observeEvent(input$example_data_go, { + tadat$original_source <- "Example" + }) + + # Populate the boxes if a progress file is loaded + shiny::observeEvent(tadat$load_progress_file, { + if (!is.na(tadat$load_progress_file)) { + if (tadat$original_source == "Example") { + shiny::updateSelectInput(session, "example_data", selected = tadat$example_data) + } else if (tadat$original_source == "Query") { + shiny::updateSelectizeInput(session, "state", selected = tadat$statecode) + shiny::updateSelectizeInput(session, "county", selected = tadat$countycode) + shiny::updateTextInput(session, "huc") + shiny::updateSelectizeInput(session, "siteid", selected = tadat$siteid) + shiny::updateSelectizeInput(session, "type", selected = tadat$siteType) + shiny::updateSelectizeInput(session, + "characteristic", + selected = tadat$characteristicName) + shiny::updateSelectizeInput(session, "chargroup", selected = tadat$characteristicType) + shiny::updateSelectizeInput(session, "media", selected = tadat$sampleMedia) + shiny::updateSelectizeInput(session, "proj", selected = tadat$proj) + shiny::updateSelectizeInput(session, "org", selected = tadat$organization) + shiny::updateDateInput(session, "startdate", value = tadat$startDate) + shiny::updateDateInput(session, "enddate", value = tadat$endDate) + } + } + + }) + }) } @@ -267,7 +462,8 @@ initializeTable <- function(tadat, raw) { shinyjs::enable(selector = '.nav li a[data-value="Figures"]') shinyjs::enable(selector = '.nav li a[data-value="Review"]') } else { - tadat$new <- TRUE # this is used to determine if the app should go to the overview page first - only for datasets that are new to TADAShiny + tadat$new <- + TRUE # this is used to determine if the app should go to the overview page first - only for datasets that are new to TADAShiny tadat$ovgo <- TRUE # load data into overview page shinyjs::enable(selector = '.nav li a[data-value="Overview"]') shinyjs::enable(selector = '.nav li a[data-value="Flag"]') @@ -275,11 +471,11 @@ initializeTable <- function(tadat, raw) { # Set flagging column to FALSE raw$TADA.Remove <- FALSE } - + removals <- data.frame(matrix(nrow = nrow(raw), ncol = 0)) # removals["Media Type"] = ifelse(!raw$TADA.ActivityMediaName%in%c("WATER"),TRUE,raw$Removed) # removals["Special Characters"] = ifelse(raw$TADA.ResultMeasureValueDataTypes.Flag%in%c("ND or NA","Text","Coerced to NA"),TRUE,raw$Removed) - + tadat$raw <- raw tadat$removals <- removals } diff --git a/R/sandbox.R b/R/sandbox.R new file mode 100644 index 000000000..e69de29bb diff --git a/R/utils_flag_functions.R b/R/utils_flag_functions.R index bb2781496..2595f89d4 100644 --- a/R/utils_flag_functions.R +++ b/R/utils_flag_functions.R @@ -9,8 +9,6 @@ levs <- prompt_table$Level n_switches <- length(prompts) flag_types <- prompt_table$flagType -switch_defaults <- prompt_table$Level != "Optional" -switch_disabled <- prompt_table$Level == "Required" flagCensus <- function(raw) { @@ -149,3 +147,19 @@ applyFlags <- function(in_table, orgs) { return(out) } + +checkFlagColumns <- function(dataset){ + # Flags that, as of 11/16/23, aren't being used + flags_not_required = c("TADA.InvalidCoordinates.Flag", "TADA.SingleOrgDup.Flag") + flag_cols = setdiff(unique(test_table$columnName), flags_not_required) + dataset_cols = names(dataset) + found = intersect(flag_cols, dataset_cols) + if (length(flag_cols) == length(found)){ + return(TRUE) + } else { + + return(FALSE) + } + + +} diff --git a/R/utils_track_progress.R b/R/utils_track_progress.R index de874aeb1..037cd6ab6 100644 --- a/R/utils_track_progress.R +++ b/R/utils_track_progress.R @@ -1,103 +1,201 @@ -tsf_prompts = c("Job id:", "Data source:", "Selected flags:", "Selected filters:") - -trackEverything <- function(tadat, input) { - #print("Memory:") - #trackMemory(tadat, input) - #print("Input:") - #print(input) - #print("Switches: ") - #switch_vals = getFlags(input) - #print(switch_vals) -} - -trackMemory <- function(tadat, input) { - print(" All: ") - print(ls()) - print(input) - if (length(names(tadat)) > 0) { - print(" tadat:") - for (i in 1:length(names(tadat))) { - name <- names(tadat)[i] - size <- as.numeric(utils::object.size(tadat[[name]])) - print(paste0(" ", name, ": ", size)) - } - } - -} - writeFile <- function(tadat, filename) { - job_id <- paste0("ts", format(Sys.time(), "%y%m%d%H%M%S")) + original_source = tadat$original_source + job_id = tadat$job_id + statecode = tadat$statecode + countycode = tadat$countycode + example_data = tadat$example_data + huc = tadat$huc + siteid = tadat$siteid + siteType = tadat$siteType + characteristicName = tadat$characteristicName + characteristicType = tadat$characteristicType + sampleMedia = tadat$sampleMedia + proj = tadat$proj + organization = tadat$organization + startDate = tadat$startDate + endDate = tadat$endDate org_table <- tadat$org_table - dataSource <- tadat$dataSource - dataSourceDesc <- tadat$dataSourceDesc selected_flags <- tadat$selected_flags m2f <- tadat$m2f - selected_filters <- tadat$selected_filters + selected_filters <- tadat$selected_filters[c("Field", "Value", "Filter")] nd_method <- tadat$nd_method od_method <- tadat$od_method nd_mult <- tadat$nd_mult od_mult <- tadat$od_mult - print(nd_method) - print(nd_mult) - print(od_method) - print(od_mult) - save(job_id, - org_table, - m2f, - dataSource, - dataSourceDesc, - selected_flags, - selected_filters, - nd_method, - od_method, - nd_mult, - od_mult, - file = filename) + save( + original_source, + job_id, + example_data, + statecode, + countycode, + huc, + siteid, + siteType, + characteristicName, + characteristicType, + sampleMedia, + proj, + organization, + startDate, + endDate, + org_table, + selected_flags, + m2f, + selected_filters, + nd_method, + od_method, + nd_mult, + od_mult, + file = filename + ) + } readFile <- function(tadat, filename) { - load(filename, verbose = TRUE) - tadat$load_file = filename + load(filename, verbose = FALSE) + checkFlagColumns(tadat$raw) + tadat$load_progress_file = filename + # Confirm compatibility - #job_id = job_id - #shinyjs::disable(selector = '.nav li a[data-value="Overview"]') - - # Populate organizational rankings - if (!is.null(org_table)){ - tadat$org_table <- org_table + job_id = job_id + if (!is.null(m2f)) { + tadat$m2f = m2f } + - # Populate flags - if (!is.null(selected_flags)){ + if (!is.null(selected_flags)) { tadat$selected_flags = selected_flags shinyjs::enable(selector = '.nav li a[data-value="Flag"]') + } else { + print("No flags selected") } - - if (!is.null(m2f)){ - tadat$m2f = m2f - } - - # Populate filters - if (!is.null(selected_filters)){ - tadat$selected_filters = selected_filters + + # Enable tabs if certain fields are not null + if (!is.null(selected_filters)) { shinyjs::enable(selector = '.nav li a[data-value="Filter"]') } - - shinyjs::enable(selector = '.nav li a[data-value="Censored"]') - shinyjs::enable(selector = '.nav li a[data-value="Review"]') - # Censored data + tadat$original_source = original_source + tadat$job_id = job_id + tadat$example_data = example_data + tadat$statecode = statecode + tadat$countycode = countycode + tadat$huc = huc + tadat$siteid = siteid + tadat$siteType = siteType + tadat$characteristicName = characteristicName + tadat$characteristicType = characteristicType + tadat$sampleMedia = sampleMedia + tadat$proj = proj + tadat$organization = organization + tadat$startDate = startDate + tadat$endDate = endDate + tadat$org_table = org_table + tadat$m2f = m2f + tadat$selected_filters = selected_filters tadat$nd_method = nd_method - tadat$nd_mult = nd_mult tadat$od_method = od_method - tadat$od_mult = od_mult - } + tadat$nd_mult = nd_mult + tadat$od_mult +} - -invalidFile <- function(trigger){ +invalidFile <- function(trigger) { print("Failure") print(trigger) } + + +writeNarrativeDataFrame <- function(tadat) { + df <- data.frame(Parameter=character(), Value=character()) + df[nrow(df) + 1, ] = c("TADA Shiny Job ID", tadat$job_id) + df[nrow(df) + 1, ] = c("Original data source: ", tadat$original_source) + + # Data Query Tab + if (tadat$original_source == "Example") { + df[nrow(df) + 1, ] = c("Example data file", tadat$example_data) + } else if (tadat$original_source == "Query") { + query_params = data.frame( + param = c( + "State Code", + "County Code", + "HUC Code", + "Site ID", + "Site Type", + "Characteristic Name", + "Characteristic Type", + "Sample Media", + "Project Name", + "Organization Name", + "Start Date", + "End Date" + ), + value = c( + tadat$statecode, + tadat$countycode, + tadat$huc, + tadat$siteid, + tadat$siteType, + tadat$characteristicName, + tadat$characteristicType, + tadat$sampleMedia, + tadat$proj, + tadat$organization, + tadat$startDate, + tadat$endDate + ) + ) + for (i in seq_len(nrow(query_params))) { + if (!is.null(query_params[i, "value"])) { + df[nrow(df) + 1, ] = query_params[i,] + } + } + } + + # Overview Tab + for (row in 1:nrow(tadat$org_table)) { + df[nrow(df) + 1, ] = c(paste0("Organization Rank ", row), tadat$org_table[row, 'OrganizationFormalName']) + } + + + # Flagging Tab + for (flag in tadat$selected_flags) { + df[nrow(df) + 1, ] = c("Selected Flag", flag) + } + + + if (!is.null(tadat$m2f)) { + df[nrow(df) + 1, ] = c("Depth unit conversion", tadat$m2f) + } else { + df[nrow(df) + 1, ] = c("Depth unit conversion", "None") + } + + + # Filtering tab + for (row in 1:nrow(tadat$selected_filters)) { + df[nrow(df) + 1, ] = c( + "Selected Filter", + paste0( + tadat$selected_filters[row, 'Filter'], + ": ", + tadat$selected_filters[row, 'Field'], + " = ", + tadat$selected_filters[row, 'Value'] + ) + ) + } + + # Censored Data tab + if (is.null(tadat$nd_mult)){ + tadat$nd_mult = "n/a" + } + if (is.null(tadat$od_mult)){ + tadat$od_mult = "n/a" + } + df[nrow(df) + 1, ] = c("Non-Detect Handling Method", sub("x", tadat$nd_mult, tadat$nd_method)) + df[nrow(df) + 1, ] = c("Over-Detect Handling Method", sub("x", tadat$od_mult, tadat$od_method)) + + return(df) +} diff --git a/app.R b/app.R index 01e8a169f..aaa43d633 100644 --- a/app.R +++ b/app.R @@ -4,4 +4,4 @@ pkgload::load_all(export_all = FALSE,helpers = FALSE,attach_testthat = FALSE) options( "golem.app.prod" = TRUE) -TADAShiny::run_app() # add parameters here (if any) +TADAShiny::run_app() # add parameters here (if any) \ No newline at end of file