Dev v0.8.1

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: safetyGraphics
 Title: Create Interactive Graphics Related to Clinical Trial Safety
-Version: 0.8.0
+Version: 0.8.1
 Authors@R: c(
 	person("Jeremy", "Wildfire", email = "jeremy_wildfire@rhoworld.com", role = c("cre","aut")),
 	person("Becca", "Krouse", role="aut"),

R/checkField.R

@@ -13,11 +13,11 @@
 #' @examples
 #' testSettings<-generateSettings(standard="AdAM")
 #' fields<-list("measure_values","TB")
-#' safetyGraphics:::checkFieldSettings(fieldKey=fields,settings=testSettings, data=adlbc) 
+#' safetyGraphics:::checkField(fieldKey=fields,settings=testSettings, data=adlbc) 
 #' 
 #' @keywords internal
 
-checkFieldSettings <- function(fieldKey, settings, data){
+checkField <- function(fieldKey, settings, data){
   stopifnot(typeof(fieldKey)=="list", typeof(settings)=="list")
 
   # Check to see that the field data specified in the seetings is found in the data
@@ -29,12 +29,22 @@ checkFieldSettings <- function(fieldKey, settings, data){
   fieldCheck$value <-  getSettingValue(key=fieldCheck$key,settings=settings)
 
   #get the name of the column containing the field 
-  columnTextKey<-getSettingsMetadata(cols="field_column_key",text_keys=fieldCheck$text_key)
+  lastKey <- fieldCheck$key[[length(fieldCheck$key)]]
+
+  #use the parent metadata entry if the item is a vector
+  if(is.numeric(lastKey)){
+    sub_key <- fieldKey[-length(fieldKey)]
+    sub_text_key <- paste(unlist(sub_key), collapse='--')
+    columnTextKey <-getSettingsMetadata(cols="field_column_key",text_keys=sub_text_key)
+  }else{
+    columnTextKey <-getSettingsMetadata(cols="field_column_key",text_keys=fieldCheck$text_key)
+  }
+
   columnKey<-textKeysToList(columnTextKey)[[1]]
   columnName<-getSettingValue(key=columnKey,settings=settings)
 
   if(length(fieldCheck$value)>0){
-    fieldCheck$valid <-  hasField(fieldValue=fieldCheck$value, columnName=columnName,data=data)     
+    fieldCheck$valid <- hasField(fieldValue=fieldCheck$value, columnName=columnName,data=data)     
   }else{
     fieldCheck$value <-  "--No Value Given--"
     fieldCheck$valid <- TRUE #null values are ok

R/trimData.R

@@ -4,37 +4,55 @@
 #'
 #' @param data a data frame to trim
 #' @param settings the settings list used to determine which rows and columns to drop
+#' @param chart the chart being created
 #' @return A dataframe with unnecessary columns and rows removed
 #'
 #' @examples
 #' testSettings <- generateSettings(standard="adam")
-#' safetyGraphics:::trimData(data=adlbc, settings=testSettings) 
-#' 
+#' trimmed<-safetyGraphics:::trimData(data=adlbc, settings=testSettings)
+#'
 #' @importFrom dplyr filter
-#' @importFrom purrr map 
-#' @importFrom rlang parse_expr
-#' 
+#' @importFrom purrr map
+#' @importFrom rlang parse_expr .data
+#'
 #' @keywords internal
 
 
-trimData <- function(data, settings){
-  
+trimData <- function(data, settings, chart="edish"){
+
   ## Remove columns not in settings ##
-
   col_names <- colnames(data)
-  settings_keys  <- safetyGraphics::getSettingsMetadata(cols="text_key", filter_expr=column_mapping==TRUE) %>%
-    str_split("--")
 
-  settings_values <- map(settings_keys, function(x) {return(safetyGraphics:::getSettingValue(x, settings))})
-
-  common_cols <- intersect(col_names,settings_values)
+  allKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$column_mapping, cols = c("text_key","setting_type"))
+  dataKeys <- allKeys %>% filter(.data$setting_type !="vector") %>% pull(.data$text_key) %>% textKeysToList()
+
+  # Add items in vectors to list individually
+  dataVectorKeys <- allKeys %>% filter(.data$setting_type =="vector") %>% pull(.data$text_key) %>% textKeysToList()
+  for(key in dataVectorKeys){
+    current<-getSettingValue(key, settings=settings)
+    if (length(current) > 0 ) {
+      for (i in 1:length(current)){
+        newKey <- key
+        newKey[[1+length(newKey)]]<-i
+        sub <- current[[i]]
+        if(typeof(sub)=="list"){
+          newKey[[1+length(newKey)]]<-"value_col"
+        }  
+        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 ##
-  
+
   if(!is.null(settings[['baseline']][['value_col']]) | !is.null(settings[['analysisFlag']][['value_col']])) {
-    
+
     # Create Baseline String
     baseline_string <- ifelse(!is.null(settings[['baseline']][['value_col']]),
      paste(settings[['baseline']][['value_col']], "%in% settings[['baseline']][['values']]"),
@@ -44,19 +62,19 @@ trimData <- function(data, settings){
     analysis_string <- ifelse(!is.null(settings[['analysisFlag']][['value_col']]),
       paste(settings[['analysisFlag']][['value_col']], "%in% settings[['analysisFlag']][['values']]"),
     "")
-    
-    # Include OR operator if both are specified 
+
+    # Include OR operator if both are specified
     operator <- ifelse(!is.null(settings[['baseline']][['value_col']]) & !is.null(settings[['analysisFlag']][['value_col']]),
                         "|","")
-  
+
     # Create filter string and make it an expression
     filter_string <- paste(baseline_string, operator, analysis_string)
     filter_expression <- parse_expr(filter_string)
-    
+
     #Filter on baseline and analysisFlag
-    data_subset <-  filter(data_subset, !!filter_expression) 
-    
-  } 
-    
+    data_subset <-  filter(data_subset, !!filter_expression)
+
+  }
+
   return(data_subset)
 }

R/validateSettings.R

@@ -39,24 +39,53 @@
 
 
 validateSettings <- function(data, settings, chart="eDish"){
-
+  
   settingStatus<-list()
-
+  
   # Check that all required parameters are not null
   requiredChecks <- getRequiredSettings(chart = chart) %>% purrr::map(checkRequired, settings = settings)
-
+  
   #Check that non-null setting columns are found in the data
-  dataKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$column_mapping, cols = "text_key")%>%textKeysToList()
+  allKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$column_mapping, cols = c("text_key","setting_type"))
+  dataKeys <- allKeys %>% filter(.data$setting_type !="vector") %>% pull(.data$text_key) %>% textKeysToList()
+
+  # Add items in vectors to list individually
+  dataVectorKeys <- allKeys %>% filter(.data$setting_type =="vector") %>% pull(.data$text_key) %>% textKeysToList()
+  for(key in dataVectorKeys){
+    current<-getSettingValue(key, settings=settings)
+    if (length(current) > 0 ) {
+      for (i in 1:length(current)){
+        newKey <- key
+        newKey[[1+length(newKey)]]<-i
+        sub <- current[[i]]
+        if(typeof(sub)=="list"){
+          newKey[[1+length(newKey)]]<-"value_col"
+        }  
+        dataKeys[[1+length(dataKeys)]]<-newKey 
+      }
+    }
+  }
+
   columnChecks <- dataKeys %>% purrr::map(checkColumn, settings=settings, data=data)
 
   #Check that non-null field/column combinations are found in the data
-  fieldKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$field_mapping)%>%
-    filter(.data$setting_type!="vector")%>% #TODO: check the vectorized fields as well. Not sure a big deal now, since none are required ... 
-    select(.data$text_key)%>%
-    unlist()%>%
-    textKeysToList()
+  allKeys <- getSettingsMetadata(charts=chart, filter_expr = .data$field_mapping, cols = c("text_key","setting_type"))
+  fieldKeys <- allKeys %>% filter(.data$setting_type!="vector")%>% pull(.data$text_key)%>%textKeysToList()
+
+  #Add items in vectors to list individually
+  fieldVectorKeys <- allKeys %>% filter(.data$setting_type=="vector")%>% pull(.data$text_key)%>%textKeysToList()
+  for(key in fieldVectorKeys){
+    current<-getSettingValue(key, settings=settings)
+    if (length(current) > 0 ) {
+      for (i in 1:length(current)){
+        newKey <- key
+        newKey[[1+length(newKey)]]<-i
+        fieldKeys[[1+length(fieldKeys)]]<-newKey
+      }
+    }
+  }
   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 )
@@ -76,10 +105,10 @@ validateSettings <- function(data, settings, chart="eDish"){
 
   #valid=true if all checks pass, false otherwise
   settingStatus$valid <- settingStatus$checks%>%select(.data$valid)%>%unlist%>%all
-
+  
   #create summary string
   failCount <- nrow(settingStatus$checks%>%filter(!.data$valid))
   checkCount <- nrow(settingStatus$checks)
   settingStatus$status <- paste0(failCount," of ",checkCount," checks failed.")
   return (settingStatus)
-}
+}

inst/eDISH_app/modules/renderSettings/renderSettings.R

@@ -213,7 +213,7 @@ renderSettings <- function(input, output, session, data, settings, status){
     }
 
     if (! is.null(input$`analysisFlag--values`)){
-      if (! input$`analysisFlag--values`==""){
+      if (! input$`analysisFlag--values`[1]==""){
         settings$analysisFlag <- list(value_col = input$`analysisFlag--value_col`,
                                       values = input$`analysisFlag--values`)
       }

tests/testthat/test_trimData.R

@@ -11,6 +11,9 @@ analysisFlag_settings <- settings
 analysisFlag_settings[['analysisFlag']][['value_col']] <- 'TRTA'
 analysisFlag_settings[['analysisFlag']][['values']] <- list("Placebo","Xanomeline High Dose")
 
+filter_settings <- settings
+filter_settings[['filters']]<-list("SEX", "AGEGR1")
+
 both_settings <- baseline_settings
 both_settings[['analysisFlag']][['value_col']] <- 'TRTA'
 both_settings[['analysisFlag']][['values']] <- list("Placebo","Xanomeline High Dose")
@@ -21,6 +24,8 @@ test_that("columns are removed",{
   expect_length(trimData(adlbc, baseline_settings), 6)
   expect_length(trimData(adlbc, analysisFlag_settings), 7)
   expect_length(trimData(adlbc, both_settings), 7)
+  expect_length(trimData(adlbc, filter_settings), 8)
+
 })
 
 test_that("rows are removed",{