diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R
index d74a076a..5e8981f6 100644
--- a/R/settingsMetadata.R
+++ b/R/settingsMetadata.R
@@ -8,6 +8,7 @@
#' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting}
#' \item{label}{Label}
#' \item{description}{Description}
+#' \item{setting_cat}{Setting category (data, measure, appearance)}
#' \item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"}
#' \item{setting_required}{Flag indicating if the setting is required}
#' \item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data}
diff --git a/data-raw/settingsMetadata.csv b/data-raw/settingsMetadata.csv
index ce95c2f3..3854500d 100644
--- a/data-raw/settingsMetadata.csv
+++ b/data-raw/settingsMetadata.csv
@@ -1,26 +1,26 @@
-chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,adam,sdtm
-TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,USUBJID,USUBJID
-TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,AVAL,STRESN
-TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,PARAM,TEST
-TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1LO,STNRLO
-TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1HI,STNRHI
-TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,ADY,DY
-TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,VISIT,VISIT
-TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,VISITNUM,VISITNUM
-TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE,,,
-TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE,,,
-TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)"
-TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)"
-TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Bilirubin (umol/L),Total Bilirubin
-TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP)
-TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE,,,
-TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col,,
-TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE,,,
-TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col,,
-TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,
-TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,
-TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE,,,
-TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE,,,
-TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE,,,
-TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,,
-TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",Character,FALSE,FALSE,NA,FALSE,,,
\ No newline at end of file
+chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,adam,sdtm,setting_cat
+TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,USUBJID,USUBJID,data
+TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,AVAL,STRESN,data
+TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,PARAM,TEST,data
+TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)",data
+TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)",data
+TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Bilirubin (umol/L),Total Bilirubin,data
+TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP),data
+TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1LO,STNRLO,data
+TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1HI,STNRHI,data
+TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,ADY,DY,data
+TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,VISIT,VISIT,data
+TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,VISITNUM,VISITNUM,data
+TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE,,,,data
+TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE,,,,data
+TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE,,,,data
+TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col,,,data
+TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE,,,,data
+TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col,,,data
+TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,,measure
+TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,,measure
+TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE,,,,appearance
+TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE,,,,appearance
+TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE,,,,appearance
+TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,,,appearance
+TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",character,FALSE,FALSE,NA,FALSE,,,,appearance
diff --git a/data/settingsMetadata.rda b/data/settingsMetadata.rda
index c70c9c65..80803726 100644
Binary files a/data/settingsMetadata.rda and b/data/settingsMetadata.rda differ
diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R
index 41e62c3f..0820440c 100644
--- a/inst/eDISH_app/modules/renderSettings/renderSettings.R
+++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R
@@ -1,189 +1,101 @@
-source("modules/renderSettings/util/labelSetting.R")
-source("modules/renderSettings/util/flagSetting.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")
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 +148,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,7 +173,9 @@ 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())
@@ -278,106 +192,29 @@ renderSettings <- function(input, output, session, data, settings, status){
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 (name in isolate(input_names())){
+
+ 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)
+ }
+
+ }
+ })
+
### 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..df8f910d 100644
--- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R
+++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R
@@ -5,11 +5,31 @@ renderSettingsUI <- function(id){
tagList(
verticalLayout(
-
fluidRow(
- column(6,
+ column(4,
+ wellPanel(
+ div(
+ span(h2(tags$strong("Select Chart(s):"))),
+ checkboxGroupInput(ns("charts"),"",
+ choices = c("e-DISH" = "edish"),
+ selected="edish"))
+ )
+ )
+ ),
+ fluidRow(
+ column(4,
+ tags$hr()
+ )
+ ),
+ fluidRow(
+ column(4,
+ h2(tags$strong("Customize Settings:"))
+ )
+ ),
+ fluidRow(
+ column(4,
div(
- div(style="display: inline-block;", h3("Data Mapping")),
+ div(style="display: inline-block;", h3(tags$i("Data Mapping"))),
div(style="display: inline-block;", checkboxInput(ns("show_data_mapping"), "show", TRUE))
)
)
@@ -18,146 +38,16 @@ renderSettingsUI <- function(id){
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)
- )
+ uiOutput(ns("data_mapping_ui"))
))
)
),
fluidRow(
- column(6,
+ column(4,
div(
- div(style="display: inline-block;", h3("Measure Settings")),
+ div(style="display: inline-block;", h3(tags$i("Measure Settings"))),
div(style="display: inline-block;", checkboxInput(ns("show_measure_settings"), "show", TRUE))
)
)
@@ -166,17 +56,8 @@ renderSettingsUI <- function(id){
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)
- )
-
+ uiOutput(ns("measure_settings_ui"))
+
)
)
)
@@ -184,7 +65,7 @@ renderSettingsUI <- function(id){
fluidRow(
column(6,
div(
- div(style="display: inline-block;", h3("Appearance Settings")),
+ div(style="display: inline-block;", h3(tags$i("Appearance Settings"))),
div(style="display: inline-block;", checkboxInput(ns("show_appearance_settings"), "show", TRUE))
)
)
@@ -193,35 +74,7 @@ renderSettingsUI <- function(id){
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.")
- )
+ uiOutput(ns("appearance_settings_ui"))
)
)
)
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..b1af014d
--- /dev/null
+++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R
@@ -0,0 +1,87 @@
+createControl <- function(key, metadata, data, settings, ns){
+
+ sm_key <- filter(metadata, text_key==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")
+
+ ### 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){
+ if(is.null(setting_value)){
+ choices <- colnames(data)
+ placeholder <- list(
+ onInitialize = I('function() {
+ this.setValue("");}'))
+ } else{
+ choices <- unique(c(setting_value, colnames(data)))
+ placeholder <- list (onInitialize = I('function() { }'))
+ }
+ } else if (sm_key$field_mapping==TRUE){
+ if(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 there is 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
+ if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){
+
+ multiple <- (sm_key$setting_type=="vector")
+
+ div(
+ span(title = setting_description, tags$label(HTML(setting_label))),
+ span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")),
+ selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple)
+ )
+ } else if (sm_key$setting_type=="vector"){
+
+ div(
+ span(title = setting_description, tags$label(HTML(setting_label))),
+ span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")),
+ selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE)
+ )
+
+ } else if (sm_key$setting_type=="numeric"){
+ div(
+ div(title = setting_description, tags$label(HTML(setting_label))),
+ sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50)
+ )
+ } else if (sm_key$setting_type=="logical"){
+ div(
+ div(title = setting_description, tags$label(HTML(setting_label))),
+ checkboxInput(inputId = ns(key), label = NULL, value=setting_value)
+ )
+ } else if (sm_key$setting_type=="character"){
+ div(
+ div(title = setting_description, tags$label(HTML(setting_label))),
+ textAreaInput(inputId = ns(key), label = NULL, value = setting_value)
+ )
+ }
+}
\ 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..b127f9ec
--- /dev/null
+++ b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R
@@ -0,0 +1,11 @@
+createSettingLabel <- function(key){
+ sm <- getSettingsMetadata(text_keys=key)
+ setting_label <- sm$label
+ required <- sm$setting_required
+
+ if (required){
+ paste0(" ", setting_label, "*")
+ } else {
+ paste0(" ", setting_label)
+ }
+}
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..8a7e955e
--- /dev/null
+++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R
@@ -0,0 +1,13 @@
+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/server.R b/inst/eDISH_app/server.R
index e18fc851..9ee0f420 100644
--- a/inst/eDISH_app/server.R
+++ b/inst/eDISH_app/server.R
@@ -9,7 +9,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 +21,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 +35,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 +44,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/man/settingsMetadata.Rd b/man/settingsMetadata.Rd
index fa44dcd2..1fd4c3d7 100644
--- a/man/settingsMetadata.Rd
+++ b/man/settingsMetadata.Rd
@@ -10,6 +10,7 @@
\item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting}
\item{label}{Label}
\item{description}{Description}
+ \item{setting_cat}{Setting category (data, measure, appearance)}
\item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"}
\item{setting_required}{Flag indicating if the setting is required}
\item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data}