Incorporate Reverse Dependency Improvements

.Rbuildignore

@@ -24,3 +24,5 @@ _\.new\.png$
 ^tarballs$
 ^revdep
 ^revdep$
+^manifest\.json$
+^\.rscignore$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: riskassessment
 Title: A web app designed to interface with the `riskmetric` package
-Version: 3.0.0.9015
+Version: 3.0.0.9016
 Authors@R: c( 
     person("Aaron", "Clark", role = c("aut", "cre"), email = "aaron.clark@biogen.com"),
     person("Robert", "Krajcik", role = "aut", email = "robert.krajcik@biogen.com"),
@@ -81,7 +81,8 @@ Suggests:
     shinytest2,
     spelling,
     testthat (>= 3.0.0),
-    tinytex
+    tinytex,
+    withr
 Config/testthat/edition: 3
 Language: en-US
 Depends: 

NEWS.md

@@ -15,6 +15,7 @@
 * Move package upload process to a function
 * Updated logo in reports to lighter version to match application UI
 * Utilize `{archive}` to parse DESCRIPTION file in package upload process
+* Incorporates table to show reverse dependencies included in the database
 
 # riskassessment 3.0.0
 

R/global.R

@@ -42,6 +42,7 @@ utils::globalVariables(
     'downloads',
     'ea_v',
     'estimate',
+    'explore_metrics',
     'func',
     'have_changed',
     'Last modified',
@@ -69,6 +70,7 @@ utils::globalVariables(
     'rpt_choices',
     'score',
     'setNames',
+    'status',
     'succ_icon',
     'text',
     'token',

R/mod_addComment.R

@@ -57,7 +57,7 @@ addCommentServer <- function(id, metric_abrv, user, credentials, pkg_name) {
 
     observeEvent(input$submit_comment, {
       req(input$add_comment)
-      req("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("general_comment" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
       comment <- trimws(input$add_comment)
 

R/mod_code_explorer.R

@@ -73,7 +73,7 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
           ),
           br(), br(),
           div(id = ns("comments_for_fe"), fluidRow(
-            if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(id = ns("add_comment")),
+            if ("general_comment" %in% unlist(credentials$privileges[user$role], use.names = FALSE)) addCommentUI(id = ns("add_comment")),
             viewCommentsUI(id = ns("view_comments"))))
         )
       }

R/mod_communityMetrics.R

@@ -51,7 +51,7 @@ communityMetricsServer <- function(id, selected_pkg, community_metrics, user, cr
                      plotly::plotlyOutput(NS(id, "downloads_plot"), height = "500px")))),
             br(), br(),
             div(id = "comments_for_cum", fluidRow( 
-              if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(id = session$ns("add_comment")),
+              if ("general_comment" %in% unlist(credentials$privileges[user$role], use.names = FALSE)) addCommentUI(id = session$ns("add_comment")),
               viewCommentsUI(id = session$ns("view_comments"))))
           )
       }

R/mod_decision_automation.R

@@ -428,7 +428,7 @@ mod_decision_automation_server <- function(id, user, credentials){
     #### Outputs ####
     purrr::walk(c("auto_dropdown", "auto_dropdown2"), ~
                   observeEvent(input[[.x]], {
-                    req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+                    req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
                     showModal(modalDialog(
                       size = "l",
@@ -515,7 +515,7 @@ mod_decision_automation_server <- function(id, user, credentials){
     })
 
     output$auto_classify <- renderUI({
-      if ("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) {
+      if ("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE)) {
         tagList(
           br(),br(),
           hr(),
@@ -540,7 +540,7 @@ mod_decision_automation_server <- function(id, user, credentials){
     })
 
     output$decision_rule_div <- renderUI({
-      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
       tagList(
         div(
           style = "display: flex",
@@ -625,7 +625,7 @@ mod_decision_automation_server <- function(id, user, credentials){
 
     output$auto_settings <-
       renderUI({
-        req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+        req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
         div(
           style = "float: right;",
@@ -637,7 +637,7 @@ mod_decision_automation_server <- function(id, user, credentials){
 
     output$auto_settings2 <-
       renderUI({
-        req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+        req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
         div(
           style = "float: right;",
@@ -721,7 +721,7 @@ mod_decision_automation_server <- function(id, user, credentials){
       })
 
     observeEvent(input$submit_auto, {
-      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
       showModal(modalDialog(
         size = "l",
@@ -752,7 +752,7 @@ mod_decision_automation_server <- function(id, user, credentials){
     })
 
     observeEvent(input$submit_color, {
-      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
       showModal(modalDialog(
         size = "l",
@@ -784,7 +784,7 @@ mod_decision_automation_server <- function(id, user, credentials){
     })
 
     observeEvent(input$confirm_submit_auto, {
-      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
       req(!disable_auto_submit())
 
       out_lst <- purrr::compact(reactiveValuesToList(auto_decision))
@@ -829,7 +829,7 @@ mod_decision_automation_server <- function(id, user, credentials){
 
 
     observeEvent(input$confirm_submit_col, {
-      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE))
+      req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE))
 
       selected_colors <- 
         decision_lst %>%

R/mod_introJS.R

@@ -37,7 +37,7 @@ introJSServer <- function(id, text, user, credentials) {
   moduleServer(id, function(input, output, session) {
 
     steps <- reactive({
-      if(user$admin || "weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) {
+      if(user$admin || "weight_adjust" %in% unlist(credentials$privileges[user$role], use.names = FALSE)) {
         apptab_steps <- bind_rows(apptab_admn, apptab_steps)
       }
 

R/mod_maintenanceMetrics.R

@@ -39,7 +39,7 @@ maintenanceMetricsServer <- function(id, selected_pkg, maint_metrics, user, cred
             metricGridUI(NS(id, 'metricGrid')),
             br(), br(),
             fluidRow(div(id = "comments_for_mm",
-                         if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(NS(id, 'add_comment')),
+                         if ("general_comment" %in% unlist(credentials$privileges[user$role], use.names = FALSE)) addCommentUI(NS(id, 'add_comment')),
                          viewCommentsUI(NS(id, 'view_comments')))
             )
           )

R/mod_packageDependencies.R

@@ -57,7 +57,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
       req(selected_pkg$name() != "-")
       req(tabready() == 1L)
 
-      get_assess_blob(selected_pkg$name())
+      get_assess_blob(selected_pkg$name(), metric_lst = c("dependencies", "suggests", "reverse_dependencies"))
     })
 
     observeEvent(list(pkgref(), toggled()), {
@@ -92,6 +92,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
       if (rlang::is_empty(pkgref()$dependencies[[1]])) depends(dplyr::tibble(package = character(0), type = character(0), name = character(0)))
 
       revdeps(pkgref()$reverse_dependencies[[1]] %>% as.vector())
+
       # send either depends() or both to build_dep_cards(), depending on toggled()
       if (toggled() == 0L) {
         cards(build_dep_cards(data = depends(), loaded = session$userData$loaded2_db()$name, toggled = 0L))
@@ -147,24 +148,39 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
     }, ignoreInit = TRUE)
 
     data_table <- eventReactive(pkg_df(), {
-      cbind(
-        pkg_df(),
-        data.frame(
-          Actions = shinyInput(
-            actionButton, nrow(pkg_df()),
-            "button_",
-            size = "xs",
-            style = "height:24px; padding-top:1px;",
-            label = icon("arrow-right", class = "fa-regular", lib = "font-awesome"),
-            onclick = paste0('Shiny.setInputValue(\"', ns("select_button"), '\", this.id, {priority: "event"})')
-          )
-        )
-      ) %>% # remove action button if there is nothing to review
+      add_buttons_to_table(pkg_df(), ns("select_button")) %>% 
+        # remove action button if there is nothing to review
         mutate(Actions = if_else(identical(package, character(0)) | name %in% c(rownames(installed.packages(priority = "base"))), "", Actions)) %>% 
         # if package name not yet loaded, switch the actionbutton to fa-upload
         mutate(Actions = if_else(!name %in% session$userData$loaded2_db()$name, gsub("fas fa-arrow-right fa-regular", "fas fa-upload fa-solid", Actions), Actions))
     })
 
+    revdeps_local <- reactive({
+      df <- session$userData$loaded2_db()
+      req(df, df$name)
+
+      revdeps <-
+        df %>%
+        dplyr::filter(name %in% revdeps()) %>%
+        dplyr::pull(name) %>%
+        get_assess_blob(metric_lst = "suggests")
+
+      if (nrow(revdeps) == 0) return(dplyr::left_join(bind_rows(revdeps, list(suggests = logical())), df, by = "name"))
+
+      revdeps %>%
+        dplyr::mutate(suggests = purrr::map_lgl(suggests, ~ any(grepl(selected_pkg$name(), .x$package)))) %>%
+        dplyr::left_join(df, by = "name")
+    })
+
+    table_revdeps_local <- reactive({
+      req(revdeps_local())
+
+      revdeps_local() %>%
+        dplyr::filter(toggled() == 1L | !suggests) %>%
+        dplyr::select(-suggests) %>%
+        add_buttons_to_table(ns("go_to_revdep"))
+    })
+
     # Create metric grid card.
     metricGridServer(id = 'metricGrid', metrics = cards) 
 
@@ -176,7 +192,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
         showHelperMessage()
       } else {
         req(depends())
-        
+
         fluidPage(
           shiny::
             tagList(
@@ -217,65 +233,27 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
               fluidRow(
                 column(
                   width = 8,
-                    DT::renderDataTable(server = FALSE, {
-                      # Hiding name from DT table. target contains index for "name"
-                      # The - 1 is because js uses 0 index instead of 1 like R
-                      target <- which(names(data_table()) %in% c("name")) - 1
-
-                      formattable::as.datatable(
-                        formattable::formattable(
-                          data_table(),
-                          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"
-                                  )
-                              )
-                            )
-                          )
-                        ),
-                        selection = "none",
-                        colnames = c("Package", "Type", "Name", "Version", "Score", "Review Package"),
-                        rownames = FALSE,
-                        options = list(
-                          lengthMenu = list(c(15, -1), c("15", "All")),
-                          columnDefs = list(list(visible = FALSE, targets = target)),
-                          searchable = FALSE
-                        ),
-                        style = "default"
-                      ) %>%
-                        DT::formatStyle(names(data_table()), textAlign = "center")
-                    })
-                ) # column
-              ), # fluidRow
-              br(),
-              h4(glue::glue("Reverse Dependencies: {length(revdeps())}"), style = "text-align: left;"),
+                  DT::renderDataTable(server = FALSE, {
+                    datatable_custom(data_table())                      
+                  })
+                )
+              ), 
               br(), br(),
+              h3(glue::glue("All reverse Dependencies: {length(revdeps())}"), style = "text-align: left;"),
+              br(),
               fluidRow(
                 column(
                   width = 8,
+                  h4(glue::glue("Reverse Dependencies available in database: {nrow(table_revdeps_local()) %||% 0}"), style = "text-align: left;"),
+                  br(), 
+                  DT::renderDataTable({
+                    datatable_custom(
+                      table_revdeps_local(), 
+                      colnames = c("Package", "Version", "Score", "Review Package"),
+                      hide_names = NULL
+                    )
+                  }),
+                  br(), br(),
                   wellPanel(
                     renderText(revdeps() %>% sort()),
                     style = "max-height: 500px; overflow: auto"
@@ -287,21 +265,30 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
       }
     }) # renderUI
 
+    # the package selected in the table to either browser to or to upload:
+    selected_package <- reactiveVal() 
     pkgname <- reactiveVal()
+    observeEvent(input$select_button, {
+      req(pkg_df())
+      selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
+      selected_package(with(pkg_df(), name[selectedRow]))
+      pkgname("-")
+    })
+    observeEvent(input$go_to_revdep, {
+      req(table_revdeps_local())
+      selectedRow <- as.numeric(strsplit(input$go_to_revdep, "_")[[1]][2])
+      selected_package(with(table_revdeps_local(), name[selectedRow]))
+    })
 
-    observeEvent(input$select_button,
+    observeEvent(selected_package(),
      {
-       req(pkg_df())
        rev_pkg(0L)
-
-       selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
-
-       # grab the package name
-       pkg_name <- pkg_df()[selectedRow, 3] %>% pull()
        pkgname("-")
-
-       if (!pkg_name %in% session$userData$loaded2_db()$name) {
-         pkgname(pkg_name)
+       # to ensure that if the same package is clicked on, this observeEvent will 
+       # run again:
+       on.exit(selected_package(NULL)) 
+       if (!selected_package() %in% session$userData$loaded2_db()$name) {
+         pkgname(selected_package())
          shiny::showModal(modalDialog(
            size = "l",
            easyClose = TRUE,
@@ -311,7 +298,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
            fluidRow(
              column(
                width = 12,
-               "Please confirm to load this package: ", span(class = "text-info", input$decision),
+               "Please confirm to load this package: ", span(class = "text-info", selected_package()),
              )
            ),
            br(),
@@ -326,7 +313,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, parent) {
            session = parent,
            inputId = "sidebar-select_pkg",
            choices = c("-", session$userData$loaded2_db()$name),
-           selected = pkg_name
+           selected = selected_package()
          )
        }
      },