diff --git a/R/app_server.R b/R/app_server.R index 5f036c454..1f4d1e0fc 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -32,12 +32,19 @@ app_server <- function(input, output, session) { shinyjs::disable(selector = '.nav li a[data-value="Figures"]') shinyjs::disable(selector = '.nav li a[data-value="Review"]') + # switch that indicates when a file is being loaded + 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? shiny::observeEvent(tadat$new, { shiny::showModal(shiny::modalDialog( title = "Data Loaded", - "Your data were successfully loaded into the app and are displayed on the Overview tab. See summary information about your dataset in the gray box at the bottom of the app." + "Your data were successfully loaded into the app and are displayed on the Overview tab. The following data wrangling steps were performed automatically when data was loaded: 1) created TADA versions of a subset of columns for editing (originals are retained), 2) removed exact duplicates, 3) handled/flagged special characters and text in result values and units, 4) identified detection limit data and copied limit value to result value if blank, 5) harmonized result and depth units to TADA defaults, and 6) replaced retired characteristic names with current names. See summary information about your dataset in the gray box at the bottom of the app." )) shiny::updateTabsetPanel(session = session, inputId = "tabbar", selected = "Overview") tadat$new <- NULL @@ -50,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/golem_utils_ui.R b/R/golem_utils_ui.R index 0d11ee4e7..c91475023 100644 --- a/R/golem_utils_ui.R +++ b/R/golem_utils_ui.R @@ -230,6 +230,7 @@ with_red_star <- function(text) { #' @examples #' rep_br(5) #' @importFrom shiny HTML + rep_br <- function(times = 1) { HTML(rep("
", times = times)) } diff --git a/R/mod_TADA_summary.R b/R/mod_TADA_summary.R index 9d96d92df..d3578e3a9 100644 --- a/R/mod_TADA_summary.R +++ b/R/mod_TADA_summary.R @@ -38,9 +38,24 @@ mod_TADA_summary_ui <- function(id) { )))), shiny::fluidRow(column(6, shiny::uiOutput(ns( "dwn_all" - )))) + )))), + 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( + 2, shiny::actionButton(ns("disclaimer"), "DISCLAIMER") + )), htmltools::br(), htmltools::br() ), @@ -60,20 +75,25 @@ mod_TADA_summary_server <- function(id, tadat) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns # reactive list to hold reactive objects specific to this module - summary_things <- shiny::reactiveValues() - + summary_things = shiny::reactiveValues() + + # 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( @@ -81,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, @@ -92,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)) { @@ -106,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 @@ -117,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 @@ -138,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 @@ -149,36 +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 + + # download dataset button - only appears if there data exists 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 (.zip)", + 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) + utils::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") + # }) + + # 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." + ) + ) }) }) } @@ -194,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 f712c2c57..805105fff 100644 --- a/R/mod_censored_data.R +++ b/R/mod_censored_data.R @@ -7,36 +7,85 @@ #' @noRd #' #' @importFrom shiny NS tagList + +nd_method_options <- + c("Multiply detection limit by x", + "Random number between 0 and detection limit", + "No change") +od_method_options <- c("Multiply detection limit by x", "No change") + mod_censored_data_ui <- function(id) { ns <- NS(id) tagList( shiny::fluidRow(htmltools::h3("Censored Data Categories")), - shiny::fluidRow("TADAdataRetrieval assigns each result in your dataset to non-detect, over-detect, other, or uncensored. The pie chart below displays the relative proportions of results in each category. Please note that detection limit data with conflicts or data quality issues are not displayed in this pie chart or handled in the methods below."), + shiny::fluidRow( + "TADAdataRetrieval assigns each result in your dataset to non-detect, over-detect, other, or uncensored. The pie chart below displays the relative proportions of results in each category. Please note that detection limit data with conflicts or data quality issues are not displayed in this pie chart or handled in the methods below." + ), htmltools::br(), - shiny::fluidRow(column(12, shiny::plotOutput(ns("id_censplot")))), + shiny::fluidRow(column(12, shiny::plotOutput( + ns("id_censplot") + ))), htmltools::br(), - shiny::fluidRow(htmltools::h3("Handle Censored Data Using Simple Methods")), - shiny::fluidRow("Use the drop down menus below to pick a simple method for handling non-detects and over-detects in the dataset. When you press 'Apply Methods to Dataset', a table will appear below with the first 10 detection limit results, showing their initial values and estimated values."), + shiny::fluidRow(htmltools::h3( + "Handle Censored Data Using Simple Methods" + )), + shiny::fluidRow( + "Use the drop down menus below to pick a simple method for handling non-detects and over-detects in the dataset. When you press 'Apply Methods to Dataset', a table will appear below with the first 10 detection limit results, showing their initial values and estimated values." + ), htmltools::br(), shiny::fluidRow( - column(3, shiny::selectInput(ns("nd_method"), "Non-Detect Handling Method", choices = c("Multiply detection limit by x", "Random number between 0 and detection limit", "No change"), multiple = FALSE)), + column( + 3, + shiny::selectizeInput( + ns("nd_method"), + "Non-Detect Handling Method", + choices = nd_method_options, + selected = nd_method_options[1], + multiple = TRUE, + options = list(maxItems = 1) + ) + ), column(3, shiny::uiOutput(ns("nd_mult"))), - column(3, shiny::selectInput(ns("od_method"), "Over-Detect Handling Method", choices = c("Multiply detection limit by x", "No change"), selected = "No change", multiple = FALSE)), + column( + 3, + shiny::selectizeInput( + ns("od_method"), + "Over-Detect Handling Method", + choices = od_method_options, + selected = od_method_options[2], + multiple = TRUE, + options = list(maxItems = 1) + ) + ), column(3, shiny::uiOutput(ns("od_mult"))) ), shiny::fluidRow( - column(3, shiny::actionButton(ns("apply_methods"), "Apply Methods to Dataset", style = "color: #fff; background-color: #337ab7; border-color: #2e6da4")), + column( + 3, + shiny::actionButton(ns("apply_methods"), "Apply Methods to Dataset", style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") + ), column(3, shiny::uiOutput(ns("undo_methods"))) ), htmltools::br(), - shiny::fluidRow(column(12, DT::DTOutput(ns("see_det")))), + shiny::fluidRow(column(12, DT::DTOutput(ns( + "see_det" + )))), htmltools::br(), - shiny::fluidRow(htmltools::h3("Consider More Complex Censored Data Handling Methods")), - shiny::fluidRow("Use the picker list below to select grouping columns to create summary table. The summary table shows the number of non- and over-detects in each group, the total number of results in each group, the number of detection limit types (censoring levels) and the percentage of the dataset that is censored. These numbers are then used to suggest a potential statistical censored data method to use. Currently, the user must perform more complex analyses outside of TADAShiny."), + shiny::fluidRow( + htmltools::h3("Consider More Complex Censored Data Handling Methods") + ), + shiny::fluidRow( + "Use the picker list below to select grouping columns to create summary table. The summary table shows the number of non- and over-detects in each group, the total number of results in each group, the number of detection limit types (censoring levels) and the percentage of the dataset that is censored. These numbers are then used to suggest a potential statistical censored data method to use. Currently, the user must perform more complex analyses outside of TADAShiny." + ), htmltools::br(), shiny::fluidRow(shiny::wellPanel( - shiny::fluidRow(column(12, shiny::uiOutput(ns("cens_groups")))), - shiny::fluidRow(column(12, shiny::actionButton(ns("cens_sumbutton"), "ID and Summarize Censored Data", style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"))) + shiny::fluidRow(column(12, shiny::uiOutput( + ns("cens_groups") + ))), + shiny::fluidRow(column( + 12, + shiny::actionButton(ns("cens_sumbutton"), "ID and Summarize Censored Data", style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") + )) )), shiny::fluidRow(DT::DTOutput(ns("cens_sumtable")), width = 600) ) @@ -48,10 +97,12 @@ mod_censored_data_ui <- function(id) { mod_censored_data_server <- function(id, tadat) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns - + + # initialize dropdown values + # reactive values specific to this module censdat <- shiny::reactiveValues() - + # update dataset when on censored data page shiny::observeEvent(tadat$tab, { shiny::req(tadat$raw) @@ -64,42 +115,107 @@ mod_censored_data_server <- function(id, tadat) { # paste0(length(dat$ResultIdentifier[dat$TADA.Remove==TRUE])," results were flagged for removal because they have conflicting, ambiguous and/or unfamiliar detection limits and conditions. These will show up in the pie chart, but only 'Non-Detect', 'Over-Detect', and 'Uncensored' results will be used in the sections below. You may download your dataset for review at any time using the 'Download Working Dataset' button at the bottom of the page.") # )) # } - censdat$dat <- subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) # however, this reactive object has all of the data that were not previously removed and do not have ambiguous detection limit data. This is the "clean" dataset + censdat$dat <- + subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) # however, this reactive object has all of the data that were not previously removed and do not have ambiguous detection limit data. This is the "clean" dataset } }) - + # pie chart showing breakdown of censored/uncensored data passed through idCensoredData function output$id_censplot <- shiny::renderPlot({ shiny::req(censdat$dat) piedat <- censdat$dat %>% dplyr::group_by(TADA.CensoredData.Flag) %>% dplyr::summarise(num = length(ResultIdentifier)) - piedat$Label <- paste0(piedat$TADA.CensoredData.Flag, " - ", scales::comma(piedat$num), " results") + piedat$Label <- + paste0(piedat$TADA.CensoredData.Flag, + " - ", + scales::comma(piedat$num), + " results") # Basic piechart ggplot2::ggplot(piedat, ggplot2::aes(x = "", y = num, fill = Label)) + - ggplot2::geom_bar(stat = "identity", width = 1, color = "white") + + ggplot2::geom_bar(stat = "identity", + width = 1, + color = "white") + ggplot2::labs(title = "Number of Results per Censored Data Category") + ggplot2::coord_polar("y", start = 0) + ggplot2::scale_fill_brewer(palette = "Dark2") + ggplot2::theme_void() + # remove background, grid, numeric labels - ggplot2::theme(plot.title = ggplot2::element_text(face = "bold", size = 18), legend.title = ggplot2::element_text(size = 16), legend.text = ggplot2::element_text(size = 14)) #+ + ggplot2::theme( + plot.title = ggplot2::element_text(face = "bold", size = 18), + legend.title = ggplot2::element_text(size = 16), + legend.text = ggplot2::element_text(size = 14) + ) #+ # ggplot2::geom_text(ggplot2::aes(label = scales::comma(num)), color = "white", size=6,position = ggplot2::position_stack(vjust = 0.5)) }) - + + # 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") { - shiny::numericInput(ns("nd_mult"), "Multiplier (x)", value = 0.5, min = 0) + 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 = 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") { - shiny::numericInput(ns("od_mult"), "Multiplier (x)", value = 1, min = 0) + 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 = init_val, + min = 0) } }) - + + + # initialize global variables for saving/loading + + tadat$censor_applied = FALSE + + 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) + } + }) + + # 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, { shinybusy::show_modal_spinner( @@ -108,10 +224,17 @@ mod_censored_data_server <- function(id, tadat) { text = "Applying selected methods...", session = shiny::getDefaultReactiveDomain() ) - removed <- subset(tadat$raw, tadat$raw$TADA.Remove == TRUE) # first, remove results we dont want to handle at all - good <- 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"), actual = c("multiplier", "randombelowlimit", "as-is")) - if (is.null(input$nd_mult)) { # these if's get the reactive inputs into a format that the TADA function will understand + removed <- + subset(tadat$raw, tadat$raw$TADA.Remove == TRUE) # first, remove results we dont want to handle at all + good <- + subset(tadat$raw, tadat$raw$TADA.Remove == FALSE) # keep the "goods" that will be run through the simpleCensoredMethods function + trans <- + data.frame( + input = nd_method_options, + actual = c("multiplier", "randombelowlimit", "as-is") + ) + if (is.null(input$nd_mult)) { + # these if's get the reactive inputs into a format that the TADA function will understand nd_multiplier <- "null" } else { nd_multiplier <- input$nd_mult @@ -121,41 +244,81 @@ mod_censored_data_server <- function(id, tadat) { } else { od_multiplier <- input$od_mult } - good <- TADA::TADA_SimpleCensoredMethods(good, nd_method = trans$actual[trans$input == input$nd_method], nd_multiplier = nd_multiplier, od_method = trans$actual[trans$input == input$od_method], od_multiplier = od_multiplier) - tadat$raw <- plyr::rbind.fill(removed, good) # stitch good and removed datasets back together in tadat$raw + good <- + TADA::TADA_SimpleCensoredMethods( + good, + nd_method = trans$actual[trans$input == input$nd_method], + nd_multiplier = nd_multiplier, + od_method = trans$actual[trans$input == input$od_method], + od_multiplier = od_multiplier + ) + tadat$raw <- + plyr::rbind.fill(removed, good) # stitch good and removed datasets back together in tadat$raw tadat$raw <- TADA::TADA_OrderCols(tadat$raw) - + # create dataset displayed in table below - dat <- subset(good, good$TADA.CensoredData.Flag %in% c("Non-Detect", "Over-Detect")) - dat <- dat[, c("ResultIdentifier", "TADA.CharacteristicName", "TADA.DetectionQuantitationLimitMeasure.MeasureValue", "DetectionQuantitationLimitMeasure.MeasureUnitCode", "TADA.ResultMeasureValue", "TADA.ResultMeasure.MeasureUnitCode")] - dat <- dat %>% dplyr::rename("Estimated Detection Limit Value" = TADA.ResultMeasureValue, "Original Detection Limit Value" = TADA.DetectionQuantitationLimitMeasure.MeasureValue, "Original Unit" = DetectionQuantitationLimitMeasure.MeasureUnitCode, "Estimated Unit" = TADA.ResultMeasure.MeasureUnitCode) - censdat$exdat <- dat[1:10, ] # just show the first 10 records so user can see what happened to data + dat <- + subset(good, + good$TADA.CensoredData.Flag %in% c("Non-Detect", "Over-Detect")) + dat <- + dat[, c( + "ResultIdentifier", + "TADA.CharacteristicName", + "TADA.DetectionQuantitationLimitMeasure.MeasureValue", + "DetectionQuantitationLimitMeasure.MeasureUnitCode", + "TADA.ResultMeasureValue", + "TADA.ResultMeasure.MeasureUnitCode" + )] + dat <- + dat %>% dplyr::rename( + "Estimated Detection Limit Value" = TADA.ResultMeasureValue, + "Original Detection Limit Value" = TADA.DetectionQuantitationLimitMeasure.MeasureValue, + "Original Unit" = DetectionQuantitationLimitMeasure.MeasureUnitCode, + "Estimated Unit" = TADA.ResultMeasure.MeasureUnitCode + ) + censdat$exdat <- + dat[1:10, ] # just show the first 10 records so user can see what happened to data shinybusy::remove_modal_spinner(session = shiny::getDefaultReactiveDomain()) + tadat$censor_applied = TRUE }) - + # this button appears after someone has applied the OD/ND methods, in case they want to undo and try another method instead output$undo_methods <- shiny::renderUI({ shiny::req(censdat$exdat) shiny::actionButton(ns("undo_methods"), "Undo Method Application", style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") }) - + # executes the undo if undo methods button is pressed. shiny::observeEvent(input$undo_methods, { censdat$exdat <- NULL # reset exdat - tadat$raw$TADA.ResultMeasureValue <- ifelse(tadat$raw$TADA.ResultMeasureValueDataTypes.Flag == "Result Value/Unit Estimated from Detection Limit", tadat$raw$TADA.DetectionQuantitationLimitMeasure.MeasureValue, tadat$raw$TADA.ResultMeasureValue) # reset to detection quantitation limit value - tadat$raw$TADA.ResultMeasureValueDataTypes.Flag[tadat$raw$TADA.ResultMeasureValueDataTypes.Flag == "Result Value/Unit Estimated from Detection Limit"] <- "Result Value/Unit Copied from Detection Limit" # reset data types flag to what it was before simpleCensoredMethods function run + tadat$raw$TADA.ResultMeasureValue <- + ifelse( + tadat$raw$TADA.ResultMeasureValueDataTypes.Flag == "Result Value/Unit Estimated from Detection Limit", + tadat$raw$TADA.DetectionQuantitationLimitMeasure.MeasureValue, + tadat$raw$TADA.ResultMeasureValue + ) # reset to detection quantitation limit value + tadat$raw$TADA.ResultMeasureValueDataTypes.Flag[tadat$raw$TADA.ResultMeasureValueDataTypes.Flag == "Result Value/Unit Estimated from Detection Limit"] <- + "Result Value/Unit Copied from Detection Limit" # reset data types flag to what it was before simpleCensoredMethods function run tadat$raw <- tadat$raw %>% dplyr::select(-TADA.CensoredMethod) + tadat$censor_applied = FALSE }) - + # creates a nice table showing an example of how censored data were changed. output$see_det <- DT::renderDT({ shiny::req(censdat$exdat) - DT::datatable(censdat$exdat[1:10, ], - options = list(dom = "t", scrollX = TRUE, pageLength = 10, searching = FALSE), - selection = "none", rownames = FALSE + DT::datatable( + censdat$exdat[1:10, ], + options = list( + dom = "t", + scrollX = TRUE, + pageLength = 10, + searching = FALSE + ), + selection = "none", + rownames = FALSE ) }) - + # from the clean dataset, get all of the column names someone might want to group by when summarizing their data for use in more advanced censored data methods. output$cens_groups <- shiny::renderUI({ shiny::req(censdat$dat) @@ -168,34 +331,62 @@ mod_censored_data_server <- function(id, tadat) { "TADA.DetectionQuantitationLimitMeasure.MeasureValue", "DetectionQuantitationLimitMeasure.MeasureValue" )] # remove the columns that are generally unique to each result from consideration. Why would someone want to group by result value or identifier? Then every summary would be unique to one value...not a "summary" - tcols <- ccols[grepl("TADA.", ccols)] # put all of the TADA columns at the top of the selection drop down - ucols <- ccols[!grepl("TADA.", ccols)] # then have the WQP columns - ccols <- c(tcols, ucols) # string them back together in one vector used in the selection widget below - shiny::selectizeInput(ns("cens_groups"), + tcols <- + ccols[grepl("TADA.", ccols)] # put all of the TADA columns at the top of the selection drop down + ucols <- + ccols[!grepl("TADA.", ccols)] # then have the WQP columns + ccols <- + c(tcols, ucols) # string them back together in one vector used in the selection widget below + shiny::selectizeInput( + ns("cens_groups"), label = "Select Grouping Columns for Summarization", - choices = ccols, selected = c("TADA.ComparableDataIdentifier"), + choices = ccols, + selected = c("TADA.ComparableDataIdentifier"), multiple = TRUE ) }) - + # runs the summary function when cens button is pushed following group selection shiny::observeEvent(input$cens_sumbutton, { - summary <- TADA::TADA_Stats(censdat$dat, group_cols = input$cens_groups) - censdat$summary <- summary[, !names(summary) %in% c("UpperFence", "LowerFence", "Min", "Max", "Mean", "Percentile_5th", "Percentile_10th", "Percentile_15th", "Percentile_25th", "Percentile_50th_Median", "Percentile_75th", "Percentile_85th", "Percentile_95th", "Percentile_98th")] + summary <- + TADA::TADA_Stats(censdat$dat, group_cols = input$cens_groups) + censdat$summary <- + summary[, !names(summary) %in% c( + "UpperFence", + "LowerFence", + "Min", + "Max", + "Mean", + "Percentile_5th", + "Percentile_10th", + "Percentile_15th", + "Percentile_25th", + "Percentile_50th_Median", + "Percentile_75th", + "Percentile_85th", + "Percentile_95th", + "Percentile_98th" + )] }) - + # creates summary table complete with csv button in case someone wants to # download the summary table output$cens_sumtable <- DT::renderDT({ - DT::datatable(censdat$summary, + DT::datatable( + censdat$summary, extensions = "Buttons", options = list( - dom = "Blftipr", scrollX = TRUE, - pageLength = 10, searching = FALSE, - order = list(list(length(input$cens_groups), "desc")), + dom = "Blftipr", + scrollX = TRUE, + pageLength = 10, + searching = FALSE, + order = list(list(length( + input$cens_groups + ), "desc")), buttons = c("csv") ), - selection = "none", rownames = FALSE + selection = "none", + rownames = FALSE ) }) }) diff --git a/R/mod_data_flagging.R b/R/mod_data_flagging.R index 6358f8c34..f7b659cfa 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)) - values$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( @@ -88,40 +130,30 @@ mod_data_flagging_server <- function(id, tadat) { session = shiny::getDefaultReactiveDomain() ) - # Add flagging columns to raw table + # Add flagging columns to raw table, make sure line below is + # not commented out once done with testing 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_" - values$selected_flags <- flag_types[shinyValue(switch_id, n_switches)] + switch_id = "switch_" + tadat$selected_flags = flag_types[shinyValue(switch_id, n_switches)] for (i in which(switch_disabled)) { shinyjs::disable(paste0(switch_id, i)) } }) - - shiny::observeEvent(values$selected_flags, { - prefix <- "Flag: " - tadat$removals <- dplyr::select(tadat$removals, -(dplyr::starts_with(prefix))) - for (flag in values$selected_flags) { - if (!all(is.na(values$testResults[flag]))) { - tadat$removals[paste0(prefix, flag)] <- values$testResults[flag] - } - } - }) - + switchTable <- shiny::reactive({ df <- data.frame( Reason = prompts, @@ -130,7 +162,7 @@ mod_data_flagging_server <- function(id, tadat) { Decision = flagSwitch(n_switches) ) }) - + output$flagTable <- DT::renderDT( shiny::isolate(switchTable()), escape = FALSE, @@ -160,8 +192,13 @@ 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, { + shiny::updateRadioButtons(session, "m2f", selected = tadat$m2f) + }) + shiny::observeEvent(input$m2f, { + tadat$m2f <- input$m2f shiny::req(tadat$raw) if (input$m2f == "feet") { shinybusy::show_modal_spinner( @@ -170,7 +207,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( @@ -179,7 +217,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( @@ -188,7 +227,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 e308c1ca2..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" - ) + "Exclude Selected Values", + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ) ), htmltools::br(), @@ -37,16 +35,14 @@ mod_filtering_ui <- function(id) { column( 3, shiny::actionButton(ns("removeFilters"), - "Reset Selected Filters", - style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" - ) + "Reset Selected Filters", + 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" - ) + "Reset All Filters", + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4") ) ) ) @@ -63,17 +59,19 @@ mod_filtering_server <- function(id, tadat) { values$selected_field <- NULL shinyjs::hide("addOnlys") shinyjs::hide("addExcludes") - + # make sure dataset being used to create filters is only REMOVE = FALSE shiny::observe({ 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") } }) - + # First data table with key columns output$filterStep1 <- DT::renderDT( tables$filter_fields, @@ -86,13 +84,15 @@ mod_filtering_server <- function(id, tadat) { paging = FALSE ) ) - + # 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 '", @@ -104,7 +104,8 @@ mod_filtering_server <- function(id, tadat) { shinyjs::show("addOnlys") shinyjs::show("addExcludes") }) - + + # show unique values for selected column output$filterStep2 <- DT::renderDT( tables$filter_values, @@ -116,18 +117,19 @@ mod_filtering_server <- function(id, tadat) { pageLength = dim(tables$filter_values)[1] ) ) - + # empty selected table on open - tables$selected <- + 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 - output$selectedFilters <- DT::renderDT( - tables$selected, + output$selectedFilters = DT::renderDT( + tadat$selected_filters, escape = FALSE, selection = "multiple", rownames = FALSE, @@ -137,7 +139,7 @@ mod_filtering_server <- function(id, tadat) { language = list(zeroRecords = "No filters selected") ) ) - + # what happens when you click "Include Only Selected Values" shiny::observeEvent(input$addOnlys, { if (is.null(input$filterStep2_rows_selected)) { @@ -152,7 +154,7 @@ mod_filtering_server <- function(id, tadat) { selectFilters("Keep only") } }) - + # what happens when you click "Exclude Selected Values" shiny::observeEvent(input$addExcludes, { if (is.null(input$filterStep2_rows_selected)) { @@ -167,12 +169,18 @@ mod_filtering_server <- function(id, tadat) { selectFilters("Exclude") } }) - + # reset all filters in bottom table shiny::observeEvent(input$resetFilters, { - tables$selected <- tables$selected[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 shiny::observeEvent(input$removeFilters, { if (is.null(input$selectedFilters_rows_selected)) { @@ -182,11 +190,11 @@ mod_filtering_server <- function(id, tadat) { "You must select (by clicking on) the filter(s) you'd like to remove from the applied filters table." ) ) - } else { - tables$selected <- tables$selected[-input$selectedFilters_rows_selected, ] + } else{ + tadat$selected_filters = tadat$selected_filters[-input$selectedFilters_rows_selected,] } }) - + # Called whenever a "Include" or "Exclude" button is clicked selectFilters <- function(Filter) { # Locks the value of the selected field to "Include" or "Exclude" @@ -195,23 +203,24 @@ 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 - tables$selected <- rbind(tables$selected, new_rows) - tables$selected <- - tables$selected %>% dplyr::distinct(Field, Value, .keep_all = TRUE) + tadat$selected_filters = rbind(tadat$selected_filters, new_rows) + tadat$selected_filters = + tadat$selected_filters %>% dplyr::distinct(Field, Value, .keep_all = TRUE) } - + ##### # These functions are used to lock fields to "Include or Exclude" # 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] }) - + applyLocks <- function() { if (!is.null(values$selected_field)) { active_lock <- values$locked[values$selected_field] @@ -229,31 +238,39 @@ mod_filtering_server <- function(id, tadat) { shinyjs::disable("addOnlys") shinyjs::disable("addExcludes") } + } - + shiny::observeEvent(values$locked, { applyLocks() }) ##### - + # This gets run whenever a change in selected filters happens - shiny::observeEvent(tables$selected, { - prefix <- "Filter: " + shiny::observeEvent(tadat$selected_filters, { + # 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(tables$selected) > 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") - + # Loop through the filters field-by-field - for (active_field in unique(tables$selected$Field)) { + for (active_field in unique(tadat$selected_filters$Field)) { filter_type <- values$locked[active_field] - field_filters <- tables$selected[tables$selected$Field == 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"]) @@ -265,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()) } @@ -282,3 +317,5 @@ mod_filtering_server <- function(id, tadat) { } }) } + + diff --git a/R/mod_overview.R b/R/mod_overview.R index afb37398a..b8542d166 100644 --- a/R/mod_overview.R +++ b/R/mod_overview.R @@ -13,23 +13,49 @@ mod_overview_ui <- function(id) { ns <- NS(id) tagList( htmltools::h3("Data Overview"), - htmltools::HTML("Note: This page shows maps and figures using the original dataset uploaded to this TADAShiny session. If you'd like to see updated figures after working in other tabs, please press the 'Refresh' button."), + htmltools::HTML( + "Note: This page shows maps and figures using the original dataset uploaded to this TADAShiny session. If you'd like to see updated figures after working in other tabs, please press the 'Refresh' button." + ), htmltools::div(style = "margin-bottom:10px"), - shiny::fluidRow(column(3, shiny::actionButton(ns("refresh_overview"), "Refresh", shiny::icon("arrows-rotate"), style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"))), + shiny::fluidRow(column( + 3, + shiny::actionButton( + ns("refresh_overview"), + "Refresh", + shiny::icon("arrows-rotate"), + style = "color: #fff; background-color: #337ab7; border-color: #2e6da4" + ) + )), htmltools::hr(), - shiny::fluidRow(column(12, shiny::wellPanel(shiny::htmlOutput(ns("overview_totals"))))), - htmltools::HTML("Your dataset, mapped: Zoom in and click on sites of interest. A pop up will appear that shows the number of measurements, characteristics, and visits at each site."), + shiny::fluidRow(column( + 12, shiny::wellPanel(shiny::htmlOutput(ns( + "overview_totals" + ))) + )), + htmltools::HTML( + "Your dataset, mapped: Zoom in and click on sites of interest. A pop up will appear that shows the number of measurements, characteristics, and visits at each site." + ), htmltools::br(), - shiny::fluidRow(column(12, shinycssloaders::withSpinner(leaflet::leafletOutput(ns("overview_map"), height = "500px")))), # "Larger point sizes represent more samples collected at a site; darker points represent more characteristics collected at a site. Click on a point to see the site ID, name, and sample/visit/parameter counts." + shiny::fluidRow(column( + 12, shinycssloaders::withSpinner(leaflet::leafletOutput(ns("overview_map"), height = "500px")) + )), + # "Larger point sizes represent more samples collected at a site; darker points represent more characteristics collected at a site. Click on a point to see the site ID, name, and sample/visit/parameter counts." htmltools::br(), shiny::fluidRow( - column(6, shiny::plotOutput(ns("overview_hist"), height = "500px")), # "This histogram shows sample collection frequency for all sites over the time period queried.", - column(6, shiny::plotOutput(ns("overview_barchar"), height = "600px")) + column(6, shiny::plotOutput(ns("overview_hist"), height = "500px")), + # "This histogram shows sample collection frequency for all sites over the time period queried.", + column(6, shiny::plotOutput(ns( + "overview_barchar" + ), height = "600px")) ), htmltools::h3("Organizations in dataset"), - htmltools::HTML("The table below shows the organizations that collected data in your dataset and the number of measurements collected by each. Notice the third column, 'Rank'. This editable column is present because sometimes organizations unintentionally upload the same dataset multiple times to the WQP. For example, USGS will collect data at the request of state agencies. The USGS 'copy' of the results is uploaded to NWIS and made available in the portal, and the state agency's 'copy' of the results is uploaded to WQX. This rank provides the necessary info needed to flag and select one representative result from groups of duplicative uploads based on date, characteristic and result value/unit, and proximity to other sites. Double click in a cell in the 'Rank' column to edit the hierarchy of organizations and Ctrl-Enter to save those changes in the table: the default ranks organizations by the number of measurements in the dataset. Using the state vs USGS data example, if the state agency's organization name has a higher rank (ex. ranked #1) than USGS (ex. ranked #2), its result will be selected over the USGS upload of the sample, and the USGS version will be flagged for removal."), + htmltools::HTML( + "The table below shows the organizations that collected data in your dataset and the number of measurements collected by each. Notice the third column, 'Rank'. This editable column is present because sometimes organizations unintentionally upload the same dataset multiple times to the WQP. For example, USGS will collect data at the request of state agencies. The USGS 'copy' of the results is uploaded to NWIS and made available in the portal, and the state agency's 'copy' of the results is uploaded to WQX. This rank provides the necessary info needed to flag and select one representative result from groups of duplicative uploads based on date, characteristic and result value/unit, and proximity to other sites. Double click in a cell in the 'Rank' column to edit the hierarchy of organizations and Ctrl-Enter to save those changes in the table: the default ranks organizations by the number of measurements in the dataset. Using the state vs USGS data example, if the state agency's organization name has a higher rank (ex. ranked #1) than USGS (ex. ranked #2), its result will be selected over the USGS upload of the sample, and the USGS version will be flagged for removal." + ), htmltools::div(style = "margin-bottom:10px"), - shiny::fluidRow(column(12, DT::DTOutput(ns("overview_orgtable"), height = "500px"))) + shiny::fluidRow(column(12, DT::DTOutput( + ns("overview_orgtable"), height = "500px" + ))) ) } @@ -39,24 +65,29 @@ mod_overview_ui <- function(id) { mod_overview_server <- function(id, tadat) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns - + # this a reactive list created to hold all the reactive objects specific to this module. mapdat <- shiny::reactiveValues() - + # create dataset for map and histogram using raw data shiny::observeEvent(tadat$ovgo, { req(tadat$raw) # create gray text tile info mapdat$text <- tadat$raw %>% dplyr::filter(TADA.Remove == FALSE) %>% - dplyr::select(ResultIdentifier, MonitoringLocationIdentifier, OrganizationFormalName, ActivityStartDate) + dplyr::select( + ResultIdentifier, + MonitoringLocationIdentifier, + OrganizationFormalName, + ActivityStartDate + ) # create summary info and binning for map orgs <- tadat$raw %>% dplyr::filter(TADA.Remove == FALSE) %>% dplyr::group_by(OrganizationFormalName, OrganizationIdentifier) %>% dplyr::summarise("Result_Count" = length(unique(ResultIdentifier))) %>% dplyr::ungroup() - mapdat$orgs <- orgs %>% + tadat$org_table <- orgs %>% dplyr::arrange(-Result_Count) %>% dplyr::mutate("Rank" = 1:length(Result_Count)) # get top 10 characteristics by result number in the dataset and place the rest in a group called "all others" @@ -64,82 +95,127 @@ mod_overview_server <- function(id, tadat) { dplyr::filter(TADA.Remove == FALSE) %>% dplyr::group_by(TADA.CharacteristicName) %>% dplyr::summarise("Result_Count" = length(unique(ResultIdentifier))) - topslice <- chars %>% dplyr::slice_max(order_by = Result_Count, n = 10) + topslice <- + chars %>% dplyr::slice_max(order_by = Result_Count, n = 10) bottomslice <- chars %>% dplyr::ungroup() %>% dplyr::filter(!TADA.CharacteristicName %in% topslice$TADA.CharacteristicName) %>% dplyr::select("Result_Count") %>% dplyr::summarise("Result_Count" = sum(Result_Count)) %>% dplyr::mutate("TADA.CharacteristicName" = "ALL OTHERS") - chars <- plyr::rbind.fill(topslice, bottomslice) %>% dplyr::filter(Result_Count > 0) - chars <- chars %>% dplyr::mutate(TADA.Chars = substr(TADA.CharacteristicName, 1, 22)) - chars$TADA.Chars <- ifelse(nchar(chars$TADA.CharacteristicName) > 22, paste0(chars$TADA.Chars, "..."), chars$TADA.Chars) - chars <- chars %>% dplyr::mutate(TADA.Chars = forcats::fct_reorder(TADA.Chars, Result_Count, .desc = TRUE)) + chars <- + plyr::rbind.fill(topslice, bottomslice) %>% dplyr::filter(Result_Count > 0) + chars <- + chars %>% dplyr::mutate(TADA.Chars = substr(TADA.CharacteristicName, 1, 22)) + chars$TADA.Chars <- + ifelse( + nchar(chars$TADA.CharacteristicName) > 22, + paste0(chars$TADA.Chars, "..."), + chars$TADA.Chars + ) + chars <- + chars %>% dplyr::mutate(TADA.Chars = forcats::fct_reorder(TADA.Chars, Result_Count, .desc = TRUE)) mapdat$chars <- chars tadat$ovgo <- NULL if (is.null(tadat$orgs)) { - tadat$orgs <- mapdat$orgs$OrganizationIdentifier + tadat$orgs <- tadat$org_table$OrganizationIdentifier } }) - + # this widget produces the text at the top of the page describing record, site, and org numbers in dataset output$overview_totals <- shiny::renderText({ shiny::req(mapdat$text) - paste0("Your dataset contains ", scales::comma(length(unique(mapdat$text$ResultIdentifier))), " unique results from ", scales::comma(length(unique(mapdat$text$MonitoringLocationIdentifier))), " monitoring location(s) and ", scales::comma(length(unique(mapdat$text$OrganizationFormalName))), " unique organization(s).") + paste0( + "Your dataset contains ", + scales::comma(length( + unique(mapdat$text$ResultIdentifier) + )), + " unique results from ", + scales::comma(length( + unique(mapdat$text$MonitoringLocationIdentifier) + )), + " monitoring location(s) and ", + scales::comma(length( + unique(mapdat$text$OrganizationFormalName) + )), + " unique organization(s)." + ) }) - + # the leaflet map output$overview_map <- leaflet::renderLeaflet({ shiny::req(mapdat$text) - TADA::TADA_OverviewMap(tadat$raw[tadat$raw$TADA.Remove == FALSE, ]) + TADA::TADA_OverviewMap(tadat$raw[tadat$raw$TADA.Remove == FALSE,]) }) - + # histogram showing results collected over time. output$overview_hist <- shiny::renderPlot({ shiny::req(mapdat$text) ggplot2::ggplot(data = mapdat$text, ggplot2::aes(x = as.Date(ActivityStartDate, format = "%Y-%m-%d"))) + - ggplot2::geom_histogram(color = "black", fill = "#005ea2", binwidth = 7) + + ggplot2::geom_histogram(color = "black", + fill = "#005ea2", + binwidth = 7) + ggplot2::labs(title = "Results collected per week over date range queried", x = "Time", y = "Result Count") + ggplot2::theme_classic(base_size = 16) }) - + # organization numbers table, the editable part allows user to change only the third column (rankings) # https://yihui.shinyapps.io/DT-edit/ output$overview_orgtable <- DT::renderDT( - mapdat$orgs[, !names(mapdat$orgs) %in% c("OrganizationIdentifier")], + tadat$org_table[,!names(tadat$org_table) %in% c("OrganizationIdentifier")], editable = list(target = "column", disable = list(columns = c(0, 1))), - colnames = c("Organization Name", "Results Count", "Rank - Double Click to Edit, Ctrl-Enter to Save"), - options = list(pageLength = length(unique(mapdat$orgs$OrganizationFormalName)), searching = FALSE, scrollY = TRUE), + colnames = c( + "Organization Name", + "Results Count", + "Rank - Double Click to Edit, Ctrl-Enter to Save" + ), + options = list( + pageLength = length(unique( + tadat$org_table$OrganizationFormalName + )), + searching = FALSE, + scrollY = TRUE + ), rownames = FALSE, selection = "none" ) - - # observe({ - # print("What did the two raindrops say to the third one? Two is company, but three is a cloud.") - # print(input$overview_orgtable_cell_edit) - # }) - + shiny::observeEvent(input$overview_orgtable_cell_edit, { - org_rank <- data.frame(OrganizationIdentifier = mapdat$orgs$OrganizationIdentifier, Rank = as.numeric(input$overview_orgtable_cell_edit$value)) %>% dplyr::arrange(Rank) - mapdat$orgs <- mapdat$orgs %>% - dplyr::select(-Rank) %>% - dplyr::left_join(org_rank) %>% - dplyr::arrange(Rank) - # mapdat$orgs = orgs %>% dplyr::arrange(-Result_Count) %>% dplyr::mutate("Rank" = 1:length(Result_Count)) - tadat$orgs <- org_rank$OrganizationIdentifier + org_rank <- + data.frame( + OrganizationIdentifier = tadat$org_table$OrganizationIdentifier, + Rank = as.numeric(input$overview_orgtable_cell_edit$value) + ) %>% dplyr::arrange(Rank) + tadat$org_table <- tadat$org_table %>% + dplyr::select(-Rank) %>% + dplyr::left_join(org_rank) %>% + dplyr::arrange(Rank) + # tadat$org_table = orgs %>% dplyr::arrange(-Result_Count) %>% dplyr::mutate("Rank" = 1:length(Result_Count)) + tadat$orgs <- org_rank$OrganizationIdentifier }) - + # characteristics bar chart showing top characteristics by result number in dataset output$overview_barchar <- shiny::renderPlot({ shiny::req(mapdat$chars) - ggplot2::ggplot(mapdat$chars, ggplot2::aes(x = TADA.Chars, y = Result_Count)) + - ggplot2::geom_bar(stat = "identity", fill = "#005ea2", color = "black") + + ggplot2::ggplot(mapdat$chars, + ggplot2::aes(x = TADA.Chars, y = Result_Count)) + + ggplot2::geom_bar(stat = "identity", + fill = "#005ea2", + color = "black") + ggplot2::labs(title = "Results per Characteristic", x = "", y = "Results Count") + ggplot2::theme_classic(base_size = 16) + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + - ggplot2::geom_text(ggplot2::aes(x = TADA.Chars, y = Result_Count + (0.07 * max(Result_Count)), label = Result_Count), size = 5, color = "black") #+ + ggplot2::geom_text( + ggplot2::aes( + x = TADA.Chars, + y = Result_Count + (0.07 * max(Result_Count)), + label = Result_Count + ), + size = 5, + color = "black" + ) #+ }) - + shiny::observeEvent(input$refresh_overview, { shiny::req(mapdat$text) tadat$ovgo <- TRUE 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.R b/R/utils.R index 0876aa3fd..8e0a76f70 100644 --- a/R/utils.R +++ b/R/utils.R @@ -16,5 +16,11 @@ utils::globalVariables(c( "Target.TADA.CharacteristicName", "Target.TADA.MethodSpecificationName", "write.csv", "read.csv", "downloadHandler", - "Rank", "Target.TADA.ResultSampleFractionText" + "Rank", "Target.TADA.ResultSampleFractionText", + "Field", "characteristicName", "characteristicType", + "countycode", "endDate", "example_data", "huc", "m2f", + "nd_method", "nd_mult", "od_method", "org_table", + "organization", "original_source", "proj", "sampleMedia", + "selected_filters", "selected_flags", "siteType", + "siteid", "startDate", "statecode" )) 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 new file mode 100644 index 000000000..037cd6ab6 --- /dev/null +++ b/R/utils_track_progress.R @@ -0,0 +1,201 @@ + +writeFile <- function(tadat, filename) { + 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 + selected_flags <- tadat$selected_flags + m2f <- tadat$m2f + 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 + + 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 = FALSE) + checkFlagColumns(tadat$raw) + tadat$load_progress_file = filename + + # Confirm compatibility + job_id = job_id + if (!is.null(m2f)) { + tadat$m2f = m2f + } + + + if (!is.null(selected_flags)) { + tadat$selected_flags = selected_flags + shinyjs::enable(selector = '.nav li a[data-value="Flag"]') + } else { + print("No flags selected") + } + + # Enable tabs if certain fields are not null + if (!is.null(selected_filters)) { + shinyjs::enable(selector = '.nav li a[data-value="Filter"]') + } + + 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$od_method = od_method + tadat$nd_mult = nd_mult + tadat$od_mult +} + + +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