Merge branch 'master' into suggests

Author: simon-smart88

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: shinyscholar
-Version: 0.4.1
+Version: 0.4.2
 Title: A Template for Creating Reproducible 'shiny' Applications
 Description: Create a skeleton 'shiny' application with create_template() that is
     reproducible, can be saved and meets academic standards for attribution.
@@ -35,7 +35,7 @@ Authors@R:
       person("Bruno", "Vilela", email = "bvilela@wustl.edu", role = "ctb"),
       person("Robert", "Muscarella", email = "bob.muscarella@gmail.com", role = "ctb"))
 Depends:
-    R (>= 3.5.0),
+    R (>= 4.1.0),
     bslib,
     gargoyle,
     leaflet (>= 2.0.2),
@@ -45,7 +45,6 @@ Imports:
     devtools,
     glue,
     knitr,
-    magrittr,
     tools,
     zip,
     DT (>= 0.5),

NAMESPACE

@@ -28,4 +28,3 @@ import(bslib)
 import(gargoyle)
 import(leaflet)
 import(shiny)
-importFrom(magrittr,"%>%")

NEWS.md

@@ -104,14 +104,18 @@ shinyscholar 0.4.0
 - Fixed API calls in `select_query()` and `select_async()`
 
 ### Changes
-- Stopped running {shinytest2} tests on CRAN 
-- Migrated from {promises} to {mirai} for running async tasks
-- Migrated to {bslib} layout functions and various UI tweaks
+- Stopped running `{shinytest2}` tests on CRAN 
+- Migrated from `{promises}` to `{mirai}` for running async tasks
+- Migrated to `{bslib}` layout functions and various UI tweaks
 - Added a small footer linking to the CRAN package to generated apps
 
 shinyscholar 0.4.1
 =============
 - Fix half-baked bslib migration
 - Further UI tweaks
 
-
+shinyscholar 0.4.2
+=============
+- Various tweaks to ensure that created apps pass `R CMD check`
+- Removed `{magrittr}` dependency and migrated to native pipes, increasing R dependency to v4.1.0
+- `create_module()` now creates skeleton functions that include `{roxygen2}` tags

R/create_template.R

@@ -85,62 +85,62 @@ create_template <- function(path, name, common_objects, modules, author,
   # Check inputs ====
 
   if (!is.character(path)){
-    logger %>% writeLog(type = "error", "path must be a character string")
+    logger |> writeLog(type = "error", "path must be a character string")
     return()
   }
 
   if (!dir.exists(path)){
-    logger %>% writeLog(type = "error", "The specified path does not exist")
+    logger |> writeLog(type = "error", "The specified path does not exist")
     return()
   }
 
   if (!is.character(name)){
-    logger %>% writeLog(type = "error", "name must be a character string")
+    logger |> writeLog(type = "error", "name must be a character string")
     return()
   }
 
   if (grepl("^[A-Za-z0-9]+$", name, perl = TRUE) == FALSE){
-    logger %>% writeLog(type = "error", "Package names can only contain letters and numbers")
+    logger |> writeLog(type = "error", "Package names can only contain letters and numbers")
     return()
   }
 
   if (grepl("^[0-9]+$", substr(name, 1, 1), perl = TRUE) == TRUE){
-    logger %>% writeLog(type = "error", "Package names cannot start with numbers")
+    logger |> writeLog(type = "error", "Package names cannot start with numbers")
     return()
   }
 
   online <- curl::has_internet()
 
   if (online) {
     if (name %in% tools::CRAN_package_db()[, c("Package")]) {
-      logger %>% writeLog(type = "error", "A package on CRAN already uses that name")
+      logger |> writeLog(type = "error", "A package on CRAN already uses that name")
       return()
     }
   } else {
-    logger %>% writeLog(type = "warning", "You are not online so your package name could
+    logger |> writeLog(type = "warning", "You are not online so your package name could
                         not be checked against existing CRAN packages")
   }
 
   if (dir.exists(file.path(path, name))){
-    logger %>% writeLog(type = "error", "The specified app directory already exists")
+    logger |> writeLog(type = "error", "The specified app directory already exists")
     return()
   }
 
   if (!is.vector(common_objects) || !is.character(common_objects)){
-    logger %>% writeLog(type = "error", "common_objects must be a vector of character strings")
+    logger |> writeLog(type = "error", "common_objects must be a vector of character strings")
     return()
   }
 
   if (any(common_objects %in% c("meta", "logger", "state", "poly", "tasks"))){
     conflicts <- common_objects[common_objects %in% c("meta", "logger", "state", "poly", "tasks", "reset")]
     conflicts <- paste(conflicts, collapse = ",")
-    logger %>% writeLog(type = "error", glue::glue("common_objects contains {conflicts} which are included
+    logger |> writeLog(type = "error", glue::glue("common_objects contains {conflicts} which are included
                                         in common by default. Please choose a different name."))
     return()
   }
 
   if (!is.data.frame(modules)){
-    logger %>% writeLog(type = "error", "modules must be a dataframe")
+    logger |> writeLog(type = "error", "modules must be a dataframe")
     return()
   }
 
@@ -150,33 +150,33 @@ create_template <- function(path, name, common_objects, modules, author,
     missing_column <- module_columns[!(module_columns %in% colnames(modules))]
     missing_column <- paste(missing_column, collapse = ",")
     if (missing_column == "async"){
-      logger %>% writeLog(type = "warning", glue::glue("As of v0.2.0 the modules dataframe should also contain an async column"))
+      logger |> writeLog(type = "warning", glue::glue("As of v0.2.0 the modules dataframe should also contain an async column"))
       modules <- cbind(modules, data.frame("async" = rep(FALSE, nrow(modules))))
     } else {
-      logger %>% writeLog(type = "error", glue::glue("The modules dataframe must contain the column(s): {missing_column}"))
+      logger |> writeLog(type = "error", glue::glue("The modules dataframe must contain the column(s): {missing_column}"))
       return()
     }
   }
 
   if (!all(colnames(modules) %in% module_columns)){
     invalid_column <- colnames(modules)[!colnames(modules) %in% module_columns]
     invalid_column <- paste(invalid_column, collapse = ",")
-    logger %>% writeLog(type = "error", glue::glue("The modules dataframe contains {invalid_column} which is/are not valid column names"))
+    logger |> writeLog(type = "error", glue::glue("The modules dataframe contains {invalid_column} which is/are not valid column names"))
     return()
   }
 
   if (any(modules$map) == TRUE && include_map == FALSE){
-    logger %>% writeLog(type = "info", "Your modules use a map but you had not included it so changing include_map to TRUE")
+    logger |> writeLog(type = "info", "Your modules use a map but you had not included it so changing include_map to TRUE")
     include_map <- TRUE
   }
 
   if (any(modules$map) == FALSE && include_map == TRUE){
-    logger %>% writeLog(type = "error", "You have included a map but none of your modules use it")
+    logger |> writeLog(type = "error", "You have included a map but none of your modules use it")
     return()
   }
 
   if (any(modules$result) == FALSE){
-    logger %>% writeLog(type = "error", "At least one module must return results")
+    logger |> writeLog(type = "error", "At least one module must return results")
     return()
   }
 
@@ -187,12 +187,12 @@ create_template <- function(path, name, common_objects, modules, author,
   }
 
   if (!is.character(author)){
-    logger %>% writeLog(type = "error", "author must be a character string")
+    logger |> writeLog(type = "error", "author must be a character string")
     return()
   }
 
   if (!is.logical(c(include_map, include_table, include_code, install))){
-    logger %>% writeLog(type = "error", "include_map, include_table,
+    logger |> writeLog(type = "error", "include_map, include_table,
                         include_code & install must be TRUE or FALSE")
     return()
   }
@@ -216,8 +216,7 @@ create_template <- function(path, name, common_objects, modules, author,
 
   if (async){
     import_line <- grep("*Imports*", description_lines)
-    description_lines <- append(description_lines, "    bslib,", import_line)
-    description_lines <- append(description_lines, "    mirai,", import_line + 7)
+    description_lines <- append(description_lines, "    mirai,", import_line + 6)
   }
 
   if (include_map){
@@ -509,7 +508,9 @@ create_template <- function(path, name, common_objects, modules, author,
 
   helper_function_params <- c(
     file = system.file("app_skeleton", "helper_functions.Rmd", package = "shinyscholar"),
-    list(include_map = include_map)
+    list(include_code = include_code,
+         include_map = include_map,
+         async = async)
   )
   helper_function_lines <- tidy_purl(helper_function_params)
   writeLines(helper_function_lines, file.path(path, "R", "helper_functions.R"))
@@ -527,7 +528,8 @@ create_template <- function(path, name, common_objects, modules, author,
 
   # Install package ====
   if (install){
-  devtools::install_local(path = path, force = TRUE)
+  devtools::document(path)
+  devtools::install(path, force = TRUE)
   }
 
   invisible()

R/custom_modules.R

@@ -97,8 +97,14 @@ create_module <- function(id, dir, map = FALSE, result = FALSE, rmd = FALSE, sav
   writeLines(module_lines, file.path(module_dir, glue::glue("{id}.R")))
 
   # create empty function
-  empty_function <- paste0(id," <- function(x){return(NULL)}")
-  writeLines(empty_function, file.path(dir, "R", paste0(id, "_f.R")))
+  function_params <- c(
+    file = system.file("module_skeleton", "function.Rmd", package = "shinyscholar"),
+    list(id = id,
+         async = async)
+  )
+
+  function_lines <- tidy_purl(function_params)
+  writeLines(function_lines, file.path(dir, "R", paste0(id, "_f.R")))
 
   # create test
   desc <- readLines(file.path(dir, "DESCRIPTION"))

R/helper_functions.R

@@ -24,7 +24,7 @@ printVecAsis <- function(x) {
 check_url <- function(url){
   req <- httr2::request(url)
   resp <- tryCatch(
-    req %>% httr2::req_perform(),
+    req |> httr2::req_perform(),
     httr2_http_404 = function(cnd){NULL},
     httr2_failure = function(cnd){NULL},
     httr2_error = function(cnd){NULL}

R/plot_hist_f.R

@@ -3,34 +3,52 @@
 #' and extracts values from a raster image, returning a histogram of density
 #' @param raster SpatRaster object
 #' @param bins The number of breaks in the histogram
+#' @param palette character. The colour palette to use
+#' @param name character. The name of the variable
 #' @param logger Stores all notification messages to be displayed in the Log
 #'   Window. Insert the logger reactive list here for running in
 #'   shiny, otherwise leave the default NULL
-#' @return a list of class histogram
+#' @return a function that generates a histogram
 #' @author Simon Smart <simon.smart@@cantab.net>
 #' @examples
 #' if (check_suggests(example = TRUE)) {
 #'   raster <- terra::rast(ncol = 8, nrow = 8)
 #'   raster[] <- sapply(1:terra::ncell(raster), function(x){
 #'     rnorm(1, ifelse(x %% 8 != 0, x %% 8, 8), 3)})
-#'   histogram <- plot_hist(raster, bins = 10)
+#'   histogram <- plot_hist(raster, bins = 10, palette = "Greens", name = "Example")
+#'   histogram()
 #' } else {
 #'   message('reinstall with install.packages("shinyscholar", dependencies = TRUE)
 #'   to run this example')
 #' }
 #' @export
 
-plot_hist <- function(raster, bins, logger = NULL) {
+plot_hist <- function(raster, bins, palette, name, logger = NULL) {
 
   check_suggests()
 
-  if (!("SpatRaster" %in% class(raster))){
-    logger %>% writeLog(type = "error", "The raster must be a SpatRaster")
+  if (!inherits(raster, "SpatRaster")){
+    logger |> writeLog(type = "error", "The raster must be a SpatRaster")
     return()
   }
 
   if (!is.numeric(bins)){
-    logger %>% writeLog(type = "error", "bins must be numeric")
+    logger |> writeLog(type = "error", "bins must be numeric")
+    return()
+  }
+
+  if (!inherits(palette, "character")){
+    logger |> writeLog(type = "error", "palette must be a character string")
+    return()
+  }
+
+  if (!inherits(name, "character")){
+    logger |> writeLog(type = "error", "name must be a character string")
+    return()
+  }
+
+  if (!(palette %in% c("Greens", "YlOrRd", "Greys", "Blues"))){
+    logger |> writeLog(type = "error", "palette must be either 'Greens', 'YlOrRd', 'Greys' or 'Blues'")
     return()
   }
 
@@ -40,5 +58,11 @@ plot_hist <- function(raster, bins, logger = NULL) {
                                            max(raster_values, na.rm = TRUE),
                                            length.out = bins + 1))
   histogram$density <- histogram$counts / sum(histogram$counts) * 100
-  histogram
+
+  pal <- RColorBrewer::brewer.pal(9, palette)
+  pal_ramp <- grDevices::colorRampPalette(c(pal[1], pal[9]))
+  hist_cols <- pal_ramp(bins)
+
+  function(){plot(histogram, freq = F, main = "", xlab = name, ylab = "Frequency (%)", col = hist_cols)}
+
 }

R/plot_scatter_f.R

@@ -5,43 +5,60 @@
 #' @param raster SpatRaster. Raster to be sampled
 #' @param sample numeric. Number of points to sample
 #' @param axis character. Which axis coordinates of the raster to return
+#' @param name character. The name of the raster variable
 #' @param logger Stores all notification messages to be displayed in the Log
 #'   Window. Insert the logger reactive list here for running in
 #'   shiny, otherwise leave the default NULL
-#' @return a dataframe containing the axis values and the cell values
+#' @return a function that generates a scatterplot
 #' @author Simon Smart <simon.smart@@cantab.net>
 #' @examples
 #' if (check_suggests(example = TRUE)) {
 #'   raster <- terra::rast(ncol = 8, nrow = 8)
 #'   raster[] <- sapply(1:terra::ncell(raster), function(x){
 #'      rnorm(1, ifelse(x %% 8 != 0, x %% 8, 8), 3)})
-#'   scatterplot <- plot_scatter(raster, sample = 10, axis = "y")
+#'   scatterplot <- plot_scatter(raster, sample = 10, axis = "Longitude", name = "Example")
+#'   scatterplot()
 #' } else {
 #'   message('reinstall with install.packages("shinyscholar", dependencies = TRUE)
 #'   to run this example')
 #' }
 #' @export
-plot_scatter <- function(raster, sample, axis, logger = NULL) {
+plot_scatter <- function(raster, sample, axis, name, logger = NULL) {
 
   check_suggests()
 
-  if (!("SpatRaster" %in% class(raster))){
-    logger %>% writeLog(type = "error", "The raster must be a SpatRaster")
+  if (!inherits(raster, "SpatRaster")){
+    logger |> writeLog(type = "error", "The raster must be a SpatRaster")
     return()
   }
 
   if (!is.numeric(sample)){
-    logger %>% writeLog(type = "error", "sample must be numeric")
+    logger |> writeLog(type = "error", "sample must be numeric")
     return()
   }
 
-  if (!(axis %in% c("x", "y"))){
-    logger %>% writeLog(type = "error", "axis must be either x or y")
+  if (!inherits(axis, "character")){
+    logger |> writeLog(type = "error", "axis must be a character string")
     return()
   }
 
-  samp <- terra::spatSample(raster, sample, method = "random", xy = TRUE, as.df = TRUE)
-  colnames(samp)[3] <- "value"
-  samp[, c(axis, "value")]
+  if (!(axis %in% c("Longitude", "Latitude"))){
+    logger |> writeLog(type = "error", "axis must be either Latitude or Longitude")
+    return()
+  }
+
+  if (!inherits(name, "character")){
+    logger |> writeLog(type = "error", "name must be a character string")
+    return()
+  }
+
+  if (axis == "Longitude"){short_axis <- "x"} else {short_axis <- "y"}
+
+  sampled <- terra::spatSample(raster, sample, method = "random", xy = TRUE, as.df = TRUE)
+  colnames(sampled)[3] <- "value"
+  sampled <-sampled[, c(short_axis, "value")]
+
+  function(){plot(sampled[[1]], sampled[[2]], xlab = axis, ylab = name)}
+
 
 }