Calculate study timing given sdtm data.

.gitignore

@@ -1 +1,3 @@
 .Rproj.user
+.Rhistory
+.Rdata

DESCRIPTION

@@ -14,3 +14,6 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.1
+Depends: 
+    R (>= 2.10)
+LazyData: true

R/getDefaultData.R

@@ -0,0 +1,17 @@
+getDefaultData <- function(standard) {
+    data <- list()
+
+    if (standard == 'sdtm') {
+        data$aes <- safetyData::sdtm_ae
+        data$dm <- safetyData::sdtm_dm
+        data$labs <- safetyData::sdtm_lb
+    }
+
+    if (standard == 'adam') {
+        data$aes <- safetyData::adam_adae
+        data$dm <- safetyData::adam_adsl
+        data$labs <- safetyData::adam_adlbc
+    }
+
+    data
+}

R/getDefaultSettings.R

@@ -0,0 +1,63 @@
+getDefaultSettings <- function(standard) {
+    settings <- list()
+
+    if (standard == 'sdtm') {
+        settings$aes <- list(
+            id_col = "USUBJID",
+            stdt_col = "AESTDTC",
+            endt_col = "AEENDTC",
+            stdy_col = NULL,
+            endy_col = NULL,
+            aeterm_col = "AETERM",
+            decod_col = 'AEDECOD',
+            bodsys_col = "AEBODSYS",
+            severity_col = "AESEV"
+        )
+
+        settings$dm <- list(
+            id_col = "USUBJID",
+            reference_date_col = 'RFSTDTC',
+            treatment_col = "ARM"
+        )
+
+        settings$labs <- list(
+            id_col = "USUBJID",
+            visit_col = 'VISIT',
+            visit_order_col = 'VISITNUM',
+            dt_col = 'LBDTC',
+            dy_col = NULL,
+            result_col = 'LBSTRESN'
+        )
+    }
+
+    if (standard == 'adam') {
+        settings$aes <- list(
+            id_col = "USUBJID",
+            stdt_col = 'ASTDT',
+            endt_col = 'AENDT',
+            stdy_col = "ASTDY",
+            endy_col = "AENDY",
+            aeterm_col = "AETERM",
+            decod_col = 'AEDECOD',
+            bodsys_col = "AEBODSYS",
+            severity_col = "AESEV"
+        )
+
+        settings$dm <- list(
+            id_col = "USUBJID",
+            reference_date_col = 'TRTSDT',
+            treatment_col = "TRT01P"
+        )
+
+        settings$labs <- list(
+            id_col = "USUBJID",
+            visit_col = 'AVISIT',
+            visit_order_col = 'AVISITN',
+            dt_col = 'ADT',
+            dy_col = 'ADY',
+            result_col = 'AVAL'
+        )
+    }
+
+    settings
+}

R/getSDTMTiming.R

@@ -0,0 +1,45 @@
+getSDTMTiming <- function() {
+    stopifnot(
+        '[ standard ] must be a character-classed variable.' =
+            class(standard) == 'character',
+        '[ standard ] must be one of "sdtm", "adam", "custom".' =
+            tolower(standard) %in% c('sdtm', 'adam', 'custom')
+    )
+
+    standard <- tolower(standard)
+
+    ## Create list of default data when undefined.
+    if (is.null(data))
+        data <- getDefaultData(standard)
+
+    ## Create list of default settings when undefined.
+    if (is.null(settings))
+        settings <- getDefaultSettings(standard)
+
+    ## Calculate study timing.
+    if (standard == 'sdtm') {
+        data$aes <- getTiming(
+            params = list(
+                data = data,
+                settings = settings,
+                standard = standard
+            ),
+            'aes',
+            domainStartDate = settings$aes$stdt_col,
+            domainEndDate = settings$aes$endt_col
+        )
+        settings$aes$stdy_col <- paste0(settings$aes$stdt_col, '_dy')
+        settings$aes$endy_col <- paste0(settings$aes$endt_col, '_dy')
+
+        data$labs <- getTiming(
+            params = list(
+                data = data,
+                settings = settings,
+                standard = standard
+            ),
+            'labs',
+            domainDate = settings$labs$dt_col
+        )
+        settings$labs$dy_col <- paste0(settings$labs$dt_col, '_dy')
+    }
+}

R/getTiming.R

@@ -0,0 +1,59 @@
+#' Calculate reference timepoint.
+#'
+#' @param params `list` Reactive list of input data and mappings
+#' @param domain `character` Name of data domain with which to calculate reference timepoint
+#' @param domainDate `character` Name of date column with which to calculate reference timepoint
+#' @param reference `character` Name of data reference with which to calculate reference timepoint
+#' @param referenceDate `character` Name of date column with which to calculate reference timepoint
+
+getTiming <- function(
+    params,
+    domain,
+    domainDate = NULL,
+    refDomain = 'dm',
+    refDate = 'RFSTDTC',
+    domainStartDate = NULL,
+    domainEndDate = NULL
+) {
+    # TODO: add stopifnot() logic
+
+    id_col <- params$settings[[ refDomain ]]$id_col
+
+    ref_data <- params$data[[ refDomain ]] %>%
+        select(
+            id_col, refDate
+        ) %>%
+        mutate(
+            # TODO: add logic around date format... lubridate::ymd?
+            refDate = as.Date(.data[[ refDate ]])
+        )
+
+    domain_data <- params$data[[ domain ]] %>%
+        left_join(
+            ref_data,
+            id_col
+        )
+
+    getStudyDay <- function(data, date_col) {
+        data[[ date_col ]] <- as.Date(data[[ date_col ]])
+
+        data[[ paste0(date_col, '_dy') ]] <- as.numeric(
+            data[[ date_col ]] - data$refDate
+        ) + (
+            data[[ date_col ]] >= data$refDate
+        )
+
+        data
+    }
+
+    if (!is.null(domainDate))
+        domain_data <- getStudyDay(domain_data, domainDate)
+
+    if (!is.null(domainStartDate))
+        domain_data <- getStudyDay(domain_data, domainStartDate)
+
+    if (!is.null(domainEndDate))
+        domain_data <- getStudyDay(domain_data, domainEndDate)
+
+    domain_data
+}

R/profileApp.R

@@ -1,24 +1,49 @@
 #' Safety Profile App
 #'
-#' @param dfAE AE Data
-#' @param dfDemog demog data
-#' @param settings safetyGraphics settings
-#' @param ptid participant ID to select when app is initialized
+#' @param data `list` Named list of data domains
+#' @param settings `list` Named list of data mappings
+#' @param ptid `character` Initially selected participant ID
+#' @param standard `character` Name of data standard
+#' - "adam" (default)
+#' - "sdtm"
+#' - "custom"
+#' @param runNow `logical` Run app?
 #'
+#' @return `shiny.appobj` Shiny app
+#'
+#' @importFrom dplyr filter
 #' @import shiny
 #'
 #' @export
 
 profileApp <- function(
-  data = list(
-    aes = safetyData::adam_adae,
-    dm = safetyData::adam_adsl,
-    labs = safetyData::adam_adlbc %>% filter(PARAMCD %in% c("PHOS", "GLUC", "PROT"))
-  ),
-  settings = NULL,
-  ptid = NULL,
-  runNow = TRUE
+    data = list(
+      aes = safetyData::adam_adae,
+      dm = safetyData::adam_adsl,
+      labs = safetyData::adam_adlbc %>%
+          filter(PARAMCD %in% c("PHOS", "GLUC", "PROT"))
+    ),
+    settings = NULL,
+    ptid = NULL,
+    standard = 'adam',
+    runNow = TRUE
 ) {
+    stopifnot(
+        '[ standard ] must be a character-classed variable.' =
+            class(standard) == 'character',
+        '[ standard ] must be one of "sdtm", "adam", "custom".' =
+            tolower(standard) %in% c('sdtm', 'adam', 'custom')
+    )
+
+    standard <- tolower(standard)
+
+    # TODO: use default data given standard
+    if (is.null(data))
+        settings <- safetyProfile::example_data[[ standard ]]
+
+    # TODO: make sure settings work
+    if (is.null(settings))
+        settings <- safetyProfile::mapping[[ standard ]]
 
   ## create default settings when settings is not defined by default
   if (is.null(settings)) {
@@ -49,11 +74,12 @@ profileApp <- function(
     )
   }
 
-  ## create object containing data and setting to pass to server
+  ## Create reactive list of data and settings to pass to server
   params <- reactive({
     list(
       data = data,
-      settings = settings
+      settings = settings,
+      standard = standard
     )
   })
 
@@ -74,8 +100,8 @@ profileApp <- function(
     }
   )
 
-  # if(runNow)
-  runApp(app)
-  # else
-  # app
+  if (runNow)
+    runApp(app)
+
+  return(app)
 }

data-raw/mapping.R

@@ -0,0 +1,21 @@
+library(dplyr)
+library(purrr)
+
+mapping_sdtm <- read.csv("data-raw/mapping_sdtm.csv")
+mapping_adam <- read.csv("data-raw/mapping_adam.csv")
+
+usethis::use_data(mapping_sdtm, overwrite = TRUE)
+usethis::use_data(mapping_adam, overwrite = TRUE)
+
+mapping <- bind_rows(mapping_sdtm, mapping_adam) %>%
+    split(.$standard) %>%
+    map(function(standard) {
+        standard %>%
+            split(.$domain) %>%
+            map(function(domain) {
+                as.list(domain$value) %>%
+                    setNames(domain$key)
+            })
+    })
+
+usethis::use_data(mapping, overwrite = TRUE)

data-raw/mapping_adam.csv

@@ -0,0 +1,19 @@
+standard,domain,key,value
+adam,aes,id_col,USUBJID
+adam,aes,stdt_col,ASTDT
+adam,aes,endt_col,AENDT
+adam,aes,stdy_col,ASTDY
+adam,aes,endy_col,AENDY
+adam,aes,aeterm_col,AETERM
+adam,aes,decod_col,AEDECOD
+adam,aes,bodsys_col,AEBODSYS
+adam,aes,severity_col,AESEV
+adam,dm,id_col,USUBJID
+adam,dm,reference_date_col,TRTSDT
+adam,dm,treatment_col,TRT01P
+adam,labs,id_col,USUBJID
+adam,labs,visit_col,AVISIT
+adam,labs,visit_order_col,AVISITN
+adam,labs,dt_col,ADT
+adam,labs,dy_col,ADY
+adam,labs,result_col,AVAL

data-raw/mapping_sdtm.csv

@@ -0,0 +1,16 @@
+standard,domain,key,value
+sdtm,aes,id_col,USUBJID
+sdtm,aes,stdt_col,AESTDTC
+sdtm,aes,endt_col,AEENDTC
+sdtm,aes,aeterm_col,AETERM
+sdtm,aes,decod_col,AEDECOD
+sdtm,aes,bodsys_col,AEBODSYS
+sdtm,aes,severity_col,AESEV
+sdtm,dm,id_col,USUBJID
+sdtm,dm,reference_date_col,RFSTDTC
+sdtm,dm,treatment_col,ARM
+sdtm,labs,id_col,USUBJID
+sdtm,labs,visit_col,VISIT
+sdtm,labs,visit_order_col,VISITNUM
+sdtm,labs,dt_col,LBDTC
+sdtm,labs,result_col,LBSTRESN