", names(dd$data)[i], " - No Standard Detected
") - } else if (dd$standard[[i]]$details[[temp_standard]]$match == "Full") { - names(choices)[i] <- paste0("", names(dd$data)[i], " - ", dd$standard[[i]]$standard, "
") + } else if (dd$standard[[i]]$details[[temp_standard]]$match == "full") { + names(choices)[i] <- paste0("", names(dd$data)[i], " - ", standard_label, "
") # If partial data spec match - give the fraction of variables matched } else { - + valid_count <- dd$standard[[i]]$details[[temp_standard]]$valid_count total_count <- dd$standard[[i]]$details[[temp_standard]]$invalid_count + valid_count - + fraction_cols <- paste0(valid_count, "/" ,total_count) names(choices)[i] <- paste0("", names(dd$data)[i], " - ", "Partial ", - dd$standard[[i]]$standard, " (", fraction_cols, " data settings)", "
") + standard_label, " (", fraction_cols, " data settings)", "") } } return(choices) }) - + # update radio buttons to display dataset names and standards for selection observeEvent(input$datafile, { req(data_choices()) vals <- data_choices() names(vals) <- NULL names <- lapply(names(data_choices()), HTML) - + prev_sel <- lapply(reactiveValuesToList(input), unclass)$select_file # retain previous selection - + updateRadioButtons(session, "select_file", choiceNames = names, choiceValues = vals, selected = prev_sel) - + }) - + # get selected dataset when selection changes data_selected <- eventReactive(input$select_file, { isolate({index <- which(names(dd$data)==input$select_file)[1]}) dd$data[[index]] }) - + # upon a dataset being uploaded and selected, generate data preview output$datapreview_header <- renderUI({ data_selected() isolate(data_name <- input$select_file) h3(paste("Data Preview for", data_name)) }) - + output$data_preview <- DT::renderDataTable({ DT::datatable(data = data_selected(), caption = isolate(input$select_file), @@ -112,54 +141,54 @@ dataUpload <- function(input, output, session){ class="compact", extensions = "Scroller", options = list(scrollY=400, scrollX=TRUE)) }) - - + + # upon a dataset being selected, grab its standard standard <- eventReactive(data_selected(), { index <- which(names(dd$data)==input$select_file)[1] dd$standard[[index]] }) - + # upon a dataset being selected, use generateSettings() to produce a settings obj settings <- eventReactive(c(data_selected(), standard()), { - + current_standard <- standard()$standard - - if (! current_standard=="None"){ - partial <- ifelse(standard()$details[[current_standard]]$match == "Partial", TRUE, FALSE) - + + if (! current_standard=="none"){ + partial <- ifelse(standard()$details[[current_standard]]$match == "partial", TRUE, FALSE) + if (partial) { - partial_keys <- standard()$details[[current_standard]]$checks %>% + partial_keys <- standard()$details[[current_standard]]$checks %>% filter(valid==TRUE) %>% - select(text_key) %>% + select(text_key) %>% pull() - + generateSettings(standard=current_standard, chart="eDish", partial=partial, partial_keys = partial_keys) - + } else { generateSettings(standard=current_standard, chart="eDish") - } + } } else { generateSettings(standard=current_standard, chart="eDish") } }) - + # run validateSettings(data, standard, settings) and return a status status <- reactive({ req(data_selected()) req(settings()) - validateSettings(data_selected(), + validateSettings(data_selected(), settings(), - chart="eDish") + chart="eDish") }) - + exportTestValues(status = { status() }) ### return selected data, settings, and status to server return(list(data_selected = reactive(data_selected()), settings = reactive(settings()), status = reactive(status()))) - -} \ No newline at end of file + +} diff --git a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R index e214b5b8..cb5b6ccb 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R +++ b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R @@ -1,21 +1,34 @@ +#' Data upload module - UI code +#' +#' This module creates the Data tab for the Shiny app. +#' +#' The UI contains: +#' - a file upload control +#' - radio buttons for selecting from the available datasets +#' - raw data preview. +#' +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Data tab +#' dataUploadUI <- function(id){ - + ns <- NS(id) - - tagList( + + tagList( fluidRow( column(3, wellPanel( - h3("Data upload"), + h3("Data upload"), fileInput(ns("datafile"), "Upload a csv or sas7bdat file",accept = c(".sas7bdat", ".csv"), multiple = TRUE), - radioButtons(ns("select_file"),"Select file for eDISH chart", + radioButtons(ns("select_file"),"Select file for eDISH chart", choiceNames = list(HTML("Example data - ADaM
")), choiceValues = "Example data") ) ), - column(6, + column(6, fluidRow( - wellPanel( + wellPanel( uiOutput(ns("datapreview_header")), div(DT::dataTableOutput(ns("data_preview")), style = "font-size: 75%") ) @@ -23,5 +36,5 @@ dataUploadUI <- function(id){ ) ) ) - -} \ No newline at end of file + +} diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChart.R b/inst/eDISH_app/modules/renderChart/renderEDishChart.R index 15470cca..b900e9bf 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChart.R +++ b/inst/eDISH_app/modules/renderChart/renderEDishChart.R @@ -1,3 +1,19 @@ +#' Render eDISH chart - server code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive eDISH graphic. +#' +#' Workflow: +#' (1) A change in `data`, `settings`, or `valid` invalidates the eDISH chart output +#' (2) Upon a change in `valid`, the export chart functionality is conditionally made available or unavailable to user +#' (3) If "export chart" button is pressed, data and settings are passed to the parameterized report, knitted using +#' Rmarkdown, and downloaded to user computer. +#' +#' @param input Input objects from module namespace +#' @param output Output objects from module namespace +#' @param session An environment that can be used to access information and functionality relating to the session +#' @param data A data frame +#' @param valid A logical indicating whether data/settings combination is valid for chart + renderEDishChart <- function(input, output, session, data, settings, valid){ ns <- session$ns diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R b/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R index 8751609c..62a8fe14 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R +++ b/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R @@ -1,3 +1,11 @@ +#' Render eDISH chart - UI code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive eDISH graphic. + +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Chart tab +#' renderEDishChartUI <- function(id){ ns <- NS(id) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 41e62c3f..014d686c 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -1,189 +1,143 @@ -source("modules/renderSettings/util/labelSetting.R") -source("modules/renderSettings/util/flagSetting.R") +# Functions to include +source("modules/renderSettings/util/createSettingsSection.R") +source("modules/renderSettings/util/createSettingLabel.R") +source("modules/renderSettings/util/createControl.R") +source("modules/renderSettings/util/createSettingsUI.R") source("modules/renderSettings/util/updateSettingStatus.R") +#' Render Settings module - Server code +#' +#' This module creates the Settings tab for the Shiny app. +#' +#' Workflow: +#' (1) Reactive input_names() contains names of settings related to selected charts. When a user changes +#' chart selections, input_names() is invalidated. +#' (2) A change in input_names(), `data`, or `settings` invalidates the following: +#' - renderUI associated with data mapping settings +#' - renderUI associated with measure settings +#' - renderUI associated with appearance settings +#' (3) These renderUI's call upon the createSettingsUI() function and will update +#' even when settings tab not in view. They will create and populate the UI for all related settings. +#' (4) Field-level inputs are updated upon any of the following events: +#' - a change in selected data +#' - change in selected chart(s) +#' - change in column-level input selection +#' update includes: +#' - Deactivate/activate field-level selector based on whether column-level input has been selected +#' - Data choices for field-level inputs based on selected column-level input +#' (5) A reactive representing the new settings object (settings_new()) is created based on UI selections. This object is invalidated +#' when ANY input changes. +#' (6) A reactive representing the new data/settings validation (status_new()) is created based on data and updated settings object. +#' A change in data OR updated settings object invalidated this reactive. +#' (7) Upon a change in the new validation (status_new() and derived status_df()), updated status messages are +#' printed on UI by calling updateSettingStatus(). ALL messages are re-printed at once. +#' +#' @param input Input objects from module namespace +#' @param output Output objects from module namespace +#' @param session An environment that can be used to access information and functionality relating to the session +#' @param data A data frame +#' @param settings Settings object that corresponds to data's standard - result of generateSettings(). +#' @param status A list describing the validation state for data/settings - result of validateSettings(). +#' +#' @return A list of reactive values, including: +#' \itemize{ +#' \item{"charts"}{A vector of chart(s) selected by the user} +#' \item{"settings"}{Upadted settings object based on UI/user selections} +#' \item{"status"}{Result from validateSettings() for originally selected data + updated settings object} +#' renderSettings <- function(input, output, session, data, settings, status){ + + ns <- session$ns + + #List of all inputs + input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts=input$selected_charts, cols="text_key")}) + + + ###################################################################### + # create settings UI + # - chart selection -> gather all necessary UI elements + # - create elements based on metadata file + # - populate using data/settings + ###################################################################### + + output$data_mapping_ui <- renderUI({ + req(input$charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts=input$charts, ns=ns)) + }) + outputOptions(output, "data_mapping_ui", suspendWhenHidden = FALSE) + + output$measure_settings_ui <- renderUI({ + req(input$charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "measure", charts=input$charts, ns=ns)) + }) + outputOptions(output, "measure_settings_ui", suspendWhenHidden = FALSE) + output$appearance_settings_ui <- renderUI({ + req(input$charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "appearance", charts=input$charts, ns=ns)) + }) + outputOptions(output, "appearance_settings_ui", suspendWhenHidden = FALSE) - #TODO: Save to separate file - probably needs to be a module. - runCustomObserver<-function(name){ + + ###################################################################### + # Update field level inputs + # + # update field-level inputs if a column level setting changes + # dependent on change in data, chart selection, or column-level input + ###################################################################### + + observe({ - # Custom observer for measure_col - if(name=="measure_col"){ - observe({ - settings <- settings() - - req(input$measure_col) - - if (input$measure_col %in% colnames()){ - if (!is.null(settings$measure_col) && input$measure_col==settings$measure_col){ - choices_ast <- unique(c(settings$measure_values$AST, as.character(data()[,settings$measure_col]))) - choices_alt <- unique(c(settings$measure_values$ALT, as.character(data()[,settings$measure_col]))) - choices_tb <- unique(c(settings$measure_values$TB, as.character(data()[,settings$measure_col]))) - choices_alp <- unique(c(settings$measure_values$ALP, as.character(data()[,settings$measure_col]))) - - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - } else { - choices_ast <- unique(data()[,input$measure_col]) - choices_alt <- unique(data()[,input$measure_col]) - choices_tb <- unique(data()[,input$measure_col]) - choices_alp <- unique(data()[,input$measure_col]) - - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) - } - } else { - updateSelectizeInput(session, "measure_values--ALT", choices = "") - updateSelectizeInput(session, "measure_values--AST", choices = "") - updateSelectizeInput(session, "measure_values--TB", choices = "") - updateSelectizeInput(session, "measure_values--ALP", choices = "") - } - - }) - } + column_keys <- getSettingsMetadata(charts=input$charts, + filter_expr = field_mapping==TRUE) %>% + pull(field_column_key) %>% + unique %>% + as.list() - # Custom observer for baseline - if(name=="baseline--value_col"){ - observe({ - settings <- settings() + lapply(column_keys, function(col){ + + col_quo <- enquo(col) + observeEvent(input[[col]],{ + + field_keys <- getSettingsMetadata(charts=input$charts, col = "text_key", + filter_expr = field_column_key==!!col) - req(input$`baseline--value_col`) - if (input$`baseline--value_col` %in% colnames()){ - if (!is.null(settings$baseline$value_col) && input$`baseline--value_col`==settings$baseline$value_col){ - choices <- unique(c(settings$baseline$values, as.character(data()[,settings$baseline$value_col]))) - choices <- sort(choices) - - updateSelectizeInput(session, "baseline--values", choices = choices, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - } else { - choices <- unique(data()[,input$`baseline--value_col`]) - choices <- sort(choices) - - updateSelectizeInput(session, "baseline--values", choices = choices, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) - } - } else { - updateSelectizeInput(session, "baseline--values", choices = "") + # Toggle field-level inputs: + # ON - if column-level input is selected) + # OFF - if column-level input is not yet selected + for (fk in field_keys){ + toggleState(id = fk, condition = !input[[col]]=="") } - }) - } - - - # Custom observer for analysis population - if(name=="analysisFlag--value_col"){ - observe({ - settings <- settings() - - req(input$`analysisFlag--value_col`) - - if (input$`analysisFlag--value_col` %in% colnames()){ - if (!is.null(settings$analysisFlag$value_col) && input$`analysisFlag--value_col`==settings$analysisFlag$value_col){ - choices <- unique(c(settings$analysisFlag$values, as.character(data()[,settings$analysisFlag$value_col]))) - - updateSelectizeInput(session, "analysisFlag--values", choices = choices,, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }'))) - } else { - choices <- unique(data()[,input$`analysisFlag--value_col`]) - - updateSelectizeInput(session, "analysisFlag--values", choices = choices, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }'))) + + if (is.null(isolate(settings()[[col]])) || ! input[[col]] == isolate(settings()[[col]])){ + if (input[[col]] %in% colnames(data())){ + + choices <- unique(data()[,input[[col]]]) + + for (key in field_keys){ + updateSelectizeInput(session, inputId = key, choices = choices, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) + } + } } - } else { - updateSelectizeInput(session, "analysisFlag--values", choices = "") - } - - }) - } - } #end runCustomObserver() - - ########################### - # Make updates to the UI - ########################### - ns <- session$ns - - - #Columns in the data - colnames <- reactive({names(data())}) - - #List of all inputs - #input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts="eDiSH", cols="text_key")}) - input_names <- reactive({names(lapply(reactiveValuesToList(input), unclass))}) - #observe({print(input_names())}) + } + ) + }) + }) + + ###################################################################### # Fill settings object based on selections - # require that secondary inputs have been filled in before proceeding + # # update is triggered by any of the input selections changing - # - # NOTE: when data selection changes, the inputs are updating 1 by 1 - # Therefore, until the inputs are done updating based on new data, this object will be - # partially representing the old data, and partially representing the new data. - # not sure if this is the right place to do it...but can we clear out this object upon a data change and start over?? + ###################################################################### settings_new <- reactive({ - # print(input$id_col) settings <- list(id_col = input$id_col, value_col = input$value_col, @@ -236,13 +190,13 @@ renderSettings <- function(input, output, session, data, settings, status){ }) + ###################################################################### # validate new settings # the validation is run every time there is a change in data and/or settings. # - # NOTE: to prevent status updating as loop runs and fills in settings(), - # require the very last updated input to be available <- can't do this b/c we will have lots of - # null settings to start when no standard detected... - status_new <- reactive({ #eventReactive(settingsUI_list$settings,{ + ###################################################################### + + status_new <- reactive({ req(data()) req(settings_new()) name <- rev(isolate(input_names()))[1] @@ -261,123 +215,49 @@ renderSettings <- function(input, output, session, data, settings, status){ }) - #Setting Status information (from failed checks only) + ###################################################################### + # Setting validation status information + ###################################################################### status_df <- reactive({ req(status_new()) status_new()$checks %>% group_by(text_key) %>% mutate(num_fail = sum(valid==FALSE)) %>% + mutate(icon = ifelse(num_fail==0, "",""))%>% mutate(message_long = paste(message, collapse = " ") %>% trimws(), message_short = case_when( num_fail==0 ~ "OK", num_fail==1 ~ "1 failed check.", TRUE ~ paste(num_fail, "failed checks.") )) %>% - select(text_key, message_long, message_short, num_fail) %>% + select(text_key, icon, message_long, message_short, num_fail) %>% unique }) - + # for shiny tests exportTestValues(status_df = { status_df() }) - #List of required settings - req_settings <- safetyGraphics:::getSettingsMetadata() %>% - filter(chart_edish==TRUE & setting_required==TRUE) %>% - pull(text_key) - - #List of inputs with custom observers - custom_observer_settings <- c("measure_col", "baseline--value_col","analysisFlag--value_col") - - - #Establish observers to update settings UI for all inputs - # Different observers: - # (1a) update UI based on data selection & original settings object - # - dependent on: colnames() - # - populate all UI inputs - # - flag required settings - # (1b) Do 1a for the custom settings (e.g. measure_values options). These contained nested observers - # - dependent on: parent input$xxx - # (2) append status messages to UI - # - after UI is filled, we generate a NEW settings object & status - # - dependent on: the new settings/status, which will update after every user selection - - - # observeEvent(data(), { - observe({ - req(colnames()) - - for (name in isolate(input_names())){ - #print(name) - setting_key <- as.list(strsplit(name,"\\-\\-")) - setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings()) - setting_label <- safetyGraphics:::getSettingsMetadata(charts="eDiSH", text_keys=name, cols="label") - setting_description <- safetyGraphics:::getSettingsMetadata(charts="eDiSH", text_keys=name, cols="description") - - - column_mapping_ids <- safetyGraphics:::getSettingsMetadata(charts="eDiSH") %>% filter(column_mapping==TRUE) %>% pull(text_key) - - - if (name %in% column_mapping_ids){ - sortedChoices<-NULL - if(is.null(setting_value)){ - sortedChoices<-colnames() - updateSelectizeInput(session, name, choices=sortedChoices, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }') - )) - - - }else{ - sortedChoices<-unique(c(setting_value, colnames())) - updateSelectizeInput(session, name, choices=sortedChoices, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }') - )) - - } - } - - # 2. Check for custom observers and initialize if needed - if(name %in% custom_observer_settings){ - runCustomObserver(name=name) - } - - # 3. label setting - labelSetting(ns=ns, name=name, label=setting_label, description=setting_description) - - # 4. Flag the input if it is required - if(name %in% req_settings){ - flagSetting(session=session, name=name, originalLabel=setting_label) - - } - } - }) - - - observe({ - for (name in isolate(input_names())){ - - # 5. Print a warning if the input failed a validation check - if(name %in% status_df()$text_key){ - - status_short <- status_df()[status_df()$text_key==name, "message_short"] - status_long <- status_df()[status_df()$text_key==name, "message_long"] - - updateSettingStatus(ns=ns, name=name, status_short=status_short, status_long=status_long) - } - - } - }) - + ###################################################################### + # print validation messages + ###################################################################### + observe({ + for (key in isolate(input_names())){ + + if(key %in% status_df()$text_key){ + + status_short <- status_df()[status_df()$text_key==key, "message_short"] + status_long <- status_df()[status_df()$text_key==key, "message_long"] + icon <- status_df()[status_df()$text_key==key, "icon"] + updateSettingStatus(ns=ns, key=key, status_short=status_short, status_long=status_long, icon=icon) + } + + } + }) + ### return updated settings and status to global env. - return(list(settings = reactive(settings_new()), + return(list(charts = reactive(input$charts), + settings = reactive(settings_new()), status = reactive(status_new()))) } diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 0738d245..83a3f4c3 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -1,230 +1,23 @@ renderSettingsUI <- function(id){ - ns <- NS(id) - tagList( - verticalLayout( - - fluidRow( - column(6, - div( - div(style="display: inline-block;", h3("Data Mapping")), - div(style="display: inline-block;", checkboxInput(ns("show_data_mapping"), "show", TRUE)) - ) + fluidRow( + column(12, + class="chartSelect section", + checkboxGroupInput( + ns("charts"), + "Select Chart(s):", + choices = c("e-DISH" = "edish"), + selected="edish" ) - ), - conditionalPanel(condition="input.show_data_mapping", ns=ns, - fluidRow( - column(4, - wellPanel( - div( - span(id = ns("tt_lbl_id_col"), title = "", - tags$label(id = ns("lbl_id_col"), "")), - span(id = ns("tt_msg_id_col"), title = "", - tags$label(id = ns("msg_id_col"), "")), - selectizeInput(ns("id_col"),NULL, choices = NULL) - - ), - - div( - span(id = ns("tt_lbl_value_col"), title = "", - tags$label(id = ns("lbl_value_col"), "")), - span(id = ns("tt_msg_value_col"), title = "", - tags$label(id = ns("msg_value_col"), "")), - selectizeInput(ns("value_col"),NULL, choices = NULL) - - ), - - div( - span(id = ns("tt_lbl_measure_col"), title = "", - tags$label(id = ns("lbl_measure_col"), "")), - span(id = ns("tt_msg_measure_col"), title = "", - tags$label(id = ns("msg_measure_col"), "")), - selectizeInput(ns("measure_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--ALT"), title = "", - tags$label(id = ns("lbl_measure_values--ALT"), "")), - span(id = ns("tt_msg_measure_values--ALT"), title = "", - tags$label(id = ns("msg_measure_values--ALT"), "")), - selectizeInput(ns("measure_values--ALT"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--AST"), title = "", - tags$label(id = ns("lbl_measure_values--AST"), "")), - span(id = ns("tt_msg_measure_values--AST"), title = "", - tags$label(id = ns("msg_measure_values--AST"), "")), - selectizeInput(ns("measure_values--AST"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--TB"), title = "", - tags$label(id = ns("lbl_measure_values--TB"), "")), - span(id = ns("tt_msg_measure_values--TB"), title = "", - tags$label(id = ns("msg_measure_values--TB"), "")), - selectizeInput(ns("measure_values--TB"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--ALP"), title = "", - tags$label(id = ns("lbl_measure_values--ALP"), "")), - span(id = ns("tt_msg_measure_values--ALP"), title = "", - tags$label(id = ns("msg_measure_values--ALP"), "")), - selectizeInput(ns("measure_values--ALP"),NULL, choices = NULL) - ), - # ), - div( - span(id = ns("tt_lbl_normal_col_low"), title = "", - tags$label(id = ns("lbl_normal_col_low"), "")), - span(id = ns("tt_msg_normal_col_low"), title = "", - tags$label(id = ns("msg_normal_col_low"), "")), - selectizeInput(ns("normal_col_low"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_normal_col_high"), title = "", - tags$label(id = ns("lbl_normal_col_high"), "")), - span(id = ns("tt_msg_normal_col_high"), title = "", - tags$label(id = ns("msg_normal_col_high"), "")), - selectizeInput(ns("normal_col_high"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_visit_col"), title = "", - tags$label(id = ns("lbl_visit_col"), "")), - span(id = ns("tt_msg_visit_col"), title = "", - tags$label(id = ns("msg_visit_col"), "")), - selectizeInput(ns("visit_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_visitn_col"), title = "", - tags$label(id = ns("lbl_visitn_col"), "")), - span(id = ns("tt_msg_visitn_col"), title = "", - tags$label(id = ns("msg_visitn_col"), "")), - selectizeInput(ns("visitn_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_studyday_col"), title = "", - tags$label(id = ns("lbl_studyday_col"), "")), - span(id = ns("tt_msg_studyday_col"), title = "", - tags$label(id = ns("msg_studyday_col"), "")), - selectizeInput(ns("studyday_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_baseline--value_col"), title = "", - tags$label(id = ns("lbl_baseline--value_col"), "")), - span(id = ns("tt_msg_baseline--value_col"), title = "", - tags$label(id = ns("msg_baseline--value_col"), "")), - selectizeInput(ns("baseline--value_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_baseline--values"), title = "", - tags$label(id = ns("lbl_baseline--values"), "")), - span(id = ns("tt_msg_baseline--values"), title = "", - tags$label(id = ns("msg_baseline--values"), "")), - selectizeInput(ns("baseline--values"),NULL, choices = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_filters"), title = "", - tags$label(id = ns("lbl_filters"), "")), - span(id = ns("tt_msg_filters"), title = "", - tags$label(id = ns("msg_filters"), "")), - selectInput(ns("filters"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_group_cols"), title = "", - tags$label(id = ns("lbl_group_cols"), "")), - span(id = ns("tt_msg_group_cols"), title = "", - tags$label(id = ns("msg_group_cols"), "")), - selectInput(ns("group_cols"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_analysisFlag--value_col"), title = "", - tags$label(id = ns("lbl_analysisFlag--value_col"), "")), - span(id = ns("tt_msg_analysisFlag--value_col"), title = "", - tags$label(id = ns("msg_analysisFlag--value_col"), "")), - selectizeInput(ns("analysisFlag--value_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_analysisFlag--values"), title = "", - tags$label(id = ns("lbl_analysisFlag--values"), "")), - span(id = ns("tt_msg_analysisFlag--values"), title = "", - tags$label(id = ns("msg_analysisFlag--values"), "")), - selectizeInput(ns("analysisFlag--values"),NULL, choices = NULL, multiple = TRUE) - ) - )) - - ) - ), - - fluidRow( - column(6, - div( - div(style="display: inline-block;", h3("Measure Settings")), - div(style="display: inline-block;", checkboxInput(ns("show_measure_settings"), "show", TRUE)) - ) - ) - ), - conditionalPanel(condition="input.show_measure_settings", ns=ns, - fluidRow( - column(4, - wellPanel( - div( - div(id = ns("tt_lbl_x_options"), title = "", - tags$label(id = ns("lbl_x_options"), "")), - selectizeInput(ns("x_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("ALT", "AST", "ALP"), multiple=TRUE) - ), - div( - div(id = ns("tt_lbl_y_options"), title = "", - tags$label(id = ns("lbl_y_options"), "")), - selectizeInput(ns("y_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("TB"), multiple = TRUE) - ) - - ) - ) - ) - ), - fluidRow( - column(6, - div( - div(style="display: inline-block;", h3("Appearance Settings")), - div(style="display: inline-block;", checkboxInput(ns("show_appearance_settings"), "show", TRUE)) - ) - ) - ), - conditionalPanel(condition="input.show_appearance_settings", ns=ns, - fluidRow( - column(4, - wellPanel( - div( - div(id = ns("tt_lbl_visit_window"), title = "", - tags$label(id = ns("lbl_visit_window"), "")), - sliderInput(ns("visit_window"),NULL, value = 30, min=0, max=50) - ), - div( - div(id = ns("tt_lbl_r_ratio_filter"), title = "", - tags$label(id = ns("lbl_r_ratio_filter"), "")), - checkboxInput(ns("r_ratio_filter"),NULL, value = TRUE) - ), - conditionalPanel( - condition="input.r_ratio_filter==true", ns=ns, - div( - div(id = ns("tt_lbl_r_ratio_cut"), title = "", - tags$label(id = ns("lbl_r_ratio_cut"), "")), - sliderInput(ns("r_ratio_cut"),NULL, value = 0, min=0, max =1) - ) - ), - div( - div(id = ns("tt_lbl_showTitle"), title = "", - tags$label(id = ns("lbl_showTitle"), "")), - checkboxInput(ns("showTitle"),NULL, value = TRUE) - ), - div( - div(id = ns("tt_lbl_warningText"), title = "", - tags$label(id = ns("lbl_warningText"), "")), - textAreaInput (ns("warningText"),NULL, rows =4, - value = "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures.") - ) - ) - ) - ) ) - )) + ), + #TODO - make this a loop based on metadata + fluidRow( + createSettingsSection("data_mapping", "Data Mappings",6,ns), + createSettingsSection("measure_settings", "Measure Settings",6,ns), + createSettingsSection("appearance_settings", "Appearance Settings",6,ns) + ) + ) } diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R new file mode 100644 index 00000000..11b418a2 --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -0,0 +1,90 @@ +#' Create setting control +#' +#' Workflow: +#' (1) Get setting label and description from metadata +#' (2) Get setting value from settings object +#' (3) Get choices and placeholder text for the selectors based on metadata, data, and settings +#' (4) Create HTML code for the selector based on the following metadata: +#' - whether the option is a column or field-level input +#' - data type of the setting (e.g. character/numeric/logical, vector of length 1 vs >1) +#' - label, description, choices, selected value, placeholder text +#' +#' @param key A character key representing the setting of interest +#' @param metadata Metadata data frame to be queried for information about the setting +#' @param data A data frame to be used to populate control options +#' @param settings A settings list to be used to populate control options +#' @param ns The namespace of the current module +#' +#' @return HTML code for the div containing the setting of interest +createControl <- function(key, metadata, data, settings, ns){ + + sm_key <- filter(metadata, text_key==key) + ctl_id <- paste0("ctl_", key) + tt_msg <- paste0("tt_msg_", key) + msg <- paste0("msg_", key) + + ### get metadata for the input + setting_key <- as.list(strsplit(key,"\\-\\-")) + setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) + setting_label <- createSettingLabel(key) + setting_description <- getSettingsMetadata(text_keys=key, cols="description") + setting_required <- ifelse(getSettingsMetadata(text_keys=key, cols="setting_required"),"\nSetting Required","\nSetting Optional") + + ### if a field-level input, get metadata about the parent column-level input + field_column <- NULL + field_column_label <- NULL + if (!is.null(sm_key$field_column_key)){ + field_column <- safetyGraphics:::getSettingValue(key=list(sm_key$field_column_key), settings=settings) + field_column_label <- getSettingsMetadata(text_key = sm_key$field_column_key, cols = "label") + } + + ### get the choices for the selectors + value <- NULL + choices <- NULL + placeholder <- NULL + + if(sm_key$column_mapping==TRUE & is.null(setting_value)){ #column mapping - no value specified + choices <- colnames(data) + placeholder <- list(onInitialize = I('function() {this.setValue("");}')) + } else if(sm_key$column_mapping==TRUE & !is.null(setting_value)) { #column mapping - value specified + choices <- unique(c(setting_value, colnames(data))) + placeholder <- list (onInitialize = I('function() { }')) + } else if (sm_key$field_mapping==TRUE & is.null(field_column)){ ## if there is NOT a column specified in settings + placeholder <- list( + placeholder = paste0("Please select a ", field_column_label), + onInitialize = I('function() { + this.setValue("");}') + ) + } else if (sm_key$field_mapping==TRUE & !is.null(field_column)){ ## if there is NOT a column specified in settings + choices <- unique(c(setting_value, as.character(data[,field_column]))) %>% unlist + placeholder <- list (onInitialize = I('function() { }')) + } else if (sm_key$setting_type=="vector"){ + choices <- setting_value ### this is meant to cover the scenario for x_options/y_options + } + + ### create code for the UI + multiple <- (sm_key$setting_type=="vector") + + if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ + input <- selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) + } else if (sm_key$setting_type=="vector"){ + input <- selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) + } else if (sm_key$setting_type=="numeric"){ + input <- sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) + } else if (sm_key$setting_type=="logical"){ + input <- checkboxInput(inputId = ns(key), label = NULL, value=setting_value) + } else if (sm_key$setting_type=="character"){ + input <-textAreaInput(inputId = ns(key), label = NULL, value = setting_value) + } + + div( + class="control-wrap", + id=ns(ctl_id), + span(title = paste0(setting_description," ",setting_required), tags$label(HTML(setting_label))), + div( + class="select-wrap", + input, + div(id = ns(tt_msg), title = "", tags$label(id = ns(msg), ""), class="status") + ) + ) +} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R new file mode 100644 index 00000000..5f162221 --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R @@ -0,0 +1,13 @@ +#' Create label for chart setting selector +#' +#' @param key A character key representing the setting of interest. +#' +#' @return A character string containing full HTML text to be used for input label. Contains info icon to +#' indicate that description is available upon mouseover, setting label, and asterisk if setting is required. +#' +createSettingLabel <- function(key){ + sm <- getSettingsMetadata(text_keys=key) + setting_label <- sm$label + required <- sm$setting_required + paste0(setting_label)#, " " ) +} diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R new file mode 100644 index 00000000..eca0959e --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R @@ -0,0 +1,24 @@ +createSettingsSection <- function(class, label,cols,ns){ + section <- + column(cols, + wellPanel( + class=paste0(class," section"), + h3( + label, + materialSwitch( + ns(paste0("show_",class)), + label = "", + right=TRUE, + value = TRUE, + status = "primary" + ) + ), + conditionalPanel( + condition=paste0("input.show_",class), + ns=ns, + uiOutput(ns(paste0(class,"_ui"))) + ) + ) + ) + return(section) +} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R new file mode 100644 index 00000000..086a5940 --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R @@ -0,0 +1,22 @@ +#' Create UI for specified section of settings tab +#' +#' @param data A data frame to be used to populate control options +#' @param settings A settings list to be used to populate control options +#' @param setting_cat_val Settings category. One of "data","measure","appearance" +#' @param charts A character vector containing names of charts of interest +#' @param ns The namespace of the current module +#' +#' @return A list containing the UI code for all selectors in the specified settings category. +createSettingsUI <- function(data, settings, setting_cat_val, charts, ns){ + + sm <- getSettingsMetadata(charts=charts) %>% + filter(setting_cat==setting_cat_val) + + lapply(sm$text_key, function(key){ + createControl(key, metadata = sm, data, settings, ns) + }) +} + + + + diff --git a/inst/eDISH_app/modules/renderSettings/util/flagSetting.R b/inst/eDISH_app/modules/renderSettings/util/flagSetting.R deleted file mode 100644 index eb0b6542..00000000 --- a/inst/eDISH_app/modules/renderSettings/util/flagSetting.R +++ /dev/null @@ -1,8 +0,0 @@ -flagSetting<-function(session, name, originalLabel){ - - originalLabel <- paste("", originalLabel) - - shinyjs::html(id = paste0("lbl_", name), - html = paste0(originalLabel, "*"), - add = FALSE) -} diff --git a/inst/eDISH_app/modules/renderSettings/util/labelSetting.R b/inst/eDISH_app/modules/renderSettings/util/labelSetting.R deleted file mode 100644 index cf0f4cf7..00000000 --- a/inst/eDISH_app/modules/renderSettings/util/labelSetting.R +++ /dev/null @@ -1,14 +0,0 @@ -labelSetting<-function(ns, name, label, description){ - - - label <- paste("", label) - - label_id <- paste0("lbl_", name) - shinyjs::html(id = label_id, - html = label, - add = FALSE) - - tooltip_id <- paste0("tt_lbl_", name) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "', description, '")')) -} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R index c594d42b..a3003b57 100644 --- a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R +++ b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R @@ -1,21 +1,29 @@ -updateSettingStatus<-function(ns, name, status_short, status_long){ - - msg_id <- paste0("msg_", name) - tooltip_id <- paste0("tt_msg_", name) +#' Update setting validation status +#' +#' Workflow: +#' (1) Update abbreviated status for a given setting using green (valid) or red (invalid) text +#' (2) Update long status message for a given setting to be displayed upon mouseover +#' +#' @param ns The namespace of the current module +#' @param key A character key representing the setting of interest +#' @param status_short Abbreviated validation message +#' @param status_long Detailed validation message + +updateSettingStatus<-function(ns, key, status_short, status_long, icon){ - if (status_short=="OK"){ - shinyjs::html(id = msg_id, - html = paste(" ", status_short,"", - "")) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "Selection is valid")')) - - } else { - shinyjs::html(id = msg_id, - html = paste(" ", status_short,"", - "")) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "', status_long, '")')) + ctl_id<-paste0("ctl_", key) + #TODO: get msg_ and tooltip_ selectors using relative position to control id + msg_id <- paste0("msg_", key) + tooltip_id <- paste0("tt_msg_", key) + if(status_short=="OK"){ + shinyjs::addClass(id=ctl_id, class="valid") + shinyjs::removeClass(id=ctl_id, class="invalid") + }else{ + shinyjs::removeClass(id=ctl_id, class="valid") + shinyjs::addClass(id=ctl_id, class="invalid") + } + shinyjs::html(id = msg_id, html = paste(icon)) + if(nchar(status_long)>0){ + shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "',status_long,'").addClass("details")')) } - } diff --git a/inst/eDISH_app/server.R b/inst/eDISH_app/server.R index e18fc851..76dfae74 100644 --- a/inst/eDISH_app/server.R +++ b/inst/eDISH_app/server.R @@ -1,3 +1,10 @@ +# Server code for safetyGraphics App +# - calls dataUpload module (data tab) +# - calls renderSettings module (settings tab) +# - calls renderEDishChart (chart tab) +# - uses render UI to append a red X or green check on tab title, +# indicating whether user has satisfied requirements of that tab + function(input, output, session){ @@ -9,7 +16,8 @@ function(input, output, session){ # add status to data panel nav bar # always OK for now, since example data is loaded by default output$data_tab_title = renderUI({ - HTML(paste("Data", icon("check", class="ok"))) + # HTML(paste("Data", icon("check", class="ok"))) + span(tagList("Data", icon("check", class="ok"))) }) # based on selected data set & generated/selected settings obj, generate settings page. @@ -20,7 +28,8 @@ function(input, output, session){ # # reutrns updated settings and validation status settings_new <- callModule(renderSettings, "settingsUI", - data = isolate(reactive(dataUpload_out$data_selected())), + # data = isolate(reactive(dataUpload_out$data_selected())), # this doesnt make sense + data = reactive(dataUpload_out$data_selected()), settings = reactive(dataUpload_out$settings()), status = reactive(dataUpload_out$status())) @@ -33,7 +42,7 @@ function(input, output, session){ HTML(paste("Settings", icon("times", class="notok"))) } }) - + # update charts navbar output$chart_tab_title = renderUI({ if (settings_new$status()$valid==TRUE){ @@ -42,8 +51,8 @@ function(input, output, session){ HTML(paste("Chart", icon("times", class="notok"))) } }) - - + + # module to render eDish chart callModule(renderEDishChart, "chartEDish", data = reactive(dataUpload_out$data_selected()), diff --git a/inst/eDISH_app/ui.R b/inst/eDISH_app/ui.R index a6e2eea2..27aa19ee 100644 --- a/inst/eDISH_app/ui.R +++ b/inst/eDISH_app/ui.R @@ -1,8 +1,10 @@ +# UI Code for safetyGraphics App + tagList( useShinyjs(), - tags$style(HTML(" - .ok { color:#008000;} - .notok {color: #FF0000;}")), + tags$head( + tags$link(rel = "stylesheet", type = "text/css", href = "index.css") + ), navbarPage("eDISH Shiny app", tabPanel(title = htmlOutput("data_tab_title"), dataUploadUI("datatab") diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css new file mode 100644 index 00000000..1f292331 --- /dev/null +++ b/inst/eDISH_app/www/index.css @@ -0,0 +1,81 @@ +/* --- hide the chartSelect div until we're ready to implement multiple charts --- */ +.chartSelect{ + display:none; +} +/* ------------------------------------------------------------------------------- */ + +.section{ + min-width:400px; +} + +.control-wrap{ + margin-top:1em; +} + +.control-wrap span label{ + font-weight:normal; + color:#444; + cursor:help; +} + +.control-wrap .select-wrap .form-group{ + width:90%; /* TODO: don't love this ... update eventually */ + display:inline-block; + margin-bottom:0; +} + +.control-wrap .select-wrap .form-group .form-control{ + margin-bottom:0; +} + +.control-wrap .select-wrap .status{ + display:inline-block; + margin-top:.5em; + padding-left:0.5em; + vertical-align:top; +} + +.control-wrap .select-wrap .status.details label i { + cursor:help; +} + + +/* Validation Coloring */ + +.control-wrap.valid .select-wrap .status{ + color:green; +} + +.control-wrap.valid .select-wrap div .selectize-control .selectize-input{ + border-color:green; +} + +.control-wrap.invalid .select-wrap .status{ + color:red; +} + +.control-wrap.invalid .select-wrap div .selectize-control .selectize-input{ + border-color:red; +} + +/* Settings - header tweaks */ +.section h3 { + margin:0; +} + +.section h3 .form-group { + display:inline; +} + +.section h3 .form-group .material-switch{ + float:right; +} + + +.ok { + color:#008000; +} + +.notok { + color: #FF0000; +} \ No newline at end of file diff --git a/man/detectStandard.Rd b/man/detectStandard.Rd index 8536045e..ec561f35 100644 --- a/man/detectStandard.Rd +++ b/man/detectStandard.Rd @@ -14,16 +14,16 @@ detectStandard(data, includeFields = TRUE, domain = "labs") \item{domain}{The data domain for the data set provided. Default: \code{"labs"}.} } \value{ -A list containing the matching \code{"standard"} ("ADaM", "SDTM" or "None") and a list of \code{"details"} describing each standard considered. +A list containing the matching \code{"standard"} from \code{"standardMetadata"} and a list of \code{"details"} describing each standard considered. } \description{ -This function attempts to detect the data CDISC clinical standard used in a given R data frame. +This function attempts to detect the clinical data standard used in a given R data frame. } \details{ -This function compares the columns in the provided \code{"data"} with the required columns for a given data standard/domain combination. The function is designed to work with the SDTM and AdAM CDISC(