pharmaR · jthompson-arcus · Jun 4, 2024 · May 31, 2024 · May 31, 2024 · Jun 3, 2024
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
@@ -287,7 +287,7 @@ mod_downloadHandler_server <- function(id, pkgs, user, metric_weights){
                 } 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) %>%
                   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()
 
@@ -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,14 @@ 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,
+    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) )) 
@@ -584,43 +588,41 @@ datatable_custom <- function(
 
   formattable::as.datatable(
     formattable::formattable(
-      data,
+      data %>%
+        mutate(decision = if_else(is.na(decision) | toupper(decision) == "NA", "", decision)),
       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")),
+      # pageLength = pLength[1],
+      lengthMenu = pLength,
+      lengthChange = plChange,
       columnDefs = list(list(visible = FALSE, targets = target)),
       searchable = FALSE
     ),

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/dev/run_dev.R b/dev/run_dev.R
@@ -1,6 +1,6 @@
 # Set options here
 options(golem.app.prod = FALSE) # TRUE = production mode, FALSE = development mode
-options(shiny.fullstacktrace = FALSE)
+options(shiny.fullstacktrace = TRUE)
 options(dplyr.summarise.inform = FALSE) # suppress summarise() has grouped output by..."
 # options(shiny.autoload.r=FALSE)
 

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
@@ -940,7 +940,7 @@
         "RoxygenNote": "7.3.0",
         "Author": "Sebastien Rochette [aut, cre] (<https://orcid.org/0000-0002-1565-9313>),\n  Vincent Guyader [aut] (<https://orcid.org/0000-0003-0671-9270>),\n  Arthur Bréant [aut] (<https://orcid.org/0000-0003-1668-0963>),\n  Murielle Delmotte [aut] (<https://orcid.org/0000-0002-1339-2424>),\n  ThinkR [cph]",
         "Maintainer": "Sebastien Rochette <[email protected]>",
-        "Built": "R 4.3.3; ; 2024-05-31 13:28:09 UTC; unix",
+        "Built": "R 4.3.3; ; 2024-05-31 13:18:53 UTC; unix",
         "RemoteType": "github",
         "RemoteUsername": "thinkr-open",
         "RemoteRepo": "checkhelper",
@@ -1303,7 +1303,7 @@
         "Imports": "callr,\ncranlike (>= 1.0.2),\ncurl,\ndesc (>= 1.1.0),\ndigest,\nparsedate,\nrappdirs,\nrematch2,\ntools,\nutils,\nwithr",
         "Suggests": "covr,\npingr,\ntestthat,\nzip",
         "Encoding": "UTF-8",
-        "Built": "R 4.3.3; ; 2024-05-31 13:28:18 UTC; unix",
+        "Built": "R 4.3.3; ; 2024-05-31 13:19:02 UTC; unix",
         "RemoteType": "github",
         "RemoteHost": "api.github.com",
         "RemoteUsername": "r-lib",
@@ -4425,7 +4425,7 @@
         "RoxygenNote": "7.2.3",
         "Author": "Gábor Csárdi [cre, aut, cph],\n  Hadley Wickham [aut],\n  RConsortium [cph],\n  RStudio [cph, fnd]",
         "Maintainer": "Gábor Csárdi <[email protected]>",
-        "Built": "R 4.3.3; ; 2024-05-31 13:28:51 UTC; unix",
+        "Built": "R 4.3.3; ; 2024-05-31 13:19:35 UTC; unix",
         "RemoteType": "github",
         "RemoteUsername": "r-lib",
         "RemoteRepo": "revdepcheck",
@@ -4543,7 +4543,7 @@
         "Config/testthat/edition": "3",
         "Author": "R Validation Hub [aut],\n  Doug Kelkhoff [aut],\n  Marly Gotti [aut],\n  Eli Miller [cre, aut],\n  Kevin K [aut],\n  Yilong Zhang [aut],\n  Eric Milliman [aut],\n  Juliane Manitz [aut],\n  Mark Padgham [ctb],\n  PSI special interest group Application and Implementation of\n    Methodologies in Statistics [cph]",
         "Maintainer": "Eli Miller <[email protected]>",
-        "Built": "R 4.3.3; ; 2024-05-31 13:28:56 UTC; unix",
+        "Built": "R 4.3.3; ; 2024-05-31 13:19:40 UTC; unix",
         "RemoteType": "github",
         "RemoteUsername": "pharmaR",
         "RemoteRepo": "riskmetric",
@@ -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": "430a55358e979be5a4137660e3c8af32"
     },
     "R/mod_introJS_utils_text.R": {
       "checksum": "d98620a891752cf54b0d0282ddaa4af6"
@@ -6532,7 +6532,7 @@
       "checksum": "a894eb9114e258feb99b76cdca557cd2"
     },
     "R/mod_packageDependencies.R": {
-      "checksum": "06dcc773b509d093da214942b9f6513e"
+      "checksum": "7f2be1861ff5a38054aa7f9e091e7beb"
     },
     "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": "f82f71505446fa2494502ce38b690bb9"
     },
     "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)