Enhancement/run app via package installation

NAMESPACE

@@ -4,9 +4,12 @@ export(anonymize_pk_data)
 export(apply_filters)
 export(as_factor_preserve_label)
 export(calculate_summary_stats)
+export(check_slope_rule_overlap)
+export(compress_range)
 export(create_conc)
 export(create_dose)
 export(filter_breaks)
+export(filter_slopes)
 export(flexible_violinboxplot)
 export(format_data)
 export(general_lineplot)
@@ -71,6 +74,7 @@ importFrom(logger,log_info)
 importFrom(logger,log_trace)
 importFrom(logger,log_warn)
 importFrom(plotly,event_data)
+importFrom(plotly,ggplotly)
 importFrom(plotly,plotlyOutput)
 importFrom(plotly,plotly_build)
 importFrom(plotly,renderPlotly)

R/run_app.R

@@ -1,16 +1,17 @@
 #' Run the Shiny app
 #'
-#' List of functions imported for the shiny application.
-#' When adding new imports, please keep the alphabetical order, at lest for packages.
+#' @param ... Arguments passed to `shiny::runApp()`
 #'
+#' List of packages imported for the shiny application.
+#' When adding new imports, please keep the alphabetical order, at lest for packages.
 #' @import shiny
 #' @importFrom dplyr mutate filter select group_by summarise pull arrange ungroup
 #' @importFrom dplyr rename_with across case_when left_join rename
 #' @importFrom DT DTOutput renderDataTable datatable formatStyle styleEqual
 #' @importFrom ggplot2 ggplot geom_errorbar geom_point geom_line labs aes facet_wrap
 #' @importFrom htmlwidgets JS
 #' @importFrom PKNCA PKNCAconc PKNCAdose PKNCAdata pk.nca PKNCA.options pknca_units_table
-#' @importFrom plotly plotlyOutput renderPlotly plotly_build event_data
+#' @importFrom plotly plotlyOutput renderPlotly plotly_build event_data ggplotly
 #' @importFrom reactable reactable reactableOutput renderReactable colDef reactableTheme
 #' @importFrom reactable getReactableState
 #' @importFrom reactable.extras text_extra dropdown_extra
@@ -23,7 +24,36 @@
 #' @importFrom tools file_ext
 #' @importFrom utils read.csv write.csv
 #' @importFrom zip zipr
+#'
 #' @export
-run_app <- function() {
-  shiny::runApp(system.file("shiny", package = "aNCA"))
+run_app <- function(...) {
+  # Load all packages mentioned in the NAMESPACE
+  require("aNCA")
+  require("dplyr")
+  require("DT")
+  require("forcats")
+  require("ggplot2")
+  require("grid")
+  require("haven")
+  require("htmlwidgets")
+  require("logger")
+  require("nestcolor")
+  require("PKNCA")
+  require("plotly")
+  require("reactable.extras")
+  require("reactable")
+  require("rio")
+  require("rmarkdown")
+  require("shiny")
+  require("shinyBS")
+  require("shinyFiles")
+  require("shinyjqui")
+  require("shinyWidgets")
+  require("stats")
+  require("tern")
+  require("tidyr")
+  require("tools")
+  require("utils")
+  require("zip")
+  shiny::runApp(system.file("shiny", package = "aNCA"), ...)
 }

R/utils-slope_selector.R

@@ -12,7 +12,8 @@
 #'          columns modified in accordance to the provided slope filters.
 #' @importFrom dplyr filter group_by mutate
 #'
-.filter_slopes <- function(data, slopes, profiles) {
+#' @export
+filter_slopes <- function(data, slopes, profiles) {
   if (is.null(data) || is.null(data$conc) || is.null(data$conc$data))
     stop("Please provide valid data.")
 
@@ -39,7 +40,7 @@
     # Go over all rules and check if there is no overlap - if there is, edit accordingly
     slopes <- purrr::reduce(
       split(slopes, seq_len(nrow(slopes))),
-      .f = ~ .check_slope_rule_overlap(.x, .y, .keep = TRUE)
+      .f = ~ check_slope_rule_overlap(.x, .y, .keep = TRUE)
     )
   }
 
@@ -84,7 +85,9 @@
 #'                 that the user wants to remove rule if new range already exists in the dataset.
 #'                 If TRUE, in that case full range will be kept.
 #' @returns Data frame with full ruleset, adjusted for new rules.
-.check_slope_rule_overlap <- function(existing, new, .keep = FALSE) {
+#'
+#' @export
+check_slope_rule_overlap <- function(existing, new, .keep = FALSE) {
   # check if any rule already exists for specific patient and profile #
   existing_index <- which(
     existing$TYPE == new$TYPE &
@@ -106,11 +109,11 @@
 
   if (is_diff || .keep) {
     existing$IXrange[existing_index] <- unique(c(existing_range, new_range)) %>%
-      .compress_range()
+      compress_range()
 
   } else if (is_inter) {
     existing$IXrange[existing_index] <- setdiff(existing_range, new_range) %>%
-      .compress_range()
+      compress_range()
   }
 
   dplyr::filter(existing, !is.na(IXrange))

R/utils.R

@@ -27,11 +27,12 @@
 #' @examples
 #' \dontrun{
 #' # Basic usage
-#' .compress_range(c(1, 2, 3, 4)) # "1:4"
-#' .compress_range(c(15, 1, 11, 4, 5, 10, 2, 12, 3)) # "1:5,10:12,15"
+#' compress_range(c(1, 2, 3, 4)) # "1:4"
+#' compress_range(c(15, 1, 11, 4, 5, 10, 2, 12, 3)) # "1:5,10:12,15"
 #' }
 #'
-.compress_range <- function(range_vector) {
+#' @export
+compress_range <- function(range_vector) {
   if (!is(range_vector, "numeric")) range_vector <- suppressWarnings(as.numeric(range_vector))
   if (any(is.na(range_vector))) stop("Error: only numeric values allowed")
   if (length(range_vector) == 0) return(NA_integer_)

inst/shiny/modules/slope_selector.R

@@ -348,12 +348,12 @@ slope_selector_server <- function(
 
     # Observe input$nca
     observeEvent(profiles_per_patient(), {
-      mydata(.filter_slopes(mydata(), manual_slopes(), profiles_per_patient()))
+      mydata(filter_slopes(mydata(), manual_slopes(), profiles_per_patient()))
     })
 
     #' saves and implements provided ruleset
     observeEvent(input$save_ruleset, {
-      mydata(.filter_slopes(mydata(), manual_slopes(), profiles_per_patient()))
+      mydata(filter_slopes(mydata(), manual_slopes(), profiles_per_patient()))
       rv$trigger <- rv$trigger + 1
     })
 
@@ -362,7 +362,7 @@ slope_selector_server <- function(
     #' and exclusions before applying them to the actual dataset.
     plot_data <- reactive({
       req(mydata(), manual_slopes(), profiles_per_patient())
-      .filter_slopes(mydata(), manual_slopes(), profiles_per_patient())
+      filter_slopes(mydata(), manual_slopes(), profiles_per_patient())
     }) %>%
       shiny::debounce(750)
 
@@ -402,7 +402,7 @@ slope_selector_server <- function(
       )
 
       # Check if there is any overlap with existing rules, adda new or edit accordingly
-      new_manual_slopes <- .check_slope_rule_overlap(manual_slopes(), new_slope_rule)
+      new_manual_slopes <- check_slope_rule_overlap(manual_slopes(), new_slope_rule)
 
       manual_slopes(new_manual_slopes)
 
@@ -429,7 +429,7 @@ slope_selector_server <- function(
         select(TYPE, USUBJID, DOSNO, IX, REASON) %>%
         mutate(PATIENT = as.character(USUBJID), PROFILE = as.character(DOSNO)) %>%
         group_by(TYPE, PATIENT, PROFILE, REASON) %>%
-        summarise(IXrange = .compress_range(IX), .groups = "keep") %>%
+        summarise(IXrange = compress_range(IX), .groups = "keep") %>%
         select(TYPE, PATIENT, PROFILE, IXrange, REASON) %>%
         na.omit()
 

inst/shiny/modules/tab_tlg.R

@@ -88,7 +88,7 @@ tab_tlg_server <- function(id, data) {
 
     # Make available the CSV file with the TLG list and available links to NEST
     tlg_order <- reactiveVal(
-      read.csv(system.file("www/data/TLG_order_details.csv", package = "aNCA")) %>%
+      read.csv(system.file("data/TLG_order_details.csv", package = "aNCA")) %>%
         mutate(PKid = paste0("<a href='", Catalog_Link, "' target='_blank'>", PKid, "</a>"))
     )
 

tests/testthat/test-utils-slope_selector.R

@@ -21,7 +21,7 @@ PROFILES_FIXTURE <- list(
   "4" = list(1)
 )
 
-describe(".filter_slopes", {
+describe("filter_slopes", {
   it("should handle slope selection", {
     selection <- data.frame(
       TYPE = rep("Selection", 2),
@@ -31,7 +31,7 @@ describe(".filter_slopes", {
       REASON = "Test selection"
     )
 
-    res <- .filter_slopes(DATA_FIXTURE, selection, PROFILES_FIXTURE)
+    res <- filter_slopes(DATA_FIXTURE, selection, PROFILES_FIXTURE)
     expect_true(all(res$is.included.hl[c(1:3, 6:8)]))
     expect_true(all(res$REASON[c(1:3, 6:8)] == "Test selection"))
   })
@@ -45,19 +45,19 @@ describe(".filter_slopes", {
       REASON = "Test exclusion"
     )
 
-    res <- .filter_slopes(DATA_FIXTURE, exclusion, PROFILES_FIXTURE)
+    res <- filter_slopes(DATA_FIXTURE, exclusion, PROFILES_FIXTURE)
     expect_true(all(res$is.excluded.hl[c(5, 6, 14, 15)]))
     expect_true(all(res$REASON[c(5, 6, 14, 15)] == "Test exclusion"))
   })
 
   it("should throw an error for invalid data", {
-    expect_error(.filter_slopes(NULL, NULL, PROFILES_FIXTURE), "Please provide valid data.")
-    expect_error(.filter_slopes(list(), NULL, PROFILES_FIXTURE), "Please provide valid data.")
+    expect_error(filter_slopes(NULL, NULL, PROFILES_FIXTURE), "Please provide valid data.")
+    expect_error(filter_slopes(list(), NULL, PROFILES_FIXTURE), "Please provide valid data.")
     expect_error(
-      .filter_slopes(list(conc = list()), NULL, PROFILES_FIXTURE), "Please provide valid data."
+      filter_slopes(list(conc = list()), NULL, PROFILES_FIXTURE), "Please provide valid data."
     )
     expect_error(
-      .filter_slopes(list(conc = list()), NULL, PROFILES_FIXTURE), "Please provide valid data."
+      filter_slopes(list(conc = list()), NULL, PROFILES_FIXTURE), "Please provide valid data."
     )
   })
 })
@@ -69,7 +69,7 @@ EXISTING_FIXTURE <- data.frame(
   IXrange = "3:6"
 )
 
-describe(".check_slope_rule_overlap", {
+describe("check_slope_rule_overlap", {
   it("should add new row if no overlap is detected", {
     # different type #
     NEW <- data.frame(
@@ -78,7 +78,7 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 1,
       IXrange = "1:3"
     )
-    expect_equal(nrow(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+    expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
 
     # different patient #
     NEW <- data.frame(
@@ -87,7 +87,7 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 1,
       IXrange = "1:3"
     )
-    expect_equal(nrow(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+    expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
 
     # different profile #
     NEW <- data.frame(
@@ -96,7 +96,7 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 2,
       IXrange = "1:3"
     )
-    expect_equal(nrow(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+    expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
   })
 
   it("should remove overlapping points if no new points are detected", {
@@ -106,15 +106,15 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 1,
       IXrange = "4:5"
     )
-    expect_equal(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "3,6")
+    expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "3,6")
 
     NEW <- data.frame(
       TYPE = "Exclusion",
       PATIENT = 1,
       PROFILE = 1,
       IXrange = "3:4"
     )
-    expect_equal(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "5:6")
+    expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "5:6")
   })
 
   it("should add new points of partial overlap is detected", {
@@ -124,7 +124,7 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 1,
       IXrange = "4:9"
     )
-    expect_equal(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "3:9")
+    expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$IXrange, "3:9")
   })
 
   it("should remove full row if full range of rule is removed", {
@@ -134,6 +134,6 @@ describe(".check_slope_rule_overlap", {
       PROFILE = 1,
       IXrange = "3:6"
     )
-    expect_equal(nrow(.check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 0)
+    expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 0)
   })
 })