Use Mapped Data (#335)

* Use mapped data more directly.

* Rename domain modules and variables to be more accurate.

* Redocument.

* Use gsm release. Shinyapps doesn't seem to like the dev version.

* Provide user-facing names for columns.

* Better plugin YAML.

* Bump R requirement to match gsm.

* Don't double-fix names.

* Abstract domain-name prettification.

* Use pretty name for subject, too.

* Get rid of unused param.

* Finish removing unused arg.

DESCRIPTION

@@ -15,7 +15,7 @@ URL: https://gilead-biostats.github.io/gsm.app/,
     https://github.com/Gilead-BioStats/gsm.app
 BugReports: https://github.com/Gilead-BioStats/gsm.app/issues
 Depends: 
-    R (>= 2.10)
+    R (>= 4.0)
 Imports:
     bslib,
     cli,

R/aaa-shared.R

@@ -5,19 +5,22 @@
 #' this package, because [shiny::testServer()] specifically expects an `id`
 #' argument in module server functions.
 #'
+#' @param chrAllowedFields `character` A vector of names of allowed fields in an
+#'   object.
+#' @param chrAllowedValues `character` A vector of allowed values for a vector.
+#' @param chrDomains `character` A vector of names of domain data.frames to show
+#'   in the app. Supported domains are shown in the default value.
 #' @param chrLinkIDs `character` Module ids for multiple modules.
 #' @param chrLabels `character` A vector of labels for display to the user.
 #' @param chrMessage `character` A vector of message elements to be formatted
 #'   via [cli::cli_bullets()].
 #' @param chrMetrics `character` A named vector of MetricIDs, where the names
 #'   are the full Metric.
-#' @param chrPluginFields `character` A vector of allowed fields in a Plugin
-#'   definition.
 #' @param chrPluginFiles `character` The files in a plugin directory.
 #' @param chrRequiredColumns `character` A vector of expected columns in a
 #'   data.frame.
-#' @param chrRequiredFields `character` A vector of expected fields in a Plugin
-#'   definition.
+#' @param chrRequiredFields `character` A vector of names of required fields in
+#'   an object.
 #' @param chrSites `character` A vector of sites available in the study.
 #' @param chrValues `character` A vector of values to associate with a vector of
 #'   labels.
@@ -54,6 +57,7 @@
 #' @param intAmber `integer` The number of sites with at least one amber flag.
 #' @param lMetric `list` Named list of data describing a single metric, as well
 #'   as things like which group is selected.
+#' @param lDomains `list` Named list of data domain data.frames.
 #' @param lParticipantMetadata `list` Named list of data describing a single
 #'   participant.
 #' @param lPluginDefinition `list` A named list with required elements
@@ -146,8 +150,11 @@
 #' @param strText `character` Text to display.
 #' @param strTitle `character` A title to display for the overall app.
 #' @param strValue `character` The value of a field.
+#' @param strWhat `character` A sentence-case description of the object being
+#'   inspected.
 #' @param tagListSidebar `taglist` An optional [htmltools::tagList()] of
 #'   additional elements to add to the top of the app sidebar.
+#' @param x An object to validate.
 #'
 #' @name shared-params
 #' @keywords internal

R/data_SampleData.R

@@ -117,31 +117,36 @@
 #' @export
 #'
 #' @examples
-#' head(sample_fnFetchData("AdverseEvents"))
-#' head(sample_fnFetchData("AdverseEvents", strSiteID = "0X103"))
-#' head(sample_fnFetchData("AdverseEvents", strSubjectID = "1350"))
+#' head(sample_fnFetchData("AE"))
+#' head(sample_fnFetchData("AE", strSiteID = "0X103"))
+#' head(sample_fnFetchData("AE", strSubjectID = "1350"))
 sample_fnFetchData <- function(
   strDomain = c(
-    "AdverseEvents",
-    "DataEntry",
-    "Enrollment",
-    "Lab",
-    "ProtocolDeviations",
-    "Queries",
-    "StudyCompletion",
-    "Subject",
-    "TreatmentCompletion"
+    "AE",
+    "ENROLL",
+    "LB",
+    "PD",
+    "SDRGCOMP",
+    "STUDCOMP",
+    "SUBJ",
+    "DATACHG",
+    "DATAENT",
+    "QUERY"
   ),
   strSiteID = NULL,
   strSubjectID = NULL
 ) {
+  strDomain <- toupper(strDomain)
   strDomain <- rlang::arg_match(strDomain)
-  df <- lDomainData[[strDomain]]
+  df <- sample_lMapped[[paste0("Mapped_", strDomain)]]
+  df$studyid <- NULL
+  df$invid <- NULL
+  df <- dplyr::rename(df, SubjectID = "subjid")
   if (length(strSiteID) && strSiteID != "None") {
     df <- dplyr::filter(df, .data$GroupID == strSiteID)
   }
   if (length(strSubjectID) && strSubjectID != "None") {
     df <- dplyr::filter(df, .data$SubjectID == strSubjectID)
   }
-  return(df)
+  return(dplyr::select(df, "SubjectID", "GroupID", dplyr::everything()))
 }

R/data_Validate.R

@@ -1,6 +1,37 @@
 # We might want to do this entirely via workflows, but I feel like it's good to
 # check in the app itself since users don't HAVE to use workflows.
 
+validate_chrDomains <- function(chrDomains, envCall = rlang::caller_env()) {
+  known_domains <- c(
+    "AE",
+    "ENROLL",
+    "LB",
+    "PD",
+    "SDRGCOMP",
+    "STUDCOMP",
+    "SUBJ",
+    "DATACHG",
+    "DATAENT",
+    "QUERY"
+  )
+  upper_chrDomains <- union(toupper(chrDomains), "SUBJ")
+  unknown_domains <- setdiff(upper_chrDomains, known_domains)
+  if (length(unknown_domains)) {
+    unknown_domains_display <- chrDomains[
+      upper_chrDomains %in% unknown_domains
+    ]
+    gsmapp_abort(
+      c(
+        "{.arg chrDomains} must only contain known domains.",
+        x = "Unknown domains: {.field {unknown_domains_display}}."
+      ),
+      strClass = "invalid_input",
+      envCall = envCall
+    )
+  }
+  return(upper_chrDomains)
+}
+
 #' Confirm that an object is the expected df
 #'
 #' @inheritParams shared-params

R/gsmApp_Server.R

@@ -10,6 +10,10 @@ gsmApp_Server <- function(
   dfMetrics,
   dfResults,
   fnFetchData,
+  chrDomains = c(
+    "AE", "ENROLL", "LB", "PD", "SDRGCOMP", "STUDCOMP",
+    "SUBJ", "DATACHG", "DATAENT", "QUERY"
+  ),
   lPlugins = NULL,
   fnServer = NULL
 ) {
@@ -224,6 +228,7 @@ gsmApp_Server <- function(
     mod_ParticipantDetails_Server(
       "participant_details",
       fnFetchData = fnFetchData,
+      chrDomains = chrDomains,
       rctv_strSubjectID = rctv_strSubjectID
     )
 

R/mod_ParticipantDetails_Server.R

@@ -10,6 +10,10 @@
 mod_ParticipantDetails_Server <- function(
   id,
   fnFetchData,
+  chrDomains = c(
+    "AE", "ENROLL", "LB", "PD", "SDRGCOMP", "STUDCOMP",
+    "SUBJ", "DATACHG", "DATAENT", "QUERY"
+  ),
   rctv_strSubjectID
 ) {
   moduleServer(id, function(input, output, session) {
@@ -22,44 +26,33 @@ mod_ParticipantDetails_Server <- function(
       ) {
         return(NULL)
       }
-      domains <- c(
-        "AdverseEvents",
-        "DataEntry",
-        "Enrollment",
-        "Lab",
-        "ProtocolDeviations",
-        "Queries",
-        "StudyCompletion",
-        "Subject",
-        "TreatmentCompletion"
-      )
       SubjectID <- rctv_strSubjectID()
       withProgress(
         message = "Loading participant data",
         {
-          l_dfs <- purrr::map(domains, function(this_domain) {
+          lDomains <- purrr::map(chrDomains, function(this_domain) {
             fnFetchData(this_domain, strSubjectID = SubjectID)
           })
-          names(l_dfs) <- domains
-          l_dfs
+          names(lDomains) <- chrDomains
+          applyPrettyDomainNames(lDomains)
         }
       )
     })
     rctv_lParticipantMetadata <- reactive({
       if (length(rctv_lParticipantData())) {
-        as.list(rctv_lParticipantData()$Subject)
+        as.list(rctv_lParticipantData()$Subject_Metadata)
       }
     })
-    rctv_lParticipantMetricData <- reactive({
+    rctv_lParticipantDomainData <- reactive({
       lParticipantData <- rctv_lParticipantData()
       if (length(lParticipantData)) {
-        lParticipantData$Subject <- NULL
+        lParticipantData$Subject_Metadata <- NULL
         return(lParticipantData)
       }
     })
-    rctv_strSelectedMetric <- mod_ParticipantMetricSummary_Server(
-      "metric_summary",
-      rctv_lParticipantMetricData
+    rctv_strSelectedDomain <- mod_ParticipantDomainSummary_Server(
+      "domain_summary",
+      rctv_lParticipantDomainData
     )
 
     # Output ----
@@ -69,8 +62,8 @@ mod_ParticipantDetails_Server <- function(
 
     rctv_intSelectedRows <- mod_ParticipantDomain_Server(
       "domain",
-      rctv_lParticipantMetricData,
-      rctv_strSelectedMetric,
+      rctv_lParticipantDomainData,
+      rctv_strSelectedDomain,
       rctv_strSubjectID
     )
     return(rctv_intSelectedRows)

R/mod_ParticipantDetails_UI.R

@@ -13,7 +13,7 @@ mod_ParticipantDetails_UI <- function(id) {
       type = 7,
       id = ns("metadata-spinner")
     ),
-    mod_ParticipantMetricSummary_UI(ns("metric_summary")),
+    mod_ParticipantDomainSummary_UI(ns("domain_summary")),
     mod_ParticipantDomain_UI(ns("domain"))
   )
 }

R/mod_ParticipantDomainSummary_Server.R

@@ -0,0 +1,34 @@
+#' Participant Domain Summary server
+#'
+#' @inheritParams shared-params
+#' @returns A string identifying the selected summary as a [shiny::reactive()].
+#' @keywords internal
+mod_ParticipantDomainSummary_Server <- function(
+  id,
+  rctv_lParticipantDomainData
+) {
+  moduleServer(id, function(input, output, session) {
+    rctv_chrParticipantDomainDataNames <- reactive({
+      names(rctv_lParticipantDomainData())
+    })
+
+    output$domain_list <- renderUI({
+      lParticipantDomainData <- rctv_lParticipantDomainData()
+      if (!length(lParticipantDomainData)) {
+        return(out_Placeholder("participant"))
+      }
+      domainNames <- rctv_chrParticipantDomainDataNames()
+      mod_ActionList_UI(
+        session$ns("domain_list_choices"),
+        domainNames,
+        domainNames,
+        purrr::map_int(lParticipantDomainData, NROW)
+      )
+    })
+    rctv_strSelectedDomain <- mod_ActionList_Server(
+      "domain_list_choices",
+      rctv_chrParticipantDomainDataNames
+    )
+    return(rctv_strSelectedDomain)
+  })
+}

R/mod_ParticipantMetricSummary_UI.R → R/mod_ParticipantDomainSummary_UI.R

@@ -1,15 +1,15 @@
-#' Participant metric summary card
+#' Participant domain summary card
 #'
 #' @inheritParams shared-params
 #' @returns A [bslib::card()] with either a placeholder, or a clickable list of
-#'   available metric data for this participant.
+#'   available domain data for this participant.
 #' @keywords internal
-mod_ParticipantMetricSummary_UI <- function(id) {
+mod_ParticipantDomainSummary_UI <- function(id) {
   ns <- NS(id)
   out_Card(
-    "Metric Summary",
+    "Domain Summary",
     shinycssloaders::withSpinner(
-      uiOutput(ns("metric_list")),
+      uiOutput(ns("domain_list")),
       type = 7,
       id = ns("spinner")
     ),

R/mod_ParticipantDomain_Server.R

@@ -36,7 +36,7 @@ mod_ParticipantDomain_Server <- function(
         gtObj <- gt::gt(df) %>%
           out_gtInteractive(selection_mode = "multiple") %>%
           gt::cols_label(
-            .list = gsm::MakeParamLabelsList(colnames(df))
+            .list = gsm::MakeParamLabelsList(colnames(df), chrFieldNames)
           ) %>%
           out_gtSmartFmtNumbers(intMaxDecimals = 10L)
 

R/mod_Plugins_Server.R

@@ -15,7 +15,7 @@ mod_Plugins_Server <- function(
     if (!is.null(lPlugins)) {
       for (i in seq_along(lPlugins)) {
         lPlugin <- lPlugins[[i]]
-        fnServer <- rlang::as_function(lPlugin$fnServer)
+        fnServer <- rlang::as_function(lPlugin$shiny$Server)
         args_available <- list(
           fnFetchData = fnFetchData,
           rctv_strMetricID = rctv_strMetricID,

R/mod_Plugins_UI.R

@@ -5,13 +5,13 @@
 mod_Plugins_UI <- function(id, lPlugins = NULL) {
   ns <- NS(id)
   if (!is.null(lPlugins)) {
-    plugin_items <- purrr::imap(lPlugins, function(lPlugin, id) {
-      fnUI <- rlang::as_function(lPlugin$fnUI)
+    plugin_items <- purrr::imap(lPlugins, function(lPlugin, i) {
+      fnUI <- rlang::as_function(lPlugin$shiny$UI)
       bslib::nav_panel(
-        title = lPlugin$strTitle,
+        title = lPlugin$meta$Name,
         rlang::inject({
           fnUI(
-            ns(id),
+            ns(i),
             !!!lPlugin$lConfig
           )
         })

R/out_ParticipantMetadata.R

@@ -17,7 +17,7 @@ out_ParticipantMetadata <- function(lParticipantMetadata) {
   out_Card(
     "Participant Metadata",
     out_MetadataList(
-      gsm::MakeParamLabelsList(names(lParticipantMetadata)),
+      gsm::MakeParamLabelsList(names(lParticipantMetadata), chrFieldNames),
       unname(lParticipantMetadata)
     ),
     id = "participant-metadata"