Add ability to select biospecimen template by type (#498)

* Improve check_all Includes: - Gathering the template ids into the data frame before sending to check_all. This removes some of the dependency on check_all for handling config logic. - New functions for gathering the template ids. - Improved tracking of metadataType indices in check_all. - New function for tracking metadataType indices. - NEWS update - Incremented version - Testing * Style update * Update pkgdown.yml * Auto stash before merge of "add-in-vivo-vitro" and "prep-check-all" * Remove browser() from debugging 🤦 * Update gather_template_ids to return NA and check_cols* to handle NAs * Fix check_cols test * Add biospecimen_type features Includes: - New config options - Ability to select biospecimen template by type (or not) - Update to gather_template_ids to accept biospecimen_type - Update to get_template_synIDs to only gather synIDs and unlist the biospecimen templates if nested - Updated docs - Updated tests * Update default config to show example naming for in vitro biospecimens * Update UI biospecimen type name * Update the update portion of UI biospecimen type name * Annotate with biospecimenType so dccmonitor knows which choice was used * Add missing line ending at end of file Co-authored-by: Kelsey Montgomery <[email protected]> * Organize and improve template section of customization docs * Grab templates and pass them on to helpers to get the right template * Fix `get_template_synIDs` and update config to have better/more tests * Rephrase test text * Update lintr to not check curly braces; lintr rules conflict with styler Co-authored-by: Kelsey Montgomery <[email protected]>
Sage-Bionetworks · Jul 15, 2021 · b0d596f · b0d596f
1 parent 361b711
commit b0d596f
Show file tree

Hide file tree

Showing 12 changed files with 294 additions and 45 deletions.
diff --git a/.lintr b/.lintr
@@ -1,2 +1,2 @@
-linters: with_defaults(object_length_linter = object_length_linter(40), object_usage_linter = NULL, object_name_linter = NULL, commented_code_linter = NULL, cyclocomp_linter = NULL)
+linters: with_defaults(object_length_linter = object_length_linter(40), object_usage_linter = NULL, object_name_linter = NULL, commented_code_linter = NULL, cyclocomp_linter = NULL, open_curly_linter = NULL, closed_curly_linter = NULL)
 exclusions: list("renv/activate.R")
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: dccvalidator
 Title: Metadata Validation for Data Coordinating Centers
-Version: 0.3.0.9022
+Version: 0.3.0.9023
 Authors@R:
     c(person(given = "Kara",
              family = "Woo",

diff --git a/NEWS.md b/NEWS.md
@@ -25,6 +25,7 @@
 - Add ability for `check_col_names()` (via `get_template()`) to pull full set of metadata keys from a simple (i.e. has "properties") registered Synapse JSON schema; includes update to `get_template()` parameters, allowing for backwards compatibility with `synID` and additional functionality with `id`.
 - `check_all()` now expects the template ids to be included in `data`; if not included, will skip the check for missing column names
 - Added `get_metadataType_indices()` and `gather_template_ids()`
+- Add ability to specify biospecimen templates based on type
 
 # dccvalidator v0.3.0
 

diff --git a/R/df-helpers.R b/R/df-helpers.R
@@ -38,41 +38,91 @@ get_metadataType_indices <- function(data, meta_types) {
 #' @param species The species needed to specify the correct biospecimen
 #' or individual templates (default `NA`).
 #' @param assay The assay needed to specify the correct assay template.
+#' @param biospecimen_type The type of biospecimen template needed
+#' (default `NA`).
 #' @returns the template id from the config (`NA` if not found).
-gather_template_ids <- function(type, species = NA, assay = NA) {
+gather_template_ids <- function(type, species = NA, assay = NA,
+                                biospecimen_type = NA) {
+  templates <- get_golem_config("templates")
   switch(type,
-    manifest = get_golem_config("templates")$manifest_template,
-    individual = gather_template_id_individual(species = species),
-    biospecimen = gather_template_id_biospecimen(species = species),
-    assay = gather_template_id_assay(assay = assay)
+    manifest = templates[["manifest_template"]],
+    individual = gather_template_id_individual(
+      templates = templates,
+      species = species
+    ),
+    biospecimen = gather_template_id_biospecimen(
+      templates = templates,
+      species = species,
+      biospecimen_type = biospecimen_type
+    ),
+    assay = gather_template_id_assay(
+      templates = templates,
+      assay = assay
+    )
   )
 }
 
-## gather_template_ids helper
-gather_template_id_individual <- function(species) {
-  templates <- get_golem_config("templates")$individual_templates
-  if (species %in% names(templates)) {
-    return(templates[[species]])
+#' @title Grab specific biospecimen template ID
+#'
+#' @description Helper for [gather_template_ids]. Grabs the ID for a specific
+#' biospecimen template based on the species and, if relevant, the biospecimen
+#' type.
+#'
+#' @noRd
+#' @param templates Named list of templates, `biospecimen_templates`,
+#' `individual_templates`, `assay_templates`.
+#' @inheritParams gather_template_ids
+#' @return Biospecimen template ID from `templates` that matches the `species`
+#' and `biospecimen_type`, if relevant, or `NA` if the biospecimen templates
+#' had no match to the species and type.
+gather_template_id_biospecimen <- function(templates, species,
+                                           biospecimen_type) {
+  if (species %in% names(templates[["biospecimen_templates"]])) {
+    if (is.na(biospecimen_type) | biospecimen_type %in% "") {
+      # Grab based on species
+      return(templates[["biospecimen_templates"]][[species]])
+    } else {
+      # Grab based on both species and type
+      return(
+        templates[["biospecimen_templates"]][[species]][[biospecimen_type]]
+      )
+    }
   } else {
     return(NA)
   }
 }
 
-## gather_template_ids helper
-gather_template_id_biospecimen <- function(species) {
-  templates <- get_golem_config("templates")$biospecimen_templates
-  if (species %in% names(templates)) {
-    return(templates[[species]])
+#' @title Grab specific individual template ID
+#'
+#' @description Helper for [gather_template_ids]. Grabs the ID for a specific
+#' individual based on the species.
+#'
+#' @noRd
+#' @inheritParams gather_template_id_biospecimen
+#' @inheritParams gather_template_ids
+#' @return Individual template ID from `templates` that matches the `species`,
+#' or `NA` if there was no assay type that matched.
+gather_template_id_individual <- function(templates, species) {
+  if (species %in% names(templates[["individual_templates"]])) {
+    return(templates[["individual_templates"]][[species]])
   } else {
     return(NA)
   }
 }
 
-## gather_template_ids helper
-gather_template_id_assay <- function(assay) {
-  templates <- get_golem_config("templates")$assay_templates
-  if (assay %in% names(templates)) {
-    return(templates[[assay]])
+#' @title Grab specific assay template ID
+#'
+#' @description Helper for [gather_template_ids]. Grabs the ID for a specific
+#' assay template based on the assay type.
+#'
+#' @noRd
+#' @inheritParams gather_template_id_biospecimen
+#' @inheritParams gather_template_ids
+#' @return Assay template ID from template that matches the `assay`, or `NA`
+#' if there was no assay type that matched.
+gather_template_id_assay <- function(templates, assay) {
+  if (assay %in% names(templates[["assay_templates"]])) {
+    return(templates[["assay_templates"]][[assay]])
   } else {
     return(NA)
   }

diff --git a/R/metadata-template-dictionary.R b/R/metadata-template-dictionary.R
@@ -307,8 +307,17 @@ generate_key_description <- function(annots) {
 #' }
 get_template_synIDs <- function(templates = get_golem_config("templates")) {
   # Get all template synIDs as vector
+  temps <- templates %>%
+    get_template_synIDs_nested() %>%
+    unname() %>%
+    unlist() %>%
+    unique()
+  temps[grepl("^syn[[:digit:]]", temps)]
+}
+
+## get_template_synIDs helper
+get_template_synIDs_nested <- function(templates) {
   templates %>%
-    purrr::flatten() %>%
     unname() %>%
     unlist()
 }
diff --git a/R/mod-main.R b/R/mod-main.R
@@ -49,7 +49,10 @@ mod_main_ui <- function(id) {
           validator_ui(
             id = ns("validator"),
             species_list = get_golem_config("species_list"),
-            assay_templates = get_golem_config("templates")$assay_templates
+            assay_templates = get_golem_config("templates")$assay_templates,
+            include_biospecimen_type = get_golem_config(
+              "include_biospecimen_type"
+            )
           ),
           # Documentation tab UI
           if (get_golem_config("docs_tab")$include_tab) {
@@ -129,6 +132,9 @@ mod_main_server <- function(id, syn) {
           annots_link = get_golem_config("annotations_link"),
           templates_link = get_golem_config("templates_link"),
           contact_email = get_golem_config("contact_email"),
+          include_biospecimen_type = get_golem_config(
+            "include_biospecimen_type"
+          ),
           parent = created_folder,
           synapseclient = synapse,
           syn = syn

diff --git a/R/mod-validator.R b/R/mod-validator.R
@@ -4,12 +4,18 @@
 #' manifest, and see a report of validation results.
 #'
 #' @noRd
+#' @import shiny
 #' @param id the module id
 #' @param species_list Vector of species user can choose from for their study
 #' @param assay_templates Vector of assay template names
+#' @param include_biospecimen_type TRUE to include radiobutton options for
+#' specimen type of "in vitro" or "other (in vivo, postmortem)"; else FALSE
+#' (default) to leave out of application.
 #' @return html ui for the module
-validator_ui <- function(id, species_list, assay_templates) {
+validator_ui <- function(id, species_list, assay_templates,
+                         include_biospecimen_type = FALSE) {
   ns <- NS(id)
+
   # Validator tab UI
   tabItem(
     tabName = id,
@@ -23,6 +29,8 @@ validator_ui <- function(id, species_list, assay_templates) {
 
         # UI for getting the study name
         get_study_ui(ns("study")),
+
+        # Species
         div(
           class = "result",
           div(
@@ -43,6 +51,38 @@ validator_ui <- function(id, species_list, assay_templates) {
             trigger = "hover"
           )
         ),
+
+        # Biospecimen type
+        if (include_biospecimen_type) {
+          conditionalPanel(
+            condition = "input.species != 'drosophila'",
+            div(
+              class = "result",
+              div(
+                class = "wide",
+                shinyjs::hidden(
+                  shinyjs::disabled(
+                    radioButtons(
+                      ns("biospecimen_type"),
+                      "Biospecimen Type",
+                      choices = NA
+                    )
+                  )
+                )
+              ),
+              popify(
+                tags$a(icon(name = "question-circle"), href = "#"),
+                "Information",
+                "Select the specimen type: in vitro, in vivo or postmortem.",
+                placement = "left",
+                trigger = "hover"
+              )
+            ),
+            ns = ns
+          )
+        },
+
+        # Assay name
         div(
           class = "result",
           div(
@@ -91,7 +131,8 @@ validator_ui <- function(id, species_list, assay_templates) {
               placement = "left",
               trigger = "hover"
             )
-          )
+          ),
+          ns = ns
         ),
         div(
           class = "result",
@@ -233,7 +274,8 @@ validator_ui <- function(id, species_list, assay_templates) {
 validator_server <- function(input, output, session, study_names, species_list,
                              assay_templates, annotations_table, annots_link,
                              templates_link, contact_email, parent,
-                             synapseclient, syn) {
+                             synapseclient, syn,
+                             include_biospecimen_type = FALSE) {
 
   ## Initial titles for report boxes
   callModule(results_boxes_server, "validation_results", results = NULL)
@@ -254,6 +296,9 @@ validator_server <- function(input, output, session, study_names, species_list,
     "validate_btn",
     "reset_btn_validate"
   )
+  if (include_biospecimen_type) {
+    inputs_to_enable <- c(inputs_to_enable, "biospecimen_type")
+  }
   purrr::walk(inputs_to_enable, function(x) shinyjs::enable(x))
 
   ## Reset fileInputs, study name, and other inputs
@@ -276,6 +321,14 @@ validator_server <- function(input, output, session, study_names, species_list,
       "Species",
       species_list
     )
+    updateRadioButtons(
+      session,
+      "biospecimen_type",
+      "Specimen Type",
+      choiceNames = c("In vitro", "Other (in vivo, postmortem)"),
+      choiceValues = c("in_vitro", "other"),
+      selected = "other"
+    )
     updateSelectInput(
       session,
       "assay_name",
@@ -285,10 +338,45 @@ validator_server <- function(input, output, session, study_names, species_list,
   })
 
   ## If drosophila species checked, reset fileInput
+  ## Change Specimen Type radioButtons depending on species
   observeEvent(input$species, {
     if (input$species == "drosophila") {
       reset_inputs("indiv_meta")
       files$indiv <- NULL
+      # biospecimen type will hide automatically, but need to update the values
+      updateRadioButtons(
+        session,
+        "biospecimen_type",
+        "Specimen Type",
+        choices = "",
+        selected = ""
+      )
+    } else {
+      specimen_types <- unique(
+        names(
+          get_golem_config("templates")$biospecimen[[input$species]]
+        )
+      )
+      if (!is.null(specimen_types)) {
+        # Grab specimen types from config and default choose first in list
+        updateRadioButtons(
+          session,
+          "biospecimen_type",
+          "Biospecimen Type",
+          choices = specimen_types,
+          selected = specimen_types[1]
+        )
+        shinyjs::show("biospecimen_type")
+      } else {
+        shinyjs::hide("biospecimen_type")
+        updateRadioButtons(
+          session,
+          "biospecimen_type",
+          "Specimen Type",
+          choices = "",
+          selected = ""
+        )
+      }
     }
   })
 
@@ -348,6 +436,12 @@ validator_server <- function(input, output, session, study_names, species_list,
   species_name <- reactive({
     input$species
   })
+  biospecimen_type <- reactive({NA})
+  if (get_golem_config("include_biospecimen_type")) {
+    biospecimen_type <- reactive({
+      input$biospecimen_type
+    })
+  }
   assay_name <- reactive({
     input$assay_name
   })
@@ -415,6 +509,7 @@ validator_server <- function(input, output, session, study_names, species_list,
             study = study_name(),
             metadataType = "biospecimen",
             species = species_name(),
+            biospecimenType = biospecimen_type(),
             isDocumentation = FALSE
           ),
           synapseclient = synapse,
@@ -477,7 +572,11 @@ validator_server <- function(input, output, session, study_names, species_list,
         "template" = c(
           gather_template_ids(type = "manifest"),
           gather_template_ids(type = "individual", species = species_name()),
-          gather_template_ids(type = "biospecimen", species = species_name()),
+          gather_template_ids(
+            type = "biospecimen",
+            species = species_name(),
+            biospecimen_type = biospecimen_type()
+          ),
           gather_template_ids(type = "assay", assay = assay_name())
         )
       )