diff --git a/DESCRIPTION b/DESCRIPTION index af04f4a3..048f549f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: safetyGraphics Title: Create Interactive Graphics Related to Clinical Trial Safety -Version: 0.9.1 +Version: 0.10.0 Authors@R: c( person("Jeremy", "Wildfire", email = "jeremy_wildfire@rhoworld.com", role = c("cre","aut")), person("Becca", "Krouse", role="aut"), diff --git a/NAMESPACE b/NAMESPACE index 3acbd77b..c5514b8c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,7 +7,10 @@ export(generateSettings) export(getRequiredSettings) export(getSettingsMetadata) export(renderEDISH) +export(renderSafetyHistogram) export(safetyGraphicsApp) +export(safetyHistogram) +export(safetyHistogramOutput) export(validateSettings) import(DT) import(dplyr) @@ -16,6 +19,7 @@ import(rmarkdown) import(shinyjs) importFrom(dplyr,"filter") importFrom(dplyr,filter) +importFrom(dplyr,full_join) importFrom(haven,read_sas) importFrom(magrittr,"%>%") importFrom(purrr,keep) diff --git a/R/checkColumn.R b/R/checkColumn.R index 3674be7b..c6bb0db1 100644 --- a/R/checkColumn.R +++ b/R/checkColumn.R @@ -16,27 +16,27 @@ #' testSettings$filters[[1]]<-list(value_col="RACE",label="Race") #' testSettings$filters[[2]]<-list(value_col=NULL,label="No Column") #' testSettings$filters[[3]]<-list(value_col="NotAColumn",label="Invalid Column") -#' +#' #' #pass ($valid == TRUE) #' safetyGraphics:::checkColumn(key=list("id_col"), -#' settings=testSettings, adlbc) -#' +#' settings=testSettings, adlbc) +#' #' #pass #' safetyGraphics:::checkColumn(key=list("filters",1,"value_col"), -#' settings=testSettings, adlbc) -#' +#' settings=testSettings, adlbc) +#' #' #NULL column pass #' safetyGraphics:::checkColumn(key=list("filters",2,"value_col"), -#' settings=testSettings, adlbc) -#' +#' settings=testSettings, adlbc) +#' #' #invalid column fails #' safetyGraphics:::checkColumn(key=list("filters",3,"value_col"), -#' settings=testSettings, adlbc) +#' settings=testSettings, adlbc) #' @keywords internal checkColumn <- function(key, settings, data){ stopifnot(typeof(key)=="list",typeof(settings)=="list") - + current <- list(key=key) current$text_key <- paste( unlist(current$key), collapse='--') current$type <- "column" diff --git a/R/checkNumeric.R b/R/checkNumeric.R index 435d4627..588c95b4 100644 --- a/R/checkNumeric.R +++ b/R/checkNumeric.R @@ -10,11 +10,11 @@ #' @examples #' testSettings<-generateSettings(standard="AdAM") #' #pass ($valid == FALSE) -#' safetyGraphics:::checkNumeric(key=list("id_col"),settings=testSettings, data=adlbc) -#' +#' safetyGraphics:::checkNumeric(key=list("id_col"),settings=testSettings, data=adlbc) +#' #' #pass ($valid == TRUE) -#' safetyGraphics:::checkNumeric(key=list("value_col"),settings=testSettings, data=adlbc) -#' +#' safetyGraphics:::checkNumeric(key=list("value_col"),settings=testSettings, data=adlbc) +#' #' @keywords internal checkNumeric <- function(key, settings, data){ diff --git a/R/data_checks.R b/R/data_checks.R new file mode 100644 index 00000000..0ae20a0b --- /dev/null +++ b/R/data_checks.R @@ -0,0 +1 @@ +#Statistical Checks \ No newline at end of file diff --git a/R/generateSettings.R b/R/generateSettings.R index ac5530d1..9a52f5bb 100644 --- a/R/generateSettings.R +++ b/R/generateSettings.R @@ -1,104 +1,138 @@ #' Generate a settings object based on a data standard #' -#' This function returns a settings object for the eDish chart based on the specified data standard. +#' This function returns a settings object for the eDish chart based on the specified data standard. #' #' The function is designed to work with the SDTM and AdAM CDISC() standards for clinical trial data. Currently, eDish is the only chart supported. #' -#' @param standard The data standard for which to create settings. Valid options are "SDTM", "AdAM" or "None". Default: \code{"SDTM"} -#' @param chart The chart for which standards should be generated ("eDish" only for now) . Default: \code{"eDish"}. +#' @param standard The data standard for which to create settings. Valid options are "SDTM", "AdAM" or "None". Default: \code{"None"}. +#' @param charts The chart or chart(s) for which settings should be generated. Default: \code{NULL} (uses all available charts). +#' @param useDefaults Specifies whether default values from settingsMetadata should be included in the settings object. Default: \code{TRUE}. #' @param partial Boolean for whether or not the standard is a partial standard. Default: \code{FALSE}. #' @param partial_keys Optional character vector of the matched settings if partial is TRUE. Settings should be identified using the text_key format described in ?settingsMetadata. Setting is ignored when partial is FALSE. Default: \code{NULL}. +#' @param custom_settings a tibble with text_key and customValue columns specifiying customizations to be applied to the settings object. Default: \code{NULL}. #' @return A list containing the appropriate settings for the selected chart -#' -#' @examples -#' -#' generateSettings(standard="SDTM") +#' +#' @examples +#' +#' generateSettings(standard="SDTM") #' generateSettings(standard="SdTm") #also ok #' generateSettings(standard="ADaM") #' pkeys<- c("id_col","measure_col","value_col") #' generateSettings(standard="adam", partial=TRUE, partial_keys=pkeys) -#' -#' generateSettings(standard="a different standard") +#' +#' generateSettings(standard="a different standard") #' #returns shell settings list with no data mapping -#' +#' #' \dontrun{ -#' generateSettings(standard="adam",chart="AEExplorer") #Throws error. Only eDish supported so far. +#' generateSettings(standard="adam",chart="AEExplorer") #Throws error. Only eDish supported so far. #' } -#' -#' @importFrom dplyr "filter" +#' +#' @importFrom dplyr "filter" full_join #' @importFrom stringr str_split #' @importFrom rlang .data -#' +#' #' @export -generateSettings <- function(standard="None", chart="eDish", partial=FALSE, partial_keys=NULL){ - if(tolower(chart)!="edish"){ - stop(paste0("Can't generate settings for the specified chart ('",chart,"'). Only the 'eDish' chart is supported for now.")) - } - +generateSettings <- function(standard="None", charts=NULL, useDefaults=TRUE, partial=FALSE, partial_keys=NULL, custom_settings=NULL){ + # Check that partial_keys is supplied if partial is true if (is.null(partial_keys) & partial ) { stop("partial_keys must be supplied if the standard is partial") } - + # Coerce options to lowercase standard<-tolower(standard) - chart<-tolower(chart) - + if(!is.null(charts)){ + charts<-tolower(charts) + } + + ############################################################################# + # get keys & default values for settings using a data standard (data and field mappings) + ############################################################################ # Build a table of data mappings for the selected standard and partial settings - standardList<-c("adam","sdtm") #TODO: automatically generate this from metadata + standardList<-safetyGraphics::standardsMetadata%>%select(-.data$text_key)%>%names + if(standard %in% standardList){ - dataMappings <- safetyGraphics::getSettingsMetadata( - charts = chart, + dataDefaults <- safetyGraphics::getSettingsMetadata( + charts = charts, cols=c("text_key",standard,"setting_required") - ) %>% + ) %>% filter(.data$setting_required)%>% - rename("column_name" = standard)%>% - filter(.data$column_name != '') - - if(partial){ - dataMappings<-dataMappings%>%filter(.data$text_key %in% partial_keys) - } + select(-.data$setting_required)%>% + rename("dataDefault" = standard)%>% + filter(.data$dataDefault != '') %>% + as_tibble + }else{ + dataDefaults<-tibble(text_key=character(),dataDefault=character(), .rows=0) } - - # build shell settings for each chart - # TODO: move these to `/data` eventually - shells<-list() - shells[["edish"]]<-list( - id_col = NULL, - value_col = NULL, - measure_col = NULL, - normal_col_low = NULL, - normal_col_high = NULL, - studyday_col=NULL, - visit_col = NULL, - visitn_col = NULL, - filters = NULL, - group_cols = NULL, - measure_values = list(ALT = NULL, - AST = NULL, - TB = NULL, - ALP = NULL), - baseline = list(value_col=NULL, - values=list()), - analysisFlag = list(value_col=NULL, - values=list()), - - x_options = c("ALT", "AST", "ALP"), - y_options = c("TB", "ALP"), - visit_window = 30, - r_ratio_filter = TRUE, - r_ratio_cut = 0, - showTitle = TRUE, - warningText = "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures." - ) - - # loop through dataMappings and apply them to the shell - if(standard %in% standardList){ - for(row in 1:nrow(dataMappings)){ - shells[[chart]]<-setSettingsValue(settings = shells[[chart]], key = textKeysToList(dataMappings[row,"text_key"])[[1]], value = dataMappings[row, "column_name"]) - } + + if(partial){ + dataDefaults <-dataDefaults%>%filter(.data$text_key %in% partial_keys) + } + ############################################################################# + # get keys & default values for settings not using a data standard + ############################################################################# + if(useDefaults){ + otherDefaults <- safetyGraphics::getSettingsMetadata( + charts = charts, + filter = !.data$column_mapping & !.data$field_mapping, + cols=c("text_key","default") + )%>% + rename("otherDefault"="default") + }else{ + otherDefaults <- tibble(text_key=character(),otherDefault=character(), .rows=0) + } + + ############################################################################# + # merge all keys & default values + ############################################################################# + key_values <- full_join(dataDefaults, otherDefaults, by="text_key") + key_values <- key_values %>% mutate(default=ifelse(is.na(.data$dataDefault),.data$otherDefault,.data$dataDefault)) + + ############################################################################# + # Apply custom settings (if any) + ############################################################################# + if(!is.null(custom_settings)){ + key_values<-full_join(key_values, custom_settings, by="text_key") + } else { + key_values$customValue<-NA + } + + key_values<- key_values %>% mutate(value=ifelse(is.na(.data$customValue),.data$default,.data$customValue)) + + ############################################################################# + # create shell settings object + ############################################################################# + shell<-generateShell(charts=charts) + + ######################################################################################### + # populate the shell settings by looping through key_values and apply them to the shell + ######################################################################################### + #print(key_values) + for(row in 1:nrow(key_values)){ + text_key<-key_values[row,]%>%pull("text_key") + key<- textKeysToList(text_key)[[1]] + type <- safetyGraphics::getSettingsMetadata(text_keys=text_key,cols="setting_type") + value <- key_values[row,"value"][[1]] + finalValue <- value[[1]] + + #print(paste(text_key," (",type,"):",toString(value),typeof(value),length(value),"->",finalValue,typeof(finalValue),length(finalValue))) + shell<-setSettingsValue( + settings = shell, + key = key, + value = finalValue + ) + } + + #Coerce empty string to NULL + for (i in names(shell)){ + if (!is.null(shell[[i]])){ + if (shell[[i]][1]==""){ + shell[i] <- list(NULL) + } + } } - return(shells[[chart]]) -} \ No newline at end of file + #print(shell) + return(shell) +} diff --git a/R/generateShell.R b/R/generateShell.R new file mode 100644 index 00000000..f0dac6d7 --- /dev/null +++ b/R/generateShell.R @@ -0,0 +1,34 @@ +#' Generate a default settings shell based on settings metadata +#' +#' This function returns a default settings object based on the chart(s) specified. +#' +#' The function is designed to work with valid safetyGraphics charts. +#' +#' @param charts The chart or chart(s) to include in the shell settings object +#' @return A list containing a setting shell (all values = NA) for the selected chart(s) +#' +#' @examples +#' +#' safetyGraphics:::generateShell(charts = "eDish") +#' +#' @keywords internal + +generateShell <- function(charts=NULL){ + keys <- safetyGraphics::getSettingsMetadata( + charts = charts, + cols=c("text_key") + ) %>% textKeysToList() + + shell <- list() + + for (i in 1:length(keys) ) { + shell<-setSettingsValue( + key=keys[[i]], + value=NULL, + settings=shell, + forceCreate=TRUE + ) + } + + return(shell) +} diff --git a/R/getChartSettings.R b/R/getChartSettings.R new file mode 100644 index 00000000..58004adf --- /dev/null +++ b/R/getChartSettings.R @@ -0,0 +1,19 @@ +#' Get chart-specific settings +#' +#' Subset master settings list to chart-specific settings list only +#' +#' @param settings Settings list containing settings for all selected charts. +#' @param chart The chart for which settings should be returned. +#' +#' @return Chart-specific settings +#' +#' @examples +#' settings <- safetyGraphics::generateSettings(standard="ADaM") +#' safetyGraphics:::getChartSettings(settings = settings, chart = "edish") +#' +#' @keywords internal +#' +getChartSettings <- function(settings, chart){ + settings_names <- names(safetyGraphics::generateSettings("None",chart=chart)) + return(settings[settings_names]) +} diff --git a/R/getSettingValue.R b/R/getSettingValue.R index 9794482c..dc8a7078 100644 --- a/R/getSettingValue.R +++ b/R/getSettingValue.R @@ -29,6 +29,9 @@ getSettingValue <- function(key,settings){ #If there are more keys and the value is a list, iterate if(typeof(value)=="list"){ value<-getSettingValue(key[2:length(key)],value) + #If position is provided and the value is a vector + }else if(is.numeric(key[[2]]) & length(value)>=key[[2]] & length(key)==2){ + value<-value[[key[[2]]]] }else{ #If there are more keys, but the value is not a list, return NULL value<-NULL diff --git a/R/getSettingsMetadata.R b/R/getSettingsMetadata.R index 7ae8aec8..31463e72 100644 --- a/R/getSettingsMetadata.R +++ b/R/getSettingsMetadata.R @@ -1,55 +1,54 @@ #' Get metadata about chart settings #' -#' Retrieve specified metadata about chart settings from the data/settingsMetadata.Rda file. -#' +#' Retrieve specified metadata about chart settings from the data/settingsMetadata.Rda file. +#' #' @param charts optional vector of chart names used to filter the metadata. Exact matches only (case-insensitive). All rows returned by default. #' @param text_keys optional vector of keys used to filter the metadata. Partial matches for any of the strings are returned (case-insensitive). All rows returned by default. #' @param filter_expr optional filter expression used to subset the data. #' @param add_standards should data standard info stored in standardsMetadata be included -#' @param cols optional vector of columns to return from the metadata. All columns returned by default. +#' @param cols optional vector of columns to return from the metadata. All columns returned by default. #' @param metadata metadata data frame to be queried -#' +#' #' @return dataframe with the requested metadata or single metadata value -#' -#' @examples -#' safetyGraphics:::getSettingsMetadata() +#' +#' @examples +#' safetyGraphics:::getSettingsMetadata() #' # Returns a full copy of settingsMetadata.Rda -#' -#' safetyGraphics:::getSettingsMetadata(text_keys=c("id_col")) +#' +#' safetyGraphics:::getSettingsMetadata(text_keys=c("id_col")) #' # returns a dataframe with a single row with metadata for the id_col setting -#' -#' safetyGraphics:::getSettingsMetadata(text_keys=c("id_col"), cols=c("label")) -#' # returns the character value for the specified row. -#' +#' +#' safetyGraphics:::getSettingsMetadata(text_keys=c("id_col"), cols=c("label")) +#' # returns the character value for the specified row. +#' #' @importFrom stringr str_subset #' @importFrom magrittr "%>%" #' @import dplyr #' @importFrom rlang .data -#' +#' #' @export getSettingsMetadata<-function(charts=NULL, text_keys=NULL, cols=NULL, filter_expr=NULL, add_standards=TRUE, metadata = safetyGraphics::settingsMetadata){ - md <- metadata %>% mutate(text_key=as.character(.data$text_key)) - + if(add_standards){ ms<-safetyGraphics::standardsMetadata %>% mutate(text_key=as.character(.data$text_key)) md<-md%>%left_join(ms, by="text_key") } - + all_columns <- names(md) - + #filter the metadata based on the charts option (if any) if(!is.null(charts)){ #Don't do anything if charts isn't specified stopifnot(typeof(charts) == "character") - + # get list of all chart flags in the data chart_columns <- tolower(str_subset(all_columns, "^chart_")); - + # get a list of chart flags matching the request charts<-tolower(charts) matched_chart_columns <- intersect(chart_columns, paste0("chart_",charts)) - #filter based + #filter based if(length(matched_chart_columns)==0){ return(NULL) }else{ @@ -57,39 +56,39 @@ getSettingsMetadata<-function(charts=NULL, text_keys=NULL, cols=NULL, filter_exp md<-md%>%filter_at(vars(matched_chart_columns),any_vars(.)) } } - - #filter the metadata based on the text_keys option (if any) + + #filter the metadata based on the text_keys option (if any) if(!is.null(text_keys)){ stopifnot(typeof(text_keys) == "character") md<-md%>%filter(tolower(.data$text_key) %in% tolower(text_keys)) } - - #filter the metadata based on a the filter expression + + #filter the metadata based on a the filter expression filter_expr <- enexpr(filter_expr) if(!is.null(filter_expr)){ stopifnot(typeof(filter_expr) %in% c("language","symbol")) md<-md %>% filter(!!filter_expr) } - + #subset the metadata columns returned based on the metadata_columns option (if any) if(!is.null(cols)){ stopifnot(typeof(cols) =="character") valid_cols <- intersect(cols, names(md)) md<-md%>%select(valid_cols) } - + #coerce factors to character if(dim(md)[2]>0){ i <- sapply(md, is.factor) md[i] <- lapply(md[i], as.character) } - + #return the requested metadata if(dim(md)[1]==0 | dim(md)[2]==0){ #return null if no rows or no columns are selected return(NULL) }else if(dim(md)[2]==1){ #return a vector if there is only a single columns specified return(md[[1]]) }else{ #otherwise return the whole data frame - return(md) + return(md) } } diff --git a/R/hasColumn.R b/R/hasColumn.R index d64fc52d..b1149dc1 100644 --- a/R/hasColumn.R +++ b/R/hasColumn.R @@ -14,10 +14,15 @@ hasColumn <- function(columnName, data){ stopifnot( - typeof(columnName)=="character", - length(columnName)==1, + typeof(columnName)=="character" || is.null(columnName), + length(columnName)==1 || is.null(columnName), is.data.frame(data) ) - return(toupper(columnName) %in% toupper(colnames(data))) + if(is.null(columnName)){ + return(FALSE) + } else { + return(toupper(columnName) %in% toupper(colnames(data))) + } + } diff --git a/R/hasField.R b/R/hasField.R index ab038568..f4612c6a 100644 --- a/R/hasField.R +++ b/R/hasField.R @@ -16,18 +16,22 @@ hasField<- function(fieldValue, columnName, data){ stopifnot( length(fieldValue)==1, - typeof(columnName)=="character", - length(columnName)==1, + typeof(columnName)=="character" || is.null(columnName), + length(columnName)==1 || is.null(columnName), is.data.frame(data) ) - columnFound <- hasColumn(columnName=columnName, data=data) - if(columnFound){ + if(is.null(columnName)){ + return(FALSE) + } else { + columnFound <- hasColumn(columnName=columnName, data=data) + if(columnFound){ + validFields <- unique(data[[columnName]]) + } else{ + validFields <- c() + } + validFields <- unique(data[[columnName]]) - } else{ - validFields <- c() + return(fieldValue %in% validFields) } - - validFields <- unique(data[[columnName]]) - return(fieldValue %in% validFields) } diff --git a/R/safetyHistogram.R b/R/safetyHistogram.R new file mode 100644 index 00000000..f76698ce --- /dev/null +++ b/R/safetyHistogram.R @@ -0,0 +1,145 @@ +#' Create a Safety Histogram widget +#' +#' This function creates a Safety Histogram using R htmlwidgets. +#' +#' @param data A data frame containing the labs data. Data must be structured as one record per study participant per time point per lab measure. +#' @param id_col Unique subject identifier variable name. Default: \code{"USUBJID"}. +#' @param value_col Lab result variable name. Default: \code{"STRESN"}. +#' @param measure_col Lab measure variable name. Default: \code{"TEST"}. +#' @param normal_col_low Lower limit of normal variable name. Default: \code{"STNRLO"}. +#' @param normal_col_high Upper limit of normal variable name. Default: \code{"STNRHI"}. +#' @param unit_col Unit of measure variable name. Default is \code{"STRESU"}. +#' @param filters 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. Default: \code{NULL}. +#' @param details An optional list of specifications for details listing. Each column to be added to details listing is a nested, named list (containing the variable name: "value_col" and associated label: "label") within the larger list. Default: \code{NULL}. +#' @param start_value Value of variable defined in \code{measure_col} to be rendered in the histogram when the widget loads. +#' @param missingValues Vector of values defining a missing \code{value_col}. Default is \code{c('','NA','N/A')}. +#' @param debug_js print settings in javascript before rendering chart. Default: \code{FALSE}. +#' @param settings Optional list of settings arguments to be converted to JSON using \code{jsonlite::toJSON(settings, auto_unbox = TRUE, dataframe = "rows", null = "null")}. If provided, all other function parameters are ignored. Default: \code{NULL}. +#' +#' @examples +#' \dontrun{ +#' +#' ## Create Histogram figure customized to user data +#'safetyHistogram(data=adlbc, +#' id_col = "USUBJID", +#' value_col = "AVAL", +#' measure_col = "PARAM", +#' normal_col_low = "A1LO", +#' normal_col_high = "A1HI", +#' unit_col = "PARAMCD") +#' +#' ## Create Histogram figure using a premade settings list +#' details_list <- list( +#' list(value_col = "TRTP", label = "Treatment"), +#' list(value_col = "SEX", label = "Sex"), +#' list(value_col = "AGEGR1", label = "Age group") +#' ) +#' +#' +#' filters_list <- list( +#' list(value_col = "TRTA", label = "Treatment"), +#' list(value_col = "SEX", label = "Sex"), +#' list(value_col = "RACE", label = "RACE"), +#' list(value_col = "AGEGR1", label = "Age group") +#' ) +#' +#' settingsl <- list(id_col = "USUBJID", +#' value_col = "AVAL", +#' measure_col = "PARAM", +#' unit_col = "PARAMCD", +#' normal_col_low = "A1LO", +#' normal_col_high = "A1HI", +#' details = details_list, +#' filters = filters_list) +#' +#' safetyHistogram(data=adlbc, settings = settingsl) +#' +#' } +#' +#' @import htmlwidgets +#' +#' @export +safetyHistogram <- function(data, + id_col = "USUBJID", + value_col = "STRESN", + measure_col = "TEST", + normal_col_low = "STNRLO", + normal_col_high = "STNRHI", + unit_col = "STRESU", + filters = NULL, + details = NULL, + start_value = NULL, + missingValues = c("","NA","N/A"), + debug_js = FALSE, + settings = NULL) { + + # forward options using rSettings + if (is.null(settings)){ + rSettings = list( + data = data, + settings = jsonlite::toJSON( + list( + id_col = id_col, + value_col = value_col, + measure_col = measure_col, + normal_col_low = normal_col_low, + normal_col_high = normal_col_high, + unit_col = unit_col, + filters = filters, + details = details, + start_value = start_value, + missingValues = missingValues, + debug_js = debug_js + ), + auto_unbox = TRUE, + null = "null" + ) + ) + } else{ + rSettings = list( + data = data, + settings = jsonlite::toJSON(settings, + auto_unbox = TRUE, + null = "null") + ) + } + + # create widget + htmlwidgets::createWidget( + name = 'safetyHistogram', + rSettings, + # width = width, + # height = height, + package = 'safetyGraphics', + sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress=TRUE, browser.external = TRUE) + + ) +} + +#' Shiny bindings for safetyHistogram +#' +#' Output and render functions for using safetyHistogram within Shiny +#' applications and interactive Rmd documents. +#' +#' @param outputId output variable to read from +#' @param width,height Must be a valid CSS unit (like \code{'100\%'}, +#' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a +#' string and have \code{'px'} appended. +#' @param expr An expression that generates a safetyHistogram +#' @param env The environment in which to evaluate \code{expr}. +#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This +#' is useful if you want to save an expression in a variable. +#' +#' @name safetyHistogram-shiny +#' +#' @export +safetyHistogramOutput <- function(outputId, width = '100%', height = '400px'){ + htmlwidgets::shinyWidgetOutput(outputId, 'safetyHistogram', width, height, package = 'safetyGraphics') +} + +#' @rdname safetyHistogram-shiny +#' @export +renderSafetyHistogram <- function(expr, env = parent.frame(), quoted = FALSE) { + if (!quoted) { expr <- substitute(expr) } # force quoted + htmlwidgets::shinyRenderWidget(expr, safetyHistogramOutput, env, quoted = TRUE) +} diff --git a/R/setSettingsValue.R b/R/setSettingsValue.R index 8052d237..e0cf4f53 100644 --- a/R/setSettingsValue.R +++ b/R/setSettingsValue.R @@ -5,6 +5,7 @@ #' @param key a list (like those provided by \code{getSettingKeys()}) defining the position of parameter in the settings object. #' @param value the value to set #' @param settings The settings list used to generate a chart like \code{eDISH()} +#' @param forceCreate Specifies whether the function should create a new list() when none exisits. This most commonly occurs when deeply nested objects. #' @return the updated settings object #' #' @examples @@ -21,17 +22,26 @@ #' @keywords internal -setSettingsValue <- function(key, value, settings){ - stopifnot( - typeof(settings)=="list" - ) +setSettingsValue <- function(key, value, settings, forceCreate=FALSE){ + + if(typeof(settings)!="list"){ + if(forceCreate){ + settings=list() + }else{ + stop("Settings is not a valid list object. Set forceCreate to TRUE and re-run if you want to create a new list and continue.") + } + } firstKey <- key[[1]] if(length(key)==1){ - settings[[firstKey]]<-value + if(is.null(value)){ + settings[firstKey]<-list(NULL) + }else{ + settings[[firstKey]]<-value + } return(settings) }else{ - settings[[firstKey]]<-setSettingsValue(settings = settings[[firstKey]],key = key[2:length(key)], value) + settings[[firstKey]]<-setSettingsValue(settings = settings[[firstKey]],key = key[2:length(key)], value=value, forceCreate=forceCreate) return(settings) } } \ No newline at end of file diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R index 92882d95..e4b20340 100644 --- a/R/settingsMetadata.R +++ b/R/settingsMetadata.R @@ -5,6 +5,7 @@ #' @format A data frame with 25 rows and 10 columns #' \describe{ #' \item{chart_edish}{Flag indicating if the settings apply to the eDish Chart} +#' \item{chart_safetyhistogram}{Flag indicating if the settings apply to the Safety Histogram Chart} #' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} #' \item{label}{Label} #' \item{description}{Description} @@ -15,6 +16,7 @@ #' \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} #' \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} #' \item{setting_cat}{Setting category (data, measure, appearance)} +#' \item{default}{Default value for non-data settings} #' } #' #' @source Created for this package diff --git a/R/trimData.R b/R/trimData.R index f50fe288..70e05af6 100644 --- a/R/trimData.R +++ b/R/trimData.R @@ -19,7 +19,7 @@ trimData <- function(data, settings, chart="edish"){ - + ## Remove columns not in settings ## col_names <- colnames(data) @@ -37,35 +37,38 @@ trimData <- function(data, settings, chart="edish"){ sub <- current[[i]] if(typeof(sub)=="list"){ newKey[[1+length(newKey)]]<-"value_col" - } - dataKeys[[1+length(dataKeys)]]<-newKey + } + dataKeys[[1+length(dataKeys)]]<-newKey } } } settings_values <- map(dataKeys, function(x) {return(getSettingValue(x, settings))}) - + common_cols <- intersect(col_names,settings_values) data_subset <- select(data, unlist(common_cols)) ## Remove rows if baseline or analysisFlag is specified ## + baselineSetting<-settings[['baseline']][['value_col']] + baselineMissing <- is.null(baselineSetting) + analysisSetting<-settings[['analysisFlag']][['value_col']] + analysisMissing <- is.null(analysisSetting) - if(!is.null(settings[['baseline']][['value_col']]) | !is.null(settings[['analysisFlag']][['value_col']])) { + if(!baselineMissing | !analysisMissing) { # Create Baseline String - baseline_string <- ifelse(!is.null(settings[['baseline']][['value_col']]), + baseline_string <- ifelse(!baselineMissing, paste(settings[['baseline']][['value_col']], "%in% settings[['baseline']][['values']]"), "") # Create AnalysisFlag String - analysis_string <- ifelse(!is.null(settings[['analysisFlag']][['value_col']]), + analysis_string <- ifelse(!analysisMissing, paste(settings[['analysisFlag']][['value_col']], "%in% settings[['analysisFlag']][['values']]"), "") # Include OR operator if both are specified - operator <- ifelse(!is.null(settings[['baseline']][['value_col']]) & !is.null(settings[['analysisFlag']][['value_col']]), - "|","") + operator <- ifelse(!baselineMissing & !analysisMissing, "|", "") # Create filter string and make it an expression filter_string <- paste(baseline_string, operator, analysis_string) diff --git a/R/validateSettings.R b/R/validateSettings.R index 59b982e5..bc54f647 100644 --- a/R/validateSettings.R +++ b/R/validateSettings.R @@ -69,7 +69,9 @@ validateSettings <- function(data, settings, chart="eDish"){ columnChecks <- dataKeys %>% purrr::map(checkColumn, settings=settings, data=data) #Check that non-null field/column combinations are found in the data + fieldChecks <- NULL allKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$field_mapping, cols = c("text_key","setting_type")) + if (!is.null(allKeys)){ fieldKeys <- allKeys %>% filter(.data$setting_type!="vector")%>% pull(.data$text_key)%>%textKeysToList() #Add items in vectors to list individually @@ -85,11 +87,15 @@ validateSettings <- function(data, settings, chart="eDish"){ } } fieldChecks <- fieldKeys %>% purrr::map(checkField, settings=settings, data=data ) + } #Check that settings for mapping numeric data are associated with numeric columns - numericKeys <- getSettingsMetadata(charts=chart, filter_expr=.data$column_type=="numeric", cols="text_key")%>%textKeysToList() - numericChecks <- numericKeys %>% purrr::map(checkNumeric, settings=settings, data=data ) - + numericChecks <- NULL + numericKeys <- getSettingsMetadata(charts=chart, filter_expr=.data$column_type=="numeric", cols="text_key") + if (!is.null(numericKeys)){ + numericChecks <- numericKeys %>%textKeysToList() %>% purrr::map(checkNumeric, settings=settings, data=data ) + } + #Combine different check types in to a master list settingStatus$checks <-c(requiredChecks, columnChecks, fieldChecks, numericChecks) %>% { tibble( diff --git a/data-raw/csv_to_rda.R b/data-raw/csv_to_rda.R index de6c8b5f..3f97d5ee 100644 --- a/data-raw/csv_to_rda.R +++ b/data-raw/csv_to_rda.R @@ -1,10 +1,19 @@ library(usethis) +library(dplyr) ablbc <- read.csv("data-raw/adlbc.csv") usethis::use_data(adlbc, overwrite = TRUE) -settingsMetadata <- read.csv("data-raw/settingsMetadata.csv") +partialSettingsMetadata <- read.csv("data-raw/settingsMetadata.csv", stringsAsFactors = FALSE) + +#merge defaults on to settingsMetadata +defaults <- readRDS("data-raw/defaults.Rds") + + +settingsMetadata <- dplyr::full_join(partialSettingsMetadata, defaults, by="text_key") +#settingsMetadata <- merge(partialSettingsMetadata, defaults, by="text_key") + usethis::use_data(settingsMetadata, overwrite = TRUE) standardsMetadata <- read.csv("data-raw/standardsMetadata.csv") -usethis::use_data(standardsMetadata, overwrite = TRUE) \ No newline at end of file +usethis::use_data(standardsMetadata, overwrite = TRUE) diff --git a/data-raw/defaults.Rds b/data-raw/defaults.Rds new file mode 100644 index 00000000..8987b444 Binary files /dev/null and b/data-raw/defaults.Rds differ diff --git a/data-raw/generateDefaults.R b/data-raw/generateDefaults.R new file mode 100644 index 00000000..195423f0 --- /dev/null +++ b/data-raw/generateDefaults.R @@ -0,0 +1,33 @@ +defaults <- tribble(~text_key, ~default, + "id_col", NULL, + "value_col", NULL, + "measure_col", NULL, + "measure_values--ALT", NULL, + "measure_values--AST", NULL, + "measure_values--TB", NULL, + "measure_values--ALP", NULL, + "normal_col_low", NULL, + "normal_col_high", NULL, + "studyday_col",NULL, + "visit_col", NULL, + "visitn_col", NULL, + "filters", NULL, + "group_cols", NULL, + "baseline--value_col", NULL, + "baseline--values", list(), + "analysisFlag--value_col", NULL, + "analysisFlag--values", list(), + "x_options", c("ALT", "AST", "ALP"), + "y_options", c("TB", "ALP"), + "visit_window", 30, + "r_ratio_filter", TRUE, + "r_ratio_cut", 0, + "showTitle", TRUE, + "warningText", "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures.", + "unit_col", NULL, + "start_value", NULL, + "details", NULL, + "missingValues", c("","NA","N/A") + ) + +saveRDS(defaults, file="data-raw/defaults.Rds") diff --git a/data-raw/settingsMetadata.csv b/data-raw/settingsMetadata.csv index ac64c845..21feb7d2 100644 --- a/data-raw/settingsMetadata.csv +++ b/data-raw/settingsMetadata.csv @@ -1,26 +1,30 @@ -chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,setting_cat -TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,data -TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,data -TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,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,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,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,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,data -TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,data -TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,data -TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,data -TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,data -TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,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 \ No newline at end of file +chart_edish,chart_safetyhistogram,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,setting_cat +TRUE,TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,data +TRUE,TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,data +TRUE,TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,data +TRUE,FALSE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,data +TRUE,FALSE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,data +TRUE,FALSE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,data +TRUE,FALSE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,data +TRUE,TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,data +TRUE,TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,data +TRUE,FALSE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,data +TRUE,FALSE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,data +TRUE,FALSE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,data +TRUE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,appearance +TRUE,FALSE,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 +FALSE,TRUE,unit_col,Unit column,Unit of measure variable name,character,TRUE,TRUE,character,FALSE,,data +FALSE,TRUE,start_value,Measure start value,Value of variable defined in measure_col to be rendered in the histogram when the widget loads,character,FALSE,FALSE,NA,TRUE,measure_col,data +FALSE,TRUE,details,Details columns,"An optional list of specifications for details listing. Each column to be added to details listing is a nested, named list (containing the variable name: ""value_col"" and associated label: ""label"") within the larger list.",vector,FALSE,TRUE,NA,FALSE,,data +FALSE,TRUE,missingValues,Missing values,Values defining a missing value in the selected 'value' column,vector,FALSE,FALSE,NA,FALSE,,data diff --git a/data-raw/standardsMetadata.csv b/data-raw/standardsMetadata.csv index b51715e9..bd868f36 100644 --- a/data-raw/standardsMetadata.csv +++ b/data-raw/standardsMetadata.csv @@ -23,4 +23,8 @@ visit_window,, r_ratio_filter,, r_ratio_cut,, showTitle,, -warningText,, \ No newline at end of file +warningText,, +unit_col,STRESU,PARAMCD +start_value,, +details,, +missingValues,, diff --git a/data/adlbc.rda b/data/adlbc.rda index aa28c2db..aea28611 100644 Binary files a/data/adlbc.rda and b/data/adlbc.rda differ diff --git a/data/settingsMetadata.rda b/data/settingsMetadata.rda index 525b0f1d..edbbc4b4 100644 Binary files a/data/settingsMetadata.rda and b/data/settingsMetadata.rda differ diff --git a/data/standardsMetadata.rda b/data/standardsMetadata.rda index 4aaca682..783294d3 100644 Binary files a/data/standardsMetadata.rda and b/data/standardsMetadata.rda differ diff --git a/inst/eDISH_app/global.R b/inst/eDISH_app/global.R index a248f576..17eea0f8 100644 --- a/inst/eDISH_app/global.R +++ b/inst/eDISH_app/global.R @@ -11,12 +11,17 @@ library(stringr) library(DT) library(haven) +# create vector of all possible charts +all_charts <- c("edish","safetyhistogram") + ## source modules source('modules/renderSettings/renderSettingsUI.R') source('modules/renderSettings/renderSettings.R') -source('modules/renderChart/renderEDishChartUI.R') -source('modules/renderChart/renderEDishChart.R') +source('modules/renderChart/render_edish_chartUI.R') +source('modules/renderChart/render_edish_chart.R') +source('modules/renderChart/render_safetyhistogram_chartUI.R') +source('modules/renderChart/render_safetyhistogram_chart.R') source('modules/dataUpload/dataUploadUI.R') source('modules/dataUpload/dataUpload.R') diff --git a/inst/eDISH_app/modules/dataUpload/dataUpload.R b/inst/eDISH_app/modules/dataUpload/dataUpload.R index 82ee0633..ee42b0d1 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUpload.R +++ b/inst/eDISH_app/modules/dataUpload/dataUpload.R @@ -164,13 +164,13 @@ dataUpload <- function(input, output, session){ select(text_key) %>% pull() - generateSettings(standard=current_standard, chart="eDish", partial=partial, partial_keys = partial_keys) + generateSettings(standard=current_standard, partial=partial, partial_keys = partial_keys) } else { - generateSettings(standard=current_standard, chart="eDish") + generateSettings(standard=current_standard) } } else { - generateSettings(standard=current_standard, chart="eDish") + generateSettings(standard=current_standard) } }) @@ -180,8 +180,7 @@ dataUpload <- function(input, output, session){ req(data_selected()) req(settings()) validateSettings(data_selected(), - settings(), - chart="eDish") + settings()) }) exportTestValues(status = { status() }) diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChart.R b/inst/eDISH_app/modules/renderChart/render_edish_chart.R similarity index 87% rename from inst/eDISH_app/modules/renderChart/renderEDishChart.R rename to inst/eDISH_app/modules/renderChart/render_edish_chart.R index b900e9bf..4e9a1ff4 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChart.R +++ b/inst/eDISH_app/modules/renderChart/render_edish_chart.R @@ -1,41 +1,46 @@ #' Render eDISH chart - server code -#' -#' This module creates the Chart tab for the Shiny app, which contains the interactive eDISH graphic. -#' -#' Workflow: +#' +#' 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 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){ - + +render_edish_chart <- function(input, output, session, data, settings, valid){ + ns <- session$ns - + # render eDISH chart if settings pass validation output$chart <- renderEDISH({ req(data()) req(settings()) - - if (valid()==TRUE){ + trimmed_data <- safetyGraphics:::trimData(data = data(), settings = settings()) eDISH(data = trimmed_data, settings = settings()) - } else{ - return() - } - }) - + + }) + + # insert export chart button if settings pass validation # remove button if validation fails observeEvent(valid(), { + if (is.null(valid())){ + valid <- FALSE + } else { + valid <- valid() + } + removeUI(selector = paste0("#", ns("download"))) - if (valid()==TRUE){ + + if (valid==TRUE){ insertUI ( selector = "div.container-fluid", where = "beforeEnd", @@ -43,13 +48,13 @@ renderEDishChart <- function(input, output, session, data, settings, valid){ style="float: right;", span(class = "navbar-brand", #using one of the default nav bar classes to get css close style="padding: 8px;", #then little tweak to ensure vertical alignment - downloadButton(ns("reportDL"), "Export Chart")) ) + downloadButton(ns("reportDL"), "Export eDISH Chart")) ) ) - } + } else { removeUI(selector = paste0("#", ns("download"))) } - }) + }, ignoreNULL = FALSE) # Set up report generation on download button click @@ -71,5 +76,5 @@ renderEDishChart <- function(input, output, session, data, settings, valid){ ) } ) - -} \ No newline at end of file + +} diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R b/inst/eDISH_app/modules/renderChart/render_edish_chartUI.R similarity index 77% rename from inst/eDISH_app/modules/renderChart/renderEDishChartUI.R rename to inst/eDISH_app/modules/renderChart/render_edish_chartUI.R index 62a8fe14..4f4885db 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R +++ b/inst/eDISH_app/modules/renderChart/render_edish_chartUI.R @@ -6,11 +6,9 @@ #' #' @return The UI for the Chart tab #' -renderEDishChartUI <- function(id){ +render_edish_chartUI <- function(id){ ns <- NS(id) - tagList( - eDISHOutput(ns("chart")) - ) + eDISHOutput(ns("chart")) } \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chart.R b/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chart.R new file mode 100644 index 00000000..b5b9c6a2 --- /dev/null +++ b/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chart.R @@ -0,0 +1,27 @@ +#' Render Safety Histogram chart - server code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive Histogram graphic. +#' +#' Workflow: +#' (1) A change in `data`, `settings`, or `valid` invalidates the safety histogram chart output +#' (2) Upon a change in `valid`, the export chart functionality is conditionally made available or unavailable to user +#' +#' @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 + +render_safetyhistogram_chart <- function(input, output, session, data, settings, valid){ + + ns <- session$ns + + # render eDISH chart if settings pass validation + output$chart <- renderSafetyHistogram({ + req(data()) + req(settings()) + + safetyHistogram(data = data(), settings = settings()) + }) + +} diff --git a/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chartUI.R b/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chartUI.R new file mode 100644 index 00000000..09afeea5 --- /dev/null +++ b/inst/eDISH_app/modules/renderChart/render_safetyhistogram_chartUI.R @@ -0,0 +1,14 @@ +#' Render safety hisotgram chart - UI code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive safety histogram graphic. + +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Chart tab +#' +render_safetyhistogram_chartUI <- function(id){ + + ns <- NS(id) + + safetyHistogramOutput(ns("chart")) +} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 014d686c..066e2520 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -6,9 +6,9 @@ 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. -#' +#' +#' 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. @@ -27,11 +27,11 @@ source("modules/renderSettings/util/updateSettingStatus.R") #' - 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. +#' (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 +#' (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 @@ -39,20 +39,46 @@ source("modules/renderSettings/util/updateSettingStatus.R") #' @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: +#' @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 + + output$charts_wrap_ui <- renderUI({ + checkboxGroupButtons( + ns("charts"), + label = NULL, + choices = c( + "e-DISH" = "edish", + "Safety Histogram" = "safetyhistogram" + ), + selected=c("edish", "safetyhistogram"), + checkIcon = list( + yes = icon("ok", lib = "glyphicon"), + no = icon("remove",lib = "glyphicon") + ), + status="primary" + ) + }) + #List of all inputs - input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts=input$selected_charts, cols="text_key")}) + # Null if no charts are selected + input_names <- reactive({ + if(!is.null(input$charts)){ + safetyGraphics:::getSettingsMetadata(charts=input$charts, cols="text_key") + } else{ + NULL + } + + }) + - ###################################################################### # create settings UI # - chart selection -> gather all necessary UI elements @@ -61,203 +87,250 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### output$data_mapping_ui <- renderUI({ - req(input$charts) - tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts=input$charts, ns=ns)) + charts <- isolate(input$charts) + tagList( + createSettingsUI( + data=data(), + settings = settings(), + setting_cat_val = "data", + charts=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)) + charts <- isolate(input$charts) + tagList( + createSettingsUI( + data=data(), + settings = settings(), + setting_cat_val = "measure", + charts=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)) + charts <- isolate(input$charts) + tagList( + createSettingsUI( + data=data(), + settings = settings(), + setting_cat_val = "appearance", + charts=charts, + ns=ns + ) + ) }) + + ######### Hide Settings that are not relevant to selected charts ######## + observeEvent(input$charts,{ + + input_names <- isolate(input_names()) + + # Make sure all relevant settings are showing + if (!is.null(input_names)){ + for (setting in input_names) { + shinyjs::show(id=paste0("ctl_",setting)) + } + } + + # Get all possible metadata (input_names always reflects the current chart selections and is already filtered) + # so I'm grabbing all of these options so I can determine which should be hidden + all_settings <- getSettingsMetadata( + cols=c("text_key") + ) + + # Identify which settings in input_names() are not relevant + settings_to_drop <- setdiff(all_settings,input_names) + + # Use shinyJS::hide() to hide these inputs + for (setting in settings_to_drop) { + shinyjs::hide(id=paste0("ctl_",setting)) + } + + }, ignoreNULL=FALSE) ## input$charts = NULL if none are selected + + # ensure outputs update upon app startup + outputOptions(output, "charts_wrap_ui", suspendWhenHidden = FALSE) + outputOptions(output, "data_mapping_ui", suspendWhenHidden = FALSE) + outputOptions(output, "measure_settings_ui", suspendWhenHidden = FALSE) outputOptions(output, "appearance_settings_ui", suspendWhenHidden = FALSE) - ###################################################################### - # Update field level inputs + # 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({ - - column_keys <- getSettingsMetadata(charts=input$charts, - filter_expr = field_mapping==TRUE) %>% - pull(field_column_key) %>% - unique %>% - as.list() - - 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) - - - # 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]]=="") - } - - 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(""); - }'))) - } - } - } - } + field_rows <- getSettingsMetadata( + charts=input$charts, + filter_expr = field_mapping==TRUE ) - }) - }) - - + + if(!is.null(field_rows)){ + column_keys <- field_rows %>% + pull(field_column_key) %>% + unique %>% + as.list() + + 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 + ) + + # 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]]=="") + } + + 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("");}') + ) + ) #update SelectizeInput + } #for loop + } #if #2 + } #if #1 + } #observeEvent (inner) + ) #observeEvent (outer) + }) #lapply + } #if(!is.null) + }) #observe + ###################################################################### # Fill settings object based on selections - # + # # update is triggered by any of the input selections changing ###################################################################### - + settings_new <- reactive({ - - - settings <- list(id_col = input$id_col, - value_col = input$value_col, - measure_col = input$measure_col, - normal_col_low = input$normal_col_low, - normal_col_high = input$normal_col_high, - studyday_col = input$studyday_col, - visit_col = input$visit_col, - visitn_col = input$visitn_col, - measure_values = list(ALT = input$`measure_values--ALT`, - AST = input$`measure_values--AST`, - TB = input$`measure_values--TB`, - ALP = input$`measure_values--ALP`), - x_options = input$x_options, - y_options = input$y_options, - visit_window = input$visit_window, - r_ratio_filter = input$r_ratio_filter, - r_ratio_cut = input$r_ratio_cut, - showTitle = input$showTitle, - warningText = input$warningText) - - if (! is.null(input$`baseline--values`)){ - if (! input$`baseline--values`[1]==""){ - settings$baseline <- list(value_col = input$`baseline--value_col`, - values = input$`baseline--values`) - } - } - - if (! is.null(input$`analysisFlag--values`)){ - if (! input$`analysisFlag--values`[1]==""){ - settings$analysisFlag <- list(value_col = input$`analysisFlag--value_col`, - values = input$`analysisFlag--values`) + + getValues <- function(x){ + if (is.null(input[[x]])){ + return(NULL) + } else{ + return(input[[x]]) } } + + req(input_names()) + keys <- input_names() + values<- keys %>% map(~getValues(.x)) + + inputDF <- tibble(text_key=keys, customValue=values)%>% + rowwise %>% + filter(!is.null(customValue[[1]])) - if (!is.null(input$filters)){ - for (i in 1:length(input$filters)){ - settings$filters[[i]] <- list(value_col = input$filters[[i]], - label = input$filters[[i]]) - } + if(nrow(inputDF)>0){ + settings <- generateSettings(custom_settings=inputDF, charts=input$charts) + }else{ + settings<- generateSettings(charts=input$charts) } - if (!is.null(input$group_cols)){ - for (i in 1:length(input$group_cols)){ - settings$group_cols[[i]] <- list(value_col = input$group_cols[[i]], - label = input$group_cols[[i]]) - } - } - + return(settings) }) - - + + ###################################################################### # validate new settings # the validation is run every time there is a change in data and/or settings. # ###################################################################### - status_new <- reactive({ + status_new <- reactive({ req(data()) req(settings_new()) name <- rev(isolate(input_names()))[1] settings_new <- settings_new() - - for (i in names(settings_new)){ - if (!is.null(settings_new[[i]])){ - if (settings_new[[i]][1]==""){ - settings_new[i] <- list(NULL) - } - } + + out <- list() + + charts <- isolate(input$charts) + for (chart in charts){ + out[[chart]] <- validateSettings(data(), settings_new, chart=chart) } - - validateSettings(data(), settings_new, chart="eDish") - + + return(out) }) - - + + ###################################################################### # Setting validation status information ###################################################################### status_df <- reactive({ req(status_new()) - - status_new()$checks %>% + + flatten(status_new()) %>% + keep(., names(.)=="checks") %>% + bind_rows() %>% + unique %>% 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.") - )) %>% + 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, icon, message_long, message_short, num_fail) %>% - unique + unique }) - + # for shiny tests exportTestValues(status_df = { status_df() }) - + ###################################################################### # print validation messages ###################################################################### - observe({ - for (key in isolate(input_names())){ - + observeEvent(status_df(), { + 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) + 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(charts = reactive(input$charts), - settings = reactive(settings_new()), - status = reactive(status_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 83a3f4c3..4e1d1eef 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -1,23 +1,11 @@ renderSettingsUI <- function(id){ ns <- NS(id) - tagList( - fluidRow( - column(12, - class="chartSelect section", - checkboxGroupInput( - ns("charts"), - "Select Chart(s):", - choices = c("e-DISH" = "edish"), - selected="edish" - ) - ) - ), - #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) - ) + #TODO - make this a loop based on metadata + fluidRow( + createSettingsSection("charts_wrap", "Charts",12,ns), + 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 index 11b418a2..5466187a 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -56,7 +56,7 @@ createControl <- function(key, metadata, data, settings, ns){ 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 + choices <- unique(c(setting_value, sort(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 diff --git a/inst/eDISH_app/server.R b/inst/eDISH_app/server.R index 76dfae74..a8a0e8df 100644 --- a/inst/eDISH_app/server.R +++ b/inst/eDISH_app/server.R @@ -1,66 +1,120 @@ # 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, +# - calls chart modules (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){ - - # run dataUpload module + ############################################################## + # initialize dataUpload module # # returns selected dataset, settings, and validation status + ############################################################## dataUpload_out <- callModule(dataUpload, "datatab") - # 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"))) - span(tagList("Data", icon("check", class="ok"))) - }) - - # based on selected data set & generated/selected settings obj, generate settings page. + ############################################################## + # Initialize Settings Module + # + # generate settings page based on selected data set & generated/selected settings obj # # NOTE: module is being triggered when selected dataset changes OR when settings list changes # this could cause the module to trigger twice unecessarily in some cases because the settings are generated # AFTER the data is changed. # - # reutrns updated settings and validation status - settings_new <- callModule(renderSettings, "settingsUI", - # 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())) - - - # update settings navbar - output$settings_tab_title = renderUI({ - if (settings_new$status()$valid==TRUE){ - HTML(paste("Settings", icon("check", class="ok"))) - } else { - HTML(paste("Settings", icon("times", class="notok"))) - } - }) - - # update charts navbar - output$chart_tab_title = renderUI({ - if (settings_new$status()$valid==TRUE){ - HTML(paste("Chart", icon("check", class="ok"))) - } else { - HTML(paste("Chart", icon("times", class="notok"))) - } - }) - - - # module to render eDish chart - callModule(renderEDishChart, "chartEDish", - data = reactive(dataUpload_out$data_selected()), - settings = reactive(settings_new$settings()), - valid = reactive(settings_new$status()$valid)) + # returns updated settings and validation status + ############################################################## + +settings_new <- callModule( + renderSettings, + "settingsUI", + data = reactive(dataUpload_out$data_selected()), + settings = reactive(dataUpload_out$settings()), + status = reactive(dataUpload_out$status()) + ) + + +#toggle css class of chart tabs +observeEvent(settings_new$status(),{ + for (chart in settings_new$charts()){ + valid <- settings_new$status()[[chart]]$valid + + ## code to toggle css for chart-specific tab here + toggleClass(selector= paste0("#nav_id li.dropdown ul.dropdown-menu li a[data-value='", chart, "']"), class="valid", condition=valid==TRUE) + toggleClass(selector= paste0("#nav_id li.dropdown ul.dropdown-menu li a[data-value='", chart, "']"), class="invalid", condition=valid==FALSE) + } +}) + + ############################################################## + # Initialize Charts Modules + ############################################################## + + # set up all chart tabs from the start (allcharts defined in global.R) + # generated from server.R so we can do this dynamically in future.. + for (chart in all_charts){ + tabfun <- match.fun(paste0("render_", chart, "_chartUI")) # module UI for given tab + tabid <- paste0(chart, "_tab_title") + appendTab( + inputId = "nav_id", + tab = tabPanel( + title = chart, + tabfun(paste0("chart", chart)) + ), + menuName = "Charts" + ) + } + + # hide/show chart tabs in response to user selections + observe({ + selected_charts <- settings_new$charts() + unselected_charts <- all_charts[!all_charts %in% selected_charts] + + for(chart in unselected_charts){ + hideTab(inputId = "nav_id", + target = chart) + } + for(chart in selected_charts){ + showTab(inputId = "nav_id", + target = chart) + } + }) + + + # call all chart modules + # + # loop is broken so going back to hardcode for now. + # this will change in the future anyway - session$onSessionEnded(stopApp) + # for (chart in all_charts){ + # + # modfun <- match.fun(paste0("render_", chart, "_chart")) + # callModule( + # module = modfun, + # id = paste0("chart", chart), + # data = reactive(dataUpload_out$data_selected()), + # settings = reactive(settings_new$settings()), + # valid = reactive(settings_new$status()[[chart]]$valid) + # ) + # + # } + callModule( + module = render_edish_chart, + id = paste0("chart", "edish"), + data = reactive(dataUpload_out$data_selected()), + settings = reactive(settings_new$settings()), + valid = reactive(settings_new$status()[["edish"]]$valid) + ) + callModule( + module = render_safetyhistogram_chart, + id = paste0("chart", "safetyhistogram"), + data = reactive(dataUpload_out$data_selected()), + settings = reactive(settings_new$settings()), + valid = reactive(settings_new$status()[["safetyhistogram"]]$valid) + ) + + session$onSessionEnded(stopApp) } diff --git a/inst/eDISH_app/ui.R b/inst/eDISH_app/ui.R index 27aa19ee..2506423a 100644 --- a/inst/eDISH_app/ui.R +++ b/inst/eDISH_app/ui.R @@ -3,20 +3,24 @@ tagList( useShinyjs(), tags$head( - tags$link(rel = "stylesheet", type = "text/css", href = "index.css") + tags$link( + rel = "stylesheet", + type = "text/css", + href = "index.css") ), - navbarPage("eDISH Shiny app", - tabPanel(title = htmlOutput("data_tab_title"), - dataUploadUI("datatab") - ), - tabPanel(title = htmlOutput("settings_tab_title"), - fluidPage( - renderSettingsUI("settingsUI") - ) - ), - tabPanel(title = htmlOutput("chart_tab_title"), - id = "charttab", - renderEDishChartUI("chartEDish") - ) -) + navbarPage( + "eDISH Shiny app", + id="nav_id", + tabPanel( + title = "Data", + dataUploadUI("datatab") + ), + tabPanel( + title = "Settings", + fluidPage( + renderSettingsUI("settingsUI") + ) + ), + navbarMenu("Charts") + ) ) diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css index 1f292331..09a2280e 100644 --- a/inst/eDISH_app/www/index.css +++ b/inst/eDISH_app/www/index.css @@ -1,9 +1,3 @@ -/* --- hide the chartSelect div until we're ready to implement multiple charts --- */ -.chartSelect{ - display:none; -} -/* ------------------------------------------------------------------------------- */ - .section{ min-width:400px; } @@ -19,8 +13,8 @@ } .control-wrap .select-wrap .form-group{ - width:90%; /* TODO: don't love this ... update eventually */ - display:inline-block; + width:90%; /* TODO: don't love this ... update eventually */ + display:inline-block; margin-bottom:0; } @@ -39,8 +33,35 @@ cursor:help; } +#settingsUI-charts_wrap_ui{ + margin-top:15px; +} + +/* chart validation formatting */ +#nav_id li.dropdown ul.dropdown-menu li a.valid:after{ + font-family: "Font Awesome 5 Free"; + font-weight: 900; + content: "\f00c"; + color: green; + padding-left:0.3em; +} + -/* Validation Coloring */ + +#nav_id li.dropdown ul.dropdown-menu li a.invalid:after{ + font-family: "Font Awesome 5 Free"; + font-weight: 900; + content: "\f00d"; + color: red; + padding-left:0.3em; +} + +/* chart validation formatting */ +#nav_id li.dropdown ul.dropdown-menu li.active a:after{ + color: white; +} + +/* Setting Validation Coloring */ .control-wrap.valid .select-wrap .status{ color:green; @@ -61,7 +82,7 @@ /* Settings - header tweaks */ .section h3 { margin:0; -} +} .section h3 .form-group { display:inline; @@ -72,10 +93,10 @@ } -.ok { +.ok { color:#008000; } .notok { color: #FF0000; -} \ No newline at end of file +} diff --git a/inst/htmlwidgets/eDISH.yaml b/inst/htmlwidgets/eDISH.yaml index 17ad864a..443bcbff 100644 --- a/inst/htmlwidgets/eDISH.yaml +++ b/inst/htmlwidgets/eDISH.yaml @@ -4,11 +4,11 @@ dependencies: src: htmlwidgets/lib/d3-3.5.17 script: d3.v3.min.js - name: webcharts - version: 1.11.3 - src: htmlwidgets/lib/webcharts-1.11.3 + version: 1.11.5 + src: htmlwidgets/lib/webcharts-1.11.5 script: webcharts.js stylesheet: webcharts.css - name: safety-eDish - version: 0.16.3 - src: htmlwidgets/lib/safety-eDISH-0.16.3 + version: 0.16.7 + src: htmlwidgets/lib/safety-eDISH-0.16.7 script: safetyedish.js diff --git a/inst/htmlwidgets/lib/safety-eDISH-0.16.3/safetyedish.js b/inst/htmlwidgets/lib/safety-eDISH-0.16.7/safetyedish.js similarity index 99% rename from inst/htmlwidgets/lib/safety-eDISH-0.16.3/safetyedish.js rename to inst/htmlwidgets/lib/safety-eDISH-0.16.7/safetyedish.js index 03550241..98f329ab 100644 --- a/inst/htmlwidgets/lib/safety-eDISH-0.16.3/safetyedish.js +++ b/inst/htmlwidgets/lib/safety-eDISH-0.16.7/safetyedish.js @@ -395,7 +395,7 @@ //make sure filters is an Array if (!(settings.filters instanceof Array)) { - settings.filters = []; + settings.filters = typeof settings.filters == 'string' ? [settings.filters] : []; } //Define default details. @@ -445,6 +445,11 @@ }); } + //parse details to array if needed + if (!(settings.details instanceof Array)) { + settings.details = typeof settings.details == 'string' ? [settings.details] : []; + } + //If [settings.details] is not specified: if (!settings.details) settings.details = defaultDetails; else { @@ -473,15 +478,29 @@ // If settings.analysisFlag is null if (!settings.analysisFlag) settings.analysisFlag = { value_col: null, values: [] }; - + if (!settings.analysisFlag.value_col) settings.analysisFlag.value_col = null; + if (!(settings.analysisFlag.values instanceof Array)) { + settings.analysisFlag.values = + typeof settings.analysisFlag.values == 'string' + ? [settings.analysisFlag.values] + : []; + } //if it is null, set settings.baseline.value_col to settings.studyday_col. if (!settings.baseline) settings.baseline = { value_col: null, values: [] }; - if (settings.baseline.values.length == 0) settings.baseline.values = [0]; if (!settings.baseline.value_col) settings.baseline.value_col = settings.studyday_col; + if (!(settings.baseline.values instanceof Array)) { + settings.baseline.values = + typeof settings.baseline.values == 'string' ? [settings.baseline.values] : []; + } //parse x_ and y_options to array if needed - if (typeof settings.x_options == 'string') settings.x_options = [settings.x_options]; - if (typeof settings.y_options == 'string') settings.y_options = [settings.y_options]; + if (!(settings.x_options instanceof Array)) { + settings.x_options = typeof settings.x_options == 'string' ? [settings.x_options] : []; + } + + if (!(settings.y_options instanceof Array)) { + settings.y_options = typeof settings.y_options == 'string' ? [settings.y_options] : []; + } // track initial Cutpoint (lets us detect when cutpoint should change) settings.cuts.x = settings.x.column; diff --git a/inst/htmlwidgets/lib/safety-histogram-2.2.3/safetyHistogram.js b/inst/htmlwidgets/lib/safety-histogram-2.2.3/safetyHistogram.js new file mode 100644 index 00000000..5fff2830 --- /dev/null +++ b/inst/htmlwidgets/lib/safety-histogram-2.2.3/safetyHistogram.js @@ -0,0 +1,972 @@ +(function(global, factory) { + typeof exports === 'object' && typeof module !== 'undefined' + ? (module.exports = factory(require('d3'), require('webcharts'))) + : typeof define === 'function' && define.amd + ? define(['d3', 'webcharts'], factory) + : (global.safetyHistogram = factory(global.d3, global.webCharts)); +})(this, function(d3, webcharts) { + 'use strict'; + + if (typeof Object.assign != 'function') { + // Must be writable: true, enumerable: false, configurable: true + Object.defineProperty(Object, 'assign', { + value: function assign(target, varArgs) { + if (target == null) { + // TypeError if undefined or null + throw new TypeError('Cannot convert undefined or null to object'); + } + + var to = Object(target); + + for (var index = 1; index < arguments.length; index++) { + var nextSource = arguments[index]; + + if (nextSource != null) { + // Skip over if undefined or null + for (var nextKey in nextSource) { + // Avoid bugs when hasOwnProperty is shadowed + if (Object.prototype.hasOwnProperty.call(nextSource, nextKey)) { + to[nextKey] = nextSource[nextKey]; + } + } + } + } + + return to; + }, + writable: true, + configurable: true + }); + } + + if (!Array.prototype.find) { + Object.defineProperty(Array.prototype, 'find', { + value: function value(predicate) { + // 1. Let O be ? ToObject(this value). + if (this == null) { + throw new TypeError('"this" is null or not defined'); + } + + var o = Object(this); + + // 2. Let len be ? ToLength(? Get(O, 'length')). + var len = o.length >>> 0; + + // 3. If IsCallable(predicate) is false, throw a TypeError exception. + if (typeof predicate !== 'function') { + throw new TypeError('predicate must be a function'); + } + + // 4. If thisArg was supplied, let T be thisArg; else let T be undefined. + var thisArg = arguments[1]; + + // 5. Let k be 0. + var k = 0; + + // 6. Repeat, while k < len + while (k < len) { + // a. Let Pk be ! ToString(k). + // b. Let kValue be ? Get(O, Pk). + // c. Let testResult be ToBoolean(? Call(predicate, T, � kValue, k, O �)). + // d. If testResult is true, return kValue. + var kValue = o[k]; + if (predicate.call(thisArg, kValue, k, o)) { + return kValue; + } + // e. Increase k by 1. + k++; + } + + // 7. Return undefined. + return undefined; + } + }); + } + + if (!Array.prototype.findIndex) { + Object.defineProperty(Array.prototype, 'findIndex', { + value: function value(predicate) { + // 1. Let O be ? ToObject(this value). + if (this == null) { + throw new TypeError('"this" is null or not defined'); + } + + var o = Object(this); + + // 2. Let len be ? ToLength(? Get(O, "length")). + var len = o.length >>> 0; + + // 3. If IsCallable(predicate) is false, throw a TypeError exception. + if (typeof predicate !== 'function') { + throw new TypeError('predicate must be a function'); + } + + // 4. If thisArg was supplied, let T be thisArg; else let T be undefined. + var thisArg = arguments[1]; + + // 5. Let k be 0. + var k = 0; + + // 6. Repeat, while k < len + while (k < len) { + // a. Let Pk be ! ToString(k). + // b. Let kValue be ? Get(O, Pk). + // c. Let testResult be ToBoolean(? Call(predicate, T, � kValue, k, O �)). + // d. If testResult is true, return k. + var kValue = o[k]; + if (predicate.call(thisArg, kValue, k, o)) { + return k; + } + // e. Increase k by 1. + k++; + } + + // 7. Return -1. + return -1; + } + }); + } + + Math.log10 = Math.log10 = + Math.log10 || + function(x) { + return Math.log(x) * Math.LOG10E; + }; + + var rendererSpecificSettings = { + //required variables + id_col: 'USUBJID', + measure_col: 'TEST', + unit_col: 'STRESU', + value_col: 'STRESN', + normal_col_low: 'STNRLO', + normal_col_high: 'STNRHI', + + //optional variables + filters: null, + details: null, + + //miscellaneous settings + start_value: null, + normal_range: true, + displayNormalRange: false + }; + + var webchartsSettings = { + x: { + type: 'linear', + column: null, // set in syncSettings() + label: null, // set in syncSettings() + domain: [null, null], // set in preprocess callback + format: null, // set in preprocess callback + bin: 25 + }, + y: { + type: 'linear', + column: null, + label: '# of Observations', + domain: [0, null], + format: '1d', + behavior: 'flex' + }, + marks: [ + { + per: [], // set in syncSettings() + type: 'bar', + summarizeY: 'count', + summarizeX: 'mean', + attributes: { 'fill-opacity': 0.75 } + } + ], + aspect: 3 + }; + + var defaultSettings = Object.assign({}, rendererSpecificSettings, webchartsSettings); + + //Replicate settings in multiple places in the settings object + function syncSettings(settings) { + settings.x.label = settings.start_value; + settings.x.column = settings.value_col; + settings.marks[0].per[0] = settings.value_col; + + if (!settings.normal_range) { + settings.normal_col_low = null; + settings.normal_col_high = null; + } + + //Define default details. + var defaultDetails = [{ value_col: settings.id_col, label: 'Subject Identifier' }]; + + if (!(settings.filters instanceof Array)) { + settings.filters = typeof settings.filters == 'string' ? [settings.filters] : []; + } + + if (settings.filters) + settings.filters.forEach(function(filter) { + return defaultDetails.push({ + value_col: filter.value_col ? filter.value_col : filter, + label: filter.label + ? filter.label + : filter.value_col + ? filter.value_col + : filter + }); + }); + defaultDetails.push({ value_col: settings.value_col, label: 'Result' }); + if (settings.normal_col_low) + defaultDetails.push({ + value_col: settings.normal_col_low, + label: 'Lower Limit of Normal' + }); + if (settings.normal_col_high) + defaultDetails.push({ + value_col: settings.normal_col_high, + label: 'Upper Limit of Normal' + }); + + //If [settings.details] is not an array: + if (!(settings.details instanceof Array)) { + settings.details = typeof settings.details == 'string' ? [settings.details] : []; + } + + //If [settings.details] is not specified: + if (!settings.details) settings.details = defaultDetails; + else { + //If [settings.details] is specified: + //Allow user to specify an array of columns or an array of objects with a column property + //and optionally a column label. + settings.details.forEach(function(detail) { + if ( + defaultDetails + .map(function(d) { + return d.value_col; + }) + .indexOf(detail.value_col ? detail.value_col : detail) === -1 + ) + defaultDetails.push({ + value_col: detail.value_col ? detail.value_col : detail, + label: detail.label + ? detail.label + : detail.value_col + ? detail.value_col + : detail + }); + }); + settings.details = defaultDetails; + } + + return settings; + } + + //Map values from settings to control inputs + function syncControlInputs(settings) { + var defaultControls = [ + { + type: 'subsetter', + label: 'Measure', + value_col: settings.measure_col, + start: settings.start_value + }, + { + type: 'checkbox', + label: 'Normal Range', + option: 'displayNormalRange' + }, + { + type: 'number', + label: 'Lower Limit', + option: 'x.domain[0]', + require: true + }, + { + type: 'number', + label: 'Upper Limit', + option: 'x.domain[1]', + require: true + } + ]; + + if (Array.isArray(settings.filters) && settings.filters.length > 0) { + var otherFilters = settings.filters.map(function(filter) { + var filterObject = { + type: 'subsetter', + value_col: filter.value_col || filter, + label: filter.label || filter.value_col || filter + }; + return filterObject; + }); + + return defaultControls.concat(otherFilters); + } else return defaultControls; + } + + function countParticipants() { + var _this = this; + + this.populationCount = d3 + .set( + this.raw_data.map(function(d) { + return d[_this.config.id_col]; + }) + ) + .values().length; + } + + function cleanData() { + var _this = this; + + //Remove missing and non-numeric data. + var preclean = this.raw_data; + var clean = this.raw_data.filter(function(d) { + return /^-?[0-9.]+$/.test(d[_this.config.value_col]); + }); + var nPreclean = preclean.length; + var nClean = clean.length; + var nRemoved = nPreclean - nClean; + + //Warn user of removed records. + if (nRemoved > 0) + console.warn( + nRemoved + + ' missing or non-numeric result' + + (nRemoved > 1 ? 's have' : ' has') + + ' been removed.' + ); + + //Preserve cleaned data. + this.raw_data = clean; + + //Attach array of continuous measures to chart object. + this.measures = d3 + .set( + this.raw_data.map(function(d) { + return d[_this.config.measure_col]; + }) + ) + .values() + .sort(); + } + + function addVariables() { + var _this = this; + + this.raw_data.forEach(function(d) { + d[_this.config.measure_col] = d[_this.config.measure_col].trim(); + }); + } + + function checkFilters() { + var _this = this; + + this.controls.config.inputs = this.controls.config.inputs.filter(function(input) { + if (input.type != 'subsetter') { + return true; + } else if (!_this.raw_data[0].hasOwnProperty(input.value_col)) { + console.warn( + 'The [ ' + + input.label + + ' ] filter has been removed because the variable does not exist.' + ); + } else { + var levels = d3 + .set( + _this.raw_data.map(function(d) { + return d[input.value_col]; + }) + ) + .values(); + + if (levels.length === 1) + console.warn( + 'The [ ' + + input.label + + ' ] filter has been removed because the variable has only one level.' + ); + + return levels.length > 1; + } + }); + } + + function setInitialMeasure() { + this.controls.config.inputs.find(function(input) { + return input.label === 'Measure'; + }).start = + this.config.start_value && this.measures.indexOf(this.config.start_value) > -1 + ? this.config.start_value + : this.measures[0]; + } + + function onInit() { + // 1. Count total participants prior to data cleaning. + countParticipants.call(this); + + // 2. Drop missing values and remove measures with any non-numeric results. + cleanData.call(this); + + // 3a Define additional variables. + addVariables.call(this); + + // 3b Remove filters for nonexistent or single-level variables. + checkFilters.call(this); + + // 3c Choose the start value for the Test filter + setInitialMeasure.call(this); + } + + function addXdomainResetButton() { + var _this = this; + + //Add x-domain reset button container. + var resetContainer = this.controls.wrap + .insert('div', '.control-group:nth-child(3)') + .classed('control-group x-axis', true) + .datum({ + type: 'button', + option: 'x.domain', + label: 'x-axis:' + }); + + //Add label. + resetContainer + .append('span') + .attr('class', 'wc-control-label') + .style('text-align', 'right') + .text('X-axis:'); + + //Add button. + resetContainer + .append('button') + .text('Reset Limits') + .on('click', function() { + _this.config.x.domain = _this.measure_domain; + + _this.controls.wrap + .selectAll('.control-group') + .filter(function(f) { + return f.option === 'x.domain[0]'; + }) + .select('input') + .property('value', _this.config.x.domain[0]); + + _this.controls.wrap + .selectAll('.control-group') + .filter(function(f) { + return f.option === 'x.domain[1]'; + }) + .select('input') + .property('value', _this.config.x.domain[1]); + + _this.draw(); + }); + } + + function classXaxisLimitControls() { + this.controls.wrap + .selectAll('.control-group') + .filter(function(d) { + return ['Lower Limit', 'Upper Limit'].indexOf(d.label) > -1; + }) + .classed('x-axis', true); + } + + function addPopulationCountContainer() { + this.controls.wrap + .append('div') + .attr('id', 'populationCount') + .style('font-style', 'italic'); + } + + function addFootnoteContainer() { + this.wrap + .insert('p', '.wc-chart') + .attr('class', 'annote') + .text('Click a bar for details.'); + } + + function onLayout() { + //Add button that resets x-domain. + addXdomainResetButton.call(this); + + //Add x-axis class to x-axis limit controls. + classXaxisLimitControls.call(this); + + //Add container for population count. + addPopulationCountContainer.call(this); + + //Add container for footnote. + addFootnoteContainer.call(this); + } + + function getCurrentMeasure() { + var _this = this; + + this.previousMeasure = this.currentMeasure; + this.currentMeasure = this.filters.find(function(filter) { + return filter.col === _this.config.measure_col; + }).val; + } + + function defineMeasureData() { + var _this = this; + + this.measure_data = this.raw_data.filter(function(d) { + return d[_this.config.measure_col] === _this.currentMeasure; + }); + this.measure_domain = d3.extent(this.measure_data, function(d) { + return +d[_this.config.value_col]; + }); + } + + function setXdomain() { + if (this.currentMeasure !== this.previousMeasure) + // new measure + this.config.x.domain = this.measure_domain; + else if (this.config.x.domain[0] > this.config.x.domain[1]) + // invalid domain + this.config.x.domain.reverse(); + else if (this.config.x.domain[0] === this.config.x.domain[1]) + // domain with zero range + this.config.x.domain = this.config.x.domain.map(function(d, i) { + return i === 0 ? d - d * 0.01 : d + d * 0.01; + }); + } + + function setXaxisLabel() { + this.config.x.label = + this.currentMeasure + + (this.config.unit_col && this.measure_data[0][this.config.unit_col] + ? ' (' + this.measure_data[0][this.config.unit_col] + ')' + : ''); + } + + function setXprecision() { + var _this = this; + + //Calculate range of current measure and the log10 of the range to choose an appropriate precision. + this.config.x.range = this.config.x.domain[1] - this.config.x.domain[0]; + this.config.x.log10range = Math.log10(this.config.x.range); + this.config.x.roundedLog10range = Math.round(this.config.x.log10range); + this.config.x.precision1 = -1 * (this.config.x.roundedLog10range - 1); + this.config.x.precision2 = -1 * (this.config.x.roundedLog10range - 2); + + //Define the format of the x-axis tick labels and x-domain controls. + this.config.x.format = + this.config.x.log10range > 0.5 ? '1f' : '.' + this.config.x.precision1 + 'f'; + this.config.x.d3_format = d3.format(this.config.x.format); + this.config.x.formatted_domain = this.config.x.domain.map(function(d) { + return _this.config.x.d3_format(d); + }); + + //Define the bin format: one less than the x-axis format. + this.config.x.format1 = + this.config.x.log10range > 5 ? '1f' : '.' + this.config.x.precision2 + 'f'; + this.config.x.d3_format1 = d3.format(this.config.x.format1); + } + + function updateXaxisLimitControls() { + //Update x-axis limit controls. + this.controls.wrap + .selectAll('.control-group') + .filter(function(f) { + return f.option === 'x.domain[0]'; + }) + .select('input') + .property('value', this.config.x.formatted_domain[0]); + this.controls.wrap + .selectAll('.control-group') + .filter(function(f) { + return f.option === 'x.domain[1]'; + }) + .select('input') + .property('value', this.config.x.formatted_domain[1]); + } + + function updateXaxisResetButton() { + //Update tooltip of x-axis domain reset button. + if (this.currentMeasure !== this.previousMeasure) + this.controls.wrap + .selectAll('.x-axis') + .property( + 'title', + 'Initial Limits: [' + + this.config.x.domain[0] + + ' - ' + + this.config.x.domain[1] + + ']' + ); + } + + function onPreprocess() { + // 1. Capture currently selected measure. + getCurrentMeasure.call(this); + + // 2. Filter data on currently selected measure. + defineMeasureData.call(this); + + // 3a Set x-domain given currently selected measure. + setXdomain.call(this); + + // 3b Set x-axis label to current measure. + setXaxisLabel.call(this); + + // 4a Define precision of measure. + setXprecision.call(this); + + // 4b Update x-axis reset button when measure changes. + updateXaxisResetButton.call(this); + + // 4c Update x-axis limit controls to match y-axis domain. + updateXaxisLimitControls.call(this); + } + + function onDatatransform() {} + + // Takes a webcharts object creates a text annotation giving the + + function updateParticipantCount(chart, selector, id_unit) { + //count the number of unique ids in the current chart and calculate the percentage + var currentObs = d3 + .set( + chart.filtered_data.map(function(d) { + return d[chart.config.id_col]; + }) + ) + .values().length; + var percentage = d3.format('0.1%')(currentObs / chart.populationCount); + + //clear the annotation + var annotation = d3.select(selector); + d3.select(selector) + .selectAll('*') + .remove(); + + //update the annotation + var units = id_unit ? ' ' + id_unit : ' participant(s)'; + annotation.text( + '\n' + + currentObs + + ' of ' + + chart.populationCount + + units + + ' shown (' + + percentage + + ')' + ); + } + + function resetRenderer() { + //Reset listing. + this.listing.draw([]); + this.listing.wrap.selectAll('*').style('display', 'none'); + + //Reset footnote. + this.wrap + .select('.annote') + .classed('tableTitle', false) + .text('Click a bar for details.'); + + //Reset bar highlighting. + delete this.highlightedBin; + this.svg.selectAll('.bar').attr('opacity', 1); + } + + function onDraw() { + //Annotate population count. This function is called on draw() so that it can access the + //filtered data, i.e. the data with the current filters applied. However the filtered data is + //mark-specific, which could cause issues in other scenarios with mark-specific filters via the + //marks.[].values setting. chart.filtered_data is set to the last mark data defined rather + //than the full data with filters applied, irrespective of the mark-specific filters. + updateParticipantCount(this, '#populationCount'); + + //Reset chart and listing. Doesn't really need to be called on draw() but whatever. + resetRenderer.call(this); + } + + function handleSingleObservation() { + this.svg.select('#custom-bin').remove(); + if (this.current_data.length === 1) { + var datum = this.current_data[0]; + this.svg + .append('g') + .classed('bar-group', true) + .attr('id', 'custom-bin') + .append('rect') + .data([datum]) + .classed('wc-data-mark bar', true) + .attr({ + y: 0, + height: this.plot_height, + 'shape-rendering': 'crispEdges', + stroke: 'rgb(102,194,165)', + fill: 'rgb(102,194,165)', + 'fill-opacity': '0.75', + width: this.x(datum.values.x * 1.01) - this.x(datum.values.x * 0.99), + x: this.x(datum.values.x * 0.99) + }); + } + } + + function addBinClickListener() { + var chart = this; + var config = this.config; + var bins = this.svg.selectAll('.bar'); + var footnote = this.wrap.select('.annote'); + + bins.style('cursor', 'pointer') + .on('click', function(d) { + chart.highlightedBin = d.key; + //Update footnote. + footnote + .classed('tableTitle', true) + .text( + 'Table displays ' + + d.values.raw.length + + ' records with ' + + (chart.filtered_data[0][config.measure_col] + ' values from ') + + (chart.config.x.d3_format1(d.rangeLow) + + ' to ' + + chart.config.x.d3_format1(d.rangeHigh)) + + (config.unit_col ? ' ' + chart.filtered_data[0][config.unit_col] : '') + + '. Click outside a bar to remove details.' + ); + + //Draw listing. + chart.listing.draw(d.values.raw); + chart.listing.wrap.selectAll('*').style('display', null); + + //Reduce bin opacity and highlight selected bin. + bins.attr('fill-opacity', 0.5); + d3.select(this).attr('fill-opacity', 1); + }) + .on('mouseover', function(d) { + //Update footnote. + if (footnote.classed('tableTitle') === false) + footnote.text( + d.values.raw.length + + ' records with ' + + (chart.filtered_data[0][config.measure_col] + ' values from ') + + (chart.config.x.d3_format1(d.rangeLow) + + ' to ' + + chart.config.x.d3_format1(d.rangeHigh)) + + (config.unit_col ? ' ' + chart.filtered_data[0][config.unit_col] : '') + ); + }) + .on('mouseout', function(d) { + //Update footnote. + if (footnote.classed('tableTitle') === false) + footnote.text('Click a bar for details.'); + }); + } + + function drawNormalRanges() { + var chart = this; + var config = this.config; + var normalRangeControl = this.controls.wrap.selectAll('.control-group').filter(function(d) { + return d.label === 'Normal Range'; + }); + + if (config.normal_range) { + if (chart.config.displayNormalRange) drawNormalRanges(chart); + else chart.wrap.selectAll('.normalRange').remove(); + + normalRangeControl.on('change', function() { + chart.config.displayNormalRange = d3 + .select(this) + .select('input') + .property('checked'); + + if (chart.config.displayNormalRange) drawNormalRanges(chart); + else chart.wrap.selectAll('.normalRange').remove(); + }); + } else normalRangeControl.style('display', 'none'); + + function drawNormalRanges() { + //Clear normal ranges. + var canvas = chart.svg; + canvas.selectAll('.normalRange').remove(); + + //Capture distinct normal ranges in filtered data. + var normalRanges = d3 + .nest() + .key(function(d) { + return d[chart.config.normal_col_low] + ',' + d[chart.config.normal_col_high]; + }) // set key to comma-delimited normal range + .rollup(function(d) { + return d.length; + }) + .entries(chart.filtered_data); + var currentRange = d3.extent(chart.filtered_data, function(d) { + return +d[chart.config.value_col]; + }); + //Sort normal ranges so larger normal ranges plot beneath smaller normal ranges. + normalRanges.sort(function(a, b) { + var a_lo = a.key.split(',')[0]; + var a_hi = a.key.split(',')[1]; + var b_lo = b.key.split(',')[0]; + var b_hi = b.key.split(',')[1]; + return a_lo <= b_lo && a_hi >= b_hi + ? 2 // lesser minimum and greater maximum + : a_lo >= b_lo && a_hi <= b_hi + ? -2 // greater minimum and lesser maximum + : a_lo <= b_lo && a_hi <= b_hi + ? 1 // lesser minimum and lesser maximum + : a_lo >= b_lo && a_hi >= b_hi + ? -1 // greater minimum and greater maximum + : 1; + }); + //Add divs to chart for each normal range. + canvas + .selectAll('.normalRange rect') + .data(normalRanges) + .enter() + .insert('rect', ':first-child') + .attr({ + class: 'normalRange', + x: function x(d) { + return chart.x(Math.max(+d.key.split(',')[0], currentRange[0])); + }, // set x to range low + y: 0, + width: function width(d) { + return Math.min( + chart.plot_width - + chart.x(Math.max(+d.key.split(',')[0], currentRange[0])), // chart width - range low + + chart.x(+d.key.split(',')[1]) - + chart.x(Math.max(+d.key.split(',')[0], currentRange[0])) + ); + }, // range high - range low + + height: chart.plot_height + }) + .style({ + stroke: 'black', + fill: 'black', + 'stroke-opacity': function strokeOpacity(d) { + return (d.values / chart.filtered_data.length) * 0.75; + }, // opacity as a function of fraction of records with the given normal range + 'fill-opacity': function fillOpacity(d) { + return (d.values / chart.filtered_data.length) * 0.5; + } + }) // opacity as a function of fraction of records with the given normal range + .append('title') + .text(function(d) { + return ( + 'Normal range: ' + + d.key.split(',')[0] + + '-' + + d.key.split(',')[1] + + (chart.config.unit_col + ? '' + chart.filtered_data[0][chart.config.unit_col] + : '') + + (' (' + + d3.format('%')(d.values / chart.filtered_data.length) + + ' of records)') + ); + }); + } + } + + function addClearListing() { + var chart = this; + var footnote = this.wrap.select('.annote'); + this.wrap.selectAll('.overlay, .normalRange').on('click', function() { + delete chart.highlightedBin; + chart.listing.draw([]); + chart.listing.wrap.selectAll('*').style('display', 'none'); + chart.svg.selectAll('.bar').attr('fill-opacity', 0.75); + + if (footnote.classed('tableTitle')) + footnote.classed('tableTitle', false).text('Click a bar for details.'); + }); + } + + function maintainBinHighlighting() { + var _this = this; + + if (this.highlightedBin) + this.svg.selectAll('.bar').attr('fill-opacity', function(d) { + return d.key !== _this.highlightedBin ? 0.5 : 1; + }); + } + + function hideDuplicateXaxisTickLabels() { + this.svg.selectAll('.x.axis .tick').each(function(d, i) { + var tick = d3.select(this); + var value = +d; + var text = +tick.select('text').text(); + tick.style('display', value === text ? 'block' : 'none'); + }); + } + + function onResize() { + //Draw custom bin for single observation subsets. + handleSingleObservation.call(this); + + //Display data listing on bin click. + addBinClickListener.call(this); + + //Visualize normal ranges. + drawNormalRanges.call(this); + + //Clear listing when clicking outside bins. + addClearListing.call(this); + + //Keep highlighted bin highlighted on resize. + maintainBinHighlighting.call(this); + + //Hide duplicate x-axis tick labels (d3 sometimes draws more ticks than the precision allows). + hideDuplicateXaxisTickLabels.call(this); + } + + function onDestroy() {} + + //polyfills + + function safetyHistogram(element, settings) { + //Define chart. + var mergedSettings = Object.assign({}, defaultSettings, settings); + var syncedSettings = syncSettings(mergedSettings); + var syncedControlInputs = syncControlInputs(syncedSettings); + var controls = webcharts.createControls(element, { + location: 'top', + inputs: syncedControlInputs + }); + var chart = webcharts.createChart(element, syncedSettings, controls); + + //Define chart callbacks. + chart.on('init', onInit); + chart.on('layout', onLayout); + chart.on('preprocess', onPreprocess); + chart.on('datatransform', onDatatransform); + chart.on('draw', onDraw); + chart.on('resize', onResize); + chart.on('destroy', onDestroy); + + //Define listing + var listingSettings = { + cols: syncedSettings.details.map(function(detail) { + return detail.value_col; + }), + headers: syncedSettings.details.map(function(detail) { + return detail.label; + }), + searchable: syncedSettings.searchable, + sortable: syncedSettings.sortable, + pagination: syncedSettings.pagination, + exportable: syncedSettings.exportable + }; + var listing = webcharts.createTable(element, listingSettings); + + //Attach listing to chart. + chart.listing = listing; + + //Initialize listing and hide initially. + chart.listing.init([]); + chart.listing.wrap.selectAll('*').style('display', 'none'); + + return chart; + } + + return safetyHistogram; +}); diff --git a/inst/htmlwidgets/lib/webcharts-1.11.3/webcharts.css b/inst/htmlwidgets/lib/webcharts-1.11.5/webcharts.css similarity index 100% rename from inst/htmlwidgets/lib/webcharts-1.11.3/webcharts.css rename to inst/htmlwidgets/lib/webcharts-1.11.5/webcharts.css diff --git a/inst/htmlwidgets/lib/webcharts-1.11.3/webcharts.js b/inst/htmlwidgets/lib/webcharts-1.11.5/webcharts.js similarity index 98% rename from inst/htmlwidgets/lib/webcharts-1.11.3/webcharts.js rename to inst/htmlwidgets/lib/webcharts-1.11.5/webcharts.js index e6fe9061..24ad10ef 100644 --- a/inst/htmlwidgets/lib/webcharts-1.11.3/webcharts.js +++ b/inst/htmlwidgets/lib/webcharts-1.11.5/webcharts.js @@ -6,7 +6,7 @@ : (global.webCharts = factory(global.d3)); })(typeof self !== 'undefined' ? self : this, function(d3) { 'use strict'; - var version = '1.11.3'; + var version = '1.11.5'; function init(data) { var _this = this; @@ -518,7 +518,7 @@ if (this.filters.length) { this.filters.forEach(function(filter) { _this.filtered_data = _this.filtered_data.filter(function(d) { - return filter.val === 'All' + return filter.all === true && filter.index === 0 ? d : filter.val instanceof Array ? filter.val.indexOf(d[filter.col]) > -1 @@ -1092,7 +1092,7 @@ if (this.filters.length) { this.filters.forEach(function(e) { filtered = filtered.filter(function(d) { - return e.val === 'All' + return e.all === true && e.index === 0 ? d : e.val instanceof Array ? e.val.indexOf(d[e.col]) > -1 @@ -1831,6 +1831,7 @@ function drawBars(marks) { var _this = this; + var chart = this; var rawData = this.raw_data; var config = this.config; @@ -1896,7 +1897,7 @@ .attr('class', function(d) { return 'wc-data-mark bar ' + d.key; }) - .style('clip-path', 'url(#' + this.id + ')') + .style('clip-path', 'url(#' + chart.id + ')') .attr('y', this.y(0)) .attr('height', 0) .append('title'); @@ -2029,7 +2030,7 @@ .attr('class', function(d) { return 'wc-data-mark bar ' + d.key; }) - .style('clip-path', 'url(#' + this.id + ')') + .style('clip-path', 'url(#' + chart.id + ')') .attr('x', this.x(0)) .attr('width', 0) .append('title'); @@ -2157,7 +2158,7 @@ .attr('class', function(d) { return 'wc-data-mark bar ' + d.key; }) - .style('clip-path', 'url(#' + this.id + ')') + .style('clip-path', 'url(#' + chart.id + ')') .attr('y', this.y(0)) .attr('height', 0) .append('title'); @@ -2267,7 +2268,7 @@ .attr('class', function(d) { return 'wc-data-mark bar ' + d.key; }) - .style('clip-path', 'url(#' + this.id + ')') + .style('clip-path', 'url(#' + chart.id + ')') .attr('x', this.x(0)) .attr('width', 0) .append('title'); @@ -2362,6 +2363,7 @@ function drawLines(marks) { var _this = this; + var chart = this; var config = this.config; var line = d3.svg .line() @@ -2409,6 +2411,7 @@ var linePaths = line_grps .select('path') .attr('class', 'wc-data-mark') + .style('clip-path', 'url(#' + chart.id + ')') .datum(function(d) { return d.values; }) @@ -2458,6 +2461,7 @@ function drawPoints(marks) { var _this = this; + var chart = this; var config = this.config; var point_supergroups = this.svg.selectAll('.point-supergroup').data(marks, function(d, i) { @@ -2496,6 +2500,7 @@ //static attributes points .select('circle') + .style('clip-path', 'url(#' + chart.id + ')') .attr( 'fill-opacity', config.fill_opacity || config.fill_opacity === 0 ? config.fill_opacity : 0.6 @@ -2568,6 +2573,7 @@ function drawText(marks) { var _this = this; + var chart = this; var config = this.config; var textSupergroups = this.svg.selectAll('.text-supergroup').data(marks, function(d, i) { @@ -2610,7 +2616,7 @@ texts.each(attachMarks); // parse text like tooltips - texts.select('text').text(function(d) { + texts.select('text').style('clip-path', 'url(#' + chart.id + ')').text(function(d) { var tt = d.mark.text || ''; var xformat = config.x.summary === 'percent' ? d3.format('0%') @@ -3061,13 +3067,16 @@ } function makeSubsetterControl(control, control_wrap) { - var targets = this.targets; + var targets = this.targets; // associated charts and tables. + + //dropdown selection var changer = control_wrap .append('select') - .attr('class', 'changer') + .classed('changer', true) .attr('multiple', control.multiple ? true : null) .datum(control); + //dropdown option data var option_data = control.values ? control.values : d3 @@ -3080,17 +3089,24 @@ return f; }) ) - .values(); - option_data.sort(naturalSorter); + .values() + .sort(naturalSorter); // only sort when values are derived + //initial dropdown option control.start = control.start ? control.start : control.loose ? option_data[0] : null; + //conditionally add All option if (!control.multiple && !control.start) { option_data.unshift('All'); + control.all = true; + } else { + control.all = false; } + //what does loose mean? control.loose = !control.loose && control.start ? true : control.loose; + //dropdown options selection var options = changer .selectAll('option') .data(option_data) @@ -3103,6 +3119,7 @@ return d === control.start; }); + //define filter object for each associated target targets.forEach(function(e) { var match = e.filters .slice() @@ -3113,16 +3130,20 @@ if (match > -1) { e.filters[match] = { col: control.value_col, - val: control.start ? control.start : 'All', + val: control.start ? control.start : !control.multiple ? 'All' : option_data, + index: 0, choices: option_data, - loose: control.loose + loose: control.loose, + all: control.all }; } else { e.filters.push({ col: control.value_col, - val: control.start ? control.start : 'All', + val: control.start ? control.start : !control.multiple ? 'All' : option_data, + index: 0, choices: option_data, - loose: control.loose + loose: control.loose, + all: control.all }); } }); @@ -3139,6 +3160,7 @@ } } + //add event listener to control changer.on('change', function(d) { if (control.multiple) { var values = options @@ -3152,8 +3174,10 @@ var new_filter = { col: control.value_col, val: values, + index: null, // could specify an array of indices but seems like a waste of resources give it doesn't inform anything without an overall 'All' choices: option_data, - loose: control.loose + loose: control.loose, + all: control.all }; targets.forEach(function(e) { setSubsetter(e, new_filter); @@ -3165,11 +3189,14 @@ }); } else { var value = d3.select(this).select('option:checked').property('text'); + var index = d3.select(this).select('option:checked').property('index'); var _new_filter = { col: control.value_col, val: value, + index: index, choices: option_data, - loose: control.loose + loose: control.loose, + all: control.all }; targets.forEach(function(e) { setSubsetter(e, _new_filter); @@ -3273,7 +3300,8 @@ this.filters && this.filters.some(function(filter) { return ( - (typeof filter.val === 'string' && filter.val !== 'All') || + (typeof filter.val === 'string' && + !(filter.all === true && filter.index === 0)) || (Array.isArray(filter.val) && filter.val.length < filter.choices.length) ); }) @@ -3282,7 +3310,8 @@ this.filters .filter(function(filter) { return ( - (typeof filter.val === 'string' && filter.val !== 'All') || + (typeof filter.val === 'string' && + !(filter.all === true && filter.index === 0)) || (Array.isArray(filter.val) && filter.val.length < filter.choices.length) ); }) diff --git a/inst/htmlwidgets/safetyHistogram.js b/inst/htmlwidgets/safetyHistogram.js new file mode 100644 index 00000000..fed8b913 --- /dev/null +++ b/inst/htmlwidgets/safetyHistogram.js @@ -0,0 +1,36 @@ +HTMLWidgets.widget({ + + name: "safetyHistogram", + + type: "output", + + factory: function(el, width, height) { + + // TODO: define shared variables for this instance + + return { + + renderValue: function(rSettings) { + el.innerHTML = "
"; + var settings = rSettings.settings; + + if(settings.debug_js){ + console.log("R settings:") + console.log(rSettings); + } + + settings.max_width = 600; + rSettings.data = HTMLWidgets.dataframeToD3(rSettings.data); + safetyHistogram(".safetyhistogram", settings).init(rSettings.data); + + }, + + resize: function(width, height) { + + // TODO: code to re-render the widget with a new size + + } + + }; + } +}); \ No newline at end of file diff --git a/inst/htmlwidgets/safetyHistogram.yaml b/inst/htmlwidgets/safetyHistogram.yaml new file mode 100644 index 00000000..1982a9ac --- /dev/null +++ b/inst/htmlwidgets/safetyHistogram.yaml @@ -0,0 +1,15 @@ +dependencies: + - name: d3 + version: 3.5.17 + src: htmlwidgets/lib/d3-3.5.17 + script: d3.v3.min.js + - name: webcharts + version: 1.11.5 + src: htmlwidgets/lib/webcharts-1.11.5 + script: webcharts.js + stylesheet: webcharts.css + - name: safety-histogram + version: 2.2.3 + src: htmlwidgets/lib/safety-histogram-2.2.3 + script: safetyHistogram.js + diff --git a/man/checkColumn.Rd b/man/checkColumn.Rd index cc5eac43..b8a4e6ab 100644 --- a/man/checkColumn.Rd +++ b/man/checkColumn.Rd @@ -31,18 +31,18 @@ testSettings$filters[[3]]<-list(value_col="NotAColumn",label="Invalid Column") #pass ($valid == TRUE) safetyGraphics:::checkColumn(key=list("id_col"), - settings=testSettings, adlbc) - + settings=testSettings, adlbc) + #pass safetyGraphics:::checkColumn(key=list("filters",1,"value_col"), - settings=testSettings, adlbc) - + settings=testSettings, adlbc) + #NULL column pass safetyGraphics:::checkColumn(key=list("filters",2,"value_col"), - settings=testSettings, adlbc) - + settings=testSettings, adlbc) + #invalid column fails safetyGraphics:::checkColumn(key=list("filters",3,"value_col"), - settings=testSettings, adlbc) + settings=testSettings, adlbc) } \keyword{internal} diff --git a/man/checkNumeric.Rd b/man/checkNumeric.Rd index ce7aded3..2dc139b9 100644 --- a/man/checkNumeric.Rd +++ b/man/checkNumeric.Rd @@ -22,10 +22,10 @@ Check that settings for mapping numeric data are associated with numeric columns \examples{ testSettings<-generateSettings(standard="AdAM") #pass ($valid == FALSE) -safetyGraphics:::checkNumeric(key=list("id_col"),settings=testSettings, data=adlbc) +safetyGraphics:::checkNumeric(key=list("id_col"),settings=testSettings, data=adlbc) #pass ($valid == TRUE) -safetyGraphics:::checkNumeric(key=list("value_col"),settings=testSettings, data=adlbc) +safetyGraphics:::checkNumeric(key=list("value_col"),settings=testSettings, data=adlbc) } \keyword{internal} diff --git a/man/generateSettings.Rd b/man/generateSettings.Rd index f4bb5e9c..f5b634fa 100644 --- a/man/generateSettings.Rd +++ b/man/generateSettings.Rd @@ -4,17 +4,22 @@ \alias{generateSettings} \title{Generate a settings object based on a data standard} \usage{ -generateSettings(standard = "None", chart = "eDish", partial = FALSE, - partial_keys = NULL) +generateSettings(standard = "None", charts = NULL, + useDefaults = TRUE, partial = FALSE, partial_keys = NULL, + custom_settings = NULL) } \arguments{ -\item{standard}{The data standard for which to create settings. Valid options are "SDTM", "AdAM" or "None". Default: \code{"SDTM"}} +\item{standard}{The data standard for which to create settings. Valid options are "SDTM", "AdAM" or "None". Default: \code{"None"}.} -\item{chart}{The chart for which standards should be generated ("eDish" only for now) . Default: \code{"eDish"}.} +\item{charts}{The chart or chart(s) for which settings should be generated. Default: \code{NULL} (uses all available charts).} + +\item{useDefaults}{Specifies whether default values from settingsMetadata should be included in the settings object. Default: \code{TRUE}.} \item{partial}{Boolean for whether or not the standard is a partial standard. Default: \code{FALSE}.} \item{partial_keys}{Optional character vector of the matched settings if partial is TRUE. Settings should be identified using the text_key format described in ?settingsMetadata. Setting is ignored when partial is FALSE. Default: \code{NULL}.} + +\item{custom_settings}{a tibble with text_key and customValue columns specifiying customizations to be applied to the settings object. Default: \code{NULL}.} } \value{ A list containing the appropriate settings for the selected chart @@ -27,17 +32,17 @@ The function is designed to work with the SDTM and AdAM CDISC(%filter(text_key=="measure_col")%>%select(valid)%>%unlist) }) @@ -38,7 +38,7 @@ test_that("field level data is ignored when useFields=false",{ noFields<-evaluateStandard(data=adlbc, standard="adam", includeFields=FALSE) expect_equal(noFields[["match"]],"full") expect_equal(noFields[["match_percent"]],1) - expect_equal(noFields[["valid_count"]],6) + expect_equal(noFields[["valid_count"]],7) }) test_that("invalid options throw errors",{ diff --git a/tests/testthat/test_generateSettings.R b/tests/testthat/test_generateSettings.R index 78dbc96b..87c2da36 100644 --- a/tests/testthat/test_generateSettings.R +++ b/tests/testthat/test_generateSettings.R @@ -1,23 +1,21 @@ context("Tests for the generateSettings() function") library(safetyGraphics) -setting_names<-c("id_col","value_col","measure_col","normal_col_low","normal_col_high","studyday_col", "visit_col", "visitn_col", "filters","group_cols", "measure_values", "baseline", "analysisFlag", "x_options", "y_options", "visit_window", "r_ratio_filter", "r_ratio_cut", "showTitle", "warningText") +setting_names<-c("id_col","value_col","measure_col","normal_col_low","normal_col_high","studyday_col", "visit_col", "visitn_col", "filters","group_cols", "measure_values", "baseline", "analysisFlag", "x_options", "y_options", "visit_window", "r_ratio_filter", "r_ratio_cut", "showTitle", "warningText", "unit_col", "start_value", "details", "missingValues") test_that("a list with the expected properties and structure is returned for all standards",{ expect_is(generateSettings(standard="None"),"list") - expect_named(generateSettings(standard="None"),setting_names) - expect_named(generateSettings(standard="None")[["measure_values"]], c("ALT","AST","TB","ALP")) + expect_equal(sort(names(generateSettings(standard="None"))),sort(setting_names)) + expect_equal(sort(names(generateSettings(standard="None")[["measure_values"]])), sort(c("ALT","AST","TB","ALP"))) expect_is(generateSettings(standard="ADaM"),"list") - expect_named(generateSettings(standard="ADaM"),setting_names) - expect_named(generateSettings(standard="ADaM")[["measure_values"]], c("ALT","AST","TB","ALP")) - + expect_equal(sort(names(generateSettings(standard="ADaM"))),sort(setting_names)) + expect_equal(sort(names(generateSettings(standard="ADaM")[["measure_values"]])), sort(c("ALT","AST","TB","ALP"))) expect_is(generateSettings(standard="SDTM"),"list") - expect_named(generateSettings(standard="SDTM"),setting_names) - expect_named(generateSettings(standard="SDTM")[["measure_values"]], c("ALT","AST","TB","ALP")) -}) + expect_equal(sort(names(generateSettings(standard="SDTM"))),sort(setting_names)) + expect_equal(sort(names(generateSettings(standard="SDTM")[["measure_values"]])), sort(c("ALT","AST","TB","ALP")))}) -test_that("a warning is thrown if chart isn't eDish",{ +test_that("a warning is thrown if chart isn't found in the chart list",{ expect_error(generateSettings(chart="aeexplorer")) expect_error(generateSettings(chart="")) expect_silent(generateSettings(chart="eDish")) @@ -30,13 +28,13 @@ test_that("data mappings are null when setting=none, character otherwise",{ none_settings <- generateSettings(standard="None") for(text_key in data_setting_keys){ key<-textKeysToList(text_key)[[1]] - expect_null(getSettingValue(settings=none_settings,key=key)) + expect_equal(getSettingValue(settings=none_settings,key=key),NULL) } other_settings <- generateSettings(standard="a different standard") for(text_key in data_setting_keys){ key<-textKeysToList(text_key)[[1]] - expect_null(getSettingValue(settings=other_settings,key=key)) + expect_equal(getSettingValue(settings=other_settings,key=key),NULL) } sdtm_settings <- generateSettings(standard="SDTM") @@ -73,7 +71,7 @@ test_that("data mappings are null when setting=none, character otherwise",{ if (text_key %in% c("id_col","measure_col","measure_values--ALT")) { expect_is(getSettingValue(settings=partial_adam_settings,key=key),"character") } else { - expect_null(getSettingValue(settings=partial_adam_settings,key=key)) + expect_equal(getSettingValue(settings=partial_adam_settings,key=key),NULL) } } @@ -86,4 +84,28 @@ test_that("data mappings are null when setting=none, character otherwise",{ #Testing failure when partial is true with no specified columns expect_error(partial_settings_no_cols <- generateSettings(standard="ADaM", partial=TRUE)) + + #Test useDefaults + noDefaults <- generateSettings(standard="adam",useDefaults=FALSE) + option_keys<-c("x_options", "y_options", "visit_window", "r_ratio_filter", "r_ratio_cut", "showTitle", "warningText") + + #non data mappings are NA + for(text_key in option_keys){ + key<-textKeysToList(text_key)[[1]] + expect_equal(getSettingValue(settings=noDefaults,key=key),NULL) + } + + #data mappings are filled as expected + for(text_key in data_setting_keys){ + key<-textKeysToList(text_key)[[1]] + expect_is(getSettingValue(settings=noDefaults,key=key),"character") + } + + #Test customSettings + customizations<- tibble(text_key=c("id_col","warningText","measure_values--ALT"),customValue=c("customID","This is a custom warning","custom ALT")) + customSettings<-generateSettings(standard="adam",custom_settings=customizations) + expect_equal(getSettingValue(settings=customSettings,key=list("id_col")),"customID") + expect_equal(getSettingValue(settings=customSettings,key=list("warningText")),"This is a custom warning") + expect_equal(getSettingValue(settings=customSettings,key=list("measure_values","ALT")),"custom ALT") + expect_equal(getSettingValue(settings=customSettings,key=list("measure_col")),"PARAM") }) diff --git a/tests/testthat/test_generateShell.R b/tests/testthat/test_generateShell.R new file mode 100644 index 00000000..f0dbbba7 --- /dev/null +++ b/tests/testthat/test_generateShell.R @@ -0,0 +1,13 @@ +context("Tests for the generateShell() function") +library(safetyGraphics) + +default <- generateShell() + +test_that("a list with the expected properties and structure is returned by default",{ + expect_type(default, "list") + expect_equal(default[["id_col"]],NULL) + expect_equal(default[["measure_values"]][["ALT"]],NULL) + expect_null(default[["not_a_setting"]]) +}) + +# TODO: Add tests for the charts parameter once multiple charts are added \ No newline at end of file diff --git a/tests/testthat/test_getSettingValue.R b/tests/testthat/test_getSettingValue.R index 59f5ac00..cf577d38 100644 --- a/tests/testthat/test_getSettingValue.R +++ b/tests/testthat/test_getSettingValue.R @@ -17,6 +17,23 @@ test_that("different data types for `key` parameter work as expected",{ expect_equal(getSettingValue(key=list("measure_values",1),settings=testSettings),"Aminotransferase, alanine (ALT)") }) +test_that("can get a specific item out of a vector if desired",{ + filter_vector = list(filters=c("SEX","AGE","RACE")) + filter_list = list(filters=list("SEX","AGE","RACE")) + expect_equal(getSettingValue(key=list("filters"),settings=filter_vector),c("SEX","AGE","RACE")) + expect_equal(getSettingValue(key=list("filters",2),settings=filter_vector),"AGE") + expect_null(getSettingValue(key=list("filters",2,"test"),settings=filter_vector)) + expect_null(getSettingValue(key=list("filters",4),settings=filter_vector)) + expect_null(getSettingValue(key=list("filters","4"),settings=filter_vector)) + + + + expect_equal(getSettingValue(key=list("filters"),settings=filter_list),list("SEX","AGE","RACE")) + expect_equal(getSettingValue(key=list("filters",2),settings=filter_list),"AGE") + + +}) + test_that("returns null if the setting isn't found",{ expect_null(getSettingValue(key="testKeyandmore",settings=list(testKey="ABC"))) expect_null(getSettingValue(key=c("a","b","c"),settings=list(testKey="ABC"))) diff --git a/tests/testthat/test_getSettingsMetadata.R b/tests/testthat/test_getSettingsMetadata.R index 7d65b796..ba7f5584 100644 --- a/tests/testthat/test_getSettingsMetadata.R +++ b/tests/testthat/test_getSettingsMetadata.R @@ -20,9 +20,10 @@ customMetadata<- data.frame( mergedMetadata = suppressWarnings(bind_rows( rawMetadata%>%mutate(chart_linechart= FALSE)%>%mutate(chart_barchart= FALSE), - customMetadata%>%mutate(chart_edish= FALSE) + customMetadata%>%mutate(chart_edish= FALSE, chart_safetyhistogram=FALSE) )) + test_that("Default function copies the whole metadata dataframe",{ default<-safetyGraphics:::getSettingsMetadata(add_standards=FALSE) expect_is(default,"data.frame") @@ -71,7 +72,7 @@ test_that("charts parameter works as expected",{ linesandbars <- safetyGraphics:::getSettingsMetadata(charts=c("linechart","barchart"),metadata=mergedMetadata) expect_equal(dim(linesandbars)[1],2) - allcharts <- safetyGraphics:::getSettingsMetadata(charts=c("linechart","barchart","edish"),metadata=mergedMetadata) + allcharts <- safetyGraphics:::getSettingsMetadata(charts=c("linechart","barchart","edish","safetyhistogram"),metadata=mergedMetadata) expect_equal(dim(allcharts)[1],dim(mergedMetadata)[1]) }) diff --git a/tests/testthat/test_hasColumn.R b/tests/testthat/test_hasColumn.R index 5145492b..4751ebc8 100644 --- a/tests/testthat/test_hasColumn.R +++ b/tests/testthat/test_hasColumn.R @@ -13,7 +13,10 @@ test_that("columns are found when expected",{ # returns false when fieldValue isn't there or there is a type mismatch expect_false(hasColumn(columnName="PARAMETER",data=adlbc)) expect_false(hasColumn(columnName="SUBJID2",data=adlbc)) - + + # returns false for null columnName + expect_false(hasColumn(columnName=NULL,data=adlbc)) + # fails with invalid parameters expect_error(hasColumn(columnName=123,data=adlbc)) expect_error(hasColumn(columnName=c("PARAM","SUBJID"),data=adlbc)) diff --git a/tests/testthat/test_hasField.R b/tests/testthat/test_hasField.R index a1e9197e..7c18ed53 100644 --- a/tests/testthat/test_hasField.R +++ b/tests/testthat/test_hasField.R @@ -20,6 +20,9 @@ test_that("fields are found when expected",{ expect_false(hasField(fieldValue="Not_a_real_value",columnName="PARAM",data=adlbc)) expect_false(hasField(fieldValue=12,columnName="PARAM",data=adlbc)) + # returns false for null columnName + expect_false(hasField(fieldValue="Bilirubin (umol/L)",columnName=NULL,data=adlbc)) + # fails with invalid parameters expect_error(hasField(fieldValue="Bilirubin (umol/L)",columnName=c("PARAM","ID"),data=adlbc)) expect_error(hasField(columnName="PARAM",data=list(adlbc))) #fieldValue missing