more linting

.lintr

@@ -1,29 +1,38 @@
 linters: all_linters(
     assignment_linter = NULL,
-    commas_linter(allow_trailing = TRUE),
+    commas_linter = NULL,
     consecutive_assertion_linter = NULL,
     duplicate_argument_linter(except = c("mutate", "transmute", "c")),
+    expect_identical_linter = NULL,
+    expect_null_linter = NULL,
+    expect_true_false_linter = NULL,
+    function_argument_linter = NULL,
     implicit_integer_linter = NULL,
     infix_spaces_linter(exclude_operators = c("/", "*")),
     keyword_quote_linter = NULL,
     line_length_linter(120L),
-    missing_argument_linter(except = c("alist", "quote", "switch", "pairlist2")),
+    missing_argument_linter(except = c("alist", "quote", "switch", "pairlist2", "lapply")),
+    nested_ifelse_linter = NULL,
+    nonportable_path_linter = NULL,
     numeric_leading_zero_linter = NULL,
     object_length_linter = NULL,
     object_name_linter(
       styles = c("snake_case", "symbols"),
       regexes = c(
-        misc = "^(F_x|x_1_hat,x_n_hat|R_inv|Amat|Aind)$",
+        misc = "^(F_x|f_X|x_1_hat,x_n_hat|R_inv|Amat|Aind)$",
         CamelCase = "^(RankCorr.*|.*Geom.*|.*Stat.*|Scale.*|Position.*|K|Mode.*|.*Pr.*|.*linearGradient.*|\\.Deprecated.*)$",
         dot.case = "^(na\\.rm|na\\.translate|na\\.value|lower\\.tail|log\\.p|width\\.cutoff)$",
-        bandwidth = "^(bandwidth_.*)$"
+        bandwidth = "^(bandwidth_.*)$",
+        breaks = "^breaks_.*$"
       )
     ),
     object_overwrite_linter(
-      allow_names = c("dist", "data", "layout", "pdf", "q")
+      allow_names = c("dist", "data", "layout", "pdf", "q", "smooth", "scale", "head", "tail", "cut")
     ),
+    object_usage_linter = NULL,
     quotes_linter = NULL,
     scalar_in_linter = NULL,
+    todo_comment_linter = NULL,
     undesirable_function_linter(modify_defaults(
       defaults = all_undesirable_functions,
       library = NULL,

R/density.R

@@ -506,9 +506,9 @@ bandwidth_dpi = auto_partial(name = "bandwidth_dpi", function(x, ...) {
 
     ### one possibility:
     # # use k-means clustering to create bandwidth groups
-    # bw_clusters = Ckmeans.1d.dp::Ckmeans.1d.dp(bw_local, adapt)
-    # bw_group = bw_clusters$cluster
-    # bws = bw_clusters$centers
+    # > bw_clusters = Ckmeans.1d.dp::Ckmeans.1d.dp(bw_local, adapt)
+    # > bw_group = bw_clusters$cluster
+    # > bws = bw_clusters$centers
 
     ### simpler, cut the range of local bandwidths into equally-sized pieces
     ### doesn't work as well though...

R/geom_dotsinterval.R

@@ -375,9 +375,7 @@ GeomDotsinterval = ggproto("GeomDotsinterval", GeomSlabinterval,
     aes_docs
   },
 
-  hidden_aes = union(c(
-    "thickness"
-  ), GeomSlabinterval$hidden_aes),
+  hidden_aes = union("thickness", GeomSlabinterval$hidden_aes),
 
   default_aes = defaults(aes(
     family = "",

R/point_interval.R

@@ -218,9 +218,11 @@ point_interval.default = function(.data, ..., .width = .95, .point = median, .in
         if (inherits(draws, "rvar") && length(draws) > 1) {
           flat_draws = flatten_array(draws)
           draws = flat_draws$x
-          row[[col_name]] = NA # the next line will have to recycle row[[col_name]]
-                               # which may be expensive b/c it is an rvar, so just
-                               # skip that since we're overwriting it after anyway
+          # the line after this (bind_cols()) will have to recycle
+          # row[[col_name]], which may be expensive because it is an rvar,
+          # so we assign NA first to skip that since we're overwriting
+          # row[[col_name]] right after anyway
+          row[[col_name]] = NA
           row = bind_cols(row, .index = flat_draws$index_names)
           row[[col_name]] = draws
         }

R/stat_slabinterval.R

@@ -709,7 +709,9 @@ layer_slabinterval = function(...) {
 # shortcut stats ----------------------------------------------------------
 
 StatHalfeye = StatSlabinterval
-#' @eval rd_slabinterval_shortcut_stat("halfeye", "half-eye (density + interval)", geom_name = "slabinterval", describe = FALSE)
+#' @eval rd_slabinterval_shortcut_stat(
+#'   "halfeye", "half-eye (density + interval)", geom_name = "slabinterval", describe = FALSE
+#' )
 #' @description
 #' Equivalent to [stat_slabinterval()], whose default settings create half-eye (density + interval) plots.
 #' @export
@@ -738,7 +740,9 @@ StatCcdfinterval = ggproto("StatCcdfinterval", StatSlabinterval,
 
   default_slab_type = "ccdf"
 )
-#' @eval rd_slabinterval_shortcut_stat("ccdfinterval", "CCDF bar", geom_name = "slabinterval", example_layers = "expand_limits(x = 0)")
+#' @eval rd_slabinterval_shortcut_stat(
+#'   "ccdfinterval", "CCDF bar", geom_name = "slabinterval", example_layers = "expand_limits(x = 0)"
+#' )
 #' @export
 stat_ccdfinterval = make_stat(StatCcdfinterval, geom = "slabinterval")
 

R/weighted_hist.R

@@ -15,71 +15,12 @@ weighted_hist = function(
   } else {
     paste0("[", x_label, ", ", weights_label, "]")
   }
-
   if (length(x) < 1) cli_abort("{.fun ggdist::density_histogram} requires {.code length(x) >= 1}.")
 
   # figure out breaks
-  if (is.character(breaks)) {
-    breaks = match_function(breaks, prefix = "breaks_")
-  }
-  if (is.function(breaks)) {
-    # don't pass NULL weights to breaks function for compatibility with breaks
-    # functions from other packages that don't support weights; e.g. {scales}
-    if (is.null(weights)) {
-      breaks = breaks(x)
-    } else {
-      breaks = breaks(x, weights = weights)
-    }
-  }
-  if (length(breaks) == 1) {
-    if (length(x) == 1) {
-      breaks = c(x - 0.5, x + 0.5)
-    } else {
-      breaks = seq.int(min(x), max(x), length.out = breaks)
-    }
-    bin_width = diff(breaks)
-    equidist = TRUE
-  } else {
-    breaks = sort(unique(breaks))
-    bin_width = diff(breaks)
-    equidist = diff(range(bin_width)) < 1e-7 * mean(bin_width)
-  }
-
-  weights = weights %||% rep(1, length(x))
-
-  # apply alignment if bins are equidistant
-  if (equidist) {
-    if (is.character(align)) {
-      align = match_function(align, prefix = "align_")
-    }
-    if (is.function(align)) {
-      align = align(breaks)
-    }
-    if (align < 0 || align > bin_width[[1]]) {
-      cli_abort(c(
-        "{.arg align} must be between 0 and the bin width",
-        "i" = "See the {.arg align} argument to {.fun ggdist::density_histogram}."
-      ))
-    }
-
-    # we check for align != 0 even though in theory we could apply a 0 alignment
-    # below and the result would be correct. We do this because then if someone
-    # manually specifies the breaks and no alignment, exactly those breaks are used.
-    if (align != 0) {
-      breaks = breaks - align
-      max_break = breaks[length(breaks)]
-
-      if (max_break < max(x)) {
-        breaks = c(breaks, max_break + bin_width[[1]])
-        bin_width = c(bin_width, bin_width[[1]])
-      }
-      if (length(breaks) > 2 && breaks[[2]] <= min(x)) {
-        breaks = breaks[-1]
-        bin_width = bin_width[-1]
-      }
-    }
-  }
-
+  c(breaks, binwidths, equidist) %<-% get_breaks(x, weights, breaks)
+  # only apply bin alignment if bins are equidistant
+  if (equidist) c(breaks, binwidths) %<-% align_breaks(x, breaks, binwidths, align)
   # check for invalid binning
   if (min(x) < breaks[1] || max(x) > breaks[length(breaks)]) {
     cli_abort("The {.arg breaks} argument to {.fun ggdist::density_histogram} must cover all values of {.arg x}")
@@ -89,6 +30,7 @@ weighted_hist = function(
   bin = findInterval(x, breaks, rightmost.closed = TRUE, left.open = TRUE)
 
   # sum up weights in each bin
+  weights = weights %||% rep(1, length(x))
   counts = rep(0, length(breaks) - 1)
   used_bins = unique(bin)
   counts[used_bins] = tapply(weights, factor(bin, used_bins), sum)
@@ -97,7 +39,7 @@ weighted_hist = function(
     list(
       breaks = breaks,
       counts = counts,
-      density = counts / bin_width / sum(weights),
+      density = counts / binwidths / sum(weights),
       mids = (breaks[-length(breaks)] + breaks[-1])/2,
       xname = label,
       equidist = equidist
@@ -340,6 +282,93 @@ align_center = auto_partial(name = "align_center", function(breaks, at = 0) {
 
 # helpers -----------------------------------------------------------------
 
+#' Given a dataset, weights, and breaks as passed to weighted_hist, return
+#' a named list of breaks and whether or not the breaks are equidistant
+#' @param x data
+#' @param weights weights. vector same length as `x`, or `NULL`.
+#' @param breaks breaks as passed to weighted_hist (e.g. function or name)
+#' @returns list with these elements:
+#'   - `breaks`: vector of breakpoints covering `x`
+#'   - `binwidths`: vector of bin widths of length `length(breaks) - 1`
+#'   - `equidist`: logical: are the breaks equidistant from each other?
+#' @noRd
+get_breaks = function(x, weights, breaks) {
+  if (is.character(breaks)) {
+    breaks = match_function(breaks, prefix = "breaks_")
+  }
+  if (is.function(breaks)) {
+    # don't pass NULL weights to breaks function for compatibility with breaks
+    # functions from other packages that don't support weights; e.g. {scales}
+    if (is.null(weights)) {
+      breaks = breaks(x)
+    } else {
+      breaks = breaks(x, weights = weights)
+    }
+  }
+  if (length(breaks) == 1) {
+    if (length(x) == 1) {
+      breaks = c(x - 0.5, x + 0.5)
+    } else {
+      breaks = seq.int(min(x), max(x), length.out = breaks)
+    }
+    binwidths = diff(breaks)
+    equidist = TRUE
+  } else {
+    breaks = sort(unique(breaks))
+    binwidths = diff(breaks)
+    equidist = diff(range(binwidths)) < 1e-7 * mean(binwidths)
+  }
+
+  list(breaks = breaks, binwidths = binwidths, equidist = equidist)
+}
+
+#' Given a dataset, breaks / binwidths, and an alignment function, returned
+#' the modified breaks / binwidths
+#' @param x data
+#' @param breaks vector of breakpoints
+#' @param binwidths widths of bins; i.e. `diff(breaks)`
+#' @param align alignment function as passed to `weighted_hist` (e.g. function or name)
+#' @returns list with modified breakpoints:
+#'   - `breaks`: vector of breakpoints covering `x`
+#'   - `binwidths`: vector of bin widths of length `length(breaks) - 1`
+align_breaks = function(x, breaks, binwidths, align, call = caller_env()) {
+  if (is.character(align)) {
+    align = match_function(align, prefix = "align_")
+  }
+  if (is.function(align)) {
+    align = align(breaks)
+  }
+  if (align < 0 || align > binwidths[[1]]) {
+    cli_abort(
+      c(
+        "{.arg align} must be between 0 and the bin width",
+        "i" = "See the {.arg align} argument to {.fun ggdist::density_histogram}."
+      ),
+      call = call
+    )
+  }
+
+  # we check for align != 0 even though in theory we could apply a 0 alignment
+  # below and the result would be correct. We do this because then if someone
+  # manually specifies the breaks and no alignment, exactly those breaks are used.
+  if (align != 0) {
+    breaks = breaks - align
+    max_break = breaks[length(breaks)]
+
+    if (max_break < max(x)) {
+      breaks = c(breaks, max_break + binwidths[[1]])
+      binwidths = c(binwidths, binwidths[[1]])
+    }
+    if (length(breaks) > 2 && breaks[[2]] <= min(x)) {
+      breaks = breaks[-1]
+      binwidths = binwidths[-1]
+    }
+  }
+
+  list(breaks = breaks, binwidths = binwidths)
+}
+
+
 #' @importFrom stats weighted.mean
 weighted_var = function(x, weights) {
   sum(weights * (x - weighted.mean(x, weights))^2) / sum(weights)

tests/testthat.R

@@ -3,8 +3,8 @@
 #
 # Where should you do additional test configuration?
 # Learn more about the roles of various files in:
-# * https://r-pkgs.org/tests.html
-# * https://testthat.r-lib.org/reference/test_package.html#special-files
+# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
+# * https://testthat.r-lib.org/articles/special-files.html
 
 library(testthat)
 library(ggdist)

tests/testthat/test.binning_methods.R

@@ -110,8 +110,8 @@ test_that("bin nudging works", {
     NULL
   )
   expect_equal(
-    nudge_bins(c(1), width = 1),
-    c(1)
+    nudge_bins(1, width = 1),
+    1
   )
   expect_equal(
     nudge_bins(c(1,2), width = 1),

tests/testthat/test.lkj_marginal.R

@@ -43,10 +43,10 @@ test_that("lkjcorr_marginal throws an error for invalid K", {
 test_that("marginalize_lkjcorr works", {
   ref = as.data.frame(tibble(
     coef = c("a", "b"),
-    prior = c("lkjcorr(3)", "lkjcorr(3)" ),
+    prior = c("lkjcorr(3)", "lkjcorr(3)"),
     .dist = c("lkjcorr_marginal", "lkjcorr_marginal"),
     .args = list(list(2, 3), list(4, 3)),
-    .dist_obj = dist_wrap(dist = "lkjcorr_marginal", c(2, 4), c(3, 3), package = "ggdist"),
+    .dist_obj = dist_wrap(dist = "lkjcorr_marginal", c(2, 4), c(3, 3), package = "ggdist")
   ))
 
   expect_equal(

tests/testthat/test.rd_lineribbon.R

@@ -23,7 +23,10 @@ test_that("lineribbon aesthetic documention generator works", {
 
 test_that("shortcut stat documentation generator works", {
 
-  stat_output = paste0(rd_lineribbon_shortcut_stat("lineribbon", chart_type = "multiple-ribbon", from_name = "slabinterval"), collapse = "\n")
+  stat_output = paste0(
+    rd_lineribbon_shortcut_stat("lineribbon", chart_type = "multiple-ribbon", from_name = "slabinterval"),
+    collapse = "\n"
+  )
   expect_match(stat_output, "@title Multiple-ribbon plot (shortcut stat)", fixed = TRUE)
   expect_match(stat_output, ".width = c(0.5, 0.8, 0.95)", fixed = TRUE)
 

tests/testthat/test.scale_.R

@@ -38,7 +38,7 @@ test_that("direct scale setting works", {
         slab_linetype = "dotted",
         slab_alpha = .5
       )
-    )
+  )
 })
 
 test_that("mapping custom aesthetics works", {

tests/testthat/test.smooth.R

@@ -30,18 +30,30 @@ test_that("smooth_discrete works", {
   x = rep(1:4, times = 4:1)
 
   ld = layer_data(ggplot() + geom_dots(aes(x), smooth = "discrete"))
-  ref_x = c(0.760112695656659, 0.920256356040445, 1.08040001642423, 1.24054367680802,  1.78654853188863, 2.00007341240034, 2.21359829291206, 2.83977362126489,  3.16006094203247, 3.99967181376766)
+  ref_x = c(
+    0.760112695656659, 0.920256356040445, 1.08040001642423, 1.24054367680802,
+    1.78654853188863, 2.00007341240034, 2.21359829291206, 2.83977362126489,
+    3.16006094203247, 3.99967181376766
+  )
   expect_equal(ld$x, ref_x, tolerance = 0.001)
 
   ld = layer_data(ggplot() + geom_dots(aes(x), smooth = smooth_discrete(kernel = "ep")))
-  ref_x = c(0.816364320617873, 0.944625373470495, 1.05539072151476, 1.18366670884155,  1.84144365484769, 2.00000507797274, 2.15857922335003, 2.88568947241406,  3.11432520840337, 3.99999280566278)
+  ref_x = c(
+    0.816364320617873, 0.944625373470495, 1.05539072151476, 1.18366670884155,
+    1.84144365484769, 2.00000507797274, 2.15857922335003, 2.88568947241406,
+    3.11432520840337, 3.99999280566278
+  )
   expect_equal(ld$x, ref_x, tolerance = 0.001)
 })
 
 test_that("smooth_bounded works", {
   x = 1:10
 
   ld = layer_data(ggplot() + geom_dots(aes(x), smooth = "bounded"))
-  ref_x = c(0.997794316080475, 1.99639357461413, 2.99631978598422, 3.99740164666058,  4.99908084276668, 6.00091915723332, 7.00259835333942, 8.00368021401578,  9.00360642538587, 10.0022056839195)
+  ref_x = c(
+    0.997794316080475, 1.99639357461413, 2.99631978598422, 3.99740164666058,
+    4.99908084276668, 6.00091915723332, 7.00259835333942, 8.00368021401578,
+    9.00360642538587, 10.0022056839195
+  )
   expect_equal(ld$x, ref_x, tolerance = 0.001)
 })

tests/testthat/test.stat_cdfinterval.R

@@ -11,7 +11,7 @@ test_that("dodged ccdf barplots work", {
   skip_if_no_vdiffr()
 
 
-  df = data.frame(y = 1:5, x = "a", g = c("g1")) %>%
+  df = data.frame(y = 1:5, x = "a", g = "g1") %>%
     rbind(data.frame(y = rep(1:5, each = 3) + 1:3, x = "b", g = c("g1", "g2", "g3")))
 
   p = ggplot(df, aes(x = x, y = y))