Merge pull request #796 from pharmaR/dev

Next Release (`v3.1.1`)

.github/workflows/test-coverage.yaml

@@ -1,4 +1,4 @@
-# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
   push:
@@ -9,6 +9,8 @@ on:
 
 name: test-coverage
 
+permissions: read-all
+
 jobs:
   test-coverage:
     runs-on: ubuntu-latest
@@ -24,21 +26,45 @@ jobs:
           sudo apt-get update
           sudo apt-get install -y texlive-xetex
       
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-pandoc@v2
 
       - uses: r-lib/actions/setup-r@v2
         with:
-          use-public-rspm: true
+          use-public-rspm: false
           r-version: 'renv'
 
       - uses: r-lib/actions/setup-renv@v2
 
-      - name: Install riskassessment
-        shell: bash
-        run: R CMD INSTALL --preclean .
-
       - name: Test coverage
-        run: covr::codecov()
+        run: |
+          cov <- covr::package_coverage(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
+          )
+          covr::to_cobertura(cov)
         shell: Rscript {0}
+
+      - uses: codecov/codecov-action@v4
+        with:
+          fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }}
+          file: ./cobertura.xml
+          plugin: noop
+          disable_search: true
+          token: ${{ secrets.CODECOV_TOKEN }}
+
+      - name: Show testthat output
+        if: always()
+        run: |
+          ## --------------------------------------------------------------------
+          find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload test results
+        if: failure()
+        uses: actions/upload-artifact@v4
+        with:
+          name: coverage-test-failures
+          path: ${{ runner.temp }}/package

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: riskassessment
 Title: A web app designed to interface with the `riskmetric` package
-Version: 3.1.0
+Version: 3.1.1
 Authors@R: c( 
     person("Aaron", "Clark", role = c("aut", "cre"), email = "[email protected]"),
     person("Jeff", "Thompson", role = c("aut"),  email = "[email protected]", comment = "Co-Lead"),

NEWS.md

@@ -1,3 +1,12 @@
+# riskassessment 3.1.1
+
+* Added navigation controls in Function Explorer tab (#644)
+* Fixed bug that crashed the Package Dependencies page for pkgs without any dependency info available (#802)
+* Fixed bug that incorrectly displayed 0 dependencies as 1 (#805)
+* Fixed bug that kept full list of available packages from populating (#776)
+* Removed `.recording` attribute from `riskmetric` assessments for storage purposes
+* Ensured `tarballs` directory existed before returning from `initialize_raa()`
+
 # riskassessment 3.1.0
 
 ### User Enhancements

R/app_server.R

@@ -11,9 +11,20 @@ app_server <- function(input, output, session) {
 
   old <- options()
   onStop(function() {
-    options(old)
-    })
-  options(repos = get_db_config("package_repo"))
+    options(c(
+      # Unsets available packages filter if unset previously. Will be overriden
+      # otherwise.
+      list(available_packages_filters = NULL),
+      old
+    ))
+  })
+  options(
+    # Set session repo to value specified in configuration file
+    repos = get_db_config("package_repo"),
+    # Removes filters based on R version, OS type, sub-architecture. Only
+    # duplicates will be removed from the available package list
+    available_packages_filters = "duplicates"
+  )
 
   # Collect user info.
   user <- reactiveValues()

R/mod_code_explorer.R

@@ -31,7 +31,7 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
         showHelperMessage(message = glue::glue("Source code not available for {{{selected_pkg$name()}}}"))
       } else {
         div(introJSUI(NS(id, "introJS")),
-          br(),
+            br(),
           fluidRow(
             column(3,
                    wellPanel(
@@ -69,7 +69,28 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
                    div(id = ns("file_viewer"),
                      uiOutput(ns("file_output"), class = "file_browser"),
                      style = "height: 62vh; overflow: auto; border: 1px solid var(--bs-border-color-translucent);"
-                   )
+                   ),
+                   br(),
+                   fluidRow(style = "height:35px !important;",
+                            column(4,offset = 8,
+                                   conditionalPanel(
+                                     condition = "typeof(window.$highlights_list) != 'undefined' && window.$highlights_list.length > 1",
+                                     actionButton(ns("prev_button"),label = "",icon = icon("chevron-left"),
+                                                  style ="width: 32px !important; 
+                            height: 32px !important;
+                            font-size: 16px !important;
+                            line-height: 5px !important;
+                            padding: 0px !important;") |>bslib::tooltip("Previous occurence"), style = "display: inline-block;",
+
+                            div(id = "search_index","",style ="display:inline"),
+                            actionButton(ns("next_button"),label = "",icon = icon("chevron-right"),
+                                           style = "width: 32px !important; 
+                            height: 32px !important;
+                            font-size: 16px !important;
+                            line-height: 5px !important;
+                            padding: 0px !important;
+                            display:inline;
+                            ")|>bslib::tooltip("Next occurence",placement ="right"), style = "display: inline-block;")))
             )
           ),
           br(), br(),
@@ -127,7 +148,7 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
       close(con)
       func_list <- c(input$exported_function, paste0("`", input$exported_function, "`"))
       highlight_index <- parse_data() %>% 
-        filter(stringr::str_ends(file, input$test_files) & func %in% func_list) %>% 
+        filter(basename(file) == input$test_files & func %in% func_list) %>% 
         pull(line)
       renderCode(lines, highlight_index)
     }) %>%
@@ -144,7 +165,7 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
       close(con)
       func_list <- c(input$exported_function, paste0("`", input$exported_function, "`"))
       highlight_index <- parse_data() %>% 
-        filter(stringr::str_ends(file, input$source_files) & func %in% func_list) %>% 
+        filter(basename(file) ==  input$source_files & func %in% func_list) %>% 
         pull(line)
       renderCode(lines, highlight_index)
     }) %>%
@@ -157,16 +178,70 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(
       con <- archive::archive_read(file.path("tarballs",
                                              glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")),
                                    file = fp)
+
       Rdfile <-tools::parse_Rd(con)
       close(con)
+      shinyjs::runjs('
+                    $highlights_list = undefined;')
+
       HTML(paste0(utils::capture.output(tools::Rd2HTML(Rdfile,
                                                package = c(selected_pkg$name(),
                                                            selected_pkg$version()), out = "")), collapse = "\n"))
     }) %>%
       bindEvent(input$man_files, input$exported_function, ignoreNULL = FALSE)
 
     introJSServer("introJS", text = reactive(fe_steps), user, credentials)
+    search_index_value <- reactiveVal(1)
+    highlight_list <- reactiveVal(1)
+
+    observeEvent(input$next_button,{
+      if (input$next_button > 0){
+      shinyjs::runjs('
+                    var $index =Array.from($highlights_list).findIndex(node => node.isEqualNode($curr_sel));
+                    if( $index == $highlights_list.length -1) 
+                    {
+              
+                          $curr_sel = $highlights_list[0]
+                          search_index.innerHTML = 1 + " of " + $highlights_list.length;
+              
+                    }
+                else 
+                    {
+                          $curr_sel = $highlights_list[$index +1]
+                          search_index.innerHTML =  ( $index+2) + " of " + $highlights_list.length;
+                    }  
+                
+                    var $target = document.querySelector("#code_explorer-file_viewer")
+                    $target.scrollTop = 0;
+                    $target.scrollTop =$curr_sel.offsetTop -40; ')
+
+      }
+
+    })
 
+    observeEvent(input$prev_button,{
+      if (input$prev_button > 0){
+
+        shinyjs::runjs('var $index =Array.from($highlights_list).findIndex(node => node.isEqualNode($curr_sel));
+                      if( $index ==0) 
+                      {
+                            $curr_sel = $highlights_list[$highlights_list.length -1]
+                            search_index.innerHTML =   $highlights_list.length + " of " + $highlights_list.length;
+                      }
+                        else 
+                      {
+                            $curr_sel = $highlights_list[$index -1]
+                            search_index.innerHTML =   ($index) + " of " + $highlights_list.length;
+                      }  
+                      var $target = document.querySelector("#code_explorer-file_viewer")
+ 
+                      $target.scrollTop = 0; 
+                      $target.scrollTop = $curr_sel.offsetTop  - 40; 
+
+              ')
+      }
+
+    })
     output$file_output <- renderUI({
       switch (input$file_type,
               test = test_code(),

R/mod_code_explorer_utils.R

@@ -172,9 +172,19 @@ renderCode <- function(lines, hlindex) {
                })
              ),
              tags$script(HTML("
+                             
         document.querySelectorAll('.code pre').forEach(bl => {
           hljs.highlightBlock(bl);
         }); 
+        var $highlights_list = document.querySelectorAll('.highlight')
+        var $curr_sel = document.querySelector('.highlight')
+       if(typeof($highlights_list) != 'undefined' & $curr_sel != null){
+        var $target = document.querySelector('#code_explorer-file_viewer')
+        $target.scrollTop = 0;
+        $target.scrollTop = $curr_sel.offsetTop  - 40;
+        var $index1 =Array.from($highlights_list).findIndex(node => node.isEqualNode($curr_sel)) +1;
+        search_index.innerHTML =   $index1 + ' of ' + $highlights_list.length;
+       }
       "))
   )
 }

R/mod_packageDependencies.R

@@ -64,7 +64,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
       req(pkgref())
       tryCatch(
         expr = {
-          deep_ends <- pkgref()$dependencies[[1]] %>% dplyr::as_tibble() %>% 
+          deep_ends <- {if(suppressWarnings(is.null(nrow(pkgref()$dependencies[[1]])) || nrow(pkgref()$dependencies[[1]]) == 0)) dplyr::tibble(package = character(0), type = character(0)) else pkgref()$dependencies[[1]] %>% dplyr::as_tibble()} %>% 
             mutate(package = stringr::str_replace(package, "\n", " ")) %>%
             mutate(name = stringr::str_extract(package, "^((([[A-z]]|[.][._[A-z]])[._[A-z0-9]]*)|[.])"))
 
@@ -94,7 +94,8 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
       )
       tryCatch(
         expr = {
-          shrug_jests <- pkgref()$suggests[[1]] %>% dplyr::as_tibble()%>% 
+          shrug_jests <- 
+            {if(suppressWarnings(is.null(nrow(pkgref()$suggests[[1]])) || nrow(pkgref()$suggests[[1]]) == 0)) dplyr::tibble(package = character(0), type = character(0)) else pkgref()$suggests[[1]] %>% dplyr::as_tibble()} %>% 
             mutate(package = stringr::str_replace(package, "\n", " ")) %>%
             mutate(name = stringr::str_extract(package, "^((([[A-z]]|[.][._[A-z]])[._[A-z0-9]]*)|[.])"))
 
@@ -122,8 +123,7 @@ packageDependenciesServer <- function(id, selected_pkg, user, credentials, paren
                                  decision_id = character(0)))
         }
       )
-      # this is so the dependencies is also a 0x2 tibble like suggests
-      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())
 

R/utils_build_cards.R

@@ -256,7 +256,6 @@ build_dep_cards <- function(data, loaded, toggled){
     is_url = numeric(),
     type = character()
   )
-
 
   deps <- data %>% 
     mutate(base = if_else(name %in% c(rownames(installed.packages(priority = "base"))), "Base", "Non-Base")) %>% 

R/utils_get_db.R

@@ -239,6 +239,42 @@ get_metric_data <- function(pkg_name, metric_class = 'maintenance', db_name = go
     )
 }
 
+#' Get Dependency Pkg Versions and Scores
+#'
+#' 
+#' @param pkg_name character name of the package
+#' @param verify_data a data.frame used to verify whether a pkg exists in the db
+#' @param cran_pkgs a data.frame containing all available cran package names/versions
+#'
+#' @returns a list
+#' @noRd
+get_versnScore <- function(pkg_name, verify_data, cran_pkgs) {
+
+  if (rlang::is_empty(pkg_name)) 
+    return(list(name = character(), version = character(), score = character(),
+                decision_id = character(), decision = character()))
+
+  if (pkg_name %in% verify_data$name) { #loaded2_db()$name
+    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,
+              decision_id = pkg_decision_id, decision = pkg_decision
+  ))   
+}
+
+
+
 #' The 'Get Dependencies Metrics Data' function
 #' 
 #' Pull the depenencies data for a specific package id, and create 
@@ -277,7 +313,7 @@ get_depends_data <- function(pkg_name,
     deps_decision_data <- purrr::map_df(deep_ends$name, ~get_versnScore(.x, loaded2_db, repo_pkgs))
     if(nrow(deps_decision_data) == 0) {
       deps_w_decision <- dplyr::tibble(name = character(0), version = character(0),
-                                       score = character(0), decision = character(0), decision_id = character(0))
+             score = character(0), decision = character(0), decision_id = character(0))
     } else {
       deps_w_decision <- deps_decision_data
     }
@@ -407,40 +443,6 @@ get_assess_blob <- function(pkg_lst, db_name = golem::get_golem_options('assessm
 }
 
 
-#' Get Dependency Pkg Versions and Scores
-#'
-#' 
-#' @param pkg_name character name of the package
-#' @param verify_data a data.frame used to verify whether a pkg exists in the db
-#' @param cran_pkgs a data.frame containing all available cran package names/versions
-#'
-#' @returns a list
-#' @noRd
-get_versnScore <- function(pkg_name, verify_data, cran_pkgs) {
-
-  if (rlang::is_empty(pkg_name)) 
-    return(list(name = character(), version = character(), score = character(),
-                decision_id = character(), decision = character()))
-
-  if (pkg_name %in% verify_data$name) { #loaded2_db()$name
-    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,
-              decision_id = pkg_decision_id, decision = pkg_decision
-              ))   
-}
-
 
 
 ##### End of get_* functions #####