Merge pull request #784 from pharmaR/ac-774

Add `Decision` col to Pkg Dependency table
pharmaR · Jun 4, 2024 · fdb0850 · fdb0850
2 parents 2daf3ed + 9b62c85
commit fdb0850
Show file tree

Hide file tree

Showing 13 changed files with 98 additions and 64 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: riskassessment
 Title: A web app designed to interface with the `riskmetric` package
-Version: 3.0.0.9022
+Version: 3.0.0.9023
 Authors@R: c( 
     person("Aaron", "Clark", role = c("aut", "cre"), email = "[email protected]"),
     person("Robert", "Krajcik", role = "aut", email = "[email protected]"),

diff --git a/NEWS.md b/NEWS.md
@@ -26,6 +26,8 @@
 * Updated 'About' page to highlight individual contributors on the project, leveraging `bslib` cards.
 * Allow users to specify decisions in the CSV upload file (#663)
 * Fix bug causing application to crash when trying to delete zero packages (#781)
+* Add `Decision` column to Package Dependencies tab so that users (#774)
+
 
 
 # riskassessment 3.0.0

diff --git a/R/app_server.R b/R/app_server.R
@@ -248,7 +248,10 @@ app_server <- function(input, output, session) {
   })
 
   session$userData$loaded2_db <- eventReactive({uploaded_pkgs(); changes()}, {
-    dbSelect("SELECT name, version, score FROM package")
+    dbSelect("SELECT name, version, score, decision_id, decision
+             FROM package as pi
+             LEFT JOIN decision_categories as dc
+              ON pi.decision_id = dc.id")
   })
 
   create_src_dir <- eventReactive(input$tabs, input$tabs == "Source Explorer")

diff --git a/R/mod_downloadHandler.R b/R/mod_downloadHandler.R
@@ -283,11 +283,12 @@ mod_downloadHandler_server <- function(id, pkgs, user, metric_weights){
 
               dep_table <- 
                 if (nrow(dep_metrics) == 0) {
-                  dplyr::tibble(package = character(), type = character(), version = character(), score = character())
+                  dplyr::tibble(package = character(), type = character(), version = character(), score = character(), decision = character())
                 } else {
                 purrr::map_df(dep_metrics$name, ~get_versnScore(.x, session$userData$loaded2_db(), session$userData$repo_pkgs())) %>%
                   right_join(dep_metrics, by = "name") %>%
-                  select(package, type, version, score) %>%
+                  select(package, type, version, score, decision) %>%
+                  mutate(decision = if_else(is.na(decision) | toupper(decision) == "NA", "", decision)) %>%
                   arrange(package, type) %>%
                   distinct()
                 }

diff --git a/R/mod_packageDependencies.R b/R/mod_packageDependencies.R
@@ -141,7 +141,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
 
       purrr::map_df(pkginfo$name, ~get_versnScore(.x, session$userData$loaded2_db(), session$userData$repo_pkgs())) %>% 
         right_join(pkginfo, by = "name") %>% 
-        select(package, type, name, version, score) %>%
+        select(package, type, name, version, score, decision) %>%
         arrange(name, type) %>% 
         distinct()
 
@@ -234,7 +234,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
             column(
               width = 8,
               DT::renderDataTable(server = FALSE, {
-                datatable_custom(data_table())                      
+                datatable_custom(data_table(), custom_dom = "lftpi")                      
               })
             )
           ), 
@@ -248,8 +248,8 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
               br(), 
               DT::renderDataTable({
                 datatable_custom(
-                  table_revdeps_local(), 
-                  colnames = c("Package", "Version", "Score", "Review Package"),
+                  table_revdeps_local() |> select(-decision_id), 
+                  colnames = c("Package", "Version", "Score", "Decision", "Review Package"),
                   hide_names = NULL
                 )
               }),

diff --git a/R/mod_reportPreview.R b/R/mod_reportPreview.R
@@ -192,12 +192,10 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics,
                                DT::renderDataTable({
                                  req(selected_pkg$name())
 
-                                 dep_table()
+                                 datatable_custom(dep_table(), pLength = list(-1), PlChange = FALSE,
+                                                  colnames = c("Package", "Type", "Version", "Score", "Decision"))
 
-                               }, options = list(dom = "t", searching = FALSE, pageLength = -1, lengthChange = FALSE,
-                                                 info = FALSE,
-                                                 columnDefs = list(list(className = 'dt-center', targets = 2))
-                               )
+                               }
                                )
                         ))
                     ),
@@ -471,7 +469,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics,
 
       purrr::map_df(dep_metrics()$name, ~get_versnScore(.x, session$userData$loaded2_db(), session$userData$repo_pkgs())) %>%
       right_join(dep_metrics(), by = "name") %>%
-      select(package, type, version, score) %>%
+      select(package, type, version, score, decision) %>%
       arrange(package, type) %>%
       distinct()
     })

diff --git a/R/utils.R b/R/utils.R
@@ -562,10 +562,15 @@ shinyInput <- function(FUN, len, id, ...) {
 #' 
 datatable_custom <- function(
     data, 
-    colnames = c("Package", "Type", "Name", "Version", "Score", "Review Package"), 
+    colnames = c("Package", "Type", "Name", "Version", "Score", "Decision", "Review Package"), 
     hide_names = "name",
+    pLength = list(c(15, -1), c("15", "All")), plChange = TRUE,
+    custom_dom = "t",
+    decision_lst = if (!is.null(golem::get_golem_options("decision_categories"))) golem::get_golem_options("decision_categories") else c("Low Risk", "Medium Risk", "High Risk"),
+    color_lst = get_colors(golem::get_golem_options("assessment_db_name")),
     ...
 ){
+
   colnames <- colnames %||% character(0)
   hide_names <- hide_names %||% character(0)
   data <- data %||% as.data.frame(matrix(nrow = 0, ncol = pmax(length(colnames), 1) )) 
@@ -578,6 +583,8 @@ datatable_custom <- function(
             Defaulting to original data frame names.")
     colnames <- names(data)
   } 
+  if("decision" %in% colnames(data)) data <- data %>% mutate(decision = if_else(is.na(decision) | toupper(decision) == "NA", "", decision))
+
   # Hiding name from DT table. 
   # The - 1 is because js uses 0 index instead of 1 like R
   target <- which(names(data) %in% hide_names) - 1
@@ -588,45 +595,42 @@ datatable_custom <- function(
       list(
         score = formattable::formatter(
           "span",
-          style = x ~ formattable::style(
-            display = "block",
-            "border-radius" = "4px",
-            "padding-right" = "4px",
-            "color" = "#000000",
-            "order" = x,
-            "background-color" = formattable::csscolor(
-              setColorPalette(100)[round(as.numeric(x)*100)]
-            )
-          )
-        ),
-        decision = formattable::formatter(
-          "span",
-          style = x ~ formattable::style(
-            display = "block",
-            "border-radius" = "4px",
-            "padding-right" = "4px",
-            "font-weight" = "bold",
-            "color" = ifelse(x %in% decision_lst, "white", "inherit"),
-            "background-color" =
-              ifelse(x %in% decision_lst,
-                     color_lst[x],
-                     "transparent"
-              )
-          )
-        )
+          style = x ~ formattable::style(display = "block",
+                                         "border-radius" = "4px",
+                                         "padding-right" = "4px",
+                                         "color" = "black",
+                                         "order" = x,
+                                         "background-color" = formattable::csscolor(
+                                           setColorPalette(100)[round(as.numeric(x)*100)]))),
+        decision = 
+              formattable::formatter(
+              "span",
+              style = x ~ formattable::style(display = "block",
+                                         "border-radius" = "4px",
+                                         "padding-right" = "4px",
+                                         "color" = ifelse(x %in% decision_lst, #'black', 
+                                                          get_text_color(color_lst[x]),
+                                                          "inherit"),
+                                         "background-color" = 
+                                           ifelse(x %in% decision_lst,
+                                                  glue::glue("var(--{risk_lbl(x, type = 'attribute')}-color)"),
+                                                  "transparent")))
+
       )
     ),
     selection = "none",
     colnames = colnames,
     rownames = FALSE,
     options = list(
-      lengthMenu = list(c(15, -1), c("15", "All")),
+      dom = custom_dom,
+      lengthMenu = pLength,
+      lengthChange = plChange,
       columnDefs = list(list(visible = FALSE, targets = target)),
       searchable = FALSE
     ),
     style = "default"
   ) %>%
-    DT::formatStyle(names(data), textAlign = "center")
+    DT::formatStyle(names(data), textAlign = "center") 
 }
 
 #' Add buttons to data frame

diff --git a/R/utils_get_db.R b/R/utils_get_db.R
@@ -382,16 +382,22 @@ get_versnScore <- function(pkg_name, verify_data, cran_pkgs) {
     return(list(name = character(), version = character(), score = character()))
 
   if (pkg_name %in% verify_data$name) { #loaded2_db()$name
-    tmp_df <- verify_data %>% filter(name == pkg_name) %>% select(score, version)
+    tmp_df <- verify_data %>% filter(name == pkg_name) %>% select(score, version, decision_id, decision)
     pkg_score <- tmp_df %>% pull(score) %>% as.character
     pkg_versn <- tmp_df %>% pull(version) %>% as.character
+    pkg_decision_id <- tmp_df %>% pull(decision_id) %>% as.character
+    pkg_decision <- tmp_df %>% pull(decision) %>% as.character
   } else {
     pkg_score <- ""
     pkg_versn <- if_else(pkg_name %in% c(rownames(installed.packages(priority="base"))), "",
                  subset(cran_pkgs, Package == pkg_name, c("Version")) %>% as.character())
+    pkg_decision_id <- ""
+    pkg_decision <- ""
   } 
 
-  return(list(name = pkg_name, version = pkg_versn, score = pkg_score))   
+  return(list(name = pkg_name, version = pkg_versn, score = pkg_score,
+              decision_id = pkg_decision_id, decision = pkg_decision
+              ))   
 }
 
 

diff --git a/inst/report_downloads/reportHtml.Rmd b/inst/report_downloads/reportHtml.Rmd
@@ -372,10 +372,13 @@ tagList(
         tagList(
           createGrid(metrics = params$dep_cards),
           br(), 
-          DT::datatable(params$dep_table,
-                        options = list(dom = "t", searching = FALSE, pageLength = -1,
-                                       lengthChange = FALSE, info = FALSE, 
-                                       columnDefs = list(list(className = 'dt-center', targets = 2))))
+          # datatable_custom(
+            DT::datatable(
+              params$dep_table #, pLength = list(-1), plChange = FALSE
+                        ,options = list(dom = "t", searching = FALSE, pageLength = -1,
+                                       lengthChange = FALSE, info = FALSE,
+                                       columnDefs = list(list(className = 'dt-center', targets = 2)))
+              )#)
         ),
       if('Dependency Comments' %in% params$report_includes)
         tagList(

diff --git a/manifest.json b/manifest.json
@@ -6220,7 +6220,7 @@
       "checksum": "99c5575cb81828e20a7fe1d205551316"
     },
     "DESCRIPTION": {
-      "checksum": "980fd095da6772e5345174c2270abc95"
+      "checksum": "c4ce70d1592eea23d969d53b917c4a5b"
     },
     "inst/app/www/css/community_metrics.css": {
       "checksum": "f08eb25c2ee48ac22ed63b0d18994a04"
@@ -6403,7 +6403,7 @@
       "checksum": "788fc881cc4446504a88888fa55e2cfa"
     },
     "inst/report_downloads/reportHtml.Rmd": {
-      "checksum": "d4b530e1159f6bba99ba098e843e46ee"
+      "checksum": "dc9c51d3badaf67a4f13fe5a5bbb57f4"
     },
     "inst/report_downloads/reportPdf.Rmd": {
       "checksum": "86b922fc17ccc912a82a6cb881281b0a"
@@ -6463,13 +6463,13 @@
       "checksum": "97d1232340e04c53088bc8f814133dcd"
     },
     "NEWS.md": {
-      "checksum": "620d2738d3b34a24f584dd342c32d25e"
+      "checksum": "f9bc97131b3753ea173bff4248b97e1f"
     },
     "R/app_config.R": {
       "checksum": "c2b61f270b86b6833f0ee39c44a1a440"
     },
     "R/app_server.R": {
-      "checksum": "47f0234369555f91c1d7d44d962d8daa"
+      "checksum": "e2a53d90bd4289198e29bec4ff19eba7"
     },
     "R/app_ui.R": {
       "checksum": "50d68f46171151cd36457a7154e5a7a3"
@@ -6508,7 +6508,7 @@
       "checksum": "e22e1f4c044bc9f11c46a5fcdba33063"
     },
     "R/mod_downloadHandler.R": {
-      "checksum": "2e3e958ef24dbb49984d83daa998544d"
+      "checksum": "923e810fb1c8c7afe2d111cd42703579"
     },
     "R/mod_introJS_utils_text.R": {
       "checksum": "d98620a891752cf54b0d0282ddaa4af6"
@@ -6532,7 +6532,7 @@
       "checksum": "a894eb9114e258feb99b76cdca557cd2"
     },
     "R/mod_packageDependencies.R": {
-      "checksum": "06dcc773b509d093da214942b9f6513e"
+      "checksum": "05b1fbde1ace35aa787552552744b057"
     },
     "R/mod_pkg_explorer_utils.R": {
       "checksum": "b7792e08cc4a67296c9df0f452c0a72a"
@@ -6541,7 +6541,7 @@
       "checksum": "dbbfdfde47d106e0deaf20822c69bf94"
     },
     "R/mod_reportPreview.R": {
-      "checksum": "40bb09d54e2fc715dfaf23ae6bb805f0"
+      "checksum": "56d62f285d64f5846cf266c79bac5b6a"
     },
     "R/mod_reweightView.R": {
       "checksum": "d3988b7b6168f0560dc9525f1c6138ed"
@@ -6571,7 +6571,7 @@
       "checksum": "74cf2ee5e7283483a88f08d60e3728b0"
     },
     "R/utils_get_db.R": {
-      "checksum": "680af236ded2012453e02affafa4c9d4"
+      "checksum": "270a240f5882ec130989f252fe18011f"
     },
     "R/utils_insert_db.R": {
       "checksum": "ee28bd9e4f053e7ee936d7d8ef5fe887"
@@ -6580,7 +6580,7 @@
       "checksum": "b689ee96f0761480ac65ca22cbbb4980"
     },
     "R/utils.R": {
-      "checksum": "a5fc3e385ec1b2bb3368a7b4c2085c6e"
+      "checksum": "dd8cda3fb9deb392b6f82798f26bd668"
     },
     "README.md": {
       "checksum": "d7e84fce2c891619912b6cc552eecc94"

diff --git a/tests/testthat.R b/tests/testthat.R
@@ -19,3 +19,4 @@ while (!chromote::has_default_chromote_object() && Sys.time() - tmpt < 1) {
 }
 
 test_check("riskassessment")
+# test_file("tests/testthat/test-downloadHandler.R")
diff --git a/tests/testthat/test-apps/downloadHandler-app/app.R b/tests/testthat/test-apps/downloadHandler-app/app.R
@@ -40,7 +40,13 @@ server <- function(input, output, session) {
   session$userData$suggests <- reactiveVal(FALSE)
 
   session$userData$loaded2_db <- reactive({
-    riskassessment:::dbSelect("select name, version, score from package")
+    riskassessment:::dbSelect("
+            SELECT name, version, score, decision_id, decision
+             FROM package as pi
+             LEFT JOIN decision_categories as dc
+              ON pi.decision_id = dc.id
+                              ") # "select name, version, score from package"
+
   })
 
   riskassessment:::mod_downloadHandler_server("downloadHandler_1", pkg, user, metric_weights)

diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
@@ -191,22 +191,32 @@ test_that(
 ) 
 
 test_that("datatable_custom works", {
-  output <- datatable_custom(mtcars, colnames = paste0("custom_", names(mtcars)))
+  output <- datatable_custom(mtcars, colnames = paste0("custom_", names(mtcars)),
+                             decision_lst = c("Low Risk", "Medium Risk", "High Risk"),
+                             color_lst = get_colors(app_sys("testdata", "skeleton.sqlite"))) #c("#9CFF94FF", "#FFD070FF", "#FF765BFF")
   expect_true(inherits(output, "datatables"))
   # it errors if not a data frame is provided:
-  expect_error(datatable_custom(matrix()))
+  expect_error(datatable_custom(matrix(),
+                                decision_lst = c("Low Risk", "Medium Risk", "High Risk"),
+                                color_lst = get_colors(app_sys("testdata", "skeleton.sqlite"))))
   # it defaults to data frame names with a warning if colnames is not of equal 
   # length as names(data)
   expect_warning(
-    datatable_custom(mtcars[, 1:2], colnames = c("a", "b", "c")),
+    datatable_custom(mtcars[, 1:2], colnames = c("a", "b", "c"),
+                     decision_lst = c("Low Risk", "Medium Risk", "High Risk"),
+                     color_lst = get_colors(app_sys("testdata", "skeleton.sqlite"))),
     "Defaulting to original data frame names"
   )
   #it returns an empty datatable if the data frame provided is NULL
-  output_no_df <- datatable_custom(NULL, colnames = paste0("custom_", names(mtcars)))
+  output_no_df <- datatable_custom(NULL, colnames = paste0("custom_", names(mtcars)),
+                                   decision_lst = c("Low Risk", "Medium Risk", "High Risk"),
+                                   color_lst = get_colors(app_sys("testdata", "skeleton.sqlite")))
   expect_true(inherits(output_no_df, "datatables"))
   expect_equal(nrow(output_no_df$x$data), 0)
   # and if the colnames parameter is also NULL:
-  output_no_df_no_colnames <- datatable_custom(NULL, colnames = NULL)
+  output_no_df_no_colnames <- datatable_custom(NULL, colnames = NULL,
+                                               decision_lst = c("Low Risk", "Medium Risk", "High Risk"),
+                                               color_lst = get_colors(app_sys("testdata", "skeleton.sqlite")))
   expect_true(inherits(output_no_df_no_colnames, "datatables"))
   expect_equal(nrow(output_no_df_no_colnames$x$data), 0)