136 integrate measure values input in chart with the mappings tab defaults control in upper right

.Rbuildignore

@@ -5,8 +5,6 @@
 ^outline\.md$
 ^\.github$
 ^\.lintr$
-^_pkgdown\.yml$
-^pkgdown$
 ^nepExplorer\.Rcheck$
 ^nepExplorer.*\.tar\.gz$
 ^nepExplorer.*\.tgz$

.gitignore

@@ -108,7 +108,6 @@ dist
 # Ignoring R History and R Data Root:
 .Rhistory
 .RData
-docs
 nepExplorer.Rcheck/
 nepExplorer*.tar.gz
 nepExplorer*.tgz

DESCRIPTION

@@ -20,14 +20,16 @@ Imports:
     shiny,
     dplyr,
     ggplot2,
-    RColorBrewer, 
+    RColorBrewer,
     magrittr,
     plotly (>= 4.0.0),
     gt,
     htmlwidgets,
     scales,
     rlang,
-    shinyjs
+    shinyjs,
+    grDevices,
+    shinyWidgets
 Suggests:
     safetyGraphics, 
     safetyData

NAMESPACE

@@ -10,6 +10,7 @@ import(dplyr)
 import(ggplot2)
 import(gt)
 import(shiny)
+importFrom(grDevices,colorRampPalette)
 importFrom(gt,gt_output)
 importFrom(gt,render_gt)
 importFrom(htmlwidgets,onRender)
@@ -24,6 +25,7 @@ importFrom(plotly,renderPlotly)
 importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(scales,percent_format)
+importFrom(shinyWidgets,pickerInput)
 importFrom(shinyjs,hidden)
 importFrom(shinyjs,hide)
 importFrom(shinyjs,show)

R/nepexplorerMod.R

@@ -6,13 +6,14 @@
 #' @import shiny
 #' @importFrom shinyjs useShinyjs
 #' @importFrom shinyjs hidden
+#' @importFrom shinyWidgets pickerInput
 #' @export
 nepexplorer_ui <- function(id) {
   ns <- NS(id)
 
   #future home of settings panel
   sidebar <- sidebarPanel(
-    selectizeInput(
+    shinyWidgets::pickerInput(
       ns("measures"),
       "Select Patient Profile Fold Change Measures",
       multiple = TRUE,
@@ -106,6 +107,7 @@ nepexplorer_server <- function(input, output, session, params) {
   })
 
   # Populate sidebar control with measures and select all by default
+
   observeEvent(param(), {
     measure_col <- param()$settings$labs$measure_col
     measures <- unique(param()$data[[measure_col]])
@@ -116,7 +118,8 @@ nepexplorer_server <- function(input, output, session, params) {
                                       measure_values[grep("nepFC", names(measure_values))])
 
     # update selectize to reflect what's specific in metadata
-    updateSelectizeInput(session,
+
+    shinyWidgets::updatePickerInput(session,
                          "measures",
                          choices = measures,
                          selected = fold_change_measures
@@ -147,9 +150,15 @@ nepexplorer_server <- function(input, output, session, params) {
   })
   #Patient Profile (demo tables + lab line charts)
   observeEvent(selected_subject(), {
-    if (length(selected_subject()) == 1) { # avoid triggering patient profiles if there isn't a subject
+    if (length(selected_subject()) == 1) {
       patientProfileServer("patprofile", df = param()$data, selected_measures = input$measures,
                            settings = param()$settings, subj_id = selected_subject())
+
+      # Create a nested observeEvent for input$measure
+      observeEvent(input$measures, {
+        patientProfileServer("patprofile", df = param()$data, selected_measures = input$measures,
+                             settings = param()$settings, subj_id = selected_subject())
+      }, ignoreInit = TRUE)
     }
   }, ignoreInit = TRUE)
 

R/patient_profile_charts.R

@@ -174,6 +174,7 @@ drawRawChange <- function(adlb, settings, labs = c("Creatinine", "Cystatin C"),
 #' @import RColorBrewer
 #' @importFrom plotly ggplotly
 #' @importFrom plotly config
+#' @importFrom grDevices colorRampPalette
 #' @return ggplot object
 drawULNFoldChange <- function(adlb, settings,
                               labs = c("Bicarbonate", "Blood Urea Nitrogen",
@@ -189,6 +190,26 @@ drawULNFoldChange <- function(adlb, settings,
              .data[[settings$normal_col_high]]) %>%
     ungroup()
 
+
+  # Get the initial colors from Set1, excluding the 6th color
+  initial_colors <- brewer.pal(9, "Set1")[-6]
+
+  # Choose another palette for extending
+  extend_palette <- brewer.pal(11, "Spectral")
+
+  # Combine the palettes
+  combined_palette <- c(initial_colors, extend_palette)
+
+  # Create a color generator function
+  color_generator <- colorRampPalette(combined_palette)
+
+  # if more than 19 labs selected, bring in the generator
+  color_scale <- if (length(labs) <= 19) {
+    color_scale <- combined_palette
+  } else {
+    color_scale <- color_generator(100)
+  }
+
   p <- ggplot(adlb_FC, aes(x = .data[[settings$studyday_col]], y = .data$FOLD_CHG,
                            color = .data[[settings$measure_col]], group = .data[[settings$measure_col]],
                            text = paste0("Study Day: ", .data[[settings$studyday_col]], "\n",
@@ -201,7 +222,7 @@ drawULNFoldChange <- function(adlb, settings,
     theme(legend.title = element_blank()) + #remove legend title
     ylab("xULN (Fold Change)") +
     xlab("Study Day") +
-    scale_colour_manual(values = brewer.pal(9, "Set1")[-6], name = "Lab Test") + # drop yellow
+    scale_colour_manual(values = color_scale, name = "Lab Test") + # drop yellow
 
     ## Add ULN Annotation
     geom_hline(yintercept = 1, linetype = "dashed", color = "gray") +

R/patient_profile_mod.R

@@ -52,26 +52,26 @@ patientProfileServer <-  function(id, df, selected_measures, settings, subj_id)
                       demo_vars = c(dm_settings$id_col, dm_settings$age_col, dm_settings$sex_col,
                                     dm_settings$race_col, dm_settings$treatment_col))
       })
-
+      
       output$percent_change <- renderUI({
-
-       default_labs <- c(lab_settings$measure_values$CREAT, lab_settings$measure_values$CYSTC)
-       available_labs <- intersect(patient_df[[lab_settings$measure_col]] %>%  unique(), default_labs)
-
+        
+        default_labs <- c(lab_settings$measure_values$CREAT, lab_settings$measure_values$CYSTC)
+        available_labs <- intersect(patient_df[[lab_settings$measure_col]] %>%  unique(), default_labs)
+        
         if (length(available_labs) > 0) {
-            drawPercentChange(adlb = patient_df,
-                              labs = available_labs,
-                              settings = lab_settings)
+          drawPercentChange(adlb = patient_df,
+                            labs = available_labs,
+                            settings = lab_settings)
         } else {
           div()
         }
       })
-
+      
       output$raw_change <- renderUI({
-
+        
         default_labs <- c(lab_settings$measure_values$CREAT, lab_settings$measure_values$CYSTC)
         available_labs <- intersect(patient_df[[lab_settings$measure_col]] %>%  unique(), default_labs)
-
+        
         if (length(available_labs) > 0) {
           drawRawChange(adlb = patient_df, settings = lab_settings,
                         labs = available_labs,
@@ -80,12 +80,12 @@ patientProfileServer <-  function(id, df, selected_measures, settings, subj_id)
           div()
         }
       })
-
+      
       output$raw_change_egfr <- renderUI({
-
+        
         default_labs <- c(lab_settings$measure_values$eGFR, lab_settings$measure_values$eGFRcys)
         available_labs <- intersect(patient_df[[lab_settings$measure_col]] %>%  unique(), default_labs)
-
+        
         if (length(available_labs) > 0) {
           drawRawChange(adlb = patient_df, settings = lab_settings,
                         labs = available_labs,
@@ -94,7 +94,7 @@ patientProfileServer <-  function(id, df, selected_measures, settings, subj_id)
           div()
         }
       })
-
+      
       output$ULN_FC <- renderUI({
         available_labs <-
           intersect(patient_df[[lab_settings$measure_col]] %>%  unique(), selected_measures)
@@ -107,24 +107,24 @@ patientProfileServer <-  function(id, df, selected_measures, settings, subj_id)
           div()
         }
       })
-
+      
       output$blood_pressure <- renderUI({
-
+        
         default_vitals <- c(vitals_settings$measure_values$DIABP,
-                          vitals_settings$measure_values$SYSBP)
-
+                            vitals_settings$measure_values$SYSBP)
+        
         available_vitals <- intersect(patient_df[[vitals_settings$measure_col]] %>%  unique(), default_vitals)
-
+        
         if (length(available_vitals) > 0) {
           drawBloodPressure(adlb = patient_df, settings = vitals_settings,
-                        labs = available_vitals)
+                            labs = available_vitals)
         } else {
           div()
         }
       })
-
+      
       output$normalized_albumin <- renderUI({
-
+        
         if (length(lab_settings$measure_values[["ALB/CREAT"]] %in%
                    patient_df[[lab_settings$measure_col]] %>%  unique()) > 0) {
           drawNormalizedAlbumin(adlb = patient_df, settings = lab_settings)
@@ -142,7 +142,7 @@ patientProfileServer <-  function(id, df, selected_measures, settings, subj_id)
           div()
         }
       })
-
+      
     }
   )
 }