use more rlang

Closes #198

* stop -> abort
* warning -> warn
* message -> inform
* setNames -> set_names

Author: jgabry

R/available-module-functions.R

@@ -17,30 +17,30 @@
 #' available_ppc("grouped", invert = TRUE)
 #'
 available_ppc <- function(pattern, fixed = FALSE, invert = FALSE) {
-  .list_module_functions("ppc", .pattern = pattern,
-                         fixed = fixed, invert = invert)
+  .list_module_functions("ppc",
+                         .pattern = pattern,
+                         fixed = fixed,
+                         invert = invert)
 }
 
 #' @rdname available_ppc
 #' @export
 available_mcmc <- function(pattern, fixed = FALSE, invert = FALSE) {
-  .list_module_functions("mcmc", .pattern = pattern,
-                         fixed = fixed, invert = invert)
+  .list_module_functions("mcmc",
+                         .pattern = pattern,
+                         fixed = fixed,
+                         invert = invert)
 }
 
 #' @export
 print.bayesplot_function_list <- function(x, ...) {
   atts <- attributes(x)
   cat("bayesplot", toupper(atts[["module"]]), "module:\n")
-  if (!is.null(atts[["pattern"]]))
-    cat(paste0(
-      "(",
-      ifelse(atts[["inverted"]], "excluding", "matching"),
-      " pattern '",
-      atts[["pattern"]],
-      "')"
-    ), "\n")
-
+  if (!is.null(atts[["pattern"]])) {
+    msg <- paste0("(", ifelse(atts[["inverted"]], "excluding", "matching"),
+                  " pattern '", atts[["pattern"]], "')")
+    cat(msg, "\n")
+  }
   cat(paste0("  ", x), sep = "\n")
   invisible(x)
 }
@@ -54,26 +54,28 @@ print.bayesplot_function_list <- function(x, ...) {
            invert = FALSE) {
 
     .module <- match.arg(.module)
-    if (missing(.pattern))
+    if (missing(.pattern)) {
       .pattern <- NULL
+    }
 
-    funs <- sort(grep(
-      paste0("^", .module, "_"),
-      getNamespaceExports("bayesplot"),
+    all_funs <- grep(
+      pattern = paste0("^", .module, "_"),
+      x = getNamespaceExports("bayesplot"),
       value = TRUE
-    ))
+    )
+    return_funs <- sort(all_funs)
+
+    if (!is.null(.pattern)) {
+      return_funs <- grep(
+        pattern = .pattern,
+        x = return_funs,
+        value = TRUE,
+        fixed = fixed,
+        invert = invert
+      )
+    }
     structure(
-      .Data =
-        if (is.null(.pattern))
-          funs
-        else
-          grep(
-            pattern = .pattern,
-            x = funs,
-            value = TRUE,
-            fixed = fixed,
-            invert = invert
-          ),
+      return_funs,
       class = c("bayesplot_function_list", "character"),
       module = .module,
       pattern = .pattern,

R/bayesplot-colors.R

@@ -129,13 +129,16 @@ NULL
 #' @rdname bayesplot-colors
 #' @export
 color_scheme_set <- function(scheme = "blue") {
-  stopifnot(is.character(scheme))
+  if (!is.character(scheme)) {
+    abort("'scheme' should be a character vector of length 1 or 6.")
+  }
+
   if (length(scheme) == 1) {
     x <- scheme_from_string(scheme)
   } else if (length(scheme) == 6) {
     x <- prepare_custom_colors(scheme)
   } else {
-    stop("'scheme' should be a character vector of length 1 or 6.")
+    abort("'scheme' should be a character vector of length 1 or 6.")
   }
   .bayesplot_aesthetics[["scheme"]] <- x
   invisible(x)
@@ -193,7 +196,7 @@ print.bayesplot_scheme <- function(x, ...) {
 
 #' @export
 plot.bayesplot_scheme <- function(x, ...) {
-  scheme <- attr(x, "scheme_name") %||% stop("Scheme name not found.")
+  scheme <- attr(x, "scheme_name") %||% abort("Scheme name not found.")
   plot_scheme(scheme)
 }
 
@@ -248,25 +251,23 @@ scheme_level_names <- function() {
 #' @noRd
 #' @param scheme A string (length 1) naming a scheme
 scheme_from_string <- function(scheme) {
-  stopifnot(length(scheme) == 1)
   if (identical(substr(scheme, 1, 4), "mix-")) {
     # user specified a mixed scheme (e.g., "mix-blue-red")
     to_mix <- unlist(strsplit(scheme, split = "-"))[2:3]
-    x <- setNames(mixed_scheme(to_mix[1], to_mix[2]), scheme_level_names())
+    x <- set_names(mixed_scheme(to_mix[1], to_mix[2]), scheme_level_names())
     return(structure(x, mixed = TRUE, scheme_name = scheme))
   } else if (identical(substr(scheme, 1, 7), "brewer-")) {
     # user specified a ColorBrewer scheme (e.g., "brewer-Blues")
     if (!requireNamespace("RColorBrewer", quietly = TRUE)) {
-      stop("Please install the 'RColorBrewer' package to use a ColorBrewer scheme.",
-           call. = FALSE)
+      abort("Please install the 'RColorBrewer' package to use a ColorBrewer scheme.")
     }
     clrs <- RColorBrewer::brewer.pal(n = 6, name = gsub("brewer-", "", scheme))
-    x <- setNames(as.list(clrs), scheme_level_names())
+    x <- set_names(as.list(clrs), scheme_level_names())
     return(structure(x, mixed = FALSE, scheme_name = scheme))
   } else {
     # check for scheme in master_color_list
     scheme <- match.arg(scheme, choices = names(master_color_list))
-    x <- setNames(master_color_list[[scheme]], scheme_level_names())
+    x <- set_names(master_color_list[[scheme]], scheme_level_names())
     return(structure(x, mixed = FALSE, scheme_name = scheme))
   }
 }
@@ -331,8 +332,7 @@ full_level_name <- function(x) {
 # Custom color scheme if 6 colors specified
 prepare_custom_colors <- function(scheme) {
   if (length(scheme) != 6) {
-    stop("Custom color schemes must contain exactly 6 colors.",
-         call. = FALSE)
+    abort("Custom color schemes must contain exactly 6 colors.")
   }
 
   not_found <- character(0)
@@ -343,16 +343,15 @@ prepare_custom_colors <- function(scheme) {
     }
   }
   if (length(not_found)) {
-    stop(
+    abort(paste(
       "Each color must specified as either a hexidecimal color value ",
       "(e.g. '#C79999') or the name of a color (e.g. 'blue'). ",
-      "The following provided colors were not found: ",
-      paste(unlist(not_found), collapse = ", "),
-      call. = FALSE
-    )
+      "The following provided colors were not found:",
+      paste(unlist(not_found), collapse = ", ")
+    ))
   }
 
-  x <- setNames(as.list(scheme), scheme_level_names())
+  x <- set_names(as.list(scheme), scheme_level_names())
   attr(x, "scheme_name") <- "custom"
   x
 }

R/bayesplot-extractors.R

@@ -86,8 +86,7 @@ log_posterior.stanfit <- function(object, inc_warmup = FALSE, ...) {
                                 inc_warmup = inc_warmup,
                                 ...)
   lp <- lapply(lp, as.array)
-  lp <- setNames(reshape2::melt(lp),
-                 c("Iteration", "Value", "Chain"))
+  lp <- set_names(reshape2::melt(lp), c("Iteration", "Value", "Chain"))
   validate_df_classes(lp, c("integer", "numeric", "integer"))
 }
 
@@ -96,9 +95,7 @@ log_posterior.stanfit <- function(object, inc_warmup = FALSE, ...) {
 #' @method log_posterior stanreg
 #'
 log_posterior.stanreg <- function(object, inc_warmup = FALSE, ...) {
-  log_posterior.stanfit(object$stanfit,
-                        inc_warmup = inc_warmup,
-                        ...)
+  log_posterior.stanfit(object$stanfit, inc_warmup = inc_warmup, ...)
 }
 
 
@@ -136,24 +133,27 @@ nuts_params.stanreg <-
 #' @export
 #' @method nuts_params list
 nuts_params.list <- function(object, pars = NULL, ...) {
-  if (!all(sapply(object, is.matrix)))
-    stop("All list elements should be matrices.")
+  if (!all(sapply(object, is.matrix))) {
+    abort("All list elements should be matrices.")
+  }
 
   dd <- lapply(object, dim)
-  if (length(unique(dd)) != 1)
-    stop("All matrices in the list must have the same dimensions.")
+  if (length(unique(dd)) != 1) {
+    abort("All matrices in the list must have the same dimensions.")
+  }
 
   nms <- lapply(object, colnames)
-  if (length(unique(nms)) != 1)
-    stop("All matrices in the list must have the same column names.")
+  if (length(unique(nms)) != 1) {
+    abort("All matrices in the list must have the same column names.")
+  }
 
-  if (length(pars))
-    object <- lapply(object, function(x)
-      x[, pars, drop = FALSE])
+  if (length(pars)) {
+    object <- lapply(object, function(x) x[, pars, drop = FALSE])
+  }
 
-  object <- setNames(reshape2::melt(object),
-                     c("Iteration", "Parameter", "Value", "Chain"))
-  validate_df_classes(object, c("integer", "factor", "numeric", "integer"))
+  out <- reshape2::melt(object)
+  out <- set_names(out, c("Iteration", "Parameter", "Value", "Chain"))
+  validate_df_classes(out, c("integer", "factor", "numeric", "integer"))
 }
 
 
@@ -220,7 +220,6 @@ neff_ratio.stanreg <- function(object, pars = NULL, regex_pars = NULL, ...) {
   if (!is.null(pars) || !is.null(regex_pars)) {
     return(ratio)
   }
-
   ratio[!names(ratio) %in% c("mean_PPD", "log-posterior")]
 }
 
@@ -240,9 +239,9 @@ validate_df_classes <- function(x, classes = character()) {
     ncol(x) == length(classes)
   )
   for (j in 1:ncol(x)) {
-    if (!inherits(x[, j], classes[j]))
-      stop(colnames(x)[j], " does not have class ", classes[j],
-           call. = FALSE)
+    if (!inherits(x[, j], classes[j])) {
+      abort(paste0(colnames(x)[j], " does not have class ", classes[j]))
+    }
   }
-  return(x)
+  x
 }

R/bayesplot-ggplot-themes.R

@@ -145,8 +145,10 @@ bayesplot_theme_get <- function() {
 bayesplot_theme_set <- function(new = theme_default()) {
   missing <- setdiff(names(ggplot2::theme_gray()), names(new))
   if (length(missing)) {
-    warning("New theme missing the following elements: ",
-            paste(missing, collapse = ", "), call. = FALSE)
+    warn(paste(
+      "New theme missing the following elements:",
+      paste(missing, collapse = ", ")
+    ))
   }
 
   old <- .bayesplot_theme_env$current

R/bayesplot-helpers.R

@@ -302,7 +302,7 @@ lbub <- function(p, med = TRUE) {
 # internal
 calc_v <- function(v, fun, fun_args, ...) {
   if (missing(v))
-    stop("'v' can't be missing.", call. = FALSE)
+    abort("'v' can't be missing.")
   if (missing(fun))
     return(v)
   f <- match.fun(fun)

R/bayesplot_grid.R

@@ -80,16 +80,16 @@ bayesplot_grid <-
     suggested_package("gridExtra")
     dots <- list(...)
     if (length(dots) && length(plots)) {
-      stop("Arguments '...' and 'plots' can't both be specified.")
+      abort("Arguments '...' and 'plots' can't both be specified.")
     } else if (length(plots)) {
       if (!is.list(plots) || !all_ggplot(plots))
-        stop("'plots' must be a list of ggplot objects.")
+        abort("'plots' must be a list of ggplot objects.")
     } else if (length(dots)) {
       if (!all_ggplot(dots))
-        stop("All objects in '...' must be ggplot objects.")
+        abort("All objects in '...' must be ggplot objects.")
       plots <- dots
     } else {
-      stop("No plots specified.")
+      abort("No plots specified.")
     }
 
     if (length(titles)) {