Merge branch 'dev' into main

SafetyGraphics · Dec 13, 2022 · 9821173 · 9821173
2 parents 63705f3 + b7ddbaa
commit 9821173
Show file tree

Hide file tree

Showing 6 changed files with 33 additions and 8 deletions.
diff --git a/R/evaluateStandard.R b/R/evaluateStandard.R
@@ -46,7 +46,7 @@ evaluateStandard <- function(data, meta, domain, standard){
   compare_summary<-list()
   compare_summary[["standard"]]<-standard
 
-  domainMeta<-meta %>% filter(domain==!!domain)
+  domainMeta<-meta %>% filter(tolower(domain)==!!domain)
   standardMap <- domainMeta%>%pull(paste0("standard_",!!standard))
   names(standardMap)<-domainMeta%>%pull(.data$text_key)
   compare_summary[["mapping"]] <- domainMeta %>% 

diff --git a/R/mod_filterTab.R b/R/mod_filterTab.R
@@ -96,18 +96,27 @@ filterTab <- function(input, output, session, domainData, filterDomain, current_
             )
         }
 
+        n <- nrow(res_filter$filtered())
+        N <- nrow(raw())
+
         shinyjs::html(
             "header-count", 
-            nrow(res_filter$filtered()),
+            n,
             asis=TRUE    
         )
 
         shinyjs::html(
             "header-total", 
-            nrow(raw()),
+            N,
             asis=TRUE
         )
 
+        # Emphasize population header when subset is applied.
+        shinyjs::toggleClass(
+          selector = "#population-header",
+          class = "subset",
+          condition = n < N
+        )
     })
 
     observe({

diff --git a/R/mod_safetyGraphicsUI.R b/R/mod_safetyGraphicsUI.R
@@ -20,10 +20,16 @@ safetyGraphicsUI <- function(id, meta, domainData, mapping, standards){
 
     #script to append population badge nav bar
     participant_badge<-tags$script(
-        HTML(
-            "var header = $('.navbar> .container-fluid');
-            header.append('<div id=\"population-header\" class=\"badge\" title=\"Selected Participants\" ><span id=\"header-count\"></span>/<span id=\"header-total\"></span></div>');"
-        )
+        HTML(paste0(
+            "var header = $('.navbar > .container-fluid');",
+            "header.append(\"",
+            "<div id='population-header' class='badge' title='Selected Participants'>",
+            "<span id='header-count'></span>",
+            "/",
+            "<span id='header-total'></span> participants",
+            "</div>",
+            "\");"
+        ))
     )
     if(isNamespaceLoaded("shinybusy")){
         spinner<-shinybusy::add_busy_spinner(spin = "atom", position="bottom-right")

diff --git a/inst/report/safetyGraphicsReport.Rmd b/inst/report/safetyGraphicsReport.Rmd
@@ -50,7 +50,7 @@ chart<-params$chart
 header <- makeChartSummary(chart, class="chart-md")
 chart_params <- makeChartParams(data, chart, mapping)
 
-mapping_list<-generateMappingList(mapping %>% filter(domain %in% chart$domain))
+mapping_list<-generateMappingList(mapping %>% dplyr::filter(domain %in% chart$domain))
 if(length(mapping_list)==1){
   mapping_list <- mapping_list[[1]]
 }

diff --git a/inst/www/index.css b/inst/www/index.css
@@ -64,6 +64,10 @@ table.metatable.dataTable tr > td:last-of-type, table.metatable.trdataTable tr >
   margin-top:1em;
 }
 
+#population-header.subset {
+    background: blue;
+}
+
 #dataSettings-previews .nav-tabs{
   margin-bottom: 1em;
 }

diff --git a/tests/testthat/test_evaluateStandard.R b/tests/testthat/test_evaluateStandard.R
@@ -42,4 +42,10 @@ test_that("invalid options throw errors",{
   expect_error(evaluateStandard(data=safetyData::adam_adlbc,domain="labs", meta=safetyCharts::meta_labs, standard="adam", includeFieldsIsNotAnOptionNow="yesPlease"))
   expect_error(evaluateStandard(data=safetyData::adam_adlbc,domain="labs", meta=list(), standard="sdtm"))
   expect_error(evaluateStandard(data=safetyData::adam_adlbc,domain="labs", meta=safetyData::adam_adlbc, standard="sdtm"))
+})
+
+
+test_that("upper case domain names are supported",{
+  uppermeta <- safetyCharts::meta_labs %>% mutate(domain="LaBs")
+  expect_equal(evaluateStandard(data=safetyData::adam_adlbc,  domain="lAbS", meta= uppermeta, standard="adam")[["match"]],"full")
 })