- Format repository R code using Air.

.Rbuildignore

@@ -23,3 +23,5 @@
 ^CITATION\.cff$
 
 .devcontainer
+^\.vscode$
+^[.]?air[.]toml$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ssdtools
 Title: Species Sensitivity Distributions
-Version: 2.6.0.9001
+Version: 2.6.0.9002
 Authors@R: c(
     person("Joe", "Thorley", , "joe@poissonconsulting.ca", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-7683-4592")),

NEWS.md

@@ -1,5 +1,10 @@
 <!-- NEWS.md is maintained by https://fledge.cynkra.com, contributors should not edit this file -->
 
+# ssdtools 2.6.0.9002
+
+- Format repository R code using Air.
+
+
 # ssdtools 2.6.0.9001
 
 - Update README with consultation process.

R/bcanz.R

@@ -52,14 +52,22 @@ ssd_dists_bcanz <- function(npars = c(2L, 5L)) {
 #' @export
 #' @examples
 #' ssd_fit_bcanz(ssddata::ccme_boron)
-ssd_fit_bcanz <- function(data, left = "Conc", ..., dists = ssd_dists_bcanz(), rescale = FALSE, silent = FALSE) {
+ssd_fit_bcanz <- function(
+  data,
+  left = "Conc",
+  ...,
+  dists = ssd_dists_bcanz(),
+  rescale = FALSE,
+  silent = FALSE
+) {
   chk_data(data)
   chk_unused(...)
   chk_subset(dists, ssd_dists_bcanz())
   chk_flag(rescale)
   chk_flag(silent)
 
-  ssd_fit_dists(data,
+  ssd_fit_dists(
+    data,
     left = left,
     right = left,
     weight = NULL,
@@ -93,9 +101,18 @@ ssd_fit_bcanz <- function(data, left = "Conc", ..., dists = ssd_dists_bcanz(), r
 #' @examples
 #' fits <- ssd_fit_bcanz(ssddata::ccme_boron)
 #' ssd_hc_bcanz(fits, nboot = 100)
-ssd_hc_bcanz <- function(x, proportion = c(0.01, 0.05, 0.1, 0.2), ..., average = TRUE, ci = FALSE, nboot = 10000, min_pboot = 0.8) {
+ssd_hc_bcanz <- function(
+  x,
+  proportion = c(0.01, 0.05, 0.1, 0.2),
+  ...,
+  average = TRUE,
+  ci = FALSE,
+  nboot = 10000,
+  min_pboot = 0.8
+) {
   chk_unused(...)
-  ssd_hc(x,
+  ssd_hc(
+    x,
     proportion = proportion,
     average = average,
     ci = ci,
@@ -127,18 +144,30 @@ ssd_hc_bcanz <- function(x, proportion = c(0.01, 0.05, 0.1, 0.2), ..., average =
 #' @examples
 #' fits <- ssd_fit_bcanz(ssddata::ccme_boron)
 #' ssd_hp_bcanz(fits, nboot = 100)
-ssd_hp_bcanz <- function(x, conc = 1, ..., average = TRUE, ci = FALSE, nboot = 10000, min_pboot = 0.8, proportion = FALSE) {
+ssd_hp_bcanz <- function(
+  x,
+  conc = 1,
+  ...,
+  average = TRUE,
+  ci = FALSE,
+  nboot = 10000,
+  min_pboot = 0.8,
+  proportion = FALSE
+) {
   chk_unused(...)
 
   if (missing(proportion) || isFALSE(proportion)) {
     lifecycle::deprecate_soft(
-      "2.3.1", I("ssd_hp(proportion = FALSE)"), I("ssd_hp(proportion = TRUE)"),
+      "2.3.1",
+      I("ssd_hp(proportion = FALSE)"),
+      I("ssd_hp(proportion = TRUE)"),
       "Please set the `proportion` argument to `ssd_hp_bcanz()` to be TRUE which will cause it to return hazard proportions instead of percentages then update your downstream code accordingly."
     )
   }
   chk_flag(proportion)
 
-  ssd_hp(x,
+  ssd_hp(
+    x,
     conc = conc,
     average = average,
     ci = ci,

R/boot.R

@@ -17,7 +17,11 @@
 
 warn_min_pboot <- function(x, min_pboot) {
   if (any(!is.na(x$pboot) & is.na(x$se) & x$nboot >= 2)) {
-    wrn("One or more pboot values less than ", min_pboot, " (decrease min_pboot with caution).")
+    wrn(
+      "One or more pboot values less than ",
+      min_pboot,
+      " (decrease min_pboot with caution)."
+    )
   }
   x
 }
@@ -26,7 +30,12 @@ sample_nonparametric <- function(data) {
   data[sample(nrow(data), replace = TRUE), ]
 }
 
-sample_parametric <- function(dist, args = args, weighted = weighted, censoring = censoring) {
+sample_parametric <- function(
+  dist,
+  args = args,
+  weighted = weighted,
+  censoring = censoring
+) {
   what <- paste0("ssd_r", dist)
   args$chk <- FALSE
   sample <- do.call(what, args)
@@ -39,7 +48,12 @@ generate_data <- function(dist, data, args, weighted, censoring, parametric) {
   if (!parametric) {
     return(sample_nonparametric(data))
   }
-  sample_parametric(dist, args = args, weighted = weighted, censoring = censoring)
+  sample_parametric(
+    dist,
+    args = args,
+    weighted = weighted,
+    censoring = censoring
+  )
 }
 
 boot_filename <- function(i, dist, prefix, ext = NULL, sep = "_") {
@@ -50,9 +64,29 @@ boot_filepath <- function(i, dist, save_to, prefix = "data", ext = ".csv") {
   file.path(save_to, boot_filename(i, dist, prefix = prefix, ext = ext))
 }
 
-sample_parameters <- function(i, dist, fun, data, args, pars, weighted, censoring, min_pmix, range_shape1, range_shape2, parametric, control, save_to, wts = NULL) {
-  new_data <- generate_data(dist,
-    data = data, args = args, weighted = weighted, censoring = censoring,
+sample_parameters <- function(
+  i,
+  dist,
+  fun,
+  data,
+  args,
+  pars,
+  weighted,
+  censoring,
+  min_pmix,
+  range_shape1,
+  range_shape2,
+  parametric,
+  control,
+  save_to,
+  wts = NULL
+) {
+  new_data <- generate_data(
+    dist,
+    data = data,
+    args = args,
+    weighted = weighted,
+    censoring = censoring,
     parametric = parametric
   )
 
@@ -69,10 +103,17 @@ sample_parameters <- function(i, dist, fun, data, args, pars, weighted, censorin
     dist2 <- dist
   }
 
-  fit <- fun(new_data, dist2,
-    min_pmix = min_pmix, range_shape1 = range_shape1,
-    range_shape2 = range_shape2, control = control, pars = pars, hessian = FALSE,
-    censoring = censoring, weighted = weighted
+  fit <- fun(
+    new_data,
+    dist2,
+    min_pmix = min_pmix,
+    range_shape1 = range_shape1,
+    range_shape2 = range_shape2,
+    control = control,
+    pars = pars,
+    hessian = FALSE,
+    censoring = censoring,
+    weighted = weighted
   )$result
 
   if (is.null(fit)) {
@@ -81,7 +122,10 @@ sample_parameters <- function(i, dist, fun, data, args, pars, weighted, censorin
   est <- estimates(fit, all_estimates = TRUE)
 
   if (!is.null(save_to)) {
-    saveRDS(est, boot_filepath(i, dist, save_to, prefix = "estimates", ext = ".rds"))
+    saveRDS(
+      est,
+      boot_filepath(i, dist, save_to, prefix = "estimates", ext = ".rds")
+    )
   }
 
   if (!is.null(wts)) {
@@ -90,7 +134,23 @@ sample_parameters <- function(i, dist, fun, data, args, pars, weighted, censorin
   est
 }
 
-boot_estimates <- function(fun, dist, estimates, pars, nboot, data, weighted, censoring, range_shape1, range_shape2, min_pmix, parametric, control, save_to, ci_method) {
+boot_estimates <- function(
+  fun,
+  dist,
+  estimates,
+  pars,
+  nboot,
+  data,
+  weighted,
+  censoring,
+  range_shape1,
+  range_shape2,
+  min_pmix,
+  parametric,
+  control,
+  save_to,
+  ci_method
+) {
   sfun <- safely(fun)
 
   args <- list(n = nrow(data))
@@ -111,20 +171,35 @@ boot_estimates <- function(fun, dist, estimates, pars, nboot, data, weighted, ce
       err("Package 'readr' must be installed.")
     }
     readr::write_csv(data, boot_filepath(0, dist, save_to))
-    saveRDS(estimates, boot_filepath(0, dist, save_to, prefix = "estimates", ext = ".rds"))
+    saveRDS(
+      estimates,
+      boot_filepath(0, dist, save_to, prefix = "estimates", ext = ".rds")
+    )
   }
 
-  estimates <- future_map(seq_len(nboot), sample_parameters,
-    dist = dist, fun = sfun,
-    data = data, args = args, pars = pars,
-    weighted = weighted, censoring = censoring, min_pmix = min_pmix,
-    range_shape1 = range_shape1, range_shape2 = range_shape2,
-    parametric = parametric, control = control, save_to = save_to,
+  estimates <- future_map(
+    seq_len(nboot),
+    sample_parameters,
+    dist = dist,
+    fun = sfun,
+    data = data,
+    args = args,
+    pars = pars,
+    weighted = weighted,
+    censoring = censoring,
+    min_pmix = min_pmix,
+    range_shape1 = range_shape1,
+    range_shape2 = range_shape2,
+    parametric = parametric,
+    control = control,
+    save_to = save_to,
     wts = wts,
     .options = furrr::furrr_options(seed = seeds)
   )
-  names(estimates) <- boot_filename(seq_along(estimates),
-    prefix = "", sep = "",
+  names(estimates) <- boot_filename(
+    seq_along(estimates),
+    prefix = "",
+    sep = "",
     dist = paste0("_", dist)
   )
   estimates[!vapply(estimates, is.null, TRUE)]

R/burrlioz.R

@@ -15,30 +15,59 @@
 #    See the License for the specific language governing permissions and
 #    limitations under the License.
 
-fit_burrlioz <- function(data, dist, min_pmix, range_shape1, range_shape2,
-                         control, pars, hessian, ...) {
-  burrIII3 <- fit_tmb(data, dist,
-    min_pmix = min_pmix, range_shape1 = range_shape1,
-    range_shape2 = range_shape2, control = control,
-    pars = pars, hessian = hessian
+fit_burrlioz <- function(
+  data,
+  dist,
+  min_pmix,
+  range_shape1,
+  range_shape2,
+  control,
+  pars,
+  hessian,
+  ...
+) {
+  burrIII3 <- fit_tmb(
+    data,
+    dist,
+    min_pmix = min_pmix,
+    range_shape1 = range_shape1,
+    range_shape2 = range_shape2,
+    control = control,
+    pars = pars,
+    hessian = hessian
   )
 
-  if (is_at_boundary(burrIII3, data,
-    range_shape1 = range_shape1,
-    range_shape2 = range_shape2, regex = "shape2$"
-  )) {
+  if (
+    is_at_boundary(
+      burrIII3,
+      data,
+      range_shape1 = range_shape1,
+      range_shape2 = range_shape2,
+      regex = "shape2$"
+    )
+  ) {
     dist <- "invpareto"
-  } else if (is_at_boundary(burrIII3, data,
-    range_shape1 = range_shape1,
-    range_shape2 = range_shape2, regex = "shape1$"
-  )) {
+  } else if (
+    is_at_boundary(
+      burrIII3,
+      data,
+      range_shape1 = range_shape1,
+      range_shape2 = range_shape2,
+      regex = "shape1$"
+    )
+  ) {
     dist <- "lgumbel"
   } else {
     return(burrIII3)
   }
-  fit_tmb(data, dist,
-    min_pmix = min_pmix, range_shape1 = range_shape1,
-    range_shape2 = range_shape2, control = control,
-    pars = NULL, hessian = hessian
+  fit_tmb(
+    data,
+    dist,
+    min_pmix = min_pmix,
+    range_shape1 = range_shape1,
+    range_shape2 = range_shape2,
+    control = control,
+    pars = NULL,
+    hessian = hessian
   )
 }