diff --git a/.Rbuildignore b/.Rbuildignore index 8edbb0801..f2851f9f2 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,5 @@ ^CITATION\.cff$ .devcontainer +^\.vscode$ +^[.]?air[.]toml$ diff --git a/DESCRIPTION b/DESCRIPTION index f2278afbb..01e92edb8 100644 --- a/DESCRIPTION +++ b/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")), diff --git a/NEWS.md b/NEWS.md index 3d511e940..6f20e1f17 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ +# ssdtools 2.6.0.9002 + +- Format repository R code using Air. + + # ssdtools 2.6.0.9001 - Update README with consultation process. diff --git a/R/bcanz.R b/R/bcanz.R index bef438e53..8c51aa814 100644 --- a/R/bcanz.R +++ b/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, diff --git a/R/boot.R b/R/boot.R index 5e7fb2f8a..9e9545bff 100644 --- a/R/boot.R +++ b/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)] diff --git a/R/burrlioz.R b/R/burrlioz.R index df0ecb834..2df64d67b 100644 --- a/R/burrlioz.R +++ b/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 ) } diff --git a/R/burrrIII3.R b/R/burrrIII3.R index fb80b300b..7f9a6e222 100644 --- a/R/burrrIII3.R +++ b/R/burrrIII3.R @@ -20,10 +20,22 @@ #' @examples #' #' ssd_pburrIII3(1) -ssd_pburrIII3 <- function(q, shape1 = 1, shape2 = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("burrIII3", - q = q, shape1 = shape1, shape2 = shape2, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_pburrIII3 <- function( + q, + shape1 = 1, + shape2 = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "burrIII3", + q = q, + shape1 = shape1, + shape2 = shape2, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -32,10 +44,22 @@ ssd_pburrIII3 <- function(q, shape1 = 1, shape2 = 1, scale = 1, lower.tail = TRU #' @examples #' #' ssd_qburrIII3(0.5) -ssd_qburrIII3 <- function(p, shape1 = 1, shape2 = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("burrIII3", - p = p, shape1 = shape1, shape2 = shape2, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_qburrIII3 <- function( + p, + shape1 = 1, + shape2 = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "burrIII3", + p = p, + shape1 = shape1, + shape2 = shape2, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -48,7 +72,14 @@ ssd_qburrIII3 <- function(p, shape1 = 1, shape2 = 1, scale = 1, lower.tail = TRU #' }) #' hist(x, breaks = 1000) ssd_rburrIII3 <- function(n, shape1 = 1, shape2 = 1, scale = 1, chk = TRUE) { - rdist("burrIII3", n = n, shape1 = shape1, shape2 = shape2, scale = scale, chk = chk) + rdist( + "burrIII3", + n = n, + shape1 = shape1, + shape2 = shape2, + scale = scale, + chk = chk + ) } #' @describeIn ssd_e Default Parameter Values for BurrIII Distribution diff --git a/R/censor.R b/R/censor.R index fe7deb7d5..f9b0b79c7 100644 --- a/R/censor.R +++ b/R/censor.R @@ -27,7 +27,13 @@ #' #' @examples #' ssd_censor_data(ssddata::ccme_boron, censoring = c(2.5, Inf)) -ssd_censor_data <- function(data, left = "Conc", ..., right = left, censoring = c(0, Inf)) { +ssd_censor_data <- function( + data, + left = "Conc", + ..., + right = left, + censoring = c(0, Inf) +) { .chk_data(data, left, right) chk_unused(...) chk_numeric(censoring) @@ -59,7 +65,11 @@ censoring_text <- function(x) { return("inconsistently censored") } left <- if (x[1] == 0) NULL else paste0("left (", signif(x[1], 4), ")") - right <- if (is.infinite(x[2])) NULL else paste0("right (", signif(x[2], 4), ")") + right <- if (is.infinite(x[2])) { + NULL + } else { + paste0("right (", signif(x[2], 4), ")") + } censoring <- c(left, right) censoring <- cc(censoring, conj = " and ", brac = "") censoring <- paste0(censoring, " censored") diff --git a/R/chk.R b/R/chk.R index 81e741cc6..90a33bcea 100644 --- a/R/chk.R +++ b/R/chk.R @@ -15,7 +15,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -.chk_data <- function(data, left, right, odds = FALSE, weight = NULL, nrow = 0, missing = FALSE) { +.chk_data <- function( + data, + left, + right, + odds = FALSE, + weight = NULL, + nrow = 0, + missing = FALSE +) { chk_string(left) chk_string(right) chk_null_or(weight, vld = vld_string) @@ -49,10 +57,19 @@ data[[weight]] <- as.double(data[[weight]]) } check_data(data, values, nrow = c(nrow, Inf)) - if (any(!is.na(data[[right]]) & !is.na(data[[left]]) & data[[right]] < data[[left]])) { + if ( + any( + !is.na(data[[right]]) & + !is.na(data[[left]]) & + data[[right]] < data[[left]] + ) + ) { msg <- paste0( - "`data$", right, "` must have values greater than or equal to `data$", - left, "`" + "`data$", + right, + "` must have values greater than or equal to `data$", + left, + "`" ) abort_chk(msg) } @@ -65,7 +82,11 @@ (is.na(data$right) | data$right == 0 | is.infinite(data$right)) if (any(missing)) { - msg <- paste0("`data` has %n row%s with effectively missing values in '", left, "'") + msg <- paste0( + "`data` has %n row%s with effectively missing values in '", + left, + "'" + ) if (right != left && any(data$left != data$right)) { msg <- paste0(msg, " and '", right, "'") } @@ -74,11 +95,21 @@ } zero_weight <- data$weight == 0 if (any(zero_weight)) { - abort_chk("`data` has %n row%s with zero weight in '", weight, "'", n = sum(zero_weight)) + abort_chk( + "`data` has %n row%s with zero weight in '", + weight, + "'", + n = sum(zero_weight) + ) } inf_weight <- is.infinite(data$weight) if (any(inf_weight)) { - abort_chk("`data` has %n row%s with Inf weight in '", weight, "'", n = sum(inf_weight)) + abort_chk( + "`data` has %n row%s with Inf weight in '", + weight, + "'", + n = sum(inf_weight) + ) } org_data } diff --git a/R/ci-methods.R b/R/ci-methods.R index 743bcb3b1..062254025 100644 --- a/R/ci-methods.R +++ b/R/ci-methods.R @@ -12,8 +12,13 @@ #' ssd_ci_methods() ssd_ci_methods <- function() { sort(c( - "MACL", "GMACL", - "multi_fixed", "multi_free", "arithmetic_samples", "geometric_samples", "weighted_samples" + "MACL", + "GMACL", + "multi_fixed", + "multi_free", + "arithmetic_samples", + "geometric_samples", + "weighted_samples" )) ## TODO: add "MATA" method? } diff --git a/R/cis.R b/R/cis.R index eeb5a2a6a..1f2d08c1c 100644 --- a/R/cis.R +++ b/R/cis.R @@ -26,7 +26,10 @@ xcis_estimates <- function(x, args, n, what, level, samples) { quantile <- unname(quantile(ests, probs = probs(level))) samples <- if (samples) ests else numeric(0) tibble( - se = sd(ests), log_se = sd(log(ests)), lcl = quantile[1], ucl = quantile[2], + se = sd(ests), + log_se = sd(log(ests)), + lcl = quantile[1], + ucl = quantile[2], samples = list(samples), row.names = NULL ) diff --git a/R/convergence.R b/R/convergence.R index 4322a63a8..8b0c48f9d 100644 --- a/R/convergence.R +++ b/R/convergence.R @@ -30,7 +30,8 @@ optimizer_converged <- function(fit) { optimizer_message <- function(fit) { code <- as.character(optim_convergence(fit)) - switch(code, + switch( + code, "1" = "Iteration limit maxit reach (try increasing the maximum number of iterations in control).", "10" = "Degeneracy of Nelder-Mead simplex.", optim_message(fit) diff --git a/R/dists.R b/R/dists.R index b5e16a562..1148646b2 100644 --- a/R/dists.R +++ b/R/dists.R @@ -29,7 +29,13 @@ #' ssd_dists(bcanz = TRUE) #' ssd_dists(tails = FALSE) #' ssd_dists(npars = 5) -ssd_dists <- function(bcanz = NULL, ..., tails = NULL, npars = 2:5, valid = TRUE) { +ssd_dists <- function( + bcanz = NULL, + ..., + tails = NULL, + npars = 2:5, + valid = TRUE +) { chk_unused(...) chk_null_or(bcanz, vld = vld_flag) chk_null_or(tails, vld = vld_flag) diff --git a/R/fit-burrlioz.R b/R/fit-burrlioz.R index b8b730395..3d1b67dd5 100644 --- a/R/fit-burrlioz.R +++ b/R/fit-burrlioz.R @@ -29,18 +29,25 @@ #' @export #' @examples #' ssd_fit_burrlioz(ssddata::ccme_boron) -ssd_fit_burrlioz <- function(data, - left = "Conc", - ..., - rescale = FALSE, - control = list(), - silent = FALSE) { +ssd_fit_burrlioz <- function( + data, + left = "Conc", + ..., + rescale = FALSE, + control = list(), + silent = FALSE +) { chk_unused(...) if (nrow(data) <= 8) { - fit <- ssd_fit_dists(data, - left = left, dists = "llogis", - computable = FALSE, nrow = 5L, - rescale = rescale, silent = silent, control = control + fit <- ssd_fit_dists( + data, + left = left, + dists = "llogis", + computable = FALSE, + nrow = 5L, + rescale = rescale, + silent = silent, + control = control ) class(fit) <- c("fitburrlioz", class(fit)) return(fit) @@ -50,10 +57,14 @@ ssd_fit_burrlioz <- function(data, range_shape2 <- c(0.001, 80) fit <- try( - ssd_fit_dists(data, - left = left, dists = "burrIII3", - rescale = rescale, computable = FALSE, - at_boundary_ok = TRUE, silent = TRUE, + ssd_fit_dists( + data, + left = left, + dists = "burrIII3", + rescale = rescale, + computable = FALSE, + at_boundary_ok = TRUE, + silent = TRUE, control = control, range_shape1 = range_shape1, range_shape2 = range_shape2 @@ -65,30 +76,47 @@ ssd_fit_burrlioz <- function(data, range_shape1 <- c(0.05, 20) range_shape2 <- c(0.05, 20) - fit <- ssd_fit_dists(data, - left = left, dists = "burrIII3", - rescale = rescale, computable = FALSE, - at_boundary_ok = TRUE, silent = TRUE, + fit <- ssd_fit_dists( + data, + left = left, + dists = "burrIII3", + rescale = rescale, + computable = FALSE, + at_boundary_ok = TRUE, + silent = TRUE, range_shape1 = range_shape1, range_shape2 = range_shape2 ) } dist <- "burrIII3" - if (is_at_boundary(fit$burrIII3, data, - range_shape1 = range_shape1, - range_shape2 = range_shape2, regex = "shape2$" - )) { + if ( + is_at_boundary( + fit$burrIII3, + data, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + regex = "shape2$" + ) + ) { dist <- "invpareto" - } else if (is_at_boundary(fit$burrIII3, data, - range_shape1 = range_shape1, - range_shape2 = range_shape2, regex = "shape1$" - )) { + } else if ( + is_at_boundary( + fit$burrIII3, + data, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + regex = "shape1$" + ) + ) { dist <- "lgumbel" } - fit <- ssd_fit_dists(data, - left = left, dists = dist, - rescale = rescale, computable = FALSE, + fit <- ssd_fit_dists( + data, + left = left, + dists = dist, + rescale = rescale, + computable = FALSE, silent = silent, range_shape1 = range_shape1, range_shape2 = range_shape2 diff --git a/R/fit-dists.R b/R/fit-dists.R index 368f26e52..02bf4ff13 100644 --- a/R/fit-dists.R +++ b/R/fit-dists.R @@ -16,8 +16,18 @@ # limitations under the License. ## required to pass dist as not available for dists that didn't fit -nullify_nonfit <- function(fit, dist, data, rescale, computable, - min_pmix, range_shape1, range_shape2, at_boundary_ok, silent) { +nullify_nonfit <- function( + fit, + dist, + data, + rescale, + computable, + min_pmix, + range_shape1, + range_shape2, + at_boundary_ok, + silent +) { error <- fit$error fit <- fit$result @@ -26,21 +36,32 @@ nullify_nonfit <- function(fit, dist, data, rescale, computable, if (!is.null(error)) { if (!silent) { wrn( - "Distribution '", dist, "' failed to fit", - rescale, ": ", error + "Distribution '", + dist, + "' failed to fit", + rescale, + ": ", + error ) } return(NULL) } fit$flags$at_boundary <- is_at_boundary( - fit, data, min_pmix, range_shape1, range_shape2 + fit, + data, + min_pmix, + range_shape1, + range_shape2 ) if (!at_boundary_ok && fit$flags$at_boundary) { if (!silent) { wrn( - "Distribution '", dist, "' failed to fit", - rescale, ": one or more parameters at boundary." + "Distribution '", + dist, + "' failed to fit", + rescale, + ": one or more parameters at boundary." ) } return(NULL) @@ -50,8 +71,12 @@ nullify_nonfit <- function(fit, dist, data, rescale, computable, message <- optimizer_message(fit) if (!silent) { wrn( - "Distribution '", dist, "' failed to converge", - rescale, ": ", message + "Distribution '", + dist, + "' failed to converge", + rescale, + ": ", + message ) } return(NULL) @@ -60,8 +85,11 @@ nullify_nonfit <- function(fit, dist, data, rescale, computable, if (computable && !fit$flags$computable) { if (!silent) { wrn( - "Distribution '", dist, - "' failed to compute standard errors", rescale, "." + "Distribution '", + dist, + "' failed to compute standard errors", + rescale, + "." ) } return(NULL) @@ -69,20 +97,51 @@ nullify_nonfit <- function(fit, dist, data, rescale, computable, fit } -remove_nonfits <- function(fits, data, rescale, computable, min_pmix, range_shape1, range_shape2, at_boundary_ok, silent) { - fits <- mapply(nullify_nonfit, fits, names(fits), +remove_nonfits <- function( + fits, + data, + rescale, + computable, + min_pmix, + range_shape1, + range_shape2, + at_boundary_ok, + silent +) { + fits <- mapply( + nullify_nonfit, + fits, + names(fits), MoreArgs = list( - data = data, rescale = rescale, computable = computable, + data = data, + rescale = rescale, + computable = computable, min_pmix = min_pmix, - range_shape1 = range_shape1, range_shape2 = range_shape2, - at_boundary_ok = at_boundary_ok, silent = silent - ), SIMPLIFY = FALSE + range_shape1 = range_shape1, + range_shape2 = range_shape2, + at_boundary_ok = at_boundary_ok, + silent = silent + ), + SIMPLIFY = FALSE ) fits <- fits[!vapply(fits, is.null, TRUE)] fits } -fit_dists <- function(data, dists, min_pmix, range_shape1, range_shape2, control, at_boundary_ok = TRUE, silent = TRUE, rescale = FALSE, computable = FALSE, pars = NULL, hessian = TRUE) { +fit_dists <- function( + data, + dists, + min_pmix, + range_shape1, + range_shape2, + control, + at_boundary_ok = TRUE, + silent = TRUE, + rescale = FALSE, + computable = FALSE, + pars = NULL, + hessian = TRUE +) { data <- data[c("left", "right", "weight")] safe_fit_dist <- safely(fit_tmb) names(dists) <- dists @@ -92,32 +151,61 @@ fit_dists <- function(data, dists, min_pmix, range_shape1, range_shape2, control pars <- rep(list(NULL), length(dists)) } - fits <- purrr::map2(dists, pars, + fits <- purrr::map2( + dists, + pars, .f = safe_fit_dist, - data = data, min_pmix = min_pmix, - range_shape1 = range_shape1, range_shape2 = range_shape2, control = control, + data = data, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + control = control, hessian = hessian ) - fits <- remove_nonfits(fits, - data = data, rescale = rescale, - computable = computable, min_pmix = min_pmix, - range_shape1 = range_shape1, range_shape2 = range_shape2, - at_boundary_ok = at_boundary_ok, silent = silent + fits <- remove_nonfits( + fits, + data = data, + rescale = rescale, + computable = computable, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + at_boundary_ok = at_boundary_ok, + silent = silent ) class(fits) <- "fitdists" fits } -fits_dists <- function(data, dists, min_pmix, range_shape1, range_shape2, control, - censoring, weighted, all_dists = TRUE, - at_boundary_ok = TRUE, silent = TRUE, rescale = FALSE, computable = FALSE, pars = NULL, hessian = TRUE) { - fits <- fit_dists(data, dists, - min_pmix = min_pmix, range_shape1 = range_shape1, +fits_dists <- function( + data, + dists, + min_pmix, + range_shape1, + range_shape2, + control, + censoring, + weighted, + all_dists = TRUE, + at_boundary_ok = TRUE, + silent = TRUE, + rescale = FALSE, + computable = FALSE, + pars = NULL, + hessian = TRUE +) { + fits <- fit_dists( + data, + dists, + min_pmix = min_pmix, + range_shape1 = range_shape1, range_shape2 = range_shape2, at_boundary_ok = at_boundary_ok, - control = control, silent = silent, - rescale = rescale, computable = computable + control = control, + silent = silent, + rescale = rescale, + computable = computable ) if (!length(fits)) { err("All distributions failed to fit.") @@ -168,24 +256,25 @@ fits_dists <- function(data, dists, min_pmix, range_shape1, range_shape2, contro #' ssd_plot_cdf(fits) #' ssd_hc(fits) ssd_fit_dists <- function( - data, - left = "Conc", - ..., - right = left, - weight = NULL, - dists = ssd_dists_bcanz(), - nrow = 6L, - rescale = FALSE, - odds_max = 0.999, - reweight = FALSE, - computable = FALSE, - at_boundary_ok = TRUE, - all_dists = FALSE, - min_pmix = ssd_min_pmix(nrow(data)), - range_shape1 = c(0.05, 20), - range_shape2 = range_shape1, - control = list(), - silent = FALSE) { + data, + left = "Conc", + ..., + right = left, + weight = NULL, + dists = ssd_dists_bcanz(), + nrow = 6L, + rescale = FALSE, + odds_max = 0.999, + reweight = FALSE, + computable = FALSE, + at_boundary_ok = TRUE, + all_dists = FALSE, + min_pmix = ssd_min_pmix(nrow(data)), + range_shape1 = c(0.05, 20), + range_shape2 = range_shape1, + control = list(), + silent = FALSE +) { chk_unused(...) chk_character_or_factor(dists) chk_vector(dists) @@ -235,15 +324,26 @@ ssd_fit_dists <- function( org_data <- as_tibble(data) data <- process_data(data, left, right, weight) - attrs <- adjust_data(data, rescale = rescale, reweight = reweight, odds_max = odds_max, silent = silent) + attrs <- adjust_data( + data, + rescale = rescale, + reweight = reweight, + odds_max = odds_max, + silent = silent + ) - fits <- fits_dists(attrs$data, dists, - min_pmix = min_pmix, range_shape1 = range_shape1, + fits <- fits_dists( + attrs$data, + dists, + min_pmix = min_pmix, + range_shape1 = range_shape1, range_shape2 = range_shape2, all_dists = all_dists, at_boundary_ok = at_boundary_ok, - control = control, silent = silent, - rescale = attrs$rescale, computable = computable, + control = control, + silent = silent, + rescale = attrs$rescale, + computable = computable, censoring = attrs$censoring, weighted = attrs$weighted ) diff --git a/R/gamma.R b/R/gamma.R index d8c1122a2..839121e47 100644 --- a/R/gamma.R +++ b/R/gamma.R @@ -20,10 +20,20 @@ #' @examples #' #' ssd_pgamma(1) -ssd_pgamma <- function(q, shape = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("gamma", - q = q, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_pgamma <- function( + q, + shape = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "gamma", + q = q, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -32,10 +42,20 @@ ssd_pgamma <- function(q, shape = 1, scale = 1, lower.tail = TRUE, log.p = FALSE #' @examples #' #' ssd_qgamma(0.5) -ssd_qgamma <- function(p, shape = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("gamma", - p = p, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_qgamma <- function( + p, + shape = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "gamma", + p = p, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } diff --git a/R/getters.R b/R/getters.R index 35773897a..25637b30f 100644 --- a/R/getters.R +++ b/R/getters.R @@ -117,8 +117,17 @@ .attrs_fitdists <- function(fits) { attrs <- attributes(fits) attrs[c( - "censoring", "cols", "control", "data", "org_data", "min_pmix", "range_shape1", - "range_shape2", "rescale", "weighted", "unequal" + "censoring", + "cols", + "control", + "data", + "org_data", + "min_pmix", + "range_shape1", + "range_shape2", + "rescale", + "weighted", + "unequal" )] } diff --git a/R/ggplot.R b/R/ggplot.R index faa138dda..de9f8d57f 100644 --- a/R/ggplot.R +++ b/R/ggplot.R @@ -24,8 +24,14 @@ #' ssd_pal() ssd_pal <- function() { values <- c( - "#999999", "#E69F00", "#56B4E9", "#009E73", - "#0072B2", "#D55E00", "#CC79A7", "#F0E442" + "#999999", + "#E69F00", + "#56B4E9", + "#009E73", + "#0072B2", + "#D55E00", + "#CC79A7", + "#F0E442" ) f <- manual_pal(values) attr(f, "max_n") <- length(values) @@ -78,17 +84,24 @@ scale_fill_ssd <- function(...) { #' @examples #' ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + #' geom_ssdpoint() -geom_ssdpoint <- function(mapping = NULL, - data = NULL, - stat = "ssdpoint", - position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_ssdpoint <- function( + mapping = NULL, + data = NULL, + stat = "ssdpoint", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { layer( - data = data, mapping = mapping, stat = stat, geom = GeomSsdpoint, - position = position, show.legend = show.legend, inherit.aes = inherit.aes, + data = data, + mapping = mapping, + stat = stat, + geom = GeomSsdpoint, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, params = list(na.rm = na.rm, ...) ) } @@ -106,24 +119,35 @@ geom_ssdpoint <- function(mapping = NULL, #' @examples #' ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc, xend = Conc * 2)) + #' geom_ssdsegment() -geom_ssdsegment <- function(mapping = NULL, - data = NULL, - stat = "ssdsegment", - position = "identity", - ..., - arrow = NULL, - arrow.fill = NULL, - lineend = "butt", - linejoin = "round", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_ssdsegment <- function( + mapping = NULL, + data = NULL, + stat = "ssdsegment", + position = "identity", + ..., + arrow = NULL, + arrow.fill = NULL, + lineend = "butt", + linejoin = "round", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { layer( - data = data, mapping = mapping, stat = stat, geom = GeomSsdsegment, - position = position, show.legend = show.legend, inherit.aes = inherit.aes, + data = data, + mapping = mapping, + stat = stat, + geom = GeomSsdsegment, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, params = list( - arrow = arrow, arrow.fill = arrow.fill, - lineend = lineend, linejoin = linejoin, na.rm = na.rm, ... + arrow = arrow, + arrow.fill = arrow.fill, + lineend = lineend, + linejoin = linejoin, + na.rm = na.rm, + ... ) ) } @@ -142,13 +166,15 @@ geom_ssdsegment <- function(mapping = NULL, #' ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + #' geom_ssdpoint() + #' geom_hcintersect(xintercept = 1.5, yintercept = 0.05) -geom_hcintersect <- function(mapping = NULL, - data = NULL, - ..., - xintercept, - yintercept, - na.rm = FALSE, - show.legend = NA) { +geom_hcintersect <- function( + mapping = NULL, + data = NULL, + ..., + xintercept, + yintercept, + na.rm = FALSE, + show.legend = NA +) { if (!missing(xintercept)) { data <- data.frame(xintercept = xintercept) mapping <- aes(xintercept = xintercept) @@ -167,8 +193,13 @@ geom_hcintersect <- function(mapping = NULL, } layer( - data = data, mapping = mapping, stat = StatIdentity, geom = GeomHcintersect, - position = PositionIdentity, show.legend = show.legend, inherit.aes = FALSE, + data = data, + mapping = mapping, + stat = StatIdentity, + geom = GeomHcintersect, + position = PositionIdentity, + show.legend = show.legend, + inherit.aes = FALSE, params = list(na.rm = na.rm, ...) ) } @@ -186,17 +217,24 @@ geom_hcintersect <- function(mapping = NULL, #' @examples #' gp <- ggplot2::ggplot(boron_pred) + #' geom_xribbon(ggplot2::aes(xmin = lcl, xmax = ucl, y = proportion)) -geom_xribbon <- function(mapping = NULL, - data = NULL, - stat = "identity", - position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_xribbon <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { layer( - data = data, mapping = mapping, stat = stat, geom = GeomXribbon, - position = position, show.legend = show.legend, inherit.aes = inherit.aes, + data = data, + mapping = mapping, + stat = stat, + geom = GeomXribbon, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, params = list(na.rm = na.rm, ...) ) } @@ -211,14 +249,16 @@ geom_xribbon <- function(mapping = NULL, #' @inheritParams ggplot2::geom_point #' @keywords internal #' @export -geom_ssd <- function(mapping = NULL, - data = NULL, - stat = "ssdpoint", - position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +geom_ssd <- function( + mapping = NULL, + data = NULL, + stat = "ssdpoint", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { lifecycle::deprecate_stop("0.3.5", "geom_ssd()", "geom_ssdpoint()") } @@ -234,13 +274,15 @@ geom_ssd <- function(mapping = NULL, #' @family ggplot2 #' @keywords internal #' @export -stat_ssd <- function(mapping = NULL, - data = NULL, - geom = "point", - position = "identity", - ..., - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE) { +stat_ssd <- function( + mapping = NULL, + data = NULL, + geom = "point", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) { lifecycle::deprecate_stop("0.3.5", "stat_ssd()") } diff --git a/R/ggproto.R b/R/ggproto.R index d5343e5bd..1335d4a31 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -24,7 +24,8 @@ NULL #' @rdname ssdtools-ggproto #' @export StatSsdpoint <- ggproto( - "StatSsdpoint", Stat, + "StatSsdpoint", + Stat, required_aes = "x", default_aes = aes(y = ..density..), compute_panel = function(data, scales) { @@ -36,7 +37,8 @@ StatSsdpoint <- ggproto( #' @rdname ssdtools-ggproto #' @export StatSsdsegment <- ggproto( - "StatSsdsegment", Stat, + "StatSsdsegment", + Stat, required_aes = c("x", "xend"), default_aes = aes(y = ..density.., yend = ..density..), compute_panel = function(data, scales) { @@ -48,21 +50,29 @@ StatSsdsegment <- ggproto( #' @rdname ssdtools-ggproto #' @export GeomSsdpoint <- ggproto( - "GeomSsdpoint", GeomPoint + "GeomSsdpoint", + GeomPoint ) #' @rdname ssdtools-ggproto #' @export GeomSsdsegment <- ggproto( - "GeomSsdsegment", GeomSegment + "GeomSsdsegment", + GeomSegment ) #' @rdname ssdtools-ggproto #' @export GeomHcintersect <- ggproto( - "GeomHcintersect", Geom, + "GeomHcintersect", + Geom, required_aes = c("xintercept", "yintercept"), - default_aes = aes(colour = "black", linewidth = 0.5, linetype = "dotted", alpha = NA), + default_aes = aes( + colour = "black", + linewidth = 0.5, + linetype = "dotted", + alpha = NA + ), draw_key = draw_key_path, draw_panel = function(data, panel_params, coord) { data$group <- seq_len(nrow(data)) @@ -81,17 +91,24 @@ GeomHcintersect <- ggproto( #' @rdname ssdtools-ggproto #' @export GeomXribbon <- ggproto( - "GeomXribbon", Geom, + "GeomXribbon", + Geom, required_aes = c("y", "xmin", "xmax"), default_aes = aes( - colour = NA, fill = "grey20", linewidth = 0.5, linetype = 1, alpha = NA + colour = NA, + fill = "grey20", + linewidth = 0.5, + linetype = 1, + alpha = NA ), draw_key = draw_key_polygon, handle_na = function(data, params) { data }, draw_group = function(data, panel_params, coord, na.rm = FALSE) { - if (na.rm) data <- data[complete.cases(data[c("y", "xmin", "xmax")]), ] + if (na.rm) { + data <- data[complete.cases(data[c("y", "xmin", "xmax")]), ] + } data <- data[order(data$group, data$y), ] # Check that aesthetics are constant @@ -105,21 +122,28 @@ GeomXribbon <- ggproto( ids <- cumsum(missing_pos) + 1 ids[missing_pos] <- NA - positions <- plyr::summarise(data, - y = c(y, rev(y)), x = c(xmax, rev(xmin)), id = c(ids, rev(ids)) + positions <- plyr::summarise( + data, + y = c(y, rev(y)), + x = c(xmax, rev(xmin)), + id = c(ids, rev(ids)) ) munched <- coord_munch(coord, positions, panel_params) - ggname("geom_ribbon", polygonGrob( - munched$x, munched$y, - id = munched$id, - default.units = "native", - gp = gpar( - fill = alpha(aes$fill, aes$alpha), - col = aes$colour, - lwd = aes$linewidth * .pt, - lty = aes$linetype + ggname( + "geom_ribbon", + polygonGrob( + munched$x, + munched$y, + id = munched$id, + default.units = "native", + gp = gpar( + fill = alpha(aes$fill, aes$alpha), + col = aes$colour, + lwd = aes$linewidth * .pt, + lty = aes$linetype + ) ) - )) + ) } ) diff --git a/R/glance.R b/R/glance.R index 82bee52b7..4eb15cb0f 100644 --- a/R/glance.R +++ b/R/glance.R @@ -52,7 +52,9 @@ glance.fitdists <- function(x, ..., wt = FALSE) { if (vld_flag(wt) && !wt) { lifecycle::deprecate_soft( - "2.3.1", I("glance(wt = FALSE)"), I("glance(wt = TRUE)"), + "2.3.1", + I("glance(wt = FALSE)"), + I("glance(wt = TRUE)"), "Please set the `wt` argument to `glance()` to be TRUE which will rename the 'weight' column to 'wt' and then update your downstream code accordingly." ) } diff --git a/R/gof.R b/R/gof.R index 394ec837d..5493893b6 100644 --- a/R/gof.R +++ b/R/gof.R @@ -75,7 +75,9 @@ ssd_gof.fitdists <- function(x, ..., pvalue = FALSE, wt = FALSE) { if (vld_flag(wt) && !wt) { lifecycle::deprecate_soft( - "2.3.1", I("ssd_gof(wt = FALSE)"), I("ssd_gof(wt = TRUE)"), + "2.3.1", + I("ssd_gof(wt = FALSE)"), + I("ssd_gof(wt = TRUE)"), "Please set the `wt` argument to `ssd_gof()` to be TRUE which will rename the 'weight' column to 'wt' and then update your downstream code accordingly." ) } diff --git a/R/gompertz.R b/R/gompertz.R index 46ea449f1..46f5bb846 100644 --- a/R/gompertz.R +++ b/R/gompertz.R @@ -32,10 +32,20 @@ dgompertz <- function(x, llocation = 0, lshape = 0, log = FALSE) { #' @examples #' #' ssd_pgompertz(1) -ssd_pgompertz <- function(q, location = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("gompertz", - q = q, location = location, shape = shape, - lower.tail = lower.tail, log.p = log.p +ssd_pgompertz <- function( + q, + location = 1, + shape = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "gompertz", + q = q, + location = location, + shape = shape, + lower.tail = lower.tail, + log.p = log.p ) } @@ -47,7 +57,13 @@ ssd_pgompertz <- function(q, location = 1, shape = 1, lower.tail = TRUE, log.p = #' @inheritParams params #' @keywords internal #' @export -pgompertz <- function(q, llocation = 0, lshape = 0, lower.tail = TRUE, log.p = FALSE) { +pgompertz <- function( + q, + llocation = 0, + lshape = 0, + lower.tail = TRUE, + log.p = FALSE +) { lifecycle::deprecate_stop("1.0.0", "pgompertz()", "ssd_pgompertz()") } @@ -56,10 +72,20 @@ pgompertz <- function(q, llocation = 0, lshape = 0, lower.tail = TRUE, log.p = F #' @examples #' #' ssd_qgompertz(0.5) -ssd_qgompertz <- function(p, location = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("gompertz", - p = p, location = location, shape = shape, - lower.tail = lower.tail, log.p = log.p +ssd_qgompertz <- function( + p, + location = 1, + shape = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "gompertz", + p = p, + location = location, + shape = shape, + lower.tail = lower.tail, + log.p = log.p ) } @@ -71,7 +97,13 @@ ssd_qgompertz <- function(p, location = 1, shape = 1, lower.tail = TRUE, log.p = #' @inheritParams params #' @keywords internal #' @export -qgompertz <- function(p, llocation = 0, lshape = 0, lower.tail = TRUE, log.p = FALSE) { +qgompertz <- function( + p, + llocation = 0, + lshape = 0, + lower.tail = TRUE, + log.p = FALSE +) { lifecycle::deprecate_stop("1.0.0", "qgompertz()", "ssd_qgompertz()") } @@ -116,7 +148,12 @@ sgompertz <- function(data, pars = NULL) { pars <- rev(unlist(pars)) } data <- data.frame(x = x) - fit <- suppressWarnings(VGAM::vglm(x ~ 1, VGAM::gompertz, coefstart = pars, data = data)) + fit <- suppressWarnings(VGAM::vglm( + x ~ 1, + VGAM::gompertz, + coefstart = pars, + data = data + )) list( log_location = unname(coef(fit)[2]) * (1 + 1e-3), log_shape = unname(coef(fit)[1]) * (1 - 1e-3) diff --git a/R/hc-burrlioz.R b/R/hc-burrlioz.R index e126ee04b..fd6f5398c 100644 --- a/R/hc-burrlioz.R +++ b/R/hc-burrlioz.R @@ -24,7 +24,15 @@ #' @return A tibble of corresponding hazard concentrations. #' @keywords internal #' @export -ssd_hc_burrlioz <- function(x, percent, proportion = 0.05, ci = FALSE, level = 0.95, nboot = 1000, - min_pboot = 0.8, parametric = FALSE) { +ssd_hc_burrlioz <- function( + x, + percent, + proportion = 0.05, + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + parametric = FALSE +) { lifecycle::deprecate_stop("0.3.5", "ssd_hc_burrlioz()", "ssd_hc()") } diff --git a/R/hc.R b/R/hc.R index 50f83293c..adccfba71 100644 --- a/R/hc.R +++ b/R/hc.R @@ -54,10 +54,14 @@ ssd_hc <- function(x, ...) { est <- do.call(fun, args) tibble( dist = dist, - proportion = proportion, est = est, - se = NA_real_, lcl = NA_real_, ucl = NA_real_, + proportion = proportion, + est = est, + se = NA_real_, + lcl = NA_real_, + ucl = NA_real_, wt = 1, - nboot = 0L, pboot = NA_real_ + nboot = 0L, + pboot = NA_real_ ) } @@ -67,17 +71,23 @@ ssd_hc <- function(x, ...) { #' #' ssd_hc(ssd_match_moments()) ssd_hc.list <- function( - x, - percent, - proportion = 0.05, - ...) { + x, + percent, + proportion = 0.05, + ... +) { chk_list(x) chk_named(x) chk_unique(names(x)) chk_unused(...) if (lifecycle::is_present(percent)) { - lifecycle::deprecate_soft("2.0.0", "ssd_hc(percent)", with = "ssd_hc(proportion)", id = "hc") + lifecycle::deprecate_soft( + "2.0.0", + "ssd_hc(percent)", + with = "ssd_hc(proportion)", + id = "hc" + ) chk_vector(percent) chk_numeric(percent) chk_range(percent, c(0, 100)) @@ -93,7 +103,10 @@ ssd_hc.list <- function( hc <- dplyr::rename(hc, proportion = "value") return(hc) } - hc <- mapply(.ssd_hc_dist, x, names(x), + hc <- mapply( + .ssd_hc_dist, + x, + names(x), MoreArgs = list(proportion = proportion), SIMPLIFY = FALSE ) @@ -107,27 +120,33 @@ ssd_hc.list <- function( #' fits <- ssd_fit_dists(ssddata::ccme_boron) #' ssd_hc(fits) ssd_hc.fitdists <- function( - x, - percent = deprecated(), - proportion = 0.05, - ..., - average = TRUE, - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - multi_est = deprecated(), - est_method = "multi", - ci_method = "weighted_samples", - parametric = TRUE, - delta = 9.21, - samples = FALSE, - save_to = NULL, - control = NULL) { + x, + percent = deprecated(), + proportion = 0.05, + ..., + average = TRUE, + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + multi_est = deprecated(), + est_method = "multi", + ci_method = "weighted_samples", + parametric = TRUE, + delta = 9.21, + samples = FALSE, + save_to = NULL, + control = NULL +) { chk_unused(...) if (lifecycle::is_present(percent)) { - lifecycle::deprecate_soft("2.0.0", "ssd_hc(percent)", "ssd_hc(proportion)", id = "hc") + lifecycle::deprecate_soft( + "2.0.0", + "ssd_hc(percent)", + "ssd_hc(proportion)", + id = "hc" + ) chk_vector(percent) chk_numeric(percent) chk_range(percent, c(0, 100)) @@ -139,7 +158,11 @@ ssd_hc.fitdists <- function( chk_range(proportion) if (lifecycle::is_present(multi_est)) { - lifecycle::deprecate_soft("2.3.1", "ssd_hc(multi_est)", "ssd_hc(est_method)") + lifecycle::deprecate_soft( + "2.3.1", + "ssd_hc(multi_est)", + "ssd_hc(est_method)" + ) chk_flag(multi_est) @@ -150,7 +173,11 @@ ssd_hc.fitdists <- function( chk_string(ci_method) if (ci_method == "weighted_arithmetic") { - lifecycle::deprecate_soft("2.3.1", I("ssd_hc(ci_method = 'weighted_arithmetic')"), I("ssd_hc(ci_method = 'MACL')")) + lifecycle::deprecate_soft( + "2.3.1", + I("ssd_hc(ci_method = 'weighted_arithmetic')"), + I("ssd_hc(ci_method = 'MACL')") + ) ci_method <- "MACL" } @@ -185,24 +212,30 @@ ssd_hc.fitdists <- function( #' fit <- ssd_fit_burrlioz(ssddata::ccme_boron) #' ssd_hc(fit) ssd_hc.fitburrlioz <- function( - x, - percent, - proportion = 0.05, - ..., - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - parametric = FALSE, - samples = FALSE, - save_to = NULL) { + x, + percent, + proportion = 0.05, + ..., + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + parametric = FALSE, + samples = FALSE, + save_to = NULL +) { chk_length(x, upper = 1L) chk_named(x) chk_subset(names(x), c("burrIII3", "invpareto", "llogis", "lgumbel")) chk_unused(...) if (lifecycle::is_present(percent)) { - lifecycle::deprecate_soft("2.0.0", "ssd_hc(percent)", "ssd_hc(proportion)", id = "hc") + lifecycle::deprecate_soft( + "2.0.0", + "ssd_hc(percent)", + "ssd_hc(proportion)", + id = "hc" + ) chk_vector(percent) chk_numeric(percent) chk_range(percent, c(0, 100)) diff --git a/R/hcp-average.R b/R/hcp-average.R index 1c28cdb6f..98c781a82 100644 --- a/R/hcp-average.R +++ b/R/hcp-average.R @@ -30,12 +30,32 @@ hcp_noci <- function(value, est_method, ci_method, ...) { } hcp_average <- function( - x, value, data, ci, level, nboot, est_method, - min_pboot, min_pmix, parametric, rescale, weighted, ci_method, censoring, - range_shape1, range_shape2, control, hc, save_to, - samples, fun) { + x, + value, + data, + ci, + level, + nboot, + est_method, + min_pboot, + min_pmix, + parametric, + rescale, + weighted, + ci_method, + censoring, + range_shape1, + range_shape2, + control, + hc, + save_to, + samples, + fun +) { if (.is_censored(censoring) && !identical_parameters(x)) { - wrn("Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters.") + wrn( + "Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters." + ) } est_same <- FALSE @@ -55,12 +75,26 @@ hcp_average <- function( hcp <- ci_fun( x, - value = value, ci = ci, level = level, nboot = nboot, est_method = est_method, + value = value, + ci = ci, + level = level, + nboot = nboot, + est_method = est_method, min_pboot = min_pboot, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, save_to = save_to, samples = samples, - ci_method = ci_method, hc = hc, fun = fun + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + save_to = save_to, + samples = samples, + ci_method = ci_method, + hc = hc, + fun = fun ) if (est_same) { @@ -73,13 +107,26 @@ hcp_average <- function( hcp_ma } est <- est_fun( - x, value, - ci = FALSE, level = level, nboot = nboot, min_pboot = min_pboot, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, save_to = save_to, samples = samples, + x, + value, + ci = FALSE, + level = level, + nboot = nboot, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + save_to = save_to, + samples = samples, est_method = est_method, - ci_method = "MACL", hc = hc + ci_method = "MACL", + hc = hc ) replace_estimates(hcp, est) } diff --git a/R/hcp-ind.R b/R/hcp-ind.R index 801c023c9..cb67e4307 100644 --- a/R/hcp-ind.R +++ b/R/hcp-ind.R @@ -21,27 +21,61 @@ hcp_ind_weight <- function(hcp, weight) { x$wt <- y x }, - x = hcp, y = weight, - USE.NAMES = FALSE, SIMPLIFY = FALSE + x = hcp, + y = weight, + USE.NAMES = FALSE, + SIMPLIFY = FALSE ) |> dplyr::bind_rows() } -hcp_ind <- function(x, value, ci, level, nboot, min_pboot, - data, rescale, - weighted, censoring, min_pmix, range_shape1, - range_shape2, parametric, - control, est_method, ci_method, hc, save_to, samples, fun) { +hcp_ind <- function( + x, + value, + ci, + level, + nboot, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + est_method, + ci_method, + hc, + save_to, + samples, + fun +) { hcp <- purrr::map( - x, hcp_tmbfit, + x, + hcp_tmbfit, nboot = nboot, - value = value, ci = ci, level = level, + value = value, + ci = ci, + level = level, min_pboot = min_pboot, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, est_method = est_method, ci_method = ci_method, - average = FALSE, control = control, - hc = hc, save_to = save_to, samples = samples, fun = fun + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + est_method = est_method, + ci_method = ci_method, + average = FALSE, + control = control, + hc = hc, + save_to = save_to, + samples = samples, + fun = fun ) weight <- glance(x, wt = TRUE)$wt diff --git a/R/hcp-ma.R b/R/hcp-ma.R index 63c0d4a7e..22801328b 100644 --- a/R/hcp-ma.R +++ b/R/hcp-ma.R @@ -68,9 +68,21 @@ ma_se <- function(se, log_se, est, wt, adj, ci_method) { if (ci_method %in% c("GMAW1", "GMAW2")) { est_ma <- ma_est(est, wt = wt, est_method = "geometric") if (ci_method == "GMAW1") { - maw_se <- maw1(log_se, est = log(est), est_ma = log(est_ma), wt = wt, adj = adj) + maw_se <- maw1( + log_se, + est = log(est), + est_ma = log(est_ma), + wt = wt, + adj = adj + ) } else { - maw_se <- maw2(log_se, est = log(est), est_ma = log(est_ma), wt = wt, adj = adj) + maw_se <- maw2( + log_se, + est = log(est), + est_ma = log(est_ma), + wt = wt, + adj = adj + ) } return(exp_se(maw_se, est_ma)) } @@ -81,8 +93,12 @@ ma_ci <- function(est, se, log_se, wt, df, level, ci_method) { tail <- 1 - (1 - level) / 2 adj <- stats::qt(tail, df = df) / stats::qnorm(tail) se_adj <- ma_se( - se = se, log_se = log_se, est = est, wt = wt, - adj = adj, ci_method = ci_method + se = se, + log_se = log_se, + est = est, + wt = wt, + adj = adj, + ci_method = ci_method ) quantiles <- stats::qnorm(c(1 - tail, tail)) @@ -106,7 +122,15 @@ ma_lcl <- function(est, lcl, se, log_se, wt, df, level, ci_method) { return(weighted_mean(lcl, wt, geometric = ci_method == "GMACL")) } if (ci_method %in% c("MAW1", "MAW2", "GMAW1", "GMAW2")) { - ci <- ma_ci(est = est, se = se, log_se = log_se, wt = wt, df = df, level = level, ci_method = ci_method) + ci <- ma_ci( + est = est, + se = se, + log_se = log_se, + wt = wt, + df = df, + level = level, + ci_method = ci_method + ) return(ci[1]) } NA_real_ @@ -117,7 +141,15 @@ ma_ucl <- function(ucl, est, se, log_se, wt, df, level, ci_method) { return(weighted_mean(ucl, wt, geometric = ci_method == "GMACL")) } if (ci_method %in% c("MAW1", "MAW2", "GMAW1", "GMAW2")) { - ci <- ma_ci(est = est, se = se, log_se = log_se, wt = wt, df = df, level = level, ci_method = ci_method) + ci <- ma_ci( + est = est, + se = se, + log_se = log_se, + wt = wt, + df = df, + level = level, + ci_method = ci_method + ) return(ci[2]) } NA_real_ @@ -136,34 +168,102 @@ hcp_ma2 <- function(hcp, weight, ndata, level, est_method, ci_method) { dplyr::summarise( est_ma = ma_est(.data$est, .data$weight, est_method = est_method), se_ma = ma_se( - se = .data$se, log_se = .data$log_se, est = .data$est, wt = .data$weight, - adj = 1, ci_method = ci_method + se = .data$se, + log_se = .data$log_se, + est = .data$est, + wt = .data$weight, + adj = 1, + ci_method = ci_method + ), + lcl_ma = ma_lcl( + lcl = .data$lcl, + est = .data$est, + se = .data$se, + log_se = .data$log_se, + wt = .data$weight, + df = .data$df, + level = level, + ci_method = ci_method + ), + ucl_ma = ma_ucl( + ucl = .data$ucl, + est = .data$est, + se = .data$se, + log_se = .data$log_se, + wt = .data$weight, + df = .data$df, + level = level, + ci_method = ci_method ), - lcl_ma = ma_lcl(lcl = .data$lcl, est = .data$est, se = .data$se, log_se = .data$log_se, wt = .data$weight, df = .data$df, level = level, ci_method = ci_method), - ucl_ma = ma_ucl(ucl = .data$ucl, est = .data$est, se = .data$se, log_se = .data$log_se, wt = .data$weight, df = .data$df, level = level, ci_method = ci_method), pboot = min(.data$pboot), samples = list(unlist(.data$samples)) ) |> dplyr::ungroup() |> dplyr::rename( - est = "est_ma", lcl = "lcl_ma", ucl = "ucl_ma", se = "se_ma" + est = "est_ma", + lcl = "lcl_ma", + ucl = "ucl_ma", + se = "se_ma" ) } -hcp_ma <- function(x, value, ci, level, nboot, est_method, min_pboot, - data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, control, - save_to, samples, ci_method, hc, fun) { +hcp_ma <- function( + x, + value, + ci, + level, + nboot, + est_method, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + save_to, + samples, + ci_method, + hc, + fun +) { hcp <- purrr::map( - x, hcp_tmbfit, - nboot = nboot, value = value, ci = ci, level = level, - min_pboot = min_pboot, data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, est_method = est_method, ci_method = ci_method, average = TRUE, control = control, - hc = hc, save_to = save_to, samples = samples, fun = fun + x, + hcp_tmbfit, + nboot = nboot, + value = value, + ci = ci, + level = level, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + est_method = est_method, + ci_method = ci_method, + average = TRUE, + control = control, + hc = hc, + save_to = save_to, + samples = samples, + fun = fun ) weight <- glance(x, wt = TRUE)$wt ndata <- ndata(data) - hcp_ma2(hcp, weight, ndata, level = level, est_method = est_method, ci_method = ci_method) + hcp_ma2( + hcp, + weight, + ndata, + level = level, + est_method = est_method, + ci_method = ci_method + ) } diff --git a/R/hcp-multi.R b/R/hcp-multi.R index 12aad0281..91aa4fc1c 100644 --- a/R/hcp-multi.R +++ b/R/hcp-multi.R @@ -15,10 +15,29 @@ # See the License for the specific language governing permissions and # limitations under the License. -hcp_multi <- function(x, value, ci, level, nboot, min_pboot, - data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, control, - save_to, samples, est_method, ci_method, hc, ...) { +hcp_multi <- function( + x, + value, + ci, + level, + nboot, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + save_to, + samples, + est_method, + ci_method, + hc, + ... +) { estimates <- estimates(x, all_estimates = TRUE) dist <- "multi" fun <- fits_dists @@ -26,11 +45,28 @@ hcp_multi <- function(x, value, ci, level, nboot, min_pboot, hcp_tmbfit2( x, - dist = dist, estimates = estimates, fun = fun, pars = pars, - value = value, ci = ci, level = level, nboot = nboot, min_pboot = min_pboot, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, save_to = save_to, - samples = samples, hc = hc, ci_method = ci_method, est_method = est_method + dist = dist, + estimates = estimates, + fun = fun, + pars = pars, + value = value, + ci = ci, + level = level, + nboot = nboot, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + save_to = save_to, + samples = samples, + hc = hc, + ci_method = ci_method, + est_method = est_method ) } diff --git a/R/hcp-samples.R b/R/hcp-samples.R index 97499b4c4..f0834a2e0 100644 --- a/R/hcp-samples.R +++ b/R/hcp-samples.R @@ -34,11 +34,19 @@ combine_samples <- function(samples, weight, nboot, geometric) { purrr::set_names(colnames) |> dplyr::as_tibble() |> dplyr::rowwise() |> - dplyr::mutate(.samples = weighted_mean(dplyr::c_across(dplyr::all_of(colnames)), wt = weight, geometric = geometric)) |> + dplyr::mutate( + .samples = weighted_mean( + dplyr::c_across(dplyr::all_of(colnames)), + wt = weight, + geometric = geometric + ) + ) |> dplyr::pull(.data$.samples) - names(samples) <- boot_filename(seq_along(samples), - prefix = "", sep = "", + names(samples) <- boot_filename( + seq_along(samples), + prefix = "", + sep = "", dist = "_average" ) samples[!is.na(samples)] @@ -52,7 +60,12 @@ hcp_combine_samples <- function(hcp, weight, ci_method, level, nboot) { dplyr::bind_rows() |> dplyr::group_by(.data$value) |> dplyr::summarise( - samples = list(combine_samples(.data$samples, weight, nboot = nboot1, geometric = geometric)) + samples = list(combine_samples( + .data$samples, + weight, + nboot = nboot1, + geometric = geometric + )) ) |> dplyr::ungroup() @@ -68,19 +81,60 @@ hcp_combine_samples <- function(hcp, weight, ci_method, level, nboot) { ) } -hcp_samples <- function(x, value, level, nboot, est_method, min_pboot, - data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, control, - save_to, ci_method, hc, fun, ...) { +hcp_samples <- function( + x, + value, + level, + nboot, + est_method, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + save_to, + ci_method, + hc, + fun, + ... +) { hcp <- purrr::map( - x, hcp_tmbfit, - value = value, ci = TRUE, level = level, nboot = nboot, - min_pboot = min_pboot, data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, est_method = est_method, ci_method = ci_method, average = TRUE, control = control, - hc = hc, save_to = save_to, samples = TRUE, fun = fun + x, + hcp_tmbfit, + value = value, + ci = TRUE, + level = level, + nboot = nboot, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + est_method = est_method, + ci_method = ci_method, + average = TRUE, + control = control, + hc = hc, + save_to = save_to, + samples = TRUE, + fun = fun ) weight <- glance(x, wt = TRUE)$wt - hcp_combine_samples(hcp, weight, ci_method = ci_method, level = level, nboot = nboot) + hcp_combine_samples( + hcp, + weight, + ci_method = ci_method, + level = level, + nboot = nboot + ) } diff --git a/R/hcp-tmbfit.R b/R/hcp-tmbfit.R index dc0fdddb1..f107e4bab 100644 --- a/R/hcp-tmbfit.R +++ b/R/hcp-tmbfit.R @@ -59,10 +59,31 @@ no_ci_hcp <- function(value, dist, est, rescale, hc) { } hcp_tmbfit2 <- function( - x, dist, estimates, fun, pars, value, ci, level, nboot, min_pboot, - data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, control, save_to, samples, hc, - est_method, ci_method) { + x, + dist, + estimates, + fun, + pars, + value, + ci, + level, + nboot, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + save_to, + samples, + hc, + est_method, + ci_method +) { args <- estimates if (hc) { @@ -75,17 +96,32 @@ hcp_tmbfit2 <- function( est <- do.call(what, args) if (!ci) { - return(no_ci_hcp(value = value, dist = dist, est = est, rescale = rescale, hc = hc)) + return(no_ci_hcp( + value = value, + dist = dist, + est = est, + rescale = rescale, + hc = hc + )) } censoring <- censoring / rescale ests <- boot_estimates( - fun = fun, dist = dist, estimates = estimates, - pars = pars, nboot = nboot, data = data, weighted = weighted, - censoring = censoring, min_pmix = min_pmix, - range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, save_to = save_to, + fun = fun, + dist = dist, + estimates = estimates, + pars = pars, + nboot = nboot, + data = data, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + save_to = save_to, ci_method = ci_method ) x <- value @@ -95,27 +131,69 @@ hcp_tmbfit2 <- function( cis <- cis_estimates(ests, what, level = level, x = x, samples = samples) hcp <- ci_hcp( cis, - estimates = ests, value = value, dist = dist, - est = est, rescale = rescale, nboot = nboot, hc = hc + estimates = ests, + value = value, + dist = dist, + est = est, + rescale = rescale, + nboot = nboot, + hc = hc ) replace_min_pboot_na(hcp, min_pboot) } hcp_tmbfit <- function( - x, nboot, value, ci, level, min_pboot, data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, est_method, ci_method, average, control, hc, save_to, samples, - fun) { + x, + nboot, + value, + ci, + level, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + est_method, + ci_method, + average, + control, + hc, + save_to, + samples, + fun +) { estimates <- estimates(x) dist <- .dist_tmbfit(x) pars <- .pars_tmbfit(x) hcp_tmbfit2( x, - dist = dist, estimates = estimates, fun = fun, pars = pars, - value = value, ci = ci, level = level, nboot = nboot, - min_pboot = min_pboot, data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - control = control, save_to = save_to, samples = samples, - hc = hc, ci_method = ci_method, est_method = est_method, parametric = parametric + dist = dist, + estimates = estimates, + fun = fun, + pars = pars, + value = value, + ci = ci, + level = level, + nboot = nboot, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + control = control, + save_to = save_to, + samples = samples, + hc = hc, + ci_method = ci_method, + est_method = est_method, + parametric = parametric ) } diff --git a/R/hcp-weighted.R b/R/hcp-weighted.R index 8e143a26b..4856472e4 100644 --- a/R/hcp-weighted.R +++ b/R/hcp-weighted.R @@ -53,10 +53,28 @@ get_nboots <- function(weight, nboot) { nboots } -hcp_weighted <- function(x, value, level, nboot, est_method, min_pboot, - data, rescale, weighted, censoring, min_pmix, - range_shape1, range_shape2, parametric, control, - save_to, ci_method, hc, fun, ...) { +hcp_weighted <- function( + x, + value, + level, + nboot, + est_method, + min_pboot, + data, + rescale, + weighted, + censoring, + min_pmix, + range_shape1, + range_shape2, + parametric, + control, + save_to, + ci_method, + hc, + fun, + ... +) { weight <- glance(x, wt = TRUE)$wt nboots <- get_nboots(weight, nboot) @@ -64,12 +82,29 @@ hcp_weighted <- function(x, value, level, nboot, est_method, min_pboot, nboots <- nboots[nboots > 0] hcp <- purrr::map2( - x, nboots, hcp_tmbfit, - value = value, ci = TRUE, level = level, - min_pboot = min_pboot, data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, est_method = est_method, ci_method = ci_method, average = TRUE, control = control, - hc = hc, save_to = save_to, samples = TRUE, fun = fun + x, + nboots, + hcp_tmbfit, + value = value, + ci = TRUE, + level = level, + min_pboot = min_pboot, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + est_method = est_method, + ci_method = ci_method, + average = TRUE, + control = control, + hc = hc, + save_to = save_to, + samples = TRUE, + fun = fun ) hcp_wb(hcp, level = level, nboot = nboot) diff --git a/R/hcp.R b/R/hcp.R index fb21ad3d0..87942d0aa 100644 --- a/R/hcp.R +++ b/R/hcp.R @@ -47,7 +47,18 @@ no_hcp <- function(hc) { ) } -clean_hcp <- function(hcp, ci, level, average, est_method, ci_method, parametric, nboot, min_pboot, samples) { +clean_hcp <- function( + hcp, + ci, + level, + average, + est_method, + ci_method, + parametric, + nboot, + min_pboot, + samples +) { hcp$est_method <- est_method hcp$ci_method <- ci_method hcp$boot_method <- if (parametric) "parametric" else "non-parametric" @@ -83,12 +94,42 @@ clean_hcp <- function(hcp, ci, level, average, est_method, ci_method, parametric } hcp |> - dplyr::select(c("dist", "value", "est", "se", "lcl", "ucl", "wt", "level", "est_method", "ci_method", "boot_method", "nboot", "pboot", "dists", "samples")) + dplyr::select(c( + "dist", + "value", + "est", + "se", + "lcl", + "ucl", + "wt", + "level", + "est_method", + "ci_method", + "boot_method", + "nboot", + "pboot", + "dists", + "samples" + )) } hcp2 <- function( - x, value, ci, level, nboot, average, est_method, min_pboot, parametric, - ci_method, control, hc, save_to, samples, fun) { + x, + value, + ci, + level, + nboot, + average, + est_method, + min_pboot, + parametric, + ci_method, + control, + hc, + save_to, + samples, + fun +) { if (!length(x) || !length(value)) { return(no_hcp()) } @@ -126,33 +167,86 @@ hcp2 <- function( if (!average) { hcp <- hcp_ind( x, - value = value, ci = ci, level = level, nboot = nboot, + value = value, + ci = ci, + level = level, + nboot = nboot, min_pboot = min_pboot, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, - est_method = est_method, ci_method = ci_method, - hc = hc, save_to = save_to, samples = samples, fun = fun + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + est_method = est_method, + ci_method = ci_method, + hc = hc, + save_to = save_to, + samples = samples, + fun = fun ) hcp$dists <- as.list(hcp$dist) } else { hcp <- hcp_average( - x = x, value = value, ci = ci, level = level, nboot = nboot, est_method = est_method, - min_pboot = min_pboot, ci_method = ci_method, - data = data, rescale = rescale, weighted = weighted, censoring = censoring, - min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2, - parametric = parametric, control = control, - hc = hc, save_to = save_to, samples = samples, fun = fun + x = x, + value = value, + ci = ci, + level = level, + nboot = nboot, + est_method = est_method, + min_pboot = min_pboot, + ci_method = ci_method, + data = data, + rescale = rescale, + weighted = weighted, + censoring = censoring, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2, + parametric = parametric, + control = control, + hc = hc, + save_to = save_to, + samples = samples, + fun = fun ) hcp$dists <- rep(list(sort(names(x))), nrow(hcp)) } - clean_hcp(hcp, ci = ci, level = level, average = average, est_method = est_method, ci_method = ci_method, parametric = parametric, nboot = nboot, min_pboot = min_pboot, samples = samples) + clean_hcp( + hcp, + ci = ci, + level = level, + average = average, + est_method = est_method, + ci_method = ci_method, + parametric = parametric, + nboot = nboot, + min_pboot = min_pboot, + samples = samples + ) } hcp <- function( - x, value, ci, level, nboot, average, est_method, delta, min_pboot, - parametric, ci_method, control, samples, save_to, - hc, fun = fit_tmb) { + x, + value, + ci, + level, + nboot, + average, + est_method, + delta, + min_pboot, + parametric, + ci_method, + control, + samples, + save_to, + hc, + fun = fit_tmb +) { chk_vector(value) chk_numeric(value) chk_flag(ci) @@ -182,10 +276,20 @@ hcp <- function( hcp <- hcp2( x, - value = value, ci = ci, level = level, nboot = nboot, - average = average, est_method = est_method, min_pboot = min_pboot, - parametric = parametric, ci_method = ci_method, - control = control, save_to = save_to, samples = samples, hc = hc, fun = fun + value = value, + ci = ci, + level = level, + nboot = nboot, + average = average, + est_method = est_method, + min_pboot = min_pboot, + parametric = parametric, + ci_method = ci_method, + control = control, + save_to = save_to, + samples = samples, + hc = hc, + fun = fun ) warn_min_pboot(hcp, min_pboot) } diff --git a/R/helpers.R b/R/helpers.R index e5a738298..3869b1e7c 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -121,8 +121,14 @@ rename_data <- function(data, left, right, weight) { data } -is_at_boundary <- function(fit, data, min_pmix = 0.5, range_shape1 = c(0.05, 20), range_shape2 = c(0.05, 20), - regex = ".*") { +is_at_boundary <- function( + fit, + data, + min_pmix = 0.5, + range_shape1 = c(0.05, 20), + range_shape2 = c(0.05, 20), + regex = ".*" +) { dist <- .dist_tmbfit(fit) if (!is_bounds(dist)) { return(FALSE) @@ -170,7 +176,13 @@ adjust_data <- function(data, rescale, reweight, odds_max, silent) { rescale <- Inf } - list(data = data, censoring = censoring, rescale = rescale, weighted = weighted, unequal = unequal) + list( + data = data, + censoring = censoring, + rescale = rescale, + weighted = weighted, + unequal = unequal + ) } mean_weighted_values <- function(data, weight = TRUE) { diff --git a/R/hp.R b/R/hp.R index 0b594b2a5..5bb4894c5 100644 --- a/R/hp.R +++ b/R/hp.R @@ -43,29 +43,34 @@ ssd_hp <- function(x, ...) { #' @describeIn ssd_hp Hazard Proportions for fitdists Object #' @export ssd_hp.fitdists <- function( - x, - conc = 1, - ..., - average = TRUE, - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - multi_est = deprecated(), - est_method = "multi", - ci_method = "weighted_samples", - parametric = TRUE, - delta = 9.21, - proportion = FALSE, - samples = FALSE, - save_to = NULL, - control = NULL) { + x, + conc = 1, + ..., + average = TRUE, + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + multi_est = deprecated(), + est_method = "multi", + ci_method = "weighted_samples", + parametric = TRUE, + delta = 9.21, + proportion = FALSE, + samples = FALSE, + save_to = NULL, + control = NULL +) { chk_vector(conc) chk_numeric(conc) chk_unused(...) if (lifecycle::is_present(multi_est)) { - lifecycle::deprecate_soft("2.3.1", "ssd_hc(multi_est)", "ssd_hc(est_method)") + lifecycle::deprecate_soft( + "2.3.1", + "ssd_hc(multi_est)", + "ssd_hc(est_method)" + ) chk_flag(multi_est) @@ -74,13 +79,20 @@ ssd_hp.fitdists <- function( chk_string(ci_method) if (ci_method == "weighted_arithmetic") { - lifecycle::deprecate_soft("2.3.1", I("ssd_hp(ci_method = 'weighted_arithmetic')"), I("ssd_hp(ci_method = 'MACL')")) + lifecycle::deprecate_soft( + "2.3.1", + I("ssd_hp(ci_method = 'weighted_arithmetic')"), + I("ssd_hp(ci_method = 'MACL')") + ) ci_method <- "MACL" } if (missing(proportion)) { - lifecycle::deprecate_soft("2.3.1", I("ssd_hp(proportion = FALSE)"), I("ssd_hp(proportion = TRUE)"), + lifecycle::deprecate_soft( + "2.3.1", + I("ssd_hp(proportion = FALSE)"), + I("ssd_hp(proportion = TRUE)"), "Please set the `proportion` argument to `ssd_hp()` to be TRUE which will cause it to return hazard proportions instead of percentages then update your downstream code accordingly.", id = "ssd_hp" ) @@ -119,17 +131,18 @@ ssd_hp.fitdists <- function( #' fit <- ssd_fit_burrlioz(ssddata::ccme_boron) #' ssd_hp(fit) ssd_hp.fitburrlioz <- function( - x, - conc = 1, - ..., - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - parametric = FALSE, - proportion = FALSE, - samples = FALSE, - save_to = NULL) { + x, + conc = 1, + ..., + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + parametric = FALSE, + proportion = FALSE, + samples = FALSE, + save_to = NULL +) { chk_length(x, upper = 1L) chk_named(x) chk_subset(names(x), c("burrIII3", "invpareto", "llogis", "lgumbel")) @@ -139,7 +152,10 @@ ssd_hp.fitburrlioz <- function( chk_unused(...) if (missing(proportion)) { - lifecycle::deprecate_soft("2.3.1", I("ssd_hp(proportion = FALSE)"), I("ssd_hp(proportion = TRUE)"), + lifecycle::deprecate_soft( + "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.", id = "ssd_hp" ) diff --git a/R/internal.R b/R/internal.R index a1fdfb863..ba4e2ef2d 100644 --- a/R/internal.R +++ b/R/internal.R @@ -39,7 +39,14 @@ pow <- function(x, y) x^y root <- function(p, f) { q <- rep(NA_real_, length(p)) for (i in seq_along(p)) { - q[i] <- stats::uniroot(f, p = p[i], lower = 0, upper = 1, extendInt = "upX", tol = .Machine$double.eps)$root + q[i] <- stats::uniroot( + f, + p = p[i], + lower = 0, + upper = 1, + extendInt = "upX", + tol = .Machine$double.eps + )$root } q } diff --git a/R/invpareto.R b/R/invpareto.R index ea9937069..f823ad25e 100644 --- a/R/invpareto.R +++ b/R/invpareto.R @@ -20,10 +20,20 @@ #' @examples #' #' ssd_pinvpareto(1) -ssd_pinvpareto <- function(q, shape = 3, scale = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("invpareto", - q = q, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_pinvpareto <- function( + q, + shape = 3, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "invpareto", + q = q, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -32,10 +42,20 @@ ssd_pinvpareto <- function(q, shape = 3, scale = 1, lower.tail = TRUE, log.p = F #' @examples #' #' ssd_qinvpareto(0.5) -ssd_qinvpareto <- function(p, shape = 3, scale = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("invpareto", - p = p, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_qinvpareto <- function( + p, + shape = 3, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "invpareto", + p = p, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -69,7 +89,8 @@ sinvpareto <- function(data, pars = NULL) { shape <- 1 / mean(log(scale / data$right)) spars <- list(log_scale = log(scale), log_shape = log(shape)) - if (!is.null(pars)) { # use new bias corrected order statistic + if (!is.null(pars)) { + # use new bias corrected order statistic pars$log_scale <- spars$log_scale return(pars) } diff --git a/R/lgumbel.R b/R/lgumbel.R index befd6d960..ef9234497 100644 --- a/R/lgumbel.R +++ b/R/lgumbel.R @@ -32,10 +32,21 @@ dlgumbel <- function(x, locationlog = 0, scalelog = 1, log = FALSE) { #' @examples #' #' ssd_plgumbel(1) -ssd_plgumbel <- function(q, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("gumbel", - q = q, location = locationlog, scale = scalelog, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_plgumbel <- function( + q, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "gumbel", + q = q, + location = locationlog, + scale = scalelog, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -56,7 +67,13 @@ ssd_elgumbel <- function() { #' @inheritParams params #' @keywords internal #' @export -plgumbel <- function(q, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { +plgumbel <- function( + q, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { lifecycle::deprecate_stop("1.0.0", "plgumbel()", "ssd_plgumbel()") } @@ -65,10 +82,21 @@ plgumbel <- function(q, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p #' @examples #' #' ssd_qlgumbel(0.5) -ssd_qlgumbel <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("gumbel", - p = p, location = locationlog, scale = scalelog, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_qlgumbel <- function( + p, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "gumbel", + p = p, + location = locationlog, + scale = scalelog, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -80,11 +108,20 @@ ssd_qlgumbel <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, lo #' @inheritParams params #' @keywords internal #' @export -qlgumbel <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { +qlgumbel <- function( + p, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { lifecycle::deprecate_stop("1.0.0", "qlgumbel()", "ssd_qlgumbel()") - ssd_qlgumbel(p, - locationlog = locationlog, scalelog = scalelog, - lower.tail = lower.tail, log.p = log.p + ssd_qlgumbel( + p, + locationlog = locationlog, + scalelog = scalelog, + lower.tail = lower.tail, + log.p = log.p ) } @@ -97,7 +134,14 @@ qlgumbel <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p #' }) #' hist(x, breaks = 1000) ssd_rlgumbel <- function(n, locationlog = 0, scalelog = 1, chk = TRUE) { - rdist("gumbel", n = n, location = locationlog, scale = scalelog, .lgt = TRUE, chk = chk) + rdist( + "gumbel", + n = n, + location = locationlog, + scale = scalelog, + .lgt = TRUE, + chk = chk + ) } #' @describeIn ssd_e Default Parameter Values for log-Gumbel Distribution diff --git a/R/llogis-llogis.R b/R/llogis-llogis.R index c314aaa50..e070cd796 100644 --- a/R/llogis-llogis.R +++ b/R/llogis-llogis.R @@ -20,13 +20,27 @@ #' @examples #' #' ssd_pllogis_llogis(1) -ssd_pllogis_llogis <- function(q, locationlog1 = 0, scalelog1 = 1, - locationlog2 = 1, scalelog2 = 1, pmix = 0.5, - lower.tail = TRUE, log.p = FALSE) { - pdist("logis_logis", - q = q, location1 = locationlog1, scale1 = scalelog1, - location2 = locationlog2, scale2 = scalelog2, pmix = pmix, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_pllogis_llogis <- function( + q, + locationlog1 = 0, + scalelog1 = 1, + locationlog2 = 1, + scalelog2 = 1, + pmix = 0.5, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "logis_logis", + q = q, + location1 = locationlog1, + scale1 = scalelog1, + location2 = locationlog2, + scale2 = scalelog2, + pmix = pmix, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -35,13 +49,27 @@ ssd_pllogis_llogis <- function(q, locationlog1 = 0, scalelog1 = 1, #' @examples #' #' ssd_qllogis_llogis(0.5) -ssd_qllogis_llogis <- function(p, locationlog1 = 0, scalelog1 = 1, - locationlog2 = 1, scalelog2 = 1, pmix = 0.5, - lower.tail = TRUE, log.p = FALSE) { - qdist("logis_logis", - p = p, location1 = locationlog1, scale1 = scalelog1, - location2 = locationlog2, scale2 = scalelog2, pmix = pmix, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_qllogis_llogis <- function( + p, + locationlog1 = 0, + scalelog1 = 1, + locationlog2 = 1, + scalelog2 = 1, + pmix = 0.5, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "logis_logis", + p = p, + location1 = locationlog1, + scale1 = scalelog1, + location2 = locationlog2, + scale2 = scalelog2, + pmix = pmix, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -53,11 +81,25 @@ ssd_qllogis_llogis <- function(p, locationlog1 = 0, scalelog1 = 1, #' x <- ssd_rllogis_llogis(10000) #' }) #' hist(x, breaks = 1000) -ssd_rllogis_llogis <- function(n, locationlog1 = 0, scalelog1 = 1, - locationlog2 = 1, scalelog2 = 1, pmix = 0.5, chk = TRUE) { - rdist("logis_logis", - n = n, location1 = locationlog1, scale1 = scalelog1, - location2 = locationlog2, scale2 = scalelog2, pmix = pmix, .lgt = TRUE, chk = chk +ssd_rllogis_llogis <- function( + n, + locationlog1 = 0, + scalelog1 = 1, + locationlog2 = 1, + scalelog2 = 1, + pmix = 0.5, + chk = TRUE +) { + rdist( + "logis_logis", + n = n, + location1 = locationlog1, + scale1 = scalelog1, + location2 = locationlog2, + scale2 = scalelog2, + pmix = pmix, + .lgt = TRUE, + chk = chk ) } @@ -68,8 +110,11 @@ ssd_rllogis_llogis <- function(n, locationlog1 = 0, scalelog1 = 1, #' ssd_ellogis_llogis() ssd_ellogis_llogis <- function() { list( - locationlog1 = 0, scalelog1 = 1, - locationlog2 = 1, scalelog2 = 1, pmix = 0.5 + locationlog1 = 0, + scalelog1 = 1, + locationlog2 = 1, + scalelog2 = 1, + pmix = 0.5 ) } @@ -94,8 +139,20 @@ sllogis_llogis <- function(data, pars = NULL) { bllogis_llogis <- function(x, min_pmix, ...) { list( - lower = list(locationlog1 = -Inf, log_scalelog1 = -Inf, locationlog2 = -Inf, log_scalelog2 = -Inf, pmix = min_pmix), - upper = list(locationlog1 = Inf, log_scalelog1 = Inf, locationlog2 = Inf, log_scalelog2 = Inf, pmix = 1 - min_pmix) + lower = list( + locationlog1 = -Inf, + log_scalelog1 = -Inf, + locationlog2 = -Inf, + log_scalelog2 = -Inf, + pmix = min_pmix + ), + upper = list( + locationlog1 = Inf, + log_scalelog1 = Inf, + locationlog2 = Inf, + log_scalelog2 = Inf, + pmix = 1 - min_pmix + ) ) } @@ -103,7 +160,9 @@ plogis_logis_ssd <- function(q, location1, scale1, location2, scale2, pmix) { if (scale1 <= 0 || scale2 <= 0 || pmix <= 0 || pmix >= 1) { return(NaN) } - pmix * plogis_ssd(q, location1, scale1) + (1 - pmix) * plogis_ssd(q, location2, scale2) + pmix * + plogis_ssd(q, location1, scale1) + + (1 - pmix) * plogis_ssd(q, location2, scale2) } qlogis_logis_ssd <- function(p, location1, scale1, location2, scale2, pmix) { @@ -128,18 +187,38 @@ rlogis_logis_ssd <- function(n, location1, scale1, location2, scale2, pmix) { x } -pllogis_llogis_ssd <- function(q, locationlog1, scalelog1, - locationlog2, scalelog2, pmix) { - plogis_logis_ssd(log(q), - location1 = locationlog1, scale1 = scalelog1, - location2 = locationlog2, scale2 = scalelog2, pmix = pmix +pllogis_llogis_ssd <- function( + q, + locationlog1, + scalelog1, + locationlog2, + scalelog2, + pmix +) { + plogis_logis_ssd( + log(q), + location1 = locationlog1, + scale1 = scalelog1, + location2 = locationlog2, + scale2 = scalelog2, + pmix = pmix ) } -qllogis_llogis_ssd <- function(p, locationlog1, scalelog1, - locationlog2, scalelog2, pmix) { - exp(qlogis_logis_ssd(p, - location1 = locationlog1, scale1 = scalelog1, - location2 = locationlog2, scale2 = scalelog2, pmix = pmix +qllogis_llogis_ssd <- function( + p, + locationlog1, + scalelog1, + locationlog2, + scalelog2, + pmix +) { + exp(qlogis_logis_ssd( + p, + location1 = locationlog1, + scale1 = scalelog1, + location2 = locationlog2, + scale2 = scalelog2, + pmix = pmix )) } diff --git a/R/llogis.R b/R/llogis.R index 0252fa17d..330347b77 100644 --- a/R/llogis.R +++ b/R/llogis.R @@ -20,10 +20,21 @@ #' @examples #' #' ssd_pllogis(1) -ssd_pllogis <- function(q, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("logis", - q = q, location = locationlog, scale = scalelog, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_pllogis <- function( + q, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "logis", + q = q, + location = locationlog, + scale = scalelog, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -32,10 +43,21 @@ ssd_pllogis <- function(q, locationlog = 0, scalelog = 1, lower.tail = TRUE, log #' @examples #' #' ssd_qllogis(0.5) -ssd_qllogis <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("logis", - p = p, location = locationlog, scale = scalelog, - lower.tail = lower.tail, log.p = log.p, .lgt = TRUE +ssd_qllogis <- function( + p, + locationlog = 0, + scalelog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "logis", + p = p, + location = locationlog, + scale = scalelog, + lower.tail = lower.tail, + log.p = log.p, + .lgt = TRUE ) } @@ -48,7 +70,14 @@ ssd_qllogis <- function(p, locationlog = 0, scalelog = 1, lower.tail = TRUE, log #' }) #' hist(x, breaks = 1000) ssd_rllogis <- function(n, locationlog = 0, scalelog = 1, chk = TRUE) { - rdist("logis", n = n, location = locationlog, scale = scalelog, .lgt = TRUE, chk = chk) + rdist( + "logis", + n = n, + location = locationlog, + scale = scalelog, + .lgt = TRUE, + chk = chk + ) } #' @describeIn ssd_e Default Parameter Values for Log-Logistic Distribution diff --git a/R/lnorm-lnorm.R b/R/lnorm-lnorm.R index dec13cb44..557b0e927 100644 --- a/R/lnorm-lnorm.R +++ b/R/lnorm-lnorm.R @@ -20,13 +20,26 @@ #' @examples #' #' ssd_plnorm_lnorm(1) -ssd_plnorm_lnorm <- function(q, meanlog1 = 0, sdlog1 = 1, - meanlog2 = 1, sdlog2 = 1, pmix = 0.5, - lower.tail = TRUE, log.p = FALSE) { - pdist("lnorm_lnorm", - q = q, meanlog1 = meanlog1, sdlog1 = sdlog1, - meanlog2 = meanlog2, sdlog2 = sdlog2, pmix = pmix, - lower.tail = lower.tail, log.p = log.p +ssd_plnorm_lnorm <- function( + q, + meanlog1 = 0, + sdlog1 = 1, + meanlog2 = 1, + sdlog2 = 1, + pmix = 0.5, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "lnorm_lnorm", + q = q, + meanlog1 = meanlog1, + sdlog1 = sdlog1, + meanlog2 = meanlog2, + sdlog2 = sdlog2, + pmix = pmix, + lower.tail = lower.tail, + log.p = log.p ) } @@ -35,13 +48,26 @@ ssd_plnorm_lnorm <- function(q, meanlog1 = 0, sdlog1 = 1, #' @examples #' #' ssd_qlnorm_lnorm(0.5) -ssd_qlnorm_lnorm <- function(p, meanlog1 = 0, sdlog1 = 1, - meanlog2 = 1, sdlog2 = 1, pmix = 0.5, - lower.tail = TRUE, log.p = FALSE) { - qdist("lnorm_lnorm", - p = p, meanlog1 = meanlog1, sdlog1 = sdlog1, - meanlog2 = meanlog2, sdlog2 = sdlog2, pmix = pmix, - lower.tail = lower.tail, log.p = log.p +ssd_qlnorm_lnorm <- function( + p, + meanlog1 = 0, + sdlog1 = 1, + meanlog2 = 1, + sdlog2 = 1, + pmix = 0.5, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "lnorm_lnorm", + p = p, + meanlog1 = meanlog1, + sdlog1 = sdlog1, + meanlog2 = meanlog2, + sdlog2 = sdlog2, + pmix = pmix, + lower.tail = lower.tail, + log.p = log.p ) } @@ -53,11 +79,24 @@ ssd_qlnorm_lnorm <- function(p, meanlog1 = 0, sdlog1 = 1, #' x <- ssd_rlnorm_lnorm(10000) #' }) #' hist(x, breaks = 1000) -ssd_rlnorm_lnorm <- function(n, meanlog1 = 0, sdlog1 = 1, - meanlog2 = 1, sdlog2 = 1, pmix = 0.5, chk = TRUE) { - rdist("lnorm_lnorm", - n = n, meanlog1 = meanlog1, sdlog1 = sdlog1, - meanlog2 = meanlog2, sdlog2 = sdlog2, pmix = pmix, chk = chk +ssd_rlnorm_lnorm <- function( + n, + meanlog1 = 0, + sdlog1 = 1, + meanlog2 = 1, + sdlog2 = 1, + pmix = 0.5, + chk = TRUE +) { + rdist( + "lnorm_lnorm", + n = n, + meanlog1 = meanlog1, + sdlog1 = sdlog1, + meanlog2 = meanlog2, + sdlog2 = sdlog2, + pmix = pmix, + chk = chk ) } @@ -68,8 +107,11 @@ ssd_rlnorm_lnorm <- function(n, meanlog1 = 0, sdlog1 = 1, #' ssd_elnorm_lnorm() ssd_elnorm_lnorm <- function() { list( - meanlog1 = 0, sdlog1 = 1, - meanlog2 = 1, sdlog2 = 1, pmix = 0.5 + meanlog1 = 0, + sdlog1 = 1, + meanlog2 = 1, + sdlog2 = 1, + pmix = 0.5 ) } @@ -95,8 +137,20 @@ slnorm_lnorm <- function(data, pars = NULL) { blnorm_lnorm <- function(x, min_pmix, ...) { list( - lower = list(meanlog1 = -Inf, log_sdlog1 = -Inf, meanlog2 = -Inf, log_sdlog2 = -Inf, pmix = min_pmix), - upper = list(meanlog1 = Inf, log_sdlog1 = Inf, meanlog2 = Inf, log_sdlog2 = Inf, pmix = 1 - min_pmix) + lower = list( + meanlog1 = -Inf, + log_sdlog1 = -Inf, + meanlog2 = -Inf, + log_sdlog2 = -Inf, + pmix = min_pmix + ), + upper = list( + meanlog1 = Inf, + log_sdlog1 = Inf, + meanlog2 = Inf, + log_sdlog2 = Inf, + pmix = 1 - min_pmix + ) ) } @@ -104,7 +158,9 @@ plnorm_lnorm_ssd <- function(q, meanlog1, sdlog1, meanlog2, sdlog2, pmix) { if (sdlog1 <= 0 || sdlog2 <= 0 || pmix <= 0 || pmix >= 1) { return(NaN) } - pmix * plnorm_ssd(q, meanlog1, sdlog1) + (1 - pmix) * plnorm_ssd(q, meanlog2, sdlog2) + pmix * + plnorm_ssd(q, meanlog1, sdlog1) + + (1 - pmix) * plnorm_ssd(q, meanlog2, sdlog2) } qlnorm_lnorm_ssd <- function(p, meanlog1, sdlog1, meanlog2, sdlog2, pmix) { diff --git a/R/lnorm.R b/R/lnorm.R index 17fe8dd55..adeb2f6df 100644 --- a/R/lnorm.R +++ b/R/lnorm.R @@ -20,10 +20,20 @@ #' @examples #' #' ssd_plnorm(1) -ssd_plnorm <- function(q, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("lnorm", - q = q, meanlog = meanlog, sdlog = sdlog, - lower.tail = lower.tail, log.p = log.p +ssd_plnorm <- function( + q, + meanlog = 0, + sdlog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "lnorm", + q = q, + meanlog = meanlog, + sdlog = sdlog, + lower.tail = lower.tail, + log.p = log.p ) } @@ -32,10 +42,20 @@ ssd_plnorm <- function(q, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FAL #' @examples #' #' ssd_qlnorm(0.5) -ssd_qlnorm <- function(p, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("lnorm", - p = p, meanlog = meanlog, sdlog = sdlog, - lower.tail = lower.tail, log.p = log.p +ssd_qlnorm <- function( + p, + meanlog = 0, + sdlog = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "lnorm", + p = p, + meanlog = meanlog, + sdlog = sdlog, + lower.tail = lower.tail, + log.p = log.p ) } diff --git a/R/match-moments.R b/R/match-moments.R index 298b45b58..3aa48f617 100644 --- a/R/match-moments.R +++ b/R/match-moments.R @@ -31,9 +31,14 @@ min_discrepancy <- function(dist, meanlog, sdlog, nsim) { pars$chk <- NULL pars <- unlist(pars) - optim(pars, discrepancy, - fun = fun, meanlog = meanlog, sdlog = sdlog, - nsim = nsim, control = list(abstol = 0.01) + optim( + pars, + discrepancy, + fun = fun, + meanlog = meanlog, + sdlog = sdlog, + nsim = nsim, + control = list(abstol = 0.01) ) } @@ -55,13 +60,24 @@ min_discrepancy <- function(dist, meanlog, sdlog, nsim) { #' print(moments) #' ssd_hc(moments) #' ssd_plot_cdf(moments) -ssd_match_moments <- function(dists = ssd_dists_bcanz(), meanlog = 1, sdlog = 1, ..., - nsim = 1e+05) { +ssd_match_moments <- function( + dists = ssd_dists_bcanz(), + meanlog = 1, + sdlog = 1, + ..., + nsim = 1e+05 +) { chk_vector(dists) chk_s3_class(dists, "character") chk_unused(...) - pars <- lapply(dists, min_discrepancy, meanlog = meanlog, sdlog = sdlog, nsim = nsim) + pars <- lapply( + dists, + min_discrepancy, + meanlog = meanlog, + sdlog = sdlog, + nsim = nsim + ) pars <- lapply(pars, function(x) x$par) names(pars) <- dists pars diff --git a/R/multi.R b/R/multi.R index b41d82c5e..4b3b9e404 100644 --- a/R/multi.R +++ b/R/multi.R @@ -22,43 +22,46 @@ #' # multi #' ssd_pmulti(1, gamma.weight = 0.5, lnorm.weight = 0.5) ssd_pmulti <- function( - q, - burrIII3.weight = 0, - burrIII3.shape1 = 1, - burrIII3.shape2 = 1, - burrIII3.scale = 1, - gamma.weight = 0, - gamma.shape = 1, - gamma.scale = 1, - gompertz.weight = 0, - gompertz.location = 1, - gompertz.shape = 1, - lgumbel.weight = 0, - lgumbel.locationlog = 0, - lgumbel.scalelog = 1, - llogis.weight = 0, - llogis.locationlog = 0, - llogis.scalelog = 1, - llogis_llogis.weight = 0, - llogis_llogis.locationlog1 = 0, - llogis_llogis.scalelog1 = 1, - llogis_llogis.locationlog2 = 1, - llogis_llogis.scalelog2 = 1, - llogis_llogis.pmix = 0.5, - lnorm.weight = 0, - lnorm.meanlog = 0, - lnorm.sdlog = 1, - lnorm_lnorm.weight = 0, - lnorm_lnorm.meanlog1 = 0, - lnorm_lnorm.sdlog1 = 1, - lnorm_lnorm.meanlog2 = 1, - lnorm_lnorm.sdlog2 = 1, - lnorm_lnorm.pmix = 0.5, - weibull.weight = 0, - weibull.shape = 1, - weibull.scale = 1, - lower.tail = TRUE, log.p = FALSE) { - pdist("multi", + q, + burrIII3.weight = 0, + burrIII3.shape1 = 1, + burrIII3.shape2 = 1, + burrIII3.scale = 1, + gamma.weight = 0, + gamma.shape = 1, + gamma.scale = 1, + gompertz.weight = 0, + gompertz.location = 1, + gompertz.shape = 1, + lgumbel.weight = 0, + lgumbel.locationlog = 0, + lgumbel.scalelog = 1, + llogis.weight = 0, + llogis.locationlog = 0, + llogis.scalelog = 1, + llogis_llogis.weight = 0, + llogis_llogis.locationlog1 = 0, + llogis_llogis.scalelog1 = 1, + llogis_llogis.locationlog2 = 1, + llogis_llogis.scalelog2 = 1, + llogis_llogis.pmix = 0.5, + lnorm.weight = 0, + lnorm.meanlog = 0, + lnorm.sdlog = 1, + lnorm_lnorm.weight = 0, + lnorm_lnorm.meanlog1 = 0, + lnorm_lnorm.sdlog1 = 1, + lnorm_lnorm.meanlog2 = 1, + lnorm_lnorm.sdlog2 = 1, + lnorm_lnorm.pmix = 0.5, + weibull.weight = 0, + weibull.shape = 1, + weibull.scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "multi", q = q, burrIII3.weight = burrIII3.weight, burrIII3.shape1 = burrIII3.shape1, @@ -94,7 +97,8 @@ ssd_pmulti <- function( weibull.weight = weibull.weight, weibull.shape = weibull.shape, weibull.scale = weibull.scale, - lower.tail = lower.tail, log.p = log.p + lower.tail = lower.tail, + log.p = log.p ) } @@ -105,43 +109,46 @@ ssd_pmulti <- function( #' # multi #' ssd_qmulti(0.5, gamma.weight = 0.5, lnorm.weight = 0.5) ssd_qmulti <- function( - p, - burrIII3.weight = 0, - burrIII3.shape1 = 1, - burrIII3.shape2 = 1, - burrIII3.scale = 1, - gamma.weight = 0, - gamma.shape = 1, - gamma.scale = 1, - gompertz.weight = 0, - gompertz.location = 1, - gompertz.shape = 1, - lgumbel.weight = 0, - lgumbel.locationlog = 0, - lgumbel.scalelog = 1, - llogis.weight = 0, - llogis.locationlog = 0, - llogis.scalelog = 1, - llogis_llogis.weight = 0, - llogis_llogis.locationlog1 = 0, - llogis_llogis.scalelog1 = 1, - llogis_llogis.locationlog2 = 1, - llogis_llogis.scalelog2 = 1, - llogis_llogis.pmix = 0.5, - lnorm.weight = 0, - lnorm.meanlog = 0, - lnorm.sdlog = 1, - lnorm_lnorm.weight = 0, - lnorm_lnorm.meanlog1 = 0, - lnorm_lnorm.sdlog1 = 1, - lnorm_lnorm.meanlog2 = 1, - lnorm_lnorm.sdlog2 = 1, - lnorm_lnorm.pmix = 0.5, - weibull.weight = 0, - weibull.shape = 1, - weibull.scale = 1, - lower.tail = TRUE, log.p = FALSE) { - qdist("multi", + p, + burrIII3.weight = 0, + burrIII3.shape1 = 1, + burrIII3.shape2 = 1, + burrIII3.scale = 1, + gamma.weight = 0, + gamma.shape = 1, + gamma.scale = 1, + gompertz.weight = 0, + gompertz.location = 1, + gompertz.shape = 1, + lgumbel.weight = 0, + lgumbel.locationlog = 0, + lgumbel.scalelog = 1, + llogis.weight = 0, + llogis.locationlog = 0, + llogis.scalelog = 1, + llogis_llogis.weight = 0, + llogis_llogis.locationlog1 = 0, + llogis_llogis.scalelog1 = 1, + llogis_llogis.locationlog2 = 1, + llogis_llogis.scalelog2 = 1, + llogis_llogis.pmix = 0.5, + lnorm.weight = 0, + lnorm.meanlog = 0, + lnorm.sdlog = 1, + lnorm_lnorm.weight = 0, + lnorm_lnorm.meanlog1 = 0, + lnorm_lnorm.sdlog1 = 1, + lnorm_lnorm.meanlog2 = 1, + lnorm_lnorm.sdlog2 = 1, + lnorm_lnorm.pmix = 0.5, + weibull.weight = 0, + weibull.shape = 1, + weibull.scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "multi", p = p, burrIII3.weight = burrIII3.weight, burrIII3.shape1 = burrIII3.shape1, @@ -177,7 +184,8 @@ ssd_qmulti <- function( weibull.weight = weibull.weight, weibull.shape = weibull.shape, weibull.scale = weibull.scale, - lower.tail = lower.tail, log.p = log.p + lower.tail = lower.tail, + log.p = log.p ) } @@ -190,43 +198,45 @@ ssd_qmulti <- function( #' }) #' hist(x, breaks = 100) ssd_rmulti <- function( - n, - burrIII3.weight = 0, - burrIII3.shape1 = 1, - burrIII3.shape2 = 1, - burrIII3.scale = 1, - gamma.weight = 0, - gamma.shape = 1, - gamma.scale = 1, - gompertz.weight = 0, - gompertz.location = 1, - gompertz.shape = 1, - lgumbel.weight = 0, - lgumbel.locationlog = 0, - lgumbel.scalelog = 1, - llogis.weight = 0, - llogis.locationlog = 0, - llogis.scalelog = 1, - llogis_llogis.weight = 0, - llogis_llogis.locationlog1 = 0, - llogis_llogis.scalelog1 = 1, - llogis_llogis.locationlog2 = 1, - llogis_llogis.scalelog2 = 1, - llogis_llogis.pmix = 0.5, - lnorm.weight = 0, - lnorm.meanlog = 0, - lnorm.sdlog = 1, - lnorm_lnorm.weight = 0, - lnorm_lnorm.meanlog1 = 0, - lnorm_lnorm.sdlog1 = 1, - lnorm_lnorm.meanlog2 = 1, - lnorm_lnorm.sdlog2 = 1, - lnorm_lnorm.pmix = 0.5, - weibull.weight = 0, - weibull.shape = 1, - weibull.scale = 1, - chk = TRUE) { - rdist("multi", + n, + burrIII3.weight = 0, + burrIII3.shape1 = 1, + burrIII3.shape2 = 1, + burrIII3.scale = 1, + gamma.weight = 0, + gamma.shape = 1, + gamma.scale = 1, + gompertz.weight = 0, + gompertz.location = 1, + gompertz.shape = 1, + lgumbel.weight = 0, + lgumbel.locationlog = 0, + lgumbel.scalelog = 1, + llogis.weight = 0, + llogis.locationlog = 0, + llogis.scalelog = 1, + llogis_llogis.weight = 0, + llogis_llogis.locationlog1 = 0, + llogis_llogis.scalelog1 = 1, + llogis_llogis.locationlog2 = 1, + llogis_llogis.scalelog2 = 1, + llogis_llogis.pmix = 0.5, + lnorm.weight = 0, + lnorm.meanlog = 0, + lnorm.sdlog = 1, + lnorm_lnorm.weight = 0, + lnorm_lnorm.meanlog1 = 0, + lnorm_lnorm.sdlog1 = 1, + lnorm_lnorm.meanlog2 = 1, + lnorm_lnorm.sdlog2 = 1, + lnorm_lnorm.pmix = 0.5, + weibull.weight = 0, + weibull.shape = 1, + weibull.scale = 1, + chk = TRUE +) { + rdist( + "multi", n = n, burrIII3.weight = burrIII3.weight, burrIII3.shape1 = burrIII3.shape1, @@ -384,41 +394,42 @@ qmulti_list <- function(p, list) { } pmulti_ssd <- function( - q, - burrIII3.weight, - burrIII3.shape1, - burrIII3.shape2, - burrIII3.scale, - gamma.weight, - gamma.shape, - gamma.scale, - gompertz.weight, - gompertz.location, - gompertz.shape, - lgumbel.weight, - lgumbel.locationlog, - lgumbel.scalelog, - llogis.weight, - llogis.locationlog, - llogis.scalelog, - llogis_llogis.weight, - llogis_llogis.locationlog1, - llogis_llogis.scalelog1, - llogis_llogis.locationlog2, - llogis_llogis.scalelog2, - llogis_llogis.pmix, - lnorm.weight, - lnorm.meanlog, - lnorm.sdlog, - lnorm_lnorm.weight, - lnorm_lnorm.meanlog1, - lnorm_lnorm.sdlog1, - lnorm_lnorm.meanlog2, - lnorm_lnorm.sdlog2, - lnorm_lnorm.pmix, - weibull.weight, - weibull.shape, - weibull.scale) { + q, + burrIII3.weight, + burrIII3.shape1, + burrIII3.shape2, + burrIII3.scale, + gamma.weight, + gamma.shape, + gamma.scale, + gompertz.weight, + gompertz.location, + gompertz.shape, + lgumbel.weight, + lgumbel.locationlog, + lgumbel.scalelog, + llogis.weight, + llogis.locationlog, + llogis.scalelog, + llogis_llogis.weight, + llogis_llogis.locationlog1, + llogis_llogis.scalelog1, + llogis_llogis.locationlog2, + llogis_llogis.scalelog2, + llogis_llogis.pmix, + lnorm.weight, + lnorm.meanlog, + lnorm.sdlog, + lnorm_lnorm.weight, + lnorm_lnorm.meanlog1, + lnorm_lnorm.sdlog1, + lnorm_lnorm.meanlog2, + lnorm_lnorm.sdlog2, + lnorm_lnorm.pmix, + weibull.weight, + weibull.shape, + weibull.scale +) { list <- .relist_estimates( list( burrIII3.weight = burrIII3.weight, @@ -462,41 +473,42 @@ pmulti_ssd <- function( } qmulti_ssd <- function( - q, - burrIII3.weight, - burrIII3.shape1, - burrIII3.shape2, - burrIII3.scale, - gamma.weight, - gamma.shape, - gamma.scale, - gompertz.weight, - gompertz.location, - gompertz.shape, - lgumbel.weight, - lgumbel.locationlog, - lgumbel.scalelog, - llogis.weight, - llogis.locationlog, - llogis.scalelog, - llogis_llogis.weight, - llogis_llogis.locationlog1, - llogis_llogis.scalelog1, - llogis_llogis.locationlog2, - llogis_llogis.scalelog2, - llogis_llogis.pmix, - lnorm.weight, - lnorm.meanlog, - lnorm.sdlog, - lnorm_lnorm.weight, - lnorm_lnorm.meanlog1, - lnorm_lnorm.sdlog1, - lnorm_lnorm.meanlog2, - lnorm_lnorm.sdlog2, - lnorm_lnorm.pmix, - weibull.weight, - weibull.shape, - weibull.scale) { + q, + burrIII3.weight, + burrIII3.shape1, + burrIII3.shape2, + burrIII3.scale, + gamma.weight, + gamma.shape, + gamma.scale, + gompertz.weight, + gompertz.location, + gompertz.shape, + lgumbel.weight, + lgumbel.locationlog, + lgumbel.scalelog, + llogis.weight, + llogis.locationlog, + llogis.scalelog, + llogis_llogis.weight, + llogis_llogis.locationlog1, + llogis_llogis.scalelog1, + llogis_llogis.locationlog2, + llogis_llogis.scalelog2, + llogis_llogis.pmix, + lnorm.weight, + lnorm.meanlog, + lnorm.sdlog, + lnorm_lnorm.weight, + lnorm_lnorm.meanlog1, + lnorm_lnorm.sdlog1, + lnorm_lnorm.meanlog2, + lnorm_lnorm.sdlog2, + lnorm_lnorm.pmix, + weibull.weight, + weibull.shape, + weibull.scale +) { list <- .relist_estimates( list( burrIII3.weight = burrIII3.weight, @@ -540,41 +552,42 @@ qmulti_ssd <- function( } rmulti_ssd <- function( - n, - burrIII3.weight, - burrIII3.shape1, - burrIII3.shape2, - burrIII3.scale, - gamma.weight, - gamma.shape, - gamma.scale, - gompertz.weight, - gompertz.location, - gompertz.shape, - lgumbel.weight, - lgumbel.locationlog, - lgumbel.scalelog, - llogis.weight, - llogis.locationlog, - llogis.scalelog, - llogis_llogis.weight, - llogis_llogis.locationlog1, - llogis_llogis.scalelog1, - llogis_llogis.locationlog2, - llogis_llogis.scalelog2, - llogis_llogis.pmix, - lnorm.weight, - lnorm.meanlog, - lnorm.sdlog, - lnorm_lnorm.weight, - lnorm_lnorm.meanlog1, - lnorm_lnorm.sdlog1, - lnorm_lnorm.meanlog2, - lnorm_lnorm.sdlog2, - lnorm_lnorm.pmix, - weibull.weight, - weibull.shape, - weibull.scale) { + n, + burrIII3.weight, + burrIII3.shape1, + burrIII3.shape2, + burrIII3.scale, + gamma.weight, + gamma.shape, + gamma.scale, + gompertz.weight, + gompertz.location, + gompertz.shape, + lgumbel.weight, + lgumbel.locationlog, + lgumbel.scalelog, + llogis.weight, + llogis.locationlog, + llogis.scalelog, + llogis_llogis.weight, + llogis_llogis.locationlog1, + llogis_llogis.scalelog1, + llogis_llogis.locationlog2, + llogis_llogis.scalelog2, + llogis_llogis.pmix, + lnorm.weight, + lnorm.meanlog, + lnorm.sdlog, + lnorm_lnorm.weight, + lnorm_lnorm.meanlog1, + lnorm_lnorm.sdlog1, + lnorm_lnorm.meanlog2, + lnorm_lnorm.sdlog2, + lnorm_lnorm.pmix, + weibull.weight, + weibull.shape, + weibull.scale +) { p <- runif(n) list <- .relist_estimates( diff --git a/R/params.R b/R/params.R index 04040d9da..51f3a59a4 100644 --- a/R/params.R +++ b/R/params.R @@ -33,7 +33,7 @@ #' @param ci A flag specifying whether to estimate confidence intervals (by bootstrapping). #' @param ci_method A string specifying which method to use for estimating #' the standard error and confidence limits from the bootstrap samples. -#' The default and recommended value is still `ci_method = "weighted_samples"` +#' The default and recommended value is still `ci_method = "weighted_samples"` #' which takes bootstrap samples #' from each distribution proportional to its AICc based weights and #' calculates the confidence limits (and SE) from this single set. @@ -46,7 +46,7 @@ #' limits while `ci_method = GMACL` which #' takes the weighted geometric mean of the confidence limits was added for completeness but is also not recommended. #' Finally `ci_method = "arithmetic_samples"` and `ci_method = "geometric_samples"` -#' take the weighted arithmetic or geometric mean of the values for +#' take the weighted arithmetic or geometric mean of the values for #' each bootstrap iteration across all the distributions and then #' calculate the confidence limits (and SE) from the single set of samples. #' @param censoring A numeric vector of the left and right censoring values. diff --git a/R/plot-cdf.R b/R/plot-cdf.R index ae7496e37..ada7c723c 100644 --- a/R/plot-cdf.R +++ b/R/plot-cdf.R @@ -35,15 +35,39 @@ ssd_plot_cdf <- function(x, ...) { #' fits <- ssd_fit_dists(ssddata::ccme_boron) #' ssd_plot_cdf(fits) #' ssd_plot_cdf(fits, average = NA) -ssd_plot_cdf.fitdists <- function(x, average = FALSE, est_method = "multi", delta = 9.21, ...) { +ssd_plot_cdf.fitdists <- function( + x, + average = FALSE, + est_method = "multi", + delta = 9.21, + ... +) { chk_scalar(average) chk_logical(average) if (!is.na(average)) { - pred <- ssd_hc(x, proportion = 1:99 / 100, average = average, est_method = est_method, delta = delta) + pred <- ssd_hc( + x, + proportion = 1:99 / 100, + average = average, + est_method = est_method, + delta = delta + ) } else { - pred <- ssd_hc(x, proportion = 1:99 / 100, average = FALSE, est_method = est_method, delta = delta) - pred_ave <- ssd_hc(x, proportion = 1:99 / 100, average = TRUE, est_method = est_method, delta = delta) + pred <- ssd_hc( + x, + proportion = 1:99 / 100, + average = FALSE, + est_method = est_method, + delta = delta + ) + pred_ave <- ssd_hc( + x, + proportion = 1:99 / 100, + average = TRUE, + est_method = est_method, + delta = delta + ) pred <- dplyr::bind_rows(pred, pred_ave) } data <- ssd_data(x) @@ -53,11 +77,18 @@ ssd_plot_cdf.fitdists <- function(x, average = FALSE, est_method = "multi", delt linecolor <- linetype gp <- ssd_plot( - data = data, pred = pred, left = cols$left, right = cols$right, - ci = FALSE, hc = NULL, linetype = linetype, linecolor = linecolor, ... + data = data, + pred = pred, + left = cols$left, + right = cols$right, + ci = FALSE, + hc = NULL, + linetype = linetype, + linecolor = linecolor, + ... ) - if(!is.null(linetype)) { - gp <- gp + labs(linetype = "Distribution", color = "Distribution") + if (!is.null(linetype)) { + gp <- gp + labs(linetype = "Distribution", color = "Distribution") } gp } @@ -80,8 +111,13 @@ ssd_plot_cdf.list <- function(x, ...) { linecolor <- linetype ssd_plot( - data = data, pred = pred, - ci = FALSE, hc = NULL, linetype = linetype, linecolor = linecolor, ... + data = data, + pred = pred, + ci = FALSE, + hc = NULL, + linetype = linetype, + linecolor = linecolor, + ... ) + labs(color = "Distribution", linetype = "Distribution") } diff --git a/R/plot-cf.R b/R/plot-cf.R index ddb30df60..355136975 100644 --- a/R/plot-cf.R +++ b/R/plot-cf.R @@ -27,7 +27,10 @@ #' @keywords internal #' @export ssd_plot_cf <- function(data, left = "Conc") { - lifecycle::deprecate_stop("0.3.5", "ssd_plot_cf()", "fitdistrplus::descdist()", + lifecycle::deprecate_stop( + "0.3.5", + "ssd_plot_cf()", + "fitdistrplus::descdist()", details = "Please use fitdistrplus::descdist(data$Conc, boot = 100L)." ) } diff --git a/R/plot-data.R b/R/plot-data.R index e655164f5..1e4b8de97 100644 --- a/R/plot-data.R +++ b/R/plot-data.R @@ -25,15 +25,26 @@ #' @export #' @examples #' ssd_plot_data(ssddata::ccme_boron, label = "Species", shape = "Group") -ssd_plot_data <- function(data, left = "Conc", right = left, ..., - label = NULL, shape = NULL, color = NULL, size = 2.5, - xlab = "Concentration", ylab = "Species Affected", - shift_x = 3, add_x = 0, - big.mark = ",", - decimal.mark = getOption("OutDec", "."), - suffix = "%", - bounds = c(left = 1, right = 1), - trans = "log10", xbreaks = waiver()) { +ssd_plot_data <- function( + data, + left = "Conc", + right = left, + ..., + label = NULL, + shape = NULL, + color = NULL, + size = 2.5, + xlab = "Concentration", + ylab = "Species Affected", + shift_x = 3, + add_x = 0, + big.mark = ",", + decimal.mark = getOption("OutDec", "."), + suffix = "%", + bounds = c(left = 1, right = 1), + trans = "log10", + xbreaks = waiver() +) { .chk_data(data, left, right, weight = NULL, missing = TRUE) chk_unused(...) chk_null_or(label, vld = vld_string) @@ -48,7 +59,6 @@ ssd_plot_data <- function(data, left = "Conc", right = left, ..., chk_string(big.mark) chk_string(decimal.mark) - .chk_bounds(bounds) data <- process_data(data, left, right, weight = NULL) @@ -63,17 +73,33 @@ ssd_plot_data <- function(data, left = "Conc", right = left, ..., if (!is.null(color)) { gp <- gp + - geom_ssdpoint(data = data, aes( - x = !!sym("left"), y = !!sym("y"), shape = !!shape, - color = !!color - ), stat = "identity") + - geom_ssdpoint(data = data, aes( - x = !!sym("right"), y = !!sym("y"), shape = !!shape, - color = !!color - ), stat = "identity") + + geom_ssdpoint( + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + shape = !!shape, + color = !!color + ), + stat = "identity" + ) + + geom_ssdpoint( + data = data, + aes( + x = !!sym("right"), + y = !!sym("y"), + shape = !!shape, + color = !!color + ), + stat = "identity" + ) + geom_ssdsegment( - data = data, aes( - x = !!sym("left"), y = !!sym("y"), xend = !!sym("right"), yend = !!sym("y"), + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + xend = !!sym("right"), + yend = !!sym("y"), color = !!color ), stat = "identity" @@ -81,30 +107,57 @@ ssd_plot_data <- function(data, left = "Conc", right = left, ..., } else { gp <- gp + geom_ssdpoint( - data = data, aes( - x = !!sym("left"), y = !!sym("y"), shape = !!shape + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + shape = !!shape ), stat = "identity" ) + - geom_ssdpoint(data = data, aes( - x = !!sym("right"), y = !!sym("y"), shape = !!shape - ), stat = "identity") + - geom_ssdsegment(data = data, aes( - x = !!sym("left"), y = !!sym("y"), xend = !!sym("right"), yend = !!sym("y") - ), stat = "identity") + geom_ssdpoint( + data = data, + aes( + x = !!sym("right"), + y = !!sym("y"), + shape = !!shape + ), + stat = "identity" + ) + + geom_ssdsegment( + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + xend = !!sym("right"), + yend = !!sym("y") + ), + stat = "identity" + ) } - gp <- gp + plot_coord_scale(data, - xlab = xlab, ylab = ylab, big.mark = big.mark, decimal.mark = decimal.mark, suffix = suffix, - trans = trans, xbreaks = xbreaks - ) + gp <- gp + + plot_coord_scale( + data, + xlab = xlab, + ylab = ylab, + big.mark = big.mark, + decimal.mark = decimal.mark, + suffix = suffix, + trans = trans, + xbreaks = xbreaks + ) if (!is.null(label)) { data$right <- (data$right + add_x) * shift_x - gp <- gp + geom_text( - data = data, aes(x = !!sym("right"), y = !!sym("y"), label = !!label), - hjust = 0, size = size, fontface = "italic" - ) + gp <- gp + + geom_text( + data = data, + aes(x = !!sym("right"), y = !!sym("y"), label = !!label), + hjust = 0, + size = size, + fontface = "italic" + ) } gp diff --git a/R/pqr.R b/R/pqr.R index d3de7c65f..4e0360dff 100644 --- a/R/pqr.R +++ b/R/pqr.R @@ -41,7 +41,9 @@ NULL .pd <- function(q, ..., fun) { args <- c(q, list(...)) - if (any(vapply(args, length, 1L) != 1L)) stop() + if (any(vapply(args, length, 1L) != 1L)) { + stop() + } if (is.nan(q)) { return(NaN) } @@ -60,12 +62,23 @@ NULL p <- mapply(.pd, q, ..., MoreArgs = list(fun = fun)) p[inf & pos] <- 1 p[inf & !pos] <- 0 - if (!lower.tail) p <- 1 - p - if (log.p) p <- log(p) + if (!lower.tail) { + p <- 1 - p + } + if (log.p) { + p <- log(p) + } p } -pdist <- function(dist, q, ..., lower.tail = TRUE, log.p = FALSE, .lgt = FALSE) { +pdist <- function( + dist, + q, + ..., + lower.tail = TRUE, + log.p = FALSE, + .lgt = FALSE +) { if (!length(q)) { return(numeric(0)) } @@ -78,15 +91,21 @@ pdist <- function(dist, q, ..., lower.tail = TRUE, log.p = FALSE, .lgt = FALSE) q[lte] <- NA_real_ p <- .pdist(dist, q = log(q), ..., lower.tail = TRUE, log.p = FALSE) p[lte] <- 0 - if (!lower.tail) p <- 1 - p - if (log.p) p <- log(p) + if (!lower.tail) { + p <- 1 - p + } + if (log.p) { + p <- log(p) + } p } .qd <- function(p, ..., fun, .lgt) { args <- c(p, list(...)) - if (any(vapply(args, length, 1L) != 1L)) stop() + if (any(vapply(args, length, 1L) != 1L)) { + stop() + } if (is.nan(p)) { return(NaN) } @@ -112,19 +131,32 @@ pdist <- function(dist, q, ..., lower.tail = TRUE, log.p = FALSE, .lgt = FALSE) q } -qdist <- function(dist, p, ..., lower.tail = TRUE, log.p = FALSE, .lgt = FALSE) { +qdist <- function( + dist, + p, + ..., + lower.tail = TRUE, + log.p = FALSE, + .lgt = FALSE +) { if (!length(p)) { return(numeric(0)) } - if (log.p) p <- exp(p) - if (!lower.tail) p <- 1 - p + if (log.p) { + p <- exp(p) + } + if (!lower.tail) { + p <- 1 - p + } nvld <- !is.na(p) & !(p >= 0 & p <= 1) p[nvld] <- NA_real_ q <- .qdist(dist, p = p, ..., .lgt = .lgt) q[nvld] <- NaN - if (.lgt) q <- exp(q) + if (.lgt) { + q <- exp(q) + } q } @@ -168,7 +200,9 @@ rdist <- function(dist, n, ..., .lgt = FALSE, chk) { } } r <- .rdist(dist, n = n, ...) - if (.lgt) r <- exp(r) + if (.lgt) { + r <- exp(r) + } r } @@ -183,10 +217,15 @@ bdist <- function(dist, data, min_pmix, range_shape1, range_shape2) { if (!exists(fun, mode = "function")) { return(list(lower = -Inf, upper = Inf)) } - do.call(fun, list( - data = data, min_pmix = min_pmix, - range_shape1 = range_shape1, range_shape2 = range_shape2 - )) + do.call( + fun, + list( + data = data, + min_pmix = min_pmix, + range_shape1 = range_shape1, + range_shape2 = range_shape2 + ) + ) } mdist <- function(dist) { diff --git a/R/predict.R b/R/predict.R index 096fbc22d..1e11c2b4d 100644 --- a/R/predict.R +++ b/R/predict.R @@ -32,24 +32,30 @@ stats::predict #' fits <- ssd_fit_dists(ssddata::ccme_boron) #' predict(fits) predict.fitdists <- function( - object, - percent, - proportion = 1:99 / 100, - ..., - average = TRUE, - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - est_method = "multi", - ci_method = "weighted_samples", - parametric = TRUE, - delta = 9.21, - control = NULL) { + object, + percent, + proportion = 1:99 / 100, + ..., + average = TRUE, + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + est_method = "multi", + ci_method = "weighted_samples", + parametric = TRUE, + delta = 9.21, + control = NULL +) { chk_unused(...) if (lifecycle::is_present(percent)) { - lifecycle::deprecate_soft("2.0.0", "ssd_hc(percent)", "ssd_hc(proportion)", id = "hc") + lifecycle::deprecate_soft( + "2.0.0", + "ssd_hc(percent)", + "ssd_hc(proportion)", + id = "hc" + ) chk_vector(percent) chk_numeric(percent) chk_range(percent, c(0, 100)) @@ -90,19 +96,25 @@ predict.fitdists <- function( #' fits <- ssd_fit_burrlioz(ssddata::ccme_boron) #' predict(fits) predict.fitburrlioz <- function( - object, - percent, - proportion = 1:99 / 100, - ..., - ci = FALSE, - level = 0.95, - nboot = 1000, - min_pboot = 0.8, - parametric = TRUE) { + object, + percent, + proportion = 1:99 / 100, + ..., + ci = FALSE, + level = 0.95, + nboot = 1000, + min_pboot = 0.8, + parametric = TRUE +) { chk_unused(...) if (lifecycle::is_present(percent)) { - lifecycle::deprecate_soft("2.0.0", "ssd_hc(percent)", "ssd_hc(proportion)", id = "hc") + lifecycle::deprecate_soft( + "2.0.0", + "ssd_hc(percent)", + "ssd_hc(proportion)", + id = "hc" + ) chk_vector(percent) chk_numeric(percent) chk_range(percent, c(0, 100)) @@ -113,7 +125,8 @@ predict.fitburrlioz <- function( chk_numeric(proportion) chk_range(proportion) - ssd_hc(object, + ssd_hc( + object, proportion = proportion, ci = ci, level = level, diff --git a/R/print.R b/R/print.R index fcb46e782..e02d5e62a 100644 --- a/R/print.R +++ b/R/print.R @@ -50,9 +50,17 @@ print.summary_fitdists <- function(x, ...) { } properties <- c(censoring, weighted, rescaled) properties <- cc(properties, conj = " and ", brac = "") - if (length(properties)) properties <- paste0(" ", properties) + if (length(properties)) { + properties <- paste0(" ", properties) + } - txt <- paste0("Parameters estimated from ", x$nrow, " rows of", properties, " data.") + txt <- paste0( + "Parameters estimated from ", + x$nrow, + " rows of", + properties, + " data." + ) cat(txt) invisible(x) } diff --git a/R/scales.R b/R/scales.R index 81c50fb93..c6367352f 100644 --- a/R/scales.R +++ b/R/scales.R @@ -28,14 +28,17 @@ #' ggplot2::ggplot(data = ssddata::anon_e, ggplot2::aes(x = Conc / 10)) + #' geom_ssdpoint() + #' ggplot2::scale_x_log10(labels = ssd_label_comma()) -ssd_label_comma <- function(digits = 3, ..., big.mark = ",", - decimal.mark = getOption("OutDec", ".")) { +ssd_label_comma <- function( + digits = 3, + ..., + big.mark = ",", + decimal.mark = getOption("OutDec", ".") +) { chk_unused(...) chk_number(digits) chk_string(big.mark) chk_string(decimal.mark) - function(x) { x <- signif(x, digits = digits) y <- prettyNum(x, big.mark = big.mark, decimal.mark = decimal.mark) @@ -57,17 +60,30 @@ ssd_label_comma <- function(digits = 3, ..., big.mark = ",", #' ggplot2::ggplot(data = ssddata::anon_e, ggplot2::aes(x = Conc / 10)) + #' geom_ssdpoint() + #' ggplot2::scale_x_log10(labels = ssd_label_comma_hc(1.26)) -ssd_label_comma_hc <- function(hc_value, digits = 3, ..., big.mark = ",", - decimal.mark = getOption("OutDec", ".")) { +ssd_label_comma_hc <- function( + hc_value, + digits = 3, + ..., + big.mark = ",", + decimal.mark = getOption("OutDec", ".") +) { chk_unused(...) chk_number(hc_value) function(x) { - marked <- ssd_label_comma(digits = digits, big.mark = big.mark, decimal.mark = decimal.mark)(x) - purrr::map_chr(marked, ~ { - if (!is.na(.x) && .x == signif(hc_value, digits = digits)) - .x <- paste0("
**", .x, "**") - .x - }) + marked <- ssd_label_comma( + digits = digits, + big.mark = big.mark, + decimal.mark = decimal.mark + )(x) + purrr::map_chr( + marked, + ~ { + if (!is.na(.x) && .x == signif(hc_value, digits = digits)) { + .x <- paste0("
**", .x, "**") + } + .x + } + ) } } diff --git a/R/seeds.R b/R/seeds.R index 06b1ebeb5..f874ea41e 100644 --- a/R/seeds.R +++ b/R/seeds.R @@ -18,7 +18,9 @@ rinteger <- function(n = 1L) { chk_whole_number(n) chk_gte(n, 0L) - if (n == 0) integer(0) + if (n == 0) { + integer(0) + } mx <- 2147483647L as.integer(runif(n, -mx, mx)) } diff --git a/R/ssd-plot.R b/R/ssd-plot.R index e16dcab54..3ee4c702c 100644 --- a/R/ssd-plot.R +++ b/R/ssd-plot.R @@ -16,39 +16,65 @@ # limitations under the License. #' @export -ggplot2::waiver +ggplot2::waiver -plot_coord_scale <- function(data, xlab, ylab, trans, big.mark, decimal.mark, - suffix, xbreaks = waiver(), xlimits = NULL, hc_value = NULL) { +plot_coord_scale <- function( + data, + xlab, + ylab, + trans, + big.mark, + decimal.mark, + suffix, + xbreaks = waiver(), + xlimits = NULL, + hc_value = NULL +) { chk_string(xlab) chk_string(ylab) if (is.waive(xbreaks)) { - xbreaks <- switch(trans, - "log10" = function(x) unique(c(scales::log10_trans()$breaks(x), hc_value)), + xbreaks <- switch( + trans, + "log10" = function(x) { + unique(c(scales::log10_trans()$breaks(x), hc_value)) + }, "log" = function(x) unique(c(scales::log_trans()$breaks(x), hc_value)), - "identity" = function(x) unique(c(scales::identity_trans()$breaks(x), hc_value)) + "identity" = function(x) { + unique(c(scales::identity_trans()$breaks(x), hc_value)) + } ) } else { xbreaks <- unique(c(xbreaks, hc_value)) } - ssd_label_fun <- ssd_label_comma(big.mark = big.mark, decimal.mark = decimal.mark) + ssd_label_fun <- ssd_label_comma( + big.mark = big.mark, + decimal.mark = decimal.mark + ) if (!is.null(hc_value)) { - ssd_label_fun <- ssd_label_comma_hc(hc_value, big.mark = big.mark, decimal.mark = decimal.mark) + ssd_label_fun <- ssd_label_comma_hc( + hc_value, + big.mark = big.mark, + decimal.mark = decimal.mark + ) } list( coord_transform(x = trans), - scale_x_continuous(xlab, + scale_x_continuous( + xlab, breaks = xbreaks, minor_breaks = NULL, labels = ssd_label_fun, limits = xlimits ), - scale_y_continuous(ylab, - labels = label_percent(suffix = suffix), limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), expand = c(0, 0) + scale_y_continuous( + ylab, + labels = label_percent(suffix = suffix), + limits = c(0, 1), + breaks = seq(0, 1, by = 0.2), + expand = c(0, 0) ) ) } @@ -63,21 +89,43 @@ plot_coord_scale <- function(data, xlab, ylab, trans, big.mark, decimal.mark, #' @export #' @examples #' ssd_plot(ssddata::ccme_boron, boron_pred, label = "Species", shape = "Group") -ssd_plot <- function(data, pred, left = "Conc", right = left, ..., - label = NULL, shape = NULL, color = NULL, size, - linetype = NULL, linecolor = NULL, - xlab = "Concentration", ylab = "Species Affected", - ci = TRUE, ribbon = TRUE, hc = 0.05, - shift_x = 3, add_x = 0, - bounds = c(left = 1, right = 1), - big.mark = ",", - decimal.mark = getOption("OutDec", "."), - suffix = "%", - trans = "log10", xbreaks = waiver(), - xlimits = NULL, text_size = 11, label_size = 2.5, - theme_classic = FALSE) { +ssd_plot <- function( + data, + pred, + left = "Conc", + right = left, + ..., + label = NULL, + shape = NULL, + color = NULL, + size, + linetype = NULL, + linecolor = NULL, + xlab = "Concentration", + ylab = "Species Affected", + ci = TRUE, + ribbon = TRUE, + hc = 0.05, + shift_x = 3, + add_x = 0, + bounds = c(left = 1, right = 1), + big.mark = ",", + decimal.mark = getOption("OutDec", "."), + suffix = "%", + trans = "log10", + xbreaks = waiver(), + xlimits = NULL, + text_size = 11, + label_size = 2.5, + theme_classic = FALSE +) { if (lifecycle::is_present(size)) { - lifecycle::deprecate_soft("2.1.0", "ssd_plot(size)", "ssd_plot(label_size)", id = "size") + lifecycle::deprecate_soft( + "2.1.0", + "ssd_plot(size)", + "ssd_plot(label_size)", + id = "size" + ) chk_number(size) label_size <- size } @@ -89,7 +137,10 @@ ssd_plot <- function(data, pred, left = "Conc", right = left, ..., chk_null_or(linetype, vld = vld_string) chk_null_or(linecolor, vld = vld_string) check_names(data, unique(c(left, right, label, shape))) - check_names(pred, c("proportion", "est", "lcl", "ucl", unique(c(linetype, linecolor)))) + check_names( + pred, + c("proportion", "est", "lcl", "ucl", unique(c(linetype, linecolor))) + ) chk_numeric(pred$proportion) chk_range(pred$proportion) check_data(pred, values = list(est = 1, lcl = c(1, NA), ucl = c(1, NA))) @@ -130,42 +181,97 @@ ssd_plot <- function(data, pred, left = "Conc", right = left, ..., if (ci) { if (ribbon) { - gp <- gp + geom_xribbon(data = pred, aes(xmin = !!sym("lcl"), xmax = !!sym("ucl"), y = !!sym("proportion")), alpha = 0.2) + gp <- gp + + geom_xribbon( + data = pred, + aes( + xmin = !!sym("lcl"), + xmax = !!sym("ucl"), + y = !!sym("proportion") + ), + alpha = 0.2 + ) } else { gp <- gp + - geom_line(data = pred, aes(x = !!sym("lcl"), y = !!sym("proportion")), color = "black", linetype = "dashed") + - geom_line(data = pred, aes(x = !!sym("ucl"), y = !!sym("proportion")), color = "black", linetype = "dashed") + geom_line( + data = pred, + aes(x = !!sym("lcl"), y = !!sym("proportion")), + color = "black", + linetype = "dashed" + ) + + geom_line( + data = pred, + aes(x = !!sym("ucl"), y = !!sym("proportion")), + color = "black", + linetype = "dashed" + ) } } if (!is.null(linecolor)) { - gp <- gp + geom_line(data = pred, aes(x = !!sym("est"), y = !!sym("proportion"), linetype = !!linetype, color = !!linecolor)) + gp <- gp + + geom_line( + data = pred, + aes( + x = !!sym("est"), + y = !!sym("proportion"), + linetype = !!linetype, + color = !!linecolor + ) + ) } else if (ribbon) { - gp <- gp + geom_line(data = pred, aes(x = !!sym("est"), y = !!sym("proportion"), linetype = !!linetype), color = "black") + gp <- gp + + geom_line( + data = pred, + aes(x = !!sym("est"), y = !!sym("proportion"), linetype = !!linetype), + color = "black" + ) } else { - gp <- gp + geom_line(data = pred, aes(x = !!sym("est"), y = !!sym("proportion"), linetype = !!linetype), color = "#3063A3") + gp <- gp + + geom_line( + data = pred, + aes(x = !!sym("est"), y = !!sym("proportion"), linetype = !!linetype), + color = "#3063A3" + ) } if (!is.null(hc)) { - gp <- gp + geom_hcintersect( - data = pred[pred$proportion %in% hc, ], - aes(xintercept = !!sym("est"), yintercept = !!sym("proportion")) - ) + gp <- gp + + geom_hcintersect( + data = pred[pred$proportion %in% hc, ], + aes(xintercept = !!sym("est"), yintercept = !!sym("proportion")) + ) } if (!is.null(color)) { gp <- gp + - geom_ssdpoint(data = data, aes( - x = !!sym("left"), y = !!sym("y"), shape = !!shape, - color = !!color - ), stat = "identity") + - geom_ssdpoint(data = data, aes( - x = !!sym("right"), y = !!sym("y"), shape = !!shape, - color = !!color - ), stat = "identity") + + geom_ssdpoint( + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + shape = !!shape, + color = !!color + ), + stat = "identity" + ) + + geom_ssdpoint( + data = data, + aes( + x = !!sym("right"), + y = !!sym("y"), + shape = !!shape, + color = !!color + ), + stat = "identity" + ) + geom_ssdsegment( - data = data, aes( - x = !!sym("left"), y = !!sym("y"), xend = !!sym("right"), yend = !!sym("y"), + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + xend = !!sym("right"), + yend = !!sym("y"), color = !!color ), stat = "identity" @@ -173,35 +279,63 @@ ssd_plot <- function(data, pred, left = "Conc", right = left, ..., } else { gp <- gp + geom_ssdpoint( - data = data, aes( - x = !!sym("left"), y = !!sym("y"), shape = !!shape + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + shape = !!shape ), stat = "identity" ) + - geom_ssdpoint(data = data, aes( - x = !!sym("right"), y = !!sym("y"), shape = !!shape - ), stat = "identity") + - geom_ssdsegment(data = data, aes( - x = !!sym("left"), y = !!sym("y"), xend = !!sym("right"), yend = !!sym("y") - ), stat = "identity") + geom_ssdpoint( + data = data, + aes( + x = !!sym("right"), + y = !!sym("y"), + shape = !!shape + ), + stat = "identity" + ) + + geom_ssdsegment( + data = data, + aes( + x = !!sym("left"), + y = !!sym("y"), + xend = !!sym("right"), + yend = !!sym("y") + ), + stat = "identity" + ) } hc_value <- NULL if (!is.null(hc)) { hc_value <- pred$est[pred$proportion %in% hc] } - gp <- gp + plot_coord_scale(data, - xlab = xlab, ylab = ylab, big.mark = big.mark, decimal.mark = decimal.mark, - suffix = suffix, - trans = trans, xbreaks = xbreaks, xlimits = xlimits, hc_value = hc_value - ) + gp <- gp + + plot_coord_scale( + data, + xlab = xlab, + ylab = ylab, + big.mark = big.mark, + decimal.mark = decimal.mark, + suffix = suffix, + trans = trans, + xbreaks = xbreaks, + xlimits = xlimits, + hc_value = hc_value + ) if (!is.null(label)) { data$right <- (data$right + add_x) * shift_x - gp <- gp + geom_text( - data = data, aes(x = !!sym("right"), y = !!sym("y"), label = !!label), - hjust = 0, size = label_size, fontface = "italic" - ) + gp <- gp + + geom_text( + data = data, + aes(x = !!sym("right"), y = !!sym("y"), label = !!label), + hjust = 0, + size = label_size, + fontface = "italic" + ) } if (theme_classic) { diff --git a/R/subset.R b/R/subset.R index 6c9bb25a0..81ff8cbfc 100644 --- a/R/subset.R +++ b/R/subset.R @@ -26,7 +26,13 @@ #' @examples #' fits <- ssd_fit_dists(ssddata::ccme_boron) #' subset(fits, c("gamma", "lnorm")) -subset.fitdists <- function(x, select = names(x), ..., delta = Inf, strict = TRUE) { +subset.fitdists <- function( + x, + select = names(x), + ..., + delta = Inf, + strict = TRUE +) { if (!length(x)) { return(x) } diff --git a/R/tidy.R b/R/tidy.R index 38079c8ac..5d0703293 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -40,7 +40,10 @@ tidy.tmbfit <- function(x, all = FALSE, ...) { est <- unname(x[, 1]) se <- unname(x[, 2]) x <- tibble( - dist = dist, term = term, est = est, se = se, + dist = dist, + term = term, + est = est, + se = se, .name_repair = "minimal" ) diff --git a/R/tmb.R b/R/tmb.R index bc9be72f5..88f10fd5e 100644 --- a/R/tmb.R +++ b/R/tmb.R @@ -23,7 +23,8 @@ tmb_model <- function(dist, data, pars) { data = data, parameters = pars, map = map, - DLL = "ssdtools_TMBExports", silent = TRUE + DLL = "ssdtools_TMBExports", + silent = TRUE ) } @@ -33,24 +34,43 @@ optimize <- function(par, fn, gr, lower, upper, control, hessian) { method <- "L-BFGS-B" if (is.null(control$trace) || control$trace < 1) { capture.output( - optim <- optim(par, fn, gr, + optim <- optim( + par, + fn, + gr, method = method, - lower = lower, upper = upper, - control = control, hessian = hessian + lower = lower, + upper = upper, + control = control, + hessian = hessian ) ) } else { - optim <- optim(par, fn, gr, + optim <- optim( + par, + fn, + gr, method = method, - lower = lower, upper = upper, - control = control, hessian = hessian + lower = lower, + upper = upper, + control = control, + hessian = hessian ) } optim } -fit_tmb <- function(data, dist, min_pmix, range_shape1, range_shape2, - control, pars = NULL, hessian = TRUE, ...) { +fit_tmb <- function( + data, + dist, + min_pmix, + range_shape1, + range_shape2, + control, + pars = NULL, + hessian = TRUE, + ... +) { pars <- sdist(dist, data, pars) model <- tmb_model(dist, data, pars = pars) bounds <- bdist(dist, data, min_pmix, range_shape1, range_shape2) @@ -58,9 +78,14 @@ fit_tmb <- function(data, dist, min_pmix, range_shape1, range_shape2, lower <- bounds$lower[names(model$par)] upper <- bounds$upper[names(model$par)] - optim <- optimize(model$par, model$fn, model$gr, - lower = lower, upper = upper, - control = control, hessian = hessian + optim <- optimize( + model$par, + model$fn, + model$gr, + lower = lower, + upper = upper, + control = control, + hessian = hessian ) fit <- list(dist = dist, model = model, optim = optim) diff --git a/R/utils.R b/R/utils.R index 701a33095..194c89994 100644 --- a/R/utils.R +++ b/R/utils.R @@ -32,7 +32,9 @@ #' } comma_signif <- function(x, digits = 3, ..., big.mark = ",") { lifecycle::deprecate_soft( - "2.0.0", "comma_signif()", "ssd_label_comma()", + "2.0.0", + "comma_signif()", + "ssd_label_comma()", details = "Use `labels = ssd_label_comma()` instead of `labels = comma_signif` when constructing `ggplot` objects." ) @@ -44,7 +46,11 @@ comma_signif <- function(x, digits = 3, ..., big.mark = ",") { x <- signif(x, digits = digits) y <- as.character(x) bol <- !is.na(x) & as.numeric(x) >= 1000 - y[bol] <- stringr::str_replace_all(y[bol], "(\\d{1,1})(\\d{3,3}(?<=\\.|$))", paste0("\\1", big.mark, "\\2")) + y[bol] <- stringr::str_replace_all( + y[bol], + "(\\d{1,1})(\\d{3,3}(?<=\\.|$))", + paste0("\\1", big.mark, "\\2") + ) y } @@ -61,9 +67,15 @@ ssd_ecd <- function(x, ties.method = "first") { lifecycle::deprecate_warn("2.3.0", "ssd_ecd(ties.method)") } chk_numeric(x) - if (!length(x)) return(numeric()) - if (length(x) == 1L) return(0.5) - if (anyNA(x)) return(rep(NA_real_, length(x))) + if (!length(x)) { + return(numeric()) + } + if (length(x) == 1L) { + return(0.5) + } + if (anyNA(x)) { + return(rep(NA_real_, length(x))) + } rank <- rank(x, ties.method = "first") stats::ppoints(length(x))[rank] } @@ -79,7 +91,12 @@ ssd_ecd <- function(x, ties.method = "first") { #' @examples #' ssd_ecd_data(ssddata::ccme_boron) ssd_ecd_data <- function( - data, left = "Conc", right = left, ..., bounds = c(left = 1, right = 1)) { + data, + left = "Conc", + right = left, + ..., + bounds = c(left = 1, right = 1) +) { .chk_data(data, left, right) .chk_bounds(bounds) chk_unused(...) diff --git a/R/weibull.R b/R/weibull.R index a7bb91169..7442b0c9f 100644 --- a/R/weibull.R +++ b/R/weibull.R @@ -20,10 +20,20 @@ #' @examples #' #' ssd_pweibull(1) -ssd_pweibull <- function(q, shape = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - pdist("weibull", - q = q, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_pweibull <- function( + q, + shape = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + pdist( + "weibull", + q = q, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } @@ -32,10 +42,20 @@ ssd_pweibull <- function(q, shape = 1, scale = 1, lower.tail = TRUE, log.p = FAL #' @examples #' #' ssd_qweibull(0.5) -ssd_qweibull <- function(p, shape = 1, scale = 1, lower.tail = TRUE, log.p = FALSE) { - qdist("weibull", - p = p, shape = shape, scale = scale, - lower.tail = lower.tail, log.p = log.p +ssd_qweibull <- function( + p, + shape = 1, + scale = 1, + lower.tail = TRUE, + log.p = FALSE +) { + qdist( + "weibull", + p = p, + shape = shape, + scale = scale, + lower.tail = lower.tail, + log.p = log.p ) } diff --git a/R/wqg.R b/R/wqg.R index f6a79b21a..4b93c1d14 100644 --- a/R/wqg.R +++ b/R/wqg.R @@ -35,7 +35,8 @@ #' } ssd_wqg_bc <- function(data, left = "Conc") { lifecycle::deprecate_warn( - "2.0.0", "ssd_wqg_bc()", + "2.0.0", + "ssd_wqg_bc()", details = "Please use `ssd_fit_bcanz()` and `ssd_hc_bcanz()` instead." ) fits <- ssd_fit_bcanz(data, left = left) @@ -63,7 +64,8 @@ ssd_wqg_bc <- function(data, left = "Conc") { #' } ssd_wqg_burrlioz <- function(data, left = "Conc") { lifecycle::deprecate_warn( - "2.0.0", "ssd_wqg_burrlioz()", + "2.0.0", + "ssd_wqg_burrlioz()", details = "Please use `ssd_fit_burrlioz()` and `ssd_hc()` instead." ) fit <- ssd_fit_burrlioz(data, left = left, rescale = FALSE) diff --git a/air.toml b/air.toml new file mode 100644 index 000000000..e69de29bb diff --git a/data-raw/data-raw.R b/data-raw/data-raw.R index 0397f8c81..a6e4abcfe 100644 --- a/data-raw/data-raw.R +++ b/data-raw/data-raw.R @@ -21,17 +21,17 @@ library(tibble) library(usethis) dist_data <- tibble::tribble( - ~dist, ~bcanz, ~tails, ~npars, ~valid, ~bound, - "burrIII3", FALSE, TRUE, 3L, TRUE, TRUE, - "gamma", TRUE, TRUE, 2L, TRUE, FALSE, - "gompertz", FALSE, TRUE, 2L, TRUE, FALSE, - "invpareto", FALSE, FALSE, 2L, FALSE, FALSE, - "lgumbel", TRUE, TRUE, 2L, TRUE, FALSE, - "llogis", TRUE, TRUE, 2L, TRUE, FALSE, - "llogis_llogis", FALSE, TRUE, 5L, TRUE, TRUE, - "lnorm", TRUE, TRUE, 2L, TRUE, FALSE, - "lnorm_lnorm", TRUE, TRUE, 5L, TRUE, TRUE, - "weibull", TRUE, TRUE, 2L, TRUE, FALSE + ~dist , ~bcanz , ~tails , ~npars , ~valid , ~bound , + "burrIII3" , FALSE , TRUE , 3L , TRUE , TRUE , + "gamma" , TRUE , TRUE , 2L , TRUE , FALSE , + "gompertz" , FALSE , TRUE , 2L , TRUE , FALSE , + "invpareto" , FALSE , FALSE , 2L , FALSE , FALSE , + "lgumbel" , TRUE , TRUE , 2L , TRUE , FALSE , + "llogis" , TRUE , TRUE , 2L , TRUE , FALSE , + "llogis_llogis" , FALSE , TRUE , 5L , TRUE , TRUE , + "lnorm" , TRUE , TRUE , 2L , TRUE , FALSE , + "lnorm_lnorm" , TRUE , TRUE , 5L , TRUE , TRUE , + "weibull" , TRUE , TRUE , 2L , TRUE , FALSE ) use_data(dist_data, overwrite = TRUE) diff --git a/paper/paper.R b/paper/paper.R index 0b54e3471..49f59531a 100644 --- a/paper/paper.R +++ b/paper/paper.R @@ -5,15 +5,20 @@ withr::with_seed(50, { ssd_gof(fits) ssd_hc(fits, ci = TRUE) autoplot(fits) - + ggplot2::ggsave("paper/autoplot.png", device = "png", width = 6, height = 4) - + predictions <- ssdtools::predict(fits, ci = TRUE) }) -ssd_plot(ssddata::ccme_boron, predictions, - hc = 0.1, xlimits = c(NA, 3000), - shape = "Group", color = "Group", label = "Species", - xlab = "Concentration (mg/L)" +ssd_plot( + ssddata::ccme_boron, + predictions, + hc = 0.1, + xlimits = c(NA, 3000), + shape = "Group", + color = "Group", + label = "Species", + xlab = "Concentration (mg/L)" ) + scale_color_ssd() diff --git a/src/TMB/compile.R b/src/TMB/compile.R index 88fe3c8b6..b7c2ae24c 100644 --- a/src/TMB/compile.R +++ b/src/TMB/compile.R @@ -1,6 +1,6 @@ # Copyright 2015-2023 Province of British Columbia # Copyright 2021 Environment and Climate Change Canada -# Copyright 2023-2024 Australian Government Department of Climate Change, +# Copyright 2023-2024 Australian Government Department of Climate Change, # Energy, the Environment and Water # # Licensed under the Apache License, Version 2.0 (the "License"); @@ -18,13 +18,21 @@ tmb_name <- "ssdtools_TMBExports" tmb_flags <- commandArgs(trailingOnly = TRUE) -if(file.exists(paste0(tmb_name, ".cpp"))) { - if(length(tmb_flags) == 0) tmb_flags <- "" - TMB::compile(file = paste0(tmb_name, ".cpp"), - PKG_CXXFLAGS = tmb_flags, - safebounds = FALSE, safeunload = FALSE) - file.copy(from = paste0(tmb_name, .Platform$dynlib.ext), - to = "..", overwrite = TRUE) +if (file.exists(paste0(tmb_name, ".cpp"))) { + if (length(tmb_flags) == 0) { + tmb_flags <- "" + } + TMB::compile( + file = paste0(tmb_name, ".cpp"), + PKG_CXXFLAGS = tmb_flags, + safebounds = FALSE, + safeunload = FALSE + ) + file.copy( + from = paste0(tmb_name, .Platform$dynlib.ext), + to = "..", + overwrite = TRUE + ) } # cleanup done in ../Makevars[.win] diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index e9fb362b7..b86ba93c9 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -38,7 +38,13 @@ expect_snapshot_plot <- function(x, name) { testthat::expect_snapshot_file(path, paste0(name, ".png")) } -expect_snapshot_boot_data <- function(x, name, digits = 6, min_pboot = 0.9, max_pboot = 1) { +expect_snapshot_boot_data <- function( + x, + name, + digits = 6, + min_pboot = 0.9, + max_pboot = 1 +) { if (!is.na(min_pboot) && min_pboot > 0) { testthat::expect_true(all(x$pboot >= min_pboot)) } @@ -76,25 +82,51 @@ test_dist <- function(dist, qroottolerance = 1.490116e-08, multi = FALSE) { ep(glue::glue("expect_identical(ssd_p{dist}(Inf), 1)")) ep(glue::glue("expect_gt(ssd_p{dist}(1.000001), ssd_p{dist}(1))")) - ep(glue::glue("expect_equal(ssd_p{dist}(1, log.p = TRUE), log(ssd_p{dist}(1)))")) - ep(glue::glue("expect_equal(ssd_p{dist}(1, lower.tail = FALSE), 1- ssd_p{dist}(1))")) - ep(glue::glue("expect_equal(ssd_p{dist}(1, lower.tail = FALSE, log.p = TRUE), log(1 - ssd_p{dist}(1)))")) + ep(glue::glue( + "expect_equal(ssd_p{dist}(1, log.p = TRUE), log(ssd_p{dist}(1)))" + )) + ep(glue::glue( + "expect_equal(ssd_p{dist}(1, lower.tail = FALSE), 1- ssd_p{dist}(1))" + )) + ep(glue::glue( + "expect_equal(ssd_p{dist}(1, lower.tail = FALSE, log.p = TRUE), log(1 - ssd_p{dist}(1)))" + )) - ep(glue::glue("expect_identical(p{}(c(NA, NaN, 0, Inf, -Inf)), - c(NA, NaN, 0, Inf, -Inf))")) - ep(glue::glue("expect_equal(ssd_p{dist}(1:2, 1:2, 3:4), - c(ssd_p{dist}(1, 1, 3), ssd_p{dist}(2, 2, 4)))")) - ep(glue::glue("expect_equal(ssd_p{dist}(1:2, c(1, NA), 3:4), - c(ssd_p{dist}(1, 1, 3), NA_real_))")) + ep(glue::glue( + "expect_identical(p{}(c(NA, NaN, 0, Inf, -Inf)), + c(NA, NaN, 0, Inf, -Inf))" + )) + ep(glue::glue( + "expect_equal(ssd_p{dist}(1:2, 1:2, 3:4), + c(ssd_p{dist}(1, 1, 3), ssd_p{dist}(2, 2, 4)))" + )) + ep(glue::glue( + "expect_equal(ssd_p{dist}(1:2, c(1, NA), 3:4), + c(ssd_p{dist}(1, 1, 3), NA_real_))" + )) ep(glue::glue("expect_gt(ssd_q{dist}(0.5000001), ssd_q{dist}(0.5))")) - ep(glue::glue("expect_identical(ssd_q{dist}(log(0.75), log.p = TRUE), ssd_q{dist}(0.75))")) - ep(glue::glue("expect_identical(ssd_q{dist}(0.75, lower.tail = FALSE), ssd_q{dist}(0.25))")) - ep(glue::glue("expect_identical(ssd_q{dist}(log(0.75), lower.tail = FALSE, log.p = TRUE), ssd_q{dist}(0.25))")) + ep(glue::glue( + "expect_identical(ssd_q{dist}(log(0.75), log.p = TRUE), ssd_q{dist}(0.75))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(0.75, lower.tail = FALSE), ssd_q{dist}(0.25))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(log(0.75), lower.tail = FALSE, log.p = TRUE), ssd_q{dist}(0.25))" + )) } else { - ep(glue::glue("expect_gt(ssd_q{dist}(0.5000001, lnorm.weight = 1), ssd_q{dist}(0.5, lnorm.weight = 1))")) - ep(glue::glue("expect_identical(ssd_q{dist}(log(0.75), log.p = TRUE, lnorm.weight = 1), ssd_q{dist}(0.75, lnorm.weight = 1))")) - ep(glue::glue("expect_identical(ssd_q{dist}(0.75, lower.tail = FALSE, lnorm.weight = 1), ssd_q{dist}(0.25, lnorm.weight = 1))")) - ep(glue::glue("expect_identical(ssd_q{dist}(log(0.75), lower.tail = FALSE, log.p = TRUE, lnorm.weight = 1), ssd_q{dist}(0.25, lnorm.weight = 1))")) + ep(glue::glue( + "expect_gt(ssd_q{dist}(0.5000001, lnorm.weight = 1), ssd_q{dist}(0.5, lnorm.weight = 1))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(log(0.75), log.p = TRUE, lnorm.weight = 1), ssd_q{dist}(0.75, lnorm.weight = 1))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(0.75, lower.tail = FALSE, lnorm.weight = 1), ssd_q{dist}(0.25, lnorm.weight = 1))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(log(0.75), lower.tail = FALSE, log.p = TRUE, lnorm.weight = 1), ssd_q{dist}(0.25, lnorm.weight = 1))" + )) } ep(glue::glue("expect_identical(ssd_q{dist}(numeric(0)), numeric(0))")) @@ -107,12 +139,20 @@ test_dist <- function(dist, qroottolerance = 1.490116e-08, multi = FALSE) { ep(glue::glue("expect_identical(ssd_q{dist}(-Inf), NaN)")) ep(glue::glue("expect_identical(ssd_q{dist}(Inf), NaN)")) ep(glue::glue("expect_identical(ssd_q{dist}(0.75, log.p = TRUE), NaN)")) - ep(glue::glue("expect_identical(ssd_q{dist}(c(NA, NaN, 0, Inf, -Inf)), c(NA, NaN, 0, NaN, NaN))")) + ep(glue::glue( + "expect_identical(ssd_q{dist}(c(NA, NaN, 0, Inf, -Inf)), c(NA, NaN, 0, NaN, NaN))" + )) if (!multi) { - ep(glue::glue("expect_identical(ssd_q{dist}(c(0.25, 0.75), 1:2, 3:4), c(ssd_q{dist}(0.25, 1, 3), ssd_q{dist}(0.75, 2, 4)))")) - ep(glue::glue("expect_identical(ssd_q{dist}(c(0.25, 0.75), c(1,NA), 3:4), c(ssd_q{dist}(0.25, 1, 3), NA_real_))")) - ep(glue::glue("expect_equal(ssd_q{dist}(ssd_p{dist}(c(0, 0.1, 0.5, 0.9, 0.99))), c(0, 0.1, 0.5, 0.9, 0.99), tolerance = {qroottolerance})")) + ep(glue::glue( + "expect_identical(ssd_q{dist}(c(0.25, 0.75), 1:2, 3:4), c(ssd_q{dist}(0.25, 1, 3), ssd_q{dist}(0.75, 2, 4)))" + )) + ep(glue::glue( + "expect_identical(ssd_q{dist}(c(0.25, 0.75), c(1,NA), 3:4), c(ssd_q{dist}(0.25, 1, 3), NA_real_))" + )) + ep(glue::glue( + "expect_equal(ssd_q{dist}(ssd_p{dist}(c(0, 0.1, 0.5, 0.9, 0.99))), c(0, 0.1, 0.5, 0.9, 0.99), tolerance = {qroottolerance})" + )) ep(glue::glue("expect_identical(ssd_r{dist}(1, NA), NA_real_)")) ep(glue::glue("expect_identical(ssd_r{dist}(2, NA), c(NA, NA_real_))")) ep(glue::glue("expect_error(ssd_r{dist}(1, 1:2))")) @@ -129,10 +169,18 @@ test_dist <- function(dist, qroottolerance = 1.490116e-08, multi = FALSE) { ep(glue::glue("expect_identical(length(ssd_r{dist}(3:4)), 2L)")) ep(glue::glue("expect_identical(length(ssd_r{dist}(c(NA, 1))), 2L)")) } else { - ep(glue::glue("expect_identical(length(ssd_r{dist}(1, lnorm.weight = 1)), 1L)")) - ep(glue::glue("expect_identical(length(ssd_r{dist}(2, lnorm.weight = 1)), 2L)")) - ep(glue::glue("expect_identical(length(ssd_r{dist}(3:4, lnorm.weight = 1)), 2L)")) - ep(glue::glue("expect_identical(length(ssd_r{dist}(c(NA, 1), lnorm.weight = 1)), 2L)")) + ep(glue::glue( + "expect_identical(length(ssd_r{dist}(1, lnorm.weight = 1)), 1L)" + )) + ep(glue::glue( + "expect_identical(length(ssd_r{dist}(2, lnorm.weight = 1)), 2L)" + )) + ep(glue::glue( + "expect_identical(length(ssd_r{dist}(3:4, lnorm.weight = 1)), 2L)" + )) + ep(glue::glue( + "expect_identical(length(ssd_r{dist}(c(NA, 1), lnorm.weight = 1)), 2L)" + )) } if (!multi) { ests <- ep(glue::glue("ssd_e{dist}()")) diff --git a/tests/testthat/test-at-boundary.R b/tests/testthat/test-at-boundary.R index adcee789d..ebca77b23 100644 --- a/tests/testthat/test-at-boundary.R +++ b/tests/testthat/test-at-boundary.R @@ -18,14 +18,21 @@ test_that("test at boundary 2 9", { data <- data.frame(Conc = c(0.02, 0.01, rlnorm(9, 1))) fit <- ssd_fit_dists(data = data) }) - expect_equal(unname(fit$lnorm_lnorm$optim$par["pmix"]), ssd_min_pmix(nrow(data))) + expect_equal( + unname(fit$lnorm_lnorm$optim$par["pmix"]), + ssd_min_pmix(nrow(data)) + ) gof <- ssd_gof(fit, wt = TRUE) expect_snapshot_data(gof, "b29") expect_identical( ssd_at_boundary(fit), c( - gamma = FALSE, lgumbel = FALSE, llogis = FALSE, lnorm = FALSE, - lnorm_lnorm = TRUE, weibull = FALSE + gamma = FALSE, + lgumbel = FALSE, + llogis = FALSE, + lnorm = FALSE, + lnorm_lnorm = TRUE, + weibull = FALSE ) ) expect_false(ssd_at_boundary(fit$lnorm)) @@ -37,14 +44,21 @@ test_that("test at boundary 2 14", { data <- data.frame(Conc = c(0.01, 0.02, rlnorm(14, 1))) fit <- ssd_fit_dists(data = data) }) - expect_equal(unname(fit$lnorm_lnorm$optim$par["pmix"]), ssd_min_pmix(nrow(data))) + expect_equal( + unname(fit$lnorm_lnorm$optim$par["pmix"]), + ssd_min_pmix(nrow(data)) + ) gof <- ssd_gof(fit, wt = TRUE) expect_snapshot_data(gof, "b214") expect_identical( ssd_at_boundary(fit), c( - gamma = FALSE, lgumbel = FALSE, llogis = FALSE, lnorm = FALSE, - lnorm_lnorm = TRUE, weibull = FALSE + gamma = FALSE, + lgumbel = FALSE, + llogis = FALSE, + lnorm = FALSE, + lnorm_lnorm = TRUE, + weibull = FALSE ) ) expect_false(ssd_at_boundary(fit$lnorm)) @@ -65,8 +79,12 @@ test_that("test at boundary 2 23", { expect_identical( ssd_at_boundary(fit), c( - gamma = FALSE, lgumbel = FALSE, llogis = FALSE, lnorm = FALSE, - lnorm_lnorm = TRUE, weibull = FALSE + gamma = FALSE, + lgumbel = FALSE, + llogis = FALSE, + lnorm = FALSE, + lnorm_lnorm = TRUE, + weibull = FALSE ) ) expect_false(ssd_at_boundary(fit$lnorm)) @@ -78,8 +96,12 @@ test_that("test at_boundary fits2.3", { expect_identical( ssd_at_boundary(fits), c( - gamma = NA, lgumbel = NA, llogis = NA, lnorm = NA, - lnorm_lnorm = NA, weibull = NA + gamma = NA, + lgumbel = NA, + llogis = NA, + lnorm = NA, + lnorm_lnorm = NA, + weibull = NA ) ) expect_identical(ssd_at_boundary(fits$lnorm), NA) diff --git a/tests/testthat/test-autoplot.R b/tests/testthat/test-autoplot.R index cc6f826cc..1694b4c08 100644 --- a/tests/testthat/test-autoplot.R +++ b/tests/testthat/test-autoplot.R @@ -16,17 +16,24 @@ # limitations under the License. test_that("autoplot", { - fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("gamma", "llogis", "lnorm")) + fits <- ssd_fit_dists( + ssddata::ccme_boron, + dists = c("gamma", "llogis", "lnorm") + ) expect_snapshot_plot(autoplot(fits), "autoplot") }) test_that("autoplot", { - fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("gamma", "llogis", "lnorm")) + fits <- ssd_fit_dists( + ssddata::ccme_boron, + dists = c("gamma", "llogis", "lnorm") + ) expect_snapshot_plot(autoplot(fits, xlab = "New"), "autoplot_new") }) test_that("autoplot", { - fits <- ssd_fit_dists(ssddata::ccme_boron, + fits <- ssd_fit_dists( + ssddata::ccme_boron, rescale = TRUE, dists = c("gamma", "llogis", "lnorm") ) @@ -36,9 +43,7 @@ test_that("autoplot", { test_that("autoplot language", { data <- ssddata::ccme_boron data$Conc <- data$Conc * 100 - fits <- ssd_fit_dists(data, - dists = c("lnorm") - ) + fits <- ssd_fit_dists(data, dists = c("lnorm")) expect_snapshot_plot(autoplot(fits, big.mark = "!!"), "suffix") expect_snapshot_plot(autoplot(fits, big.mark = ":"), "autoplot_bigmark") }) @@ -46,8 +51,9 @@ test_that("autoplot language", { test_that("autoplot small", { data <- ssddata::ccme_boron data$Conc <- data$Conc / 1000 - fits <- ssd_fit_dists(data, - dists = c("lnorm") + fits <- ssd_fit_dists(data, dists = c("lnorm")) + expect_snapshot_plot( + autoplot(fits, decimal.mark = "-"), + "autoplot_decimalmark" ) - expect_snapshot_plot(autoplot(fits, decimal.mark = "-"), "autoplot_decimalmark") }) diff --git a/tests/testthat/test-bcanz.R b/tests/testthat/test-bcanz.R index 97b72ab35..80e7e38e3 100644 --- a/tests/testthat/test-bcanz.R +++ b/tests/testthat/test-bcanz.R @@ -19,8 +19,12 @@ test_that("ssd_dists_bcanz works", { expect_identical( ssd_dists_bcanz(), c( - "gamma", "lgumbel", "llogis", - "lnorm", "lnorm_lnorm", "weibull" + "gamma", + "lgumbel", + "llogis", + "lnorm", + "lnorm_lnorm", + "weibull" ) ) }) diff --git a/tests/testthat/test-burrIII3.R b/tests/testthat/test-burrIII3.R index bcc35071a..2cfa905b0 100644 --- a/tests/testthat/test-burrIII3.R +++ b/tests/testthat/test-burrIII3.R @@ -28,7 +28,14 @@ test_that("burrIII3 gives cis with ccme_chloride", { fit <- ssd_fit_dists(ssddata::ccme_chloride, dists = "burrIII3") expect_s3_class(fit, "fitdists") withr::with_seed(50, { - hc <- ssd_hc(fit, nboot = 10, ci = TRUE, ci_method = "MACL", est_method = "arithmetic", samples = TRUE) + hc <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + ci_method = "MACL", + est_method = "arithmetic", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_chloride") }) @@ -37,14 +44,25 @@ test_that("burrIII3 gives cis with ccme_uranium", { fit <- ssd_fit_dists(ssddata::ccme_uranium, dists = "burrIII3") expect_s3_class(fit, "fitdists") withr::with_seed(50, { - hc <- ssd_hc(fit, nboot = 10, ci = TRUE, ci_method = "MACL", est_method = "arithmetic", samples = TRUE) + hc <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + ci_method = "MACL", + est_method = "arithmetic", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_uranium") }) test_that("burrIII3 fits anon_e but only at boundary ok", { - fit <- ssd_fit_dists(ssddata::anon_e, dists = "burrIII3", at_boundary_ok = TRUE) + fit <- ssd_fit_dists( + ssddata::anon_e, + dists = "burrIII3", + at_boundary_ok = TRUE + ) tidy <- tidy(fit) expect_snapshot_data(tidy, "tidy_anon_e") expect_error(expect_warning( diff --git a/tests/testthat/test-censor.R b/tests/testthat/test-censor.R index 4cb7062c7..ec86131ce 100644 --- a/tests/testthat/test-censor.R +++ b/tests/testthat/test-censor.R @@ -31,7 +31,10 @@ test_that("ssd_censor use existing right and left", { data <- ssddata::ccme_boron data$right2 <- data$Conc data$left3 <- data$Conc - expect_identical(ssd_censor_data(data, left = "left3", right = "right2"), data) + expect_identical( + ssd_censor_data(data, left = "left3", right = "right2"), + data + ) }) test_that("ssd_censor no rows", { @@ -41,13 +44,22 @@ test_that("ssd_censor no rows", { }) test_that("ssd_censor c(2.5, Inf)", { - expect_snapshot_data(ssd_censor_data(ssddata::ccme_boron, censoring = c(2.5, Inf)), "boron_25") + expect_snapshot_data( + ssd_censor_data(ssddata::ccme_boron, censoring = c(2.5, Inf)), + "boron_25" + ) }) test_that("ssd_censor c(0, 10)", { - expect_snapshot_data(ssd_censor_data(ssddata::ccme_boron, censoring = c(0, 10)), "boron_10") + expect_snapshot_data( + ssd_censor_data(ssddata::ccme_boron, censoring = c(0, 10)), + "boron_10" + ) }) test_that("ssd_censor c(2.5, 10)", { - expect_snapshot_data(ssd_censor_data(ssddata::ccme_boron, censoring = c(2.5, 10)), "boron_2510") + expect_snapshot_data( + ssd_censor_data(ssddata::ccme_boron, censoring = c(2.5, 10)), + "boron_2510" + ) }) diff --git a/tests/testthat/test-censored.R b/tests/testthat/test-censored.R index 1eed816a7..393d16eba 100644 --- a/tests/testthat/test-censored.R +++ b/tests/testthat/test-censored.R @@ -25,7 +25,10 @@ test_that("ssd_is_censored TRUE interval ssd_is_censored data", { test_that("ssd_is_censored missing value if no rows", { expect_identical( - ssd_is_censored(data.frame(Conc = numeric(0), right = numeric(0)), right = "right"), + ssd_is_censored( + data.frame(Conc = numeric(0), right = numeric(0)), + right = "right" + ), NA ) }) @@ -35,27 +38,45 @@ test_that("ssd_is_censored TRUE left ssd_is_censored data 0", { }) test_that("ssd_is_censored TRUE left ssd_is_censored data NA", { - expect_true(ssd_is_censored(data.frame(Conc = NA_real_, right = 2), right = "right")) + expect_true(ssd_is_censored( + data.frame(Conc = NA_real_, right = 2), + right = "right" + )) }) test_that("ssd_is_censored errors negative left ssd_is_censored data", { - expect_error(ssd_is_censored(data.frame(Conc = -1, right = 2), right = "right")) + expect_error(ssd_is_censored( + data.frame(Conc = -1, right = 2), + right = "right" + )) }) test_that("ssd_is_censored TRUE right ssd_is_censored data Inf", { - expect_true(ssd_is_censored(data.frame(Conc = 1, right = Inf), right = "right")) + expect_true(ssd_is_censored( + data.frame(Conc = 1, right = Inf), + right = "right" + )) }) test_that("ssd_is_censored TRUE right ssd_is_censored data NA", { - expect_true(ssd_is_censored(data.frame(Conc = 1, right = NA_real_), right = "right")) + expect_true(ssd_is_censored( + data.frame(Conc = 1, right = NA_real_), + right = "right" + )) }) test_that("ssd_is_censored errors if missing values", { - expect_error(ssd_is_censored(data.frame(Conc = NA_real_, right = NA_real_), right = "right")) + expect_error(ssd_is_censored( + data.frame(Conc = NA_real_, right = NA_real_), + right = "right" + )) }) test_that("ssd_is_censored errors if effectively missing values", { - expect_error(ssd_is_censored(data.frame(Conc = 0, right = Inf), right = "right")) + expect_error(ssd_is_censored( + data.frame(Conc = 0, right = Inf), + right = "right" + )) }) @@ -68,7 +89,11 @@ test_that("ssd_is_censored TRUE fitdists censored", { data <- ssddata::ccme_boron data$Right <- data$Conc data$Conc <- 0 - fits <- ssd_fit_dists(data, right = "Right", dists = c("gamma", "llogis", "lnorm")) + fits <- ssd_fit_dists( + data, + right = "Right", + dists = c("gamma", "llogis", "lnorm") + ) expect_true(ssd_is_censored(fits)) }) diff --git a/tests/testthat/test-censoring.R b/tests/testthat/test-censoring.R index 93dc987ec..4451246f1 100644 --- a/tests/testthat/test-censoring.R +++ b/tests/testthat/test-censoring.R @@ -7,9 +7,27 @@ test_that("left, right and interval censoring works ", { fit <- ssd_fit_dists(data, right = "right") withr::with_seed(50, { - hcnonparametric <- ssd_hc(fit, ci = TRUE, average = FALSE, parametric = FALSE, nboot = 10, min_pboot = 0.1) - expect_warning(hcparametric <- ssd_hc(fit, ci = TRUE, average = FALSE, parametric = TRUE), "^Parametric CIs cannot be calculated for censored data\\.$") - expect_warning(hcaverage <- ssd_hc(fit, ci = FALSE, average = TRUE, parametric = TRUE), "^Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters\\.$") + hcnonparametric <- ssd_hc( + fit, + ci = TRUE, + average = FALSE, + parametric = FALSE, + nboot = 10, + min_pboot = 0.1 + ) + expect_warning( + hcparametric <- ssd_hc( + fit, + ci = TRUE, + average = FALSE, + parametric = TRUE + ), + "^Parametric CIs cannot be calculated for censored data\\.$" + ) + expect_warning( + hcaverage <- ssd_hc(fit, ci = FALSE, average = TRUE, parametric = TRUE), + "^Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters\\.$" + ) }) expect_snapshot_data(hcnonparametric, "hcnonparametric", digits = 3) @@ -19,7 +37,17 @@ test_that("left, right and interval censoring works ", { withr::with_seed(50, { # FIXME - should return tibble with 1 row even if NAs - expect_error(expect_warning(hcaveragenonparametric <- ssd_hc(fit, ci = TRUE, average = TRUE, parametric = FALSE, nboot = 10, min_pboot = 0.5), "^Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters\\.$")) + expect_error(expect_warning( + hcaveragenonparametric <- ssd_hc( + fit, + ci = TRUE, + average = TRUE, + parametric = FALSE, + nboot = 10, + min_pboot = 0.5 + ), + "^Model averaged estimates cannot be calculated for censored data when the distributions have different numbers of parameters\\.$" + )) }) }) @@ -29,11 +57,29 @@ test_that("left, right and interval censoring works same number of parameter ", data$right[1] <- Inf data$Conc[2] <- 0 data$right[3] <- data$Conc[3] * 2 - fit <- ssd_fit_dists(data, right = "right", dists = ssdtools::ssd_dists_bcanz(npars = 2L)) + fit <- ssd_fit_dists( + data, + right = "right", + dists = ssdtools::ssd_dists_bcanz(npars = 2L) + ) withr::with_seed(50, { - hcnonparametric <- ssd_hc(fit, ci = TRUE, average = FALSE, parametric = FALSE, nboot = 10) - expect_warning(hcparametric <- ssd_hc(fit, ci = TRUE, average = FALSE, parametric = TRUE), "^Parametric CIs cannot be calculated for censored data\\.$") + hcnonparametric <- ssd_hc( + fit, + ci = TRUE, + average = FALSE, + parametric = FALSE, + nboot = 10 + ) + expect_warning( + hcparametric <- ssd_hc( + fit, + ci = TRUE, + average = FALSE, + parametric = TRUE + ), + "^Parametric CIs cannot be calculated for censored data\\.$" + ) hcaverage <- ssd_hc(fit, ci = FALSE, average = TRUE, parametric = TRUE) }) expect_snapshot_data(hcnonparametric, "hcnonparametric2") @@ -42,7 +88,13 @@ test_that("left, right and interval censoring works same number of parameter ", expect_snapshot_data(hcaverage, "hcaverage2") withr::with_seed(50, { - hcaveragenonparametric <- ssd_hc(fit, ci = TRUE, average = TRUE, parametric = FALSE, nboot = 10) + hcaveragenonparametric <- ssd_hc( + fit, + ci = TRUE, + average = TRUE, + parametric = FALSE, + nboot = 10 + ) }) expect_snapshot_data(hcaveragenonparametric, "hcaveragenonparametric2") }) diff --git a/tests/testthat/test-computable.R b/tests/testthat/test-computable.R index 683f291e0..7ecba5168 100644 --- a/tests/testthat/test-computable.R +++ b/tests/testthat/test-computable.R @@ -18,8 +18,12 @@ test_that("test computable fits2.3", { expect_identical( ssd_computable(fits), c( - gamma = NA, lgumbel = NA, llogis = NA, lnorm = NA, - lnorm_lnorm = NA, weibull = NA + gamma = NA, + lgumbel = NA, + llogis = NA, + lnorm = NA, + lnorm_lnorm = NA, + weibull = NA ) ) expect_identical(ssd_computable(fits$lnorm), NA) @@ -31,8 +35,12 @@ test_that("test computable fits", { expect_identical( ssd_computable(fits), c( - gamma = TRUE, lgumbel = TRUE, llogis = TRUE, lnorm = TRUE, - lnorm_lnorm = TRUE, weibull = TRUE + gamma = TRUE, + lgumbel = TRUE, + llogis = TRUE, + lnorm = TRUE, + lnorm_lnorm = TRUE, + weibull = TRUE ) ) expect_true(ssd_computable(fits$lnorm)) diff --git a/tests/testthat/test-dists.R b/tests/testthat/test-dists.R index 820f04c58..ca3b0d1a3 100644 --- a/tests/testthat/test-dists.R +++ b/tests/testthat/test-dists.R @@ -19,8 +19,16 @@ test_that("dists all", { expect_identical( ssd_dists_all(valid = NULL), c( - "burrIII3", "gamma", "gompertz", "invpareto", "lgumbel", "llogis", - "llogis_llogis", "lnorm", "lnorm_lnorm", "weibull" + "burrIII3", + "gamma", + "gompertz", + "invpareto", + "lgumbel", + "llogis", + "llogis_llogis", + "lnorm", + "lnorm_lnorm", + "weibull" ) ) }) @@ -30,8 +38,15 @@ test_that("dists shiny", { expect_identical( ssd_dists_shiny(), c( - "burrIII3", "gamma", "gompertz", "lgumbel", "llogis", - "llogis_llogis", "lnorm", "lnorm_lnorm", "weibull" + "burrIII3", + "gamma", + "gompertz", + "lgumbel", + "llogis", + "llogis_llogis", + "lnorm", + "lnorm_lnorm", + "weibull" ) ) ) @@ -55,5 +70,8 @@ test_that("dists 5 pars", { test_that("dists bcanz", { expect_identical(ssd_dists_bcanz(), ssd_dists(bcanz = TRUE)) - expect_identical(ssd_dists_bcanz(npars = 2L), c("gamma", "lgumbel", "llogis", "lnorm", "weibull")) + expect_identical( + ssd_dists_bcanz(npars = 2L), + c("gamma", "lgumbel", "llogis", "lnorm", "weibull") + ) }) diff --git a/tests/testthat/test-exposure.R b/tests/testthat/test-exposure.R index cee4c8321..aad0e3caa 100644 --- a/tests/testthat/test-exposure.R +++ b/tests/testthat/test-exposure.R @@ -35,7 +35,10 @@ test_that("exposure different mean and log", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(50, { - expect_snapshot_value(ssd_exposure(fits, 1, sdlog = 10, nboot = 100), style = "deparse") + expect_snapshot_value( + ssd_exposure(fits, 1, sdlog = 10, nboot = 100), + style = "deparse" + ) }) }) diff --git a/tests/testthat/test-fit-dists.R b/tests/testthat/test-fit-dists.R index 4615c8d85..bdab08aed 100644 --- a/tests/testthat/test-fit-dists.R +++ b/tests/testthat/test-fit-dists.R @@ -73,7 +73,8 @@ test_that("ssd_fit_dists gives chk error if valid and more than one distribution }) test_that("ssd_fit_dists returns object class fitdists", { - fit <- ssd_fit_dists(ssddata::ccme_boron, + fit <- ssd_fit_dists( + ssddata::ccme_boron, dists = c("lnorm", "llogis"), rescale = FALSE ) @@ -84,7 +85,10 @@ test_that("ssd_fit_dists happy with left as left but happy if right other", { data <- ssddata::ccme_boron data$left <- data$Conc data$right <- data$Conc - expect_s3_class(ssd_fit_dists(data, left = "left", right = "right"), "fitdists") + expect_s3_class( + ssd_fit_dists(data, left = "left", right = "right"), + "fitdists" + ) }) test_that("ssd_fit_dists not affected if all weight 1", { @@ -221,7 +225,8 @@ test_that("ssd_fit_dists warns to rescale data", { test_that("ssd_fit_dists doesn't warns to rescale data if already rescaled", { data <- data.frame(Conc = rep(2, 6)) - expect_error(expect_warning(ssd_fit_dists(data, rescale = TRUE, dist = "lnorm"), + expect_error(expect_warning( + ssd_fit_dists(data, rescale = TRUE, dist = "lnorm"), regexp = "^Distribution 'lnorm' failed to fit:" )) }) @@ -229,7 +234,8 @@ test_that("ssd_fit_dists doesn't warns to rescale data if already rescaled", { test_that("ssd_fit_dists warns of optimizer convergence code error", { data <- ssddata::ccme_boron expect_error( - expect_warning(ssd_fit_dists(data, control = list(maxit = 1), dist = "lnorm"), + expect_warning( + ssd_fit_dists(data, control = list(maxit = 1), dist = "lnorm"), regexp = "^Distribution 'lnorm' failed to converge \\(try rescaling data\\): Iteration limit maxit reach \\(try increasing the maximum number of iterations in control\\)\\.$" ) ) @@ -244,13 +250,17 @@ test_that("ssd_fit_dists estimates for ssddata::ccme_boron on bcanz dists", { }) test_that("ssd_fit_dists not reorder", { - fit <- ssd_fit_dists(ssddata::ccme_boron, + fit <- ssd_fit_dists( + ssddata::ccme_boron, dists = c("lnorm", "llogis"), rescale = FALSE ) expect_identical(npars(fit), c(lnorm = 2L, llogis = 2L)) - expect_equal(logLik(fit), c(lnorm = -117.514216489547, llogis = -118.507435324581)) + expect_equal( + logLik(fit), + c(lnorm = -117.514216489547, llogis = -118.507435324581) + ) }) test_that("ssd_fit_dists equal weights no effect", { @@ -346,13 +356,29 @@ test_that("ssd_fit_dists gives same answer for missing versus Inf right", { test_that("ssd_fit_dists min_pmix at_boundary_ok FALSE", { withr::with_seed(50, { - conc <- ssd_rlnorm_lnorm(1000, meanlog1 = 0, meanlog2 = 1, sdlog1 = 1 / 10, sdlog2 = 1 / 10, pmix = 0.1) + conc <- ssd_rlnorm_lnorm( + 1000, + meanlog1 = 0, + meanlog2 = 1, + sdlog1 = 1 / 10, + sdlog2 = 1 / 10, + pmix = 0.1 + ) }) data <- data.frame(Conc = conc) - fits <- ssd_fit_dists(data, dists = c("lnorm_lnorm", "llogis_llogis"), min_pmix = 0.1) + fits <- ssd_fit_dists( + data, + dists = c("lnorm_lnorm", "llogis_llogis"), + min_pmix = 0.1 + ) tidy <- tidy(fits) expect_error( - expect_warning(expect_warning(ssd_fit_dists(data, dists = c("lnorm_lnorm", "llogis_llogis"), min_pmix = 0.11, at_boundary_ok = FALSE))), + expect_warning(expect_warning(ssd_fit_dists( + data, + dists = c("lnorm_lnorm", "llogis_llogis"), + min_pmix = 0.11, + at_boundary_ok = FALSE + ))), "All distributions failed to fit." ) expect_snapshot_data(tidy, "min_pmix5") @@ -360,10 +386,22 @@ test_that("ssd_fit_dists min_pmix at_boundary_ok FALSE", { test_that("ssd_fit_dists min_pmix", { withr::with_seed(50, { - conc <- ssd_rlnorm_lnorm(1000, meanlog1 = 0, meanlog2 = 1, sdlog1 = 1 / 10, sdlog2 = 1 / 10, pmix = 0.1) + conc <- ssd_rlnorm_lnorm( + 1000, + meanlog1 = 0, + meanlog2 = 1, + sdlog1 = 1 / 10, + sdlog2 = 1 / 10, + pmix = 0.1 + ) }) data <- data.frame(Conc = conc) - fits <- ssd_fit_dists(data, dists = c("lnorm_lnorm"), min_pmix = 0.11, at_boundary_ok = TRUE) + fits <- ssd_fit_dists( + data, + dists = c("lnorm_lnorm"), + min_pmix = 0.11, + at_boundary_ok = TRUE + ) tidy <- tidy(fits) expect_equal(tidy$est[tidy$term == "pmix"], 0.11) }) @@ -371,12 +409,17 @@ test_that("ssd_fit_dists min_pmix", { test_that("ssd_fit_dists at_boundary_ok message", { withr::with_seed(50, { expect_warning( - ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "burrIII3"), at_boundary_ok = FALSE), + ssd_fit_dists( + ssddata::ccme_boron, + dists = c("lnorm", "burrIII3"), + at_boundary_ok = FALSE + ), "one or more parameters at boundary[.]$" ) }) expect_warning( - ssd_fit_dists(ssddata::ccme_boron, + ssd_fit_dists( + ssddata::ccme_boron, dists = c("lnorm", "burrIII3"), at_boundary_ok = TRUE, computable = TRUE @@ -393,16 +436,20 @@ test_that("ssd_fit_dists bcanz with anon_e", { test_that("ssd_fit_dists unstable with anon_e", { expect_warning( - fit <- ssd_fit_dists(ssddata::anon_e, dists = ssd_dists(bcanz = FALSE)), "gompertz" + fit <- ssd_fit_dists(ssddata::anon_e, dists = ssd_dists(bcanz = FALSE)), + "gompertz" ) tidy <- tidy(fit) expect_snapshot_data(tidy, "tidy_unstable_anon_e") }) test_that("ssd_fit_dists works min_pmix = 0.5 and at_boundary_ok = TRUE and computable = FALSE", { - fit <- ssd_fit_dists(ssddata::ccme_boron, - dists = c("lnorm", "lnorm_lnorm"), min_pmix = 0.5, - at_boundary_ok = TRUE, computable = FALSE + fit <- ssd_fit_dists( + ssddata::ccme_boron, + dists = c("lnorm", "lnorm_lnorm"), + min_pmix = 0.5, + at_boundary_ok = TRUE, + computable = FALSE ) tidy <- tidy(fit) expect_snapshot_data(tidy, "min_pmix_05") @@ -410,9 +457,15 @@ test_that("ssd_fit_dists works min_pmix = 0.5 and at_boundary_ok = TRUE and comp test_that("ssd_fit_dists min_pmix 0", { withr::with_seed(50, { - data <- data.frame(Conc = ssd_rlnorm_lnorm(100, meanlog1 = 0, meanlog2 = 2, pmix = 0.01)) + data <- data.frame( + Conc = ssd_rlnorm_lnorm(100, meanlog1 = 0, meanlog2 = 2, pmix = 0.01) + ) }) - fit <- ssd_fit_dists(data, dists = c("lnorm_lnorm", "llogis_llogis"), min_pmix = 0) + fit <- ssd_fit_dists( + data, + dists = c("lnorm_lnorm", "llogis_llogis"), + min_pmix = 0 + ) tidy <- tidy(fit) expect_snapshot_data(tidy, "tidy_pmix0") }) diff --git a/tests/testthat/test-ggplot.R b/tests/testthat/test-ggplot.R index 0f0945cc5..4cc5f72ef 100644 --- a/tests/testthat/test-ggplot.R +++ b/tests/testthat/test-ggplot.R @@ -34,23 +34,31 @@ test_that("scale_fill_ssd is ggproto", { }) test_that("stat_ssd deprecated", { - lifecycle::expect_defunct(ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + - stat_ssd()) + lifecycle::expect_defunct( + ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + + stat_ssd() + ) }) test_that("plot stat_ssd", { - expect_defunct(ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + - stat_ssd()) + expect_defunct( + ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + + stat_ssd() + ) }) test_that("geom_ssd deprecated", { - expect_defunct(ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + - geom_ssd()) + expect_defunct( + ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + + geom_ssd() + ) }) test_that("plot geom_ssd", { - expect_defunct(ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + - geom_ssd()) + expect_defunct( + ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc)) + + geom_ssd() + ) }) test_that("plot geom_ssdpoint", { @@ -68,7 +76,10 @@ test_that("plot geom_ssdpoint identity stat", { }) test_that("plot geom_ssdsegment", { - gp <- ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc, xend = Conc * 2)) + + gp <- ggplot2::ggplot( + ssddata::ccme_boron, + ggplot2::aes(x = Conc, xend = Conc * 2) + ) + geom_ssdsegment() expect_snapshot_plot(gp, "geom_ssdsegment") }) @@ -76,22 +87,33 @@ test_that("plot geom_ssdsegment", { test_that("plot geom_ssdsegment identity", { data <- ssddata::ccme_boron data$New <- (seq_len(nrow(data)) - 0.5) / nrow(data) - gp <- ggplot2::ggplot(data, ggplot2::aes( - x = Conc, xend = Conc * 2, - y = New, yend = New - )) + + gp <- ggplot2::ggplot( + data, + ggplot2::aes( + x = Conc, + xend = Conc * 2, + y = New, + yend = New + ) + ) + geom_ssdsegment(stat = "identity") expect_snapshot_plot(gp, "geom_ssdsegment_identity") }) test_that("plot geom_ssdsegment arrow", { - gp <- ggplot2::ggplot(ssddata::ccme_boron, ggplot2::aes(x = Conc, xend = Conc * 2)) + + gp <- ggplot2::ggplot( + ssddata::ccme_boron, + ggplot2::aes(x = Conc, xend = Conc * 2) + ) + geom_ssdsegment(arrow = grid::arrow()) expect_snapshot_plot(gp, "geom_ssdsegment_arrow") }) test_that("plot geom_ssdsegment no data", { - gp <- ggplot2::ggplot(ssddata::ccme_boron[FALSE, ], ggplot2::aes(x = Conc, xend = Conc * 2)) + + gp <- ggplot2::ggplot( + ssddata::ccme_boron[FALSE, ], + ggplot2::aes(x = Conc, xend = Conc * 2) + ) + geom_ssdsegment() expect_snapshot_plot(gp, "geom_ssdsegment_nodata") }) diff --git a/tests/testthat/test-glance.R b/tests/testthat/test-glance.R index ad0171142..229fb1a4c 100644 --- a/tests/testthat/test-glance.R +++ b/tests/testthat/test-glance.R @@ -82,8 +82,16 @@ test_that("glance reweight same log_lik", { data$Upper[1] <- data$Conc[1] * 1.0001 fit <- ssd_fit_dists(data, dists = c("gamma", "llogis", "lnorm")) - fit_cens <- ssd_fit_dists(data, dists = c("gamma", "llogis", "lnorm"), right = "Upper") - fit_cens_n <- ssd_fit_dists(data, dists = c("gamma", "llogis", "lnorm_lnorm"), right = "Upper") + fit_cens <- ssd_fit_dists( + data, + dists = c("gamma", "llogis", "lnorm"), + right = "Upper" + ) + fit_cens_n <- ssd_fit_dists( + data, + dists = c("gamma", "llogis", "lnorm_lnorm"), + right = "Upper" + ) glance <- glance(fit, wt = TRUE) glance_cens <- glance(fit_cens, wt = TRUE) diff --git a/tests/testthat/test-gof.R b/tests/testthat/test-gof.R index 0dafaef4f..cca03c902 100644 --- a/tests/testthat/test-gof.R +++ b/tests/testthat/test-gof.R @@ -62,7 +62,11 @@ test_that("gof censored same parameters5", { data$right <- data$Conc data$Conc[c(3, 6, 8)] <- NA - fits <- ssd_fit_dists(data, right = "right", dists = c("llogis_llogis", "lnorm_lnorm")) + fits <- ssd_fit_dists( + data, + right = "right", + dists = c("llogis_llogis", "lnorm_lnorm") + ) gof_statistic <- ssd_gof(fits, wt = TRUE) expect_snapshot_data(gof_statistic, "gof_statistic5") @@ -76,7 +80,11 @@ test_that("gof censored same diff parameters", { data$right <- data$Conc data$Conc[c(3, 6, 8)] <- NA - fits <- ssd_fit_dists(data, right = "right", dists = c("llogis", "lnorm_lnorm")) + fits <- ssd_fit_dists( + data, + right = "right", + dists = c("llogis", "lnorm_lnorm") + ) gof_statistic <- ssd_gof(fits, wt = TRUE) expect_snapshot_data(gof_statistic, "gof_statisticn") diff --git a/tests/testthat/test-hc-burrlioz.R b/tests/testthat/test-hc-burrlioz.R index 70d5e5b18..a770be8ee 100644 --- a/tests/testthat/test-hc-burrlioz.R +++ b/tests/testthat/test-hc-burrlioz.R @@ -18,14 +18,22 @@ test_that("ssd_hc_burrlioz deprecated", { fit <- ssd_fit_burrlioz(ssddata::ccme_boron) withr::with_seed(50, { - expect_defunct(hc_boron <- ssd_hc_burrlioz(fit, nboot = 10, ci = TRUE, min_pboot = 0)) + expect_defunct( + hc_boron <- ssd_hc_burrlioz(fit, nboot = 10, ci = TRUE, min_pboot = 0) + ) }) }) test_that("ssd_hc gets estimates with invpareto", { fit <- ssd_fit_burrlioz(ssddata::ccme_boron) withr::with_seed(50, { - hc_boron <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE) + hc_boron <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE + ) }) expect_snapshot_data(hc_boron, "hc_boron") }) @@ -45,7 +53,13 @@ test_that("ssd_hc gets estimates with burrIII3", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hc_burrIII3 <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE) + hc_burrIII3 <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE + ) }) expect_snapshot_data(hc_burrIII3, "hc_burrIII3") }) @@ -58,7 +72,9 @@ test_that("ssd_hc currently errors with burrIII3", { expect_identical(names(fit), "burrIII3") # FIXME: currently errors - also hp withr::with_seed(50, { - expect_error(hc_burrIII3 <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0)) + expect_error( + hc_burrIII3 <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0) + ) }) }) @@ -69,7 +85,14 @@ test_that("ssd_hc gets estimates with burrIII3 parametric", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hc_burrIII3 <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0, parametric = TRUE, samples = TRUE) + hc_burrIII3 <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + parametric = TRUE, + samples = TRUE + ) }) expect_snapshot_data(hc_burrIII3, "hc_burrIII3_parametric") }) diff --git a/tests/testthat/test-hc-root.R b/tests/testthat/test-hc-root.R index 41dc32a44..00e3f119d 100644 --- a/tests/testthat/test-hc-root.R +++ b/tests/testthat/test-hc-root.R @@ -18,10 +18,25 @@ test_that("hc multi_ci all multiple hcs cis", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(50, { - hc_average <- ssd_hc(fits, proportion = c(5, 10) / 100, average = TRUE, ci_method = "MACL", est_method = "arithmetic", nboot = 10, ci = TRUE) + hc_average <- ssd_hc( + fits, + proportion = c(5, 10) / 100, + average = TRUE, + ci_method = "MACL", + est_method = "arithmetic", + nboot = 10, + ci = TRUE + ) }) withr::with_seed(50, { - hc_multi <- ssd_hc(fits, proportion = c(5, 10) / 100, average = TRUE, ci_method = "multi_fixed", nboot = 10, ci = TRUE) + hc_multi <- ssd_hc( + fits, + proportion = c(5, 10) / 100, + average = TRUE, + ci_method = "multi_fixed", + nboot = 10, + ci = TRUE + ) }) expect_snapshot_data(hc_average, "hc_multi_ci_all_multiple_hcs_cis_average") expect_snapshot_data(hc_multi, "hc_multi_ci_all_multiple_hcs_cis_multi") @@ -30,13 +45,32 @@ test_that("hc multi_ci all multiple hcs cis", { test_that("hc multi_ci lnorm ci", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(50, { - hc_dist <- ssd_hc(fits, average = FALSE, ci = TRUE, nboot = 10, ci_method = "weighted_samples") + hc_dist <- ssd_hc( + fits, + average = FALSE, + ci = TRUE, + nboot = 10, + ci_method = "weighted_samples" + ) }) withr::with_seed(50, { - hc_average <- ssd_hc(fits, average = TRUE, ci = TRUE, nboot = 10, ci_method = "MACL", est_method = "arithmetic") + hc_average <- ssd_hc( + fits, + average = TRUE, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + est_method = "arithmetic" + ) }) withr::with_seed(50, { - hc_multi <- ssd_hc(fits, average = TRUE, ci_method = "multi_fixed", ci = TRUE, nboot = 10) + hc_multi <- ssd_hc( + fits, + average = TRUE, + ci_method = "multi_fixed", + ci = TRUE, + nboot = 10 + ) }) expect_snapshot_data(hc_dist, "hc_multi_ci_lnorm_ci_dist") diff --git a/tests/testthat/test-hc.R b/tests/testthat/test-hc.R index 1be7a682e..a3a327123 100644 --- a/tests/testthat/test-hc.R +++ b/tests/testthat/test-hc.R @@ -26,7 +26,14 @@ test_that("hc", { test_that("hc level", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::local_seed(102) - hc <- ssd_hc(fits, ci = TRUE, level = 0.89, nboot = 10, average = FALSE, samples = TRUE) + hc <- ssd_hc( + fits, + ci = TRUE, + level = 0.89, + nboot = 10, + average = FALSE, + samples = TRUE + ) expect_snapshot_data(hc, "hc89") }) @@ -43,7 +50,11 @@ test_that("hc estimate with censored data same number of 5parameters", { data <- ssddata::ccme_boron data$right <- data$Conc data$Conc[c(3, 6, 8)] <- NA - fit <- ssd_fit_dists(data, right = "right", dists = c("lnorm_lnorm", "llogis_llogis")) + fit <- ssd_fit_dists( + data, + right = "right", + dists = c("lnorm_lnorm", "llogis_llogis") + ) hc <- ssd_hc(fit) expect_snapshot_data(hc, "censored_5ll") }) @@ -79,7 +90,24 @@ test_that("hc with missing data", { test_that("ssd_hc list handles zero length list", { hc <- ssd_hc(structure(list(), .Names = character(0))) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "est_method", "ci_method", "boot_method", "nboot", "pboot", "samples")) + expect_identical( + colnames(hc), + c( + "dist", + "proportion", + "est", + "se", + "lcl", + "ucl", + "wt", + "est_method", + "ci_method", + "boot_method", + "nboot", + "pboot", + "samples" + ) + ) expect_identical(hc$dist, character(0)) expect_identical(hc$proportion, numeric(0)) expect_identical(hc$se, numeric(0)) @@ -88,7 +116,10 @@ test_that("ssd_hc list handles zero length list", { test_that("ssd_hc list works null values handles zero length list", { hc <- ssd_hc(list("lnorm" = NULL)) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_equal(hc$dist, "lnorm") expect_identical(hc$proportion, 0.05) expect_equal(hc$est, 0.193040816698737) @@ -98,7 +129,10 @@ test_that("ssd_hc list works null values handles zero length list", { test_that("ssd_hc list works multiple percent values", { hc <- ssd_hc(list("lnorm" = NULL), proportion = c(1, 99) / 100) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_identical(hc$proportion, c(1, 99) / 100) expect_equal(hc$dist, c("lnorm", "lnorm")) expect_equal(hc$est, c(0.097651733070336, 10.2404736563121)) @@ -108,7 +142,10 @@ test_that("ssd_hc list works multiple percent values", { test_that("ssd_hc list works partial percent values", { hc <- ssd_hc(list("lnorm" = NULL), proportion = c(50.5) / 100) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_identical(hc$proportion, 50.5 / 100) expect_equal(hc$dist, "lnorm") expect_equal(hc$est, 1.01261234261044) @@ -118,7 +155,10 @@ test_that("ssd_hc list works partial percent values", { test_that("ssd_hc list works specified values", { hc <- ssd_hc(list("lnorm" = list(meanlog = 2, sdlog = 2))) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_identical(hc$proportion, 0.05) expect_equal(hc$dist, "lnorm") expect_equal(hc$est, 0.275351379333677) @@ -128,7 +168,10 @@ test_that("ssd_hc list works specified values", { test_that("ssd_hc list works multiple NULL distributions", { hc <- ssd_hc(list("lnorm" = NULL, "llogis" = NULL)) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_identical(hc$proportion, c(5, 5) / 100) expect_equal(hc$dist, c("lnorm", "llogis")) expect_equal(hc$est, c(0.193040816698737, 0.0526315789473684)) @@ -136,12 +179,21 @@ test_that("ssd_hc list works multiple NULL distributions", { }) test_that("ssd_hc list works multiple NULL distributions with multiple percent", { - hc <- ssd_hc(list("lnorm" = NULL, "llogis" = NULL), proportion = c(1, 99) / 100) + hc <- ssd_hc( + list("lnorm" = NULL, "llogis" = NULL), + proportion = c(1, 99) / 100 + ) expect_s3_class(hc, "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot")) + expect_identical( + colnames(hc), + c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "nboot", "pboot") + ) expect_equal(hc$dist, c("lnorm", "lnorm", "llogis", "llogis")) expect_identical(hc$proportion, c(1, 99, 1, 99) / 100) - expect_equal(hc$est, c(0.097651733070336, 10.2404736563121, 0.0101010101010101, 98.9999999999999)) + expect_equal( + hc$est, + c(0.097651733070336, 10.2404736563121, 0.0101010101010101, 98.9999999999999) + ) expect_equal(hc$se, c(NA_real_, NA_real_, NA_real_, NA_real_)) }) @@ -150,7 +202,24 @@ test_that("ssd_hc fitdists works zero length percent", { hc <- ssd_hc(fits, proportion = numeric(0)) expect_s3_class(hc, class = "tbl_df") - expect_identical(colnames(hc), c("dist", "proportion", "est", "se", "lcl", "ucl", "wt", "est_method", "ci_method", "boot_method", "nboot", "pboot", "samples")) + expect_identical( + colnames(hc), + c( + "dist", + "proportion", + "est", + "se", + "lcl", + "ucl", + "wt", + "est_method", + "ci_method", + "boot_method", + "nboot", + "pboot", + "samples" + ) + ) expect_equal(hc$dist, character(0)) expect_identical(hc$proportion, numeric(0)) expect_equal(hc$est, numeric(0)) @@ -203,7 +272,13 @@ test_that("ssd_hc fitdists works odds", { withr::local_seed(99) fits <- ssd_fit_dists(data, dists = "lnorm", rescale = "odds") withr::local_seed(99) - hc <- ssd_hc(fits, average = FALSE, est_method = "multi", ci = TRUE, nboot = 10L) + hc <- ssd_hc( + fits, + average = FALSE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hc, "hcwet") }) @@ -213,7 +288,13 @@ test_that("ssd_hc fitdists works odds 0.8", { withr::local_seed(99) fits <- ssd_fit_dists(data, dists = "lnorm", rescale = "odds", odds_max = 0.8) withr::local_seed(99) - hc <- ssd_hc(fits, average = FALSE, est_method = "multi", ci = TRUE, nboot = 10L) + hc <- ssd_hc( + fits, + average = FALSE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hc, "hcwet08") }) @@ -232,7 +313,8 @@ test_that("ssd_hc fitdists geomean", { }) test_that("ssd_hc fitdists correctly averages", { - fits <- ssd_fit_dists(ssddata::aims_molybdenum_marine, + fits <- ssd_fit_dists( + ssddata::aims_molybdenum_marine, dists = c("lgumbel", "lnorm_lnorm"), min_pmix = 0 ) @@ -277,7 +359,13 @@ test_that("ssd_hc fitdists correct for rescaling", { test_that("ssd_hc fitdists cis", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, ci = TRUE, ci_method = "MACL", nboot = 10, samples = TRUE) + hc <- ssd_hc( + fits, + ci = TRUE, + ci_method = "MACL", + nboot = 10, + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_cis") }) @@ -285,7 +373,14 @@ test_that("ssd_hc fitdists cis", { test_that("ssd_hc fitdists cis level = 0.8", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, ci = TRUE, level = 0.8, ci_method = "MACL", nboot = 10, samples = TRUE) + hc <- ssd_hc( + fits, + ci = TRUE, + level = 0.8, + ci_method = "MACL", + nboot = 10, + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_cis_level08") }) @@ -363,7 +458,13 @@ test_that("ssd_hc works with partially left censored data non-parametric", { withr::with_seed(100, { fits <- ssd_fit_dists(data, dists = "lnorm", right = "right") - hc <- ssd_hc(fits, ci = TRUE, nboot = 10, average = FALSE, parametric = FALSE) + hc <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = FALSE, + parametric = FALSE + ) }) expect_snapshot_data(hc, "partialeftnonpara") expect_gt(hc$ucl, hc$est) @@ -417,7 +518,13 @@ test_that("ssd_hc calculates cis with equally weighted data", { data$Weight <- rep(2, nrow(data)) fits <- ssd_fit_dists(data, weight = "Weight", dists = "lnorm") withr::with_seed(10, { - hc <- ssd_hc(fits, ci = TRUE, nboot = 10, ci_method = "MACL", samples = TRUE) + hc <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + samples = TRUE + ) }) expect_snapshot_data(hc, "hcici") }) @@ -463,12 +570,28 @@ test_that("ssd_hc effect with higher weight two distributions", { data$Weight <- rep(1, nrow(data)) fits <- ssd_fit_dists(data, weight = "Weight", dists = c("lnorm", "llogis")) data$Weight <- rep(10, nrow(data)) - fits_10 <- ssd_fit_dists(data, weight = "Weight", dists = c("lnorm", "llogis")) + fits_10 <- ssd_fit_dists( + data, + weight = "Weight", + dists = c("lnorm", "llogis") + ) withr::with_seed(10, { - hc <- ssd_hc(fits, ci = TRUE, nboot = 10, ci_method = "MACL", est_method = "arithmetic") + hc <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + est_method = "arithmetic" + ) }) withr::with_seed(10, { - hc_10 <- ssd_hc(fits_10, ci = TRUE, nboot = 10, ci_method = "MACL", est_method = "arithmetic") + hc_10 <- ssd_hc( + fits_10, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + est_method = "arithmetic" + ) }) expect_snapshot_value(hc$est, style = "deparse") expect_snapshot_value(hc_10$est, style = "deparse") @@ -478,14 +601,33 @@ test_that("ssd_hc effect with higher weight two distributions", { test_that("ssd_hc cis with non-convergence", { withr::local_seed(99) - conc <- ssd_rlnorm_lnorm(100, meanlog1 = 0, meanlog2 = 1, sdlog1 = 1 / 10, sdlog2 = 1 / 10, pmix = 0.2) + conc <- ssd_rlnorm_lnorm( + 100, + meanlog1 = 0, + meanlog2 = 1, + sdlog1 = 1 / 10, + sdlog2 = 1 / 10, + pmix = 0.2 + ) data <- data.frame(Conc = conc) fit <- ssd_fit_dists(data, dists = "lnorm_lnorm", min_pmix = 0.15) expect_identical(attr(fit, "min_pmix"), 0.15) - hc15 <- ssd_hc(fit, ci = TRUE, nboot = 10, min_pboot = 0.9, ci_method = "MACL") + hc15 <- ssd_hc( + fit, + ci = TRUE, + nboot = 10, + min_pboot = 0.9, + ci_method = "MACL" + ) attr(fit, "min_pmix") <- 0.3 expect_identical(attr(fit, "min_pmix"), 0.3) - hc30 <- ssd_hc(fit, ci = TRUE, nboot = 10, min_pboot = 0.9, ci_method = "MACL") + hc30 <- ssd_hc( + fit, + ci = TRUE, + nboot = 10, + min_pboot = 0.9, + ci_method = "MACL" + ) expect_snapshot_data(hc30, "hc_30") }) @@ -504,7 +646,13 @@ test_that("ssd_hc parametric and non-parametric small sample size", { }) expect_snapshot_data(hc_para_small, "hc_para_small") withr::with_seed(47, { - hc_nonpara_small <- ssd_hc(fit, nboot = 10, ci = TRUE, parametric = FALSE, samples = TRUE) + hc_nonpara_small <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + parametric = FALSE, + samples = TRUE + ) }) expect_snapshot_data(hc_nonpara_small, "hc_nonpara_small") }) @@ -512,7 +660,13 @@ test_that("ssd_hc parametric and non-parametric small sample size", { test_that("ssd_hc_burrlioz gets estimates with invpareto", { fit <- ssd_fit_burrlioz(ssddata::ccme_boron) withr::with_seed(47, { - hc_boron <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE) + hc_boron <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE + ) }) expect_snapshot_data(hc_boron, "hc_boron") }) @@ -524,7 +678,13 @@ test_that("ssd_hc_burrlioz gets estimates with burrIII3", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hc_burrIII3 <- ssd_hc(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE) + hc_burrIII3 <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE + ) }) expect_snapshot_data(hc_burrIII3, "hc_burrIII3") }) @@ -536,9 +696,13 @@ test_that("ssd_hc_burrlioz gets estimates with burrIII3 parametric", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hc_burrIII3 <- ssd_hc(fit, - nboot = 10, ci = TRUE, min_pboot = 0, - parametric = TRUE, samples = TRUE + hc_burrIII3 <- ssd_hc( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + parametric = TRUE, + samples = TRUE ) }) expect_snapshot_data(hc_burrIII3, "hc_burrIII3_parametric") @@ -549,15 +713,29 @@ test_that("ssd_hc save_to", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 3, ci = TRUE, ci_method = "multi_fixed", save_to = dir, samples = TRUE) + hc <- ssd_hc( + fits, + nboot = 3, + ci = TRUE, + ci_method = "multi_fixed", + save_to = dir, + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_save_to") - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "data_000000002_lnorm.csv", - "data_000000003_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds", "estimates_000000002_lnorm.rds", - "estimates_000000003_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "data_000000002_lnorm.csv", + "data_000000003_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds", + "estimates_000000002_lnorm.rds", + "estimates_000000003_lnorm.rds" + ) + ) data <- read.csv(file.path(dir, "data_000000000_lnorm.csv")) expect_snapshot_data(hc, "hc_save_to1data") boot1 <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) @@ -566,9 +744,13 @@ test_that("ssd_hc save_to", { ests1 <- readRDS(file.path(dir, "estimates_000000001_lnorm.rds")) expect_identical(names(ests), names(ests1)) - expect_identical(names(ests), c( - "meanlog", "sdlog" - )) + expect_identical( + names(ests), + c( + "meanlog", + "sdlog" + ) + ) }) test_that("ssd_hc save_to ci_method = weighted_samples", { @@ -576,15 +758,29 @@ test_that("ssd_hc save_to ci_method = weighted_samples", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 3, ci = TRUE, save_to = dir, ci_method = "MACL", samples = TRUE) + hc <- ssd_hc( + fits, + nboot = 3, + ci = TRUE, + save_to = dir, + ci_method = "MACL", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_save_to_not_multi") - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "data_000000002_lnorm.csv", - "data_000000003_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds", "estimates_000000002_lnorm.rds", - "estimates_000000003_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "data_000000002_lnorm.csv", + "data_000000003_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds", + "estimates_000000002_lnorm.rds", + "estimates_000000003_lnorm.rds" + ) + ) data1 <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) expect_snapshot_data(hc, "hc_save_to1_not_multi") }) @@ -594,22 +790,43 @@ test_that("ssd_hc save_to ci_method = weighted_samples default", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 1, ci = TRUE, save_to = dir, ci_method = "MACL", est_method = "arithmetic", samples = TRUE) + hc <- ssd_hc( + fits, + nboot = 1, + ci = TRUE, + save_to = dir, + ci_method = "MACL", + est_method = "arithmetic", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_save_to_not_multi_default") expect_identical( sort(list.files(dir)), sort(c( - "data_000000000_gamma.csv", "data_000000000_lgumbel.csv", "data_000000000_llogis.csv", - "data_000000000_lnorm_lnorm.csv", "data_000000000_lnorm.csv", - "data_000000000_weibull.csv", "data_000000001_gamma.csv", "data_000000001_lgumbel.csv", - "data_000000001_llogis.csv", "data_000000001_lnorm_lnorm.csv", - "data_000000001_lnorm.csv", "data_000000001_weibull.csv", "estimates_000000000_gamma.rds", - "estimates_000000000_lgumbel.rds", "estimates_000000000_llogis.rds", - "estimates_000000000_lnorm_lnorm.rds", "estimates_000000000_lnorm.rds", - "estimates_000000000_weibull.rds", "estimates_000000001_gamma.rds", - "estimates_000000001_lgumbel.rds", "estimates_000000001_llogis.rds", - "estimates_000000001_lnorm_lnorm.rds", "estimates_000000001_lnorm.rds", + "data_000000000_gamma.csv", + "data_000000000_lgumbel.csv", + "data_000000000_llogis.csv", + "data_000000000_lnorm_lnorm.csv", + "data_000000000_lnorm.csv", + "data_000000000_weibull.csv", + "data_000000001_gamma.csv", + "data_000000001_lgumbel.csv", + "data_000000001_llogis.csv", + "data_000000001_lnorm_lnorm.csv", + "data_000000001_lnorm.csv", + "data_000000001_weibull.csv", + "estimates_000000000_gamma.rds", + "estimates_000000000_lgumbel.rds", + "estimates_000000000_llogis.rds", + "estimates_000000000_lnorm_lnorm.rds", + "estimates_000000000_lnorm.rds", + "estimates_000000000_weibull.rds", + "estimates_000000001_gamma.rds", + "estimates_000000001_lgumbel.rds", + "estimates_000000001_llogis.rds", + "estimates_000000001_lnorm_lnorm.rds", + "estimates_000000001_lnorm.rds", "estimates_000000001_weibull.rds" )) ) @@ -622,15 +839,29 @@ test_that("ssd_hc save_to rescale", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm", rescale = TRUE) withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 3, ci = TRUE, ci_method = "multi_fixed", save_to = dir, samples = TRUE) + hc <- ssd_hc( + fits, + nboot = 3, + ci = TRUE, + ci_method = "multi_fixed", + save_to = dir, + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_save_to_rescale") - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "data_000000002_lnorm.csv", - "data_000000003_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds", "estimates_000000002_lnorm.rds", - "estimates_000000003_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "data_000000002_lnorm.csv", + "data_000000003_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds", + "estimates_000000002_lnorm.rds", + "estimates_000000003_lnorm.rds" + ) + ) boot1 <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) expect_snapshot_data(hc, "hc_save_to1_rescale") }) @@ -640,15 +871,33 @@ test_that("ssd_hc save_to lnorm 1", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 1, ci = TRUE, ci_method = "multi_fixed", save_to = dir, samples = TRUE) + hc <- ssd_hc( + fits, + nboot = 1, + ci = TRUE, + ci_method = "multi_fixed", + save_to = dir, + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_save_to11") - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds" + ) + ) boot1 <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) - fit1 <- ssd_fit_dists(boot1, dists = "lnorm", left = "left", right = "right", weight = "weight") + fit1 <- ssd_fit_dists( + boot1, + dists = "lnorm", + left = "left", + right = "right", + weight = "weight" + ) est <- ssd_hc(fit1)$est expect_snapshot_value(hc$lcl, style = "deparse") expect_identical(hc$lcl, hc$ucl) @@ -659,18 +908,40 @@ test_that("ssd_hc save_to replaces", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(102, { - hc <- ssd_hc(fits, nboot = 1, ci = TRUE, ci_method = "multi_fixed", save_to = dir) - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds" - )) + hc <- ssd_hc( + fits, + nboot = 1, + ci = TRUE, + ci_method = "multi_fixed", + save_to = dir + ) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds" + ) + ) boot <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) - hc2 <- ssd_hc(fits, nboot = 1, ci = TRUE, ci_method = "multi_fixed", save_to = dir) + hc2 <- ssd_hc( + fits, + nboot = 1, + ci = TRUE, + ci_method = "multi_fixed", + save_to = dir + ) }) - expect_identical(list.files(dir), c( - "data_000000000_lnorm.csv", "data_000000001_lnorm.csv", "estimates_000000000_lnorm.rds", - "estimates_000000001_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lnorm.csv", + "data_000000001_lnorm.csv", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lnorm.rds" + ) + ) boot2 <- read.csv(file.path(dir, "data_000000001_lnorm.csv")) expect_snapshot_data(boot, "hc_boot1_replace") expect_snapshot_data(boot2, "hc_boot2_replace") @@ -680,12 +951,24 @@ test_that("ssd_hc fix_weight", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "lgumbel")) withr::with_seed(102, { - hc_unfix <- ssd_hc(fits, nboot = 10, ci = TRUE, ci_method = "multi_free", samples = TRUE) + hc_unfix <- ssd_hc( + fits, + nboot = 10, + ci = TRUE, + ci_method = "multi_free", + samples = TRUE + ) }) expect_snapshot_data(hc_unfix, "hc_unfix") withr::with_seed(102, { - hc_fix <- ssd_hc(fits, nboot = 10, ci = TRUE, ci_method = "multi_fixed", samples = TRUE) + hc_fix <- ssd_hc( + fits, + nboot = 10, + ci = TRUE, + ci_method = "multi_fixed", + samples = TRUE + ) }) expect_snapshot_data(hc_fix, "hc_fix") }) @@ -694,12 +977,26 @@ test_that("ssd_hc multiple values", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "lgumbel")) withr::with_seed(102, { - hc_unfix <- ssd_hc(fits, proportion = c(5, 10) / 100, nboot = 10, ci = TRUE, ci_method = "multi_free", samples = TRUE) + hc_unfix <- ssd_hc( + fits, + proportion = c(5, 10) / 100, + nboot = 10, + ci = TRUE, + ci_method = "multi_free", + samples = TRUE + ) }) expect_snapshot_data(hc_unfix, "hc_unfixmulti") withr::with_seed(102, { - hc_fix <- ssd_hc(fits, proportion = c(5, 10) / 100, nboot = 10, ci = TRUE, ci_method = "multi_fixed", samples = TRUE) + hc_fix <- ssd_hc( + fits, + proportion = c(5, 10) / 100, + nboot = 10, + ci = TRUE, + ci_method = "multi_fixed", + samples = TRUE + ) }) expect_snapshot_data(hc_fix, "hc_fixmulti") }) @@ -710,13 +1007,26 @@ test_that("ssd_hc multiple values save_to", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "lgumbel")) withr::with_seed(102, { - hc <- ssd_hc(fits, proportion = c(5, 10) / 100, nboot = 2, save_to = dir, ci = TRUE, ci_method = "multi_fixed") + hc <- ssd_hc( + fits, + proportion = c(5, 10) / 100, + nboot = 2, + save_to = dir, + ci = TRUE, + ci_method = "multi_fixed" + ) }) - expect_identical(list.files(dir), c( - "data_000000000_multi.csv", "data_000000001_multi.csv", "data_000000002_multi.csv", - "estimates_000000000_multi.rds", "estimates_000000001_multi.rds", - "estimates_000000002_multi.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_multi.csv", + "data_000000001_multi.csv", + "data_000000002_multi.csv", + "estimates_000000000_multi.rds", + "estimates_000000001_multi.rds", + "estimates_000000002_multi.rds" + ) + ) }) test_that("ssd_hc not multi_ci save_to", { @@ -727,35 +1037,80 @@ test_that("ssd_hc not multi_ci save_to", { withr::with_seed(102, { hc <- ssd_hc(fits, nboot = 2, ci_method = "MACL", save_to = dir, ci = TRUE) }) - expect_identical(list.files(dir), c( - "data_000000000_lgumbel.csv", "data_000000000_lnorm.csv", "data_000000001_lgumbel.csv", - "data_000000001_lnorm.csv", "data_000000002_lgumbel.csv", "data_000000002_lnorm.csv", - "estimates_000000000_lgumbel.rds", "estimates_000000000_lnorm.rds", - "estimates_000000001_lgumbel.rds", "estimates_000000001_lnorm.rds", - "estimates_000000002_lgumbel.rds", "estimates_000000002_lnorm.rds" - )) + expect_identical( + list.files(dir), + c( + "data_000000000_lgumbel.csv", + "data_000000000_lnorm.csv", + "data_000000001_lgumbel.csv", + "data_000000001_lnorm.csv", + "data_000000002_lgumbel.csv", + "data_000000002_lnorm.csv", + "estimates_000000000_lgumbel.rds", + "estimates_000000000_lnorm.rds", + "estimates_000000001_lgumbel.rds", + "estimates_000000001_lnorm.rds", + "estimates_000000002_lgumbel.rds", + "estimates_000000002_lnorm.rds" + ) + ) }) test_that("hc multi_ci false weighted", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "gamma")) withr::local_seed(102) - hc <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, samples = TRUE, ci_method = "weighted_samples", est_method = "arithmetic", min_pboot = 0.8) + hc <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + samples = TRUE, + ci_method = "weighted_samples", + est_method = "arithmetic", + min_pboot = 0.8 + ) expect_snapshot_data(hc, "hc_weighted_samples") }) test_that("hc multis match", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "gamma")) withr::with_seed(102, { - hc_tf <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, ci_method = "weighted_samples") + hc_tf <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + ci_method = "weighted_samples" + ) }) withr::with_seed(102, { - hc_ft <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "multi_fixed") + hc_ft <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "multi_fixed" + ) }) withr::with_seed(102, { - hc_ff <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "weighted_samples") + hc_ff <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "weighted_samples" + ) }) withr::with_seed(102, { - hc_tt <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, ci_method = "multi_fixed") + hc_tt <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + ci_method = "multi_fixed" + ) }) expect_identical(hc_tf$est, hc_tt$est) @@ -767,13 +1122,26 @@ test_that("hc multis match", { test_that("hc weighted bootie", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(102, { - hc_weighted2 <- ssd_hc(fits, - ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "weighted_samples", + hc_weighted2 <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "weighted_samples", samples = TRUE ) }) withr::with_seed(102, { - hc_unweighted2 <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "MACL", samples = TRUE) + hc_unweighted2 <- ssd_hc( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "MACL", + samples = TRUE + ) }) expect_identical(hc_weighted2$est, hc_unweighted2$est) @@ -848,7 +1216,14 @@ test_that("hc ci_method = 'weighted_arithmetic' deprecated for MACL", { test_that("ssd_hc fitdists arithmetic_samples ci", { fits <- ssd_fit_dists(ssddata::ccme_boron) - hc <- ssd_hc(fits, ci_method = "arithmetic_samples", est_method = "arithmetic", nboot = 10, average = TRUE, ci = TRUE) + hc <- ssd_hc( + fits, + ci_method = "arithmetic_samples", + est_method = "arithmetic", + nboot = 10, + average = TRUE, + ci = TRUE + ) expect_s3_class(hc, "tbl_df") expect_snapshot_data(hc, "hc_arithmetic_samples") }) diff --git a/tests/testthat/test-hcp-root.R b/tests/testthat/test-hcp-root.R index 94d9bf33b..27f0a8873 100644 --- a/tests/testthat/test-hcp-root.R +++ b/tests/testthat/test-hcp-root.R @@ -18,12 +18,34 @@ test_that("hp is hc conc = 1 ci_method = 'multi_fixed'", { fits <- ssd_fit_dists(ssddata::ccme_boron) conc <- 1 - hp_multi <- ssd_hp(fits, conc = conc, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) - hc_multi <- ssd_hc(fits, proportion = hp_multi$est / 100, average = TRUE, ci_method = "multi_fixed") + hp_multi <- ssd_hp( + fits, + conc = conc, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) + hc_multi <- ssd_hc( + fits, + proportion = hp_multi$est / 100, + average = TRUE, + ci_method = "multi_fixed" + ) expect_equal(hc_multi$est, 1) for (i in 1:10) { - hp_multi <- ssd_hp(fits, conc = hc_multi$est, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) - hc_multi <- ssd_hc(fits, proportion = hp_multi$est / 100, average = TRUE, ci_method = "multi_fixed") + hp_multi <- ssd_hp( + fits, + conc = hc_multi$est, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) + hc_multi <- ssd_hc( + fits, + proportion = hp_multi$est / 100, + average = TRUE, + ci_method = "multi_fixed" + ) } expect_equal(hc_multi$est, 1) }) @@ -31,12 +53,34 @@ test_that("hp is hc conc = 1 ci_method = 'multi_fixed'", { test_that("hp is hc conc = 10 ci_method = 'multi_fixed'", { fits <- ssd_fit_dists(ssddata::ccme_boron) conc <- 10 - hp_multi <- ssd_hp(fits, conc = conc, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) - hc_multi <- ssd_hc(fits, proportion = hp_multi$est / 100, average = TRUE, ci_method = "multi_fixed") + hp_multi <- ssd_hp( + fits, + conc = conc, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) + hc_multi <- ssd_hc( + fits, + proportion = hp_multi$est / 100, + average = TRUE, + ci_method = "multi_fixed" + ) expect_equal(hc_multi$est, 10.00000012176) for (i in 1:10) { - hp_multi <- ssd_hp(fits, conc = hc_multi$est, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) - hc_multi <- ssd_hc(fits, proportion = hp_multi$est / 100, average = TRUE, ci_method = "multi_fixed") + hp_multi <- ssd_hp( + fits, + conc = hc_multi$est, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) + hc_multi <- ssd_hc( + fits, + proportion = hp_multi$est / 100, + average = TRUE, + ci_method = "multi_fixed" + ) } expect_equal(hc_multi$est, 10) }) diff --git a/tests/testthat/test-hp-burrlioz.R b/tests/testthat/test-hp-burrlioz.R index 5803a977d..70734ab69 100644 --- a/tests/testthat/test-hp-burrlioz.R +++ b/tests/testthat/test-hp-burrlioz.R @@ -18,7 +18,14 @@ test_that("ssd_hp_burrlioz gets estimates with invpareto", { fit <- ssd_fit_burrlioz(ssddata::ccme_boron) withr::with_seed(47, { - hp_boron <- ssd_hp(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE, proportion = FALSE) + hp_boron <- ssd_hp( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hp_boron, "hp_boron") }) @@ -26,7 +33,13 @@ test_that("ssd_hp_burrlioz gets estimates with invpareto", { test_that("ssd_hp_burrlioz gets estimates with invpareto no ci", { fit <- ssd_fit_burrlioz(ssddata::ccme_boron) withr::with_seed(47, { - hp_boron <- ssd_hp(fit, nboot = 10, ci = FALSE, min_pboot = 0, proportion = FALSE) + hp_boron <- ssd_hp( + fit, + nboot = 10, + ci = FALSE, + min_pboot = 0, + proportion = FALSE + ) }) expect_snapshot_data(hp_boron, "hp_boron_no_ci") }) @@ -38,7 +51,14 @@ test_that("ssd_hp_burrlioz gets estimates with burrIII3", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hp_burrIII3 <- ssd_hp(fit, nboot = 10, ci = TRUE, min_pboot = 0, samples = TRUE, proportion = FALSE) + hp_burrIII3 <- ssd_hp( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hp_burrIII3, "hp_burrIII3") }) @@ -51,7 +71,15 @@ test_that("ssd_hp_burrlioz currently errors!", { expect_identical(names(fit), "burrIII3") # FIXME: currently errors! withr::with_seed(47, { - expect_error(hp_burrIII3 <- ssd_hp(fit, nboot = 10, ci = TRUE, min_pboot = 0, proportion = FALSE)) + expect_error( + hp_burrIII3 <- ssd_hp( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + proportion = FALSE + ) + ) }) }) @@ -62,9 +90,13 @@ test_that("ssd_hp_burrlioz gets estimates with burrIII3 parametric", { fit <- ssd_fit_burrlioz(data) expect_identical(names(fit), "burrIII3") withr::with_seed(49, { - hp_burrIII3 <- ssd_hp(fit, - nboot = 10, ci = TRUE, min_pboot = 0, - parametric = TRUE, samples = TRUE, + hp_burrIII3 <- ssd_hp( + fit, + nboot = 10, + ci = TRUE, + min_pboot = 0, + parametric = TRUE, + samples = TRUE, proportion = FALSE ) }) diff --git a/tests/testthat/test-hp-root.R b/tests/testthat/test-hp-root.R index b3c0865a8..21a7f17d4 100644 --- a/tests/testthat/test-hp-root.R +++ b/tests/testthat/test-hp-root.R @@ -18,9 +18,25 @@ test_that("hp multi_ci lnorm", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(502, { - hp_dist <- ssd_hp(fits, average = FALSE, ci_method = "MACL", proportion = FALSE) - hp_average <- ssd_hp(fits, average = TRUE, ci_method = "MACL", est_method = "arithmetic", proportion = FALSE) - hp_multi <- ssd_hp(fits, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) + hp_dist <- ssd_hp( + fits, + average = FALSE, + ci_method = "MACL", + proportion = FALSE + ) + hp_average <- ssd_hp( + fits, + average = TRUE, + ci_method = "MACL", + est_method = "arithmetic", + proportion = FALSE + ) + hp_multi <- ssd_hp( + fits, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) }) expect_identical(hp_average$est, hp_dist$est) expect_snapshot_value(hp_average$est, style = "deparse") @@ -37,8 +53,18 @@ test_that("hp multi_ci lnorm", { test_that("hp multi_ci all", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(502, { - hp_average <- ssd_hp(fits, average = TRUE, ci_method = "weighted_samples", proportion = FALSE) - hp_multi <- ssd_hp(fits, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) + hp_average <- ssd_hp( + fits, + average = TRUE, + ci_method = "weighted_samples", + proportion = FALSE + ) + hp_multi <- ssd_hp( + fits, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) }) expect_equal( hp_multi[!colnames(hp_multi) %in% c("ci_method", "boot_method")], @@ -52,13 +78,34 @@ test_that("hp multi_ci all", { test_that("hp multi_ci lnorm ci", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(502, { - hp_dist <- ssd_hp(fits, average = FALSE, ci = TRUE, nboot = 100, ci_method = "MACL", proportion = FALSE) + hp_dist <- ssd_hp( + fits, + average = FALSE, + ci = TRUE, + nboot = 100, + ci_method = "MACL", + proportion = FALSE + ) }) withr::with_seed(502, { - hp_average <- ssd_hp(fits, average = TRUE, ci = TRUE, nboot = 100, ci_method = "MACL", proportion = FALSE) + hp_average <- ssd_hp( + fits, + average = TRUE, + ci = TRUE, + nboot = 100, + ci_method = "MACL", + proportion = FALSE + ) }) withr::with_seed(502, { - hp_multi <- ssd_hp(fits, average = TRUE, ci_method = "multi_fixed", ci = TRUE, nboot = 100, proportion = FALSE) + hp_multi <- ssd_hp( + fits, + average = TRUE, + ci_method = "multi_fixed", + ci = TRUE, + nboot = 100, + proportion = FALSE + ) }) expect_snapshot_data(hp_average, "hp_multi_ci_lnorm_ci_average") diff --git a/tests/testthat/test-hp.R b/tests/testthat/test-hp.R index bab8042fc..a2e3c3ed4 100644 --- a/tests/testthat/test-hp.R +++ b/tests/testthat/test-hp.R @@ -19,7 +19,14 @@ test_that("hp", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(102, { - hp <- ssd_hp(fits, conc = 1, ci = TRUE, nboot = 10, average = FALSE, proportion = FALSE) + hp <- ssd_hp( + fits, + conc = 1, + ci = TRUE, + nboot = 10, + average = FALSE, + proportion = FALSE + ) }) expect_snapshot_data(hp, "hp") }) @@ -41,7 +48,24 @@ test_that("hp fitdists works with zero length conc", { hp <- ssd_hp(fits, numeric(0), proportion = FALSE) expect_s3_class(hp, "tbl_df") - expect_identical(colnames(hp), c("dist", "conc", "est", "se", "lcl", "ucl", "wt", "est_method", "ci_method", "boot_method", "nboot", "pboot", "samples")) + expect_identical( + colnames(hp), + c( + "dist", + "conc", + "est", + "se", + "lcl", + "ucl", + "wt", + "est_method", + "ci_method", + "boot_method", + "nboot", + "pboot", + "samples" + ) + ) expect_equal(hp$dist, character(0)) expect_identical(hp$conc, numeric(0)) expect_equal(hp$est, numeric(0)) @@ -109,7 +133,15 @@ test_that("hp fitdists works with cis", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(10, { - hp <- ssd_hp(fits, 1, ci = TRUE, nboot = 10, ci_method = "MACL", samples = TRUE, proportion = FALSE) + hp <- ssd_hp( + fits, + 1, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + samples = TRUE, + proportion = FALSE + ) }) expect_s3_class(hp, "tbl_df") expect_snapshot_data(hp, "hp98") @@ -135,12 +167,43 @@ test_that("hp fitdists gives different answer with model averaging as hp not sam data <- ssddata::aims_molybdenum_marine fits_lgumbel <- ssd_fit_dists(data, dists = "lgumbel") - expect_equal(ssd_hp(fits_lgumbel, ssd_hc(fits_lgumbel, proportion = 5 / 100)$est, proportion = TRUE)$est, 5 / 100) + expect_equal( + ssd_hp( + fits_lgumbel, + ssd_hc(fits_lgumbel, proportion = 5 / 100)$est, + proportion = TRUE + )$est, + 5 / 100 + ) fits_lnorm_lnorm <- ssd_fit_dists(data, dists = "lnorm_lnorm") - expect_equal(ssd_hp(fits_lnorm_lnorm, ssd_hc(fits_lnorm_lnorm, proportion = 5 / 100)$est, proportion = TRUE)$est, 5 / 100) - fits_both <- ssd_fit_dists(data, dists = c("lgumbel", "lnorm_lnorm"), min_pmix = 0) - expect_equal(ssd_hp(fits_both, ssd_hc(fits_both, proportion = 5 / 100, ci_method = "MACL", est_method = "arithmetic")$est, proportion = TRUE)$est, 4.59194131309822 / 100, tolerance = 1e-06) + expect_equal( + ssd_hp( + fits_lnorm_lnorm, + ssd_hc(fits_lnorm_lnorm, proportion = 5 / 100)$est, + proportion = TRUE + )$est, + 5 / 100 + ) + fits_both <- ssd_fit_dists( + data, + dists = c("lgumbel", "lnorm_lnorm"), + min_pmix = 0 + ) + expect_equal( + ssd_hp( + fits_both, + ssd_hc( + fits_both, + proportion = 5 / 100, + ci_method = "MACL", + est_method = "arithmetic" + )$est, + proportion = TRUE + )$est, + 4.59194131309822 / 100, + tolerance = 1e-06 + ) }) test_that("ssd_hc fitdists works odds", { @@ -149,11 +212,34 @@ test_that("ssd_hc fitdists works odds", { withr::local_seed(99) fits <- ssd_fit_dists(data, dists = "lnorm", rescale = "odds") withr::local_seed(99) - hp1 <- ssd_hp(fits, average = FALSE, proportion = TRUE, est_method = "multi", ci = TRUE, nboot = 10L) + hp1 <- ssd_hp( + fits, + average = FALSE, + proportion = TRUE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hp1, "hpwet1") - hp7 <- ssd_hp(fits, conc = 0.7979396, average = FALSE, proportion = TRUE, est_method = "multi", ci = TRUE, nboot = 10L) + hp7 <- ssd_hp( + fits, + conc = 0.7979396, + average = FALSE, + proportion = TRUE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hp7, "hpwet7") - hp10 <- ssd_hp(fits, conc = 10, average = FALSE, proportion = TRUE, est_method = "multi", ci = TRUE, nboot = 10L) + hp10 <- ssd_hp( + fits, + conc = 10, + average = FALSE, + proportion = TRUE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hp10, "hpwet10") }) @@ -163,22 +249,47 @@ test_that("ssd_hp fitdists works odds 0.8", { withr::local_seed(99) fits <- ssd_fit_dists(data, dists = "lnorm", rescale = "odds", odds_max = 0.8) withr::local_seed(99) - hp1 <- ssd_hp(fits, average = FALSE, proportion = TRUE, est_method = "multi", ci = TRUE, nboot = 10L) + hp1 <- ssd_hp( + fits, + average = FALSE, + proportion = TRUE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hp1, "hpwet081") - hp7 <- ssd_hp(fits, conc = 0.7591709, average = FALSE, proportion = TRUE, est_method = "multi", ci = TRUE, nboot = 10L) + hp7 <- ssd_hp( + fits, + conc = 0.7591709, + average = FALSE, + proportion = TRUE, + est_method = "multi", + ci = TRUE, + nboot = 10L + ) expect_snapshot_data(hp7, "hpwet087") }) test_that("ssd_hp fitdists averages", { fits <- ssd_fit_dists(ssddata::ccme_boron) - hp <- ssd_hp(fits, ci_method = "MACL", est_method = "arithmetic", proportion = FALSE) + hp <- ssd_hp( + fits, + ci_method = "MACL", + est_method = "arithmetic", + proportion = FALSE + ) expect_s3_class(hp, "tbl_df") expect_snapshot_data(hp, "hp145") }) test_that("ssd_hp fitdists geomean", { fits <- ssd_fit_dists(ssddata::ccme_boron) - hp <- ssd_hp(fits, ci_method = "MACL", est_method = "geometric", proportion = FALSE) + hp <- ssd_hp( + fits, + ci_method = "MACL", + est_method = "geometric", + proportion = FALSE + ) expect_s3_class(hp, "tbl_df") expect_snapshot_data(hp, "hp145g") }) @@ -213,7 +324,14 @@ test_that("ssd_hp doesn't calculate cis with inconsistent censoring", { data$Conc2[1] <- 1.0 fits <- ssd_fit_dists(data, dists = c("lnorm", "llogis")) withr::with_seed(10, { - hp <- ssd_hp(fits, 1, ci = TRUE, nboot = 10, ci_method = "MACL", proportion = FALSE) + hp <- ssd_hp( + fits, + 1, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + proportion = FALSE + ) }) expect_snapshot_value(hp$se, style = "deparse") @@ -248,7 +366,14 @@ test_that("ssd_hp calculates cis with equally weighted data", { data$Weight <- rep(2, nrow(data)) fits <- ssd_fit_dists(data, weight = "Weight", dists = "lnorm") withr::with_seed(10, { - hp <- ssd_hp(fits, 1, ci = TRUE, nboot = 10, ci_method = "MACL", proportion = FALSE) + hp <- ssd_hp( + fits, + 1, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + proportion = FALSE + ) }) expect_snapshot_value(hp$se, style = "deparse") }) @@ -257,7 +382,14 @@ test_that("ssd_hp calculates cis with two distributions", { data <- ssddata::ccme_boron fits <- ssd_fit_dists(data, dists = c("lnorm", "llogis")) withr::with_seed(10, { - hp <- ssd_hp(fits, 1, ci = TRUE, nboot = 10, ci_method = "MACL", proportion = FALSE) + hp <- ssd_hp( + fits, + 1, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + proportion = FALSE + ) }) expect_snapshot_value(hp$se, style = "deparse") }) @@ -294,12 +426,30 @@ test_that("ssd_hp effect with higher weight two distributions", { data$Weight <- rep(1, nrow(data)) fits <- ssd_fit_dists(data, weight = "Weight", dists = c("lnorm", "llogis")) data$Weight <- rep(10, nrow(data)) - fits_10 <- ssd_fit_dists(data, weight = "Weight", dists = c("lnorm", "llogis")) + fits_10 <- ssd_fit_dists( + data, + weight = "Weight", + dists = c("lnorm", "llogis") + ) withr::with_seed(10, { - hp <- ssd_hp(fits, 3, ci = TRUE, nboot = 10, ci_method = "MACL", proportion = FALSE) + hp <- ssd_hp( + fits, + 3, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + proportion = FALSE + ) }) withr::with_seed(10, { - hp_10 <- ssd_hp(fits_10, 3, ci = TRUE, nboot = 10, ci_method = "MACL", proportion = FALSE) + hp_10 <- ssd_hp( + fits_10, + 3, + ci = TRUE, + nboot = 10, + ci_method = "MACL", + proportion = FALSE + ) }) expect_snapshot_value(hp$est, style = "deparse") expect_snapshot_value(hp_10$est, style = "deparse") @@ -309,14 +459,37 @@ test_that("ssd_hp effect with higher weight two distributions", { test_that("ssd_hp cis with non-convergence", { withr::with_seed(99, { - conc <- ssd_rlnorm_lnorm(100, meanlog1 = 0, meanlog2 = 1, sdlog1 = 1 / 10, sdlog2 = 1 / 10, pmix = 0.2) + conc <- ssd_rlnorm_lnorm( + 100, + meanlog1 = 0, + meanlog2 = 1, + sdlog1 = 1 / 10, + sdlog2 = 1 / 10, + pmix = 0.2 + ) data <- data.frame(Conc = conc) fit <- ssd_fit_dists(data, dists = "lnorm_lnorm", min_pmix = 0.15) expect_identical(attr(fit, "min_pmix"), 0.15) - hp15 <- ssd_hp(fit, conc = 1, ci = TRUE, nboot = 100, min_pboot = 0.9, proportion = FALSE) + hp15 <- ssd_hp( + fit, + conc = 1, + ci = TRUE, + nboot = 100, + min_pboot = 0.9, + proportion = FALSE + ) attr(fit, "min_pmix") <- 0.3 expect_identical(attr(fit, "min_pmix"), 0.3) - hp30 <- ssd_hp(fit, conc = 1, ci = TRUE, nboot = 100, min_pboot = 0.9, ci_method = "MACL", samples = TRUE, proportion = FALSE) + hp30 <- ssd_hp( + fit, + conc = 1, + ci = TRUE, + nboot = 100, + min_pboot = 0.9, + ci_method = "MACL", + samples = TRUE, + proportion = FALSE + ) }) expect_s3_class(hp30, "tbl") expect_snapshot_data(hp30, "hp_30") @@ -325,7 +498,15 @@ test_that("ssd_hp cis with non-convergence", { test_that("ssd_hp with 1 bootstrap", { fit <- ssd_fit_dists(ssddata::ccme_boron, dists = "lnorm") withr::with_seed(10, { - hp <- ssd_hp(fit, 1, ci = TRUE, nboot = 1, ci_method = "MACL", samples = TRUE, proportion = FALSE) + hp <- ssd_hp( + fit, + 1, + ci = TRUE, + nboot = 1, + ci_method = "MACL", + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hp, "hp_1") }) @@ -334,12 +515,26 @@ test_that("ssd_hp fix_weight", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "lgumbel")) withr::with_seed(102, { - hc_unfix <- ssd_hp(fits, nboot = 100, ci = TRUE, ci_method = "multi_free", samples = TRUE, proportion = FALSE) + hc_unfix <- ssd_hp( + fits, + nboot = 100, + ci = TRUE, + ci_method = "multi_free", + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hc_unfix, "hc_unfix") withr::with_seed(102, { - hc_fix <- ssd_hp(fits, nboot = 100, ci = TRUE, ci_method = "multi_fixed", samples = TRUE, proportion = FALSE) + hc_fix <- ssd_hp( + fits, + nboot = 100, + ci = TRUE, + ci_method = "multi_fixed", + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hc_fix, "hc_fix") }) @@ -347,16 +542,46 @@ test_that("ssd_hp fix_weight", { test_that("hp multis match", { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("lnorm", "gamma")) withr::with_seed(102, { - hp_tf <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, ci_method = "weighted_samples", proportion = FALSE) + hp_tf <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + ci_method = "weighted_samples", + proportion = FALSE + ) }) withr::with_seed(102, { - hp_ft <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "multi_fixed", proportion = FALSE) + hp_ft <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "multi_fixed", + proportion = FALSE + ) }) withr::with_seed(102, { - hp_ff <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "weighted_samples", proportion = FALSE) + hp_ff <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "weighted_samples", + proportion = FALSE + ) }) withr::with_seed(102, { - hp_tt <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, ci_method = "multi_fixed", proportion = FALSE) + hp_tt <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + ci_method = "multi_fixed", + proportion = FALSE + ) }) expect_identical(hp_tf$est, hp_tt$est) @@ -368,13 +593,28 @@ test_that("hp multis match", { test_that("hp weighted bootie", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(102, { - hp_weighted2 <- ssd_hp(fits, - ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "weighted_samples", - samples = TRUE, proportion = FALSE + hp_weighted2 <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "weighted_samples", + samples = TRUE, + proportion = FALSE ) }) withr::with_seed(102, { - hp_unweighted2 <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, est_method = "arithmetic", ci_method = "MACL", samples = TRUE, proportion = FALSE) + hp_unweighted2 <- ssd_hp( + fits, + ci = TRUE, + nboot = 10, + average = TRUE, + est_method = "arithmetic", + ci_method = "MACL", + samples = TRUE, + proportion = FALSE + ) }) expect_identical(hp_weighted2$est, hp_unweighted2$est) @@ -407,7 +647,12 @@ test_that("hp est_method = FALSE deprecated and overrides est_method", { withr::with_seed(10, { lifecycle::expect_deprecated({ - false <- ssd_hp(fits, multi_est = FALSE, est_method = "geometric", proportion = FALSE) + false <- ssd_hp( + fits, + multi_est = FALSE, + est_method = "geometric", + proportion = FALSE + ) }) }) @@ -418,7 +663,11 @@ test_that("hp ci_method = 'weighted_arithmetic' deprecated for MACL", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(10, { lifecycle::expect_deprecated({ - weighted_arithmetic <- ssd_hp(fits, ci_method = "weighted_arithmetic", proportion = FALSE) + weighted_arithmetic <- ssd_hp( + fits, + ci_method = "weighted_arithmetic", + proportion = FALSE + ) }) }) diff --git a/tests/testthat/test-invpareto.R b/tests/testthat/test-invpareto.R index 18e47c396..0578fc66e 100644 --- a/tests/testthat/test-invpareto.R +++ b/tests/testthat/test-invpareto.R @@ -35,7 +35,13 @@ test_that("invpareto gives cis with ccme_boron", { fit <- ssd_fit_dists(ssddata::ccme_boron, dists = "invpareto") expect_s3_class(fit, "fitdists") withr::with_seed(50, { - hc <- ssd_hc(fit, nboot = 100, ci = TRUE, ci_method = "multi_fixed", samples = TRUE) + hc <- ssd_hc( + fit, + nboot = 100, + ci = TRUE, + ci_method = "multi_fixed", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_boron") }) @@ -44,7 +50,14 @@ test_that("invpareto ssd_hp gives cis with ccme_boron", { fit <- ssd_fit_dists(ssddata::ccme_boron, dists = "invpareto") expect_s3_class(fit, "fitdists") withr::with_seed(50, { - hp <- ssd_hp(fit, nboot = 100, ci = TRUE, ci_method = "multi_fixed", samples = TRUE, proportion = FALSE) + hp <- ssd_hp( + fit, + nboot = 100, + ci = TRUE, + ci_method = "multi_fixed", + samples = TRUE, + proportion = FALSE + ) }) expect_snapshot_data(hp, "hp_boron") }) @@ -84,7 +97,10 @@ test_that("invpareto unbiased scale estimator large n", { exp(ssdtools:::sinvpareto(data.frame(right = ssd_rinvpareto(n)))$log_scale) } withr::with_seed(50, { - expect_snapshot_value(mean(vapply(rep(1000, 1000), fun, 1)), style = "deparse") + expect_snapshot_value( + mean(vapply(rep(1000, 1000), fun, 1)), + style = "deparse" + ) }) }) @@ -93,48 +109,135 @@ test_that("invpareto unbiased shape estimator large n", { exp(ssdtools:::sinvpareto(data.frame(right = ssd_rinvpareto(n)))$log_shape) } withr::with_seed(50, { - expect_snapshot_value(mean(vapply(rep(1000, 1000), fun, 1)), style = "deparse") + expect_snapshot_value( + mean(vapply(rep(1000, 1000), fun, 1)), + style = "deparse" + ) }) }) test_that("invpareto with extreme data", { - data <- data.frame(Conc = c( - 2.48892649039671, 2.5258371156749, 2.51281264491458, - 2.49866046657748, 2.56572740160664, 2.49440006912093, 2.4817062813665, - 2.47546618759501, 2.53571697416386, 2.50242492575677, 2.50112253589808, - 2.5287786019635, 2.57780684900776, 2.53608336578284, 2.58101156958599, - 2.47461770234486, 2.49063194551244, 2.5856619890231, 2.48695693688166, - 2.57378026021983, 2.51235308389976, 2.48522032692049, 2.49973051106759, - 2.53625648406357, 2.51192819101941, 2.48564121012588, 2.47989185141965, - 2.47104478254847, 2.53704987914894, 2.48182203478124, 2.51943279158882, - 2.47875248023764, 2.52955571948405, 2.53413505298479, 2.4857126516631, - 2.55015093854307, 2.50566701101757, 2.5134323318284, 2.49793441210188, - 2.49424215906085, 2.48960347486455, 2.55358332496617, 2.55446292958609, - 2.48210193691792, 2.46945069890001, 2.48557684661491, 2.56460608968987, - 2.53708962699444, 2.48214951933889, 2.54412439394134, 2.59518068845417, - 2.55975671870397, 2.493434223589, 2.53455956396635, 2.49737837236316, - 2.54900643026637, 2.50513718347292, 2.54882879624245, 2.51814393193009, - 2.46420777049251, 2.46410824439861, 2.52375449633473, 2.50472480352834, - 2.47468853687034, 2.49903375287477, 2.51052484516152, 2.52440831022558, - 2.48241564711347, 2.57274003332032, 2.48966764017043, 2.5690823103684, - 2.50354051434315, 2.57783696959855, 2.55278129417344, 2.49091327122561, - 2.4858726676362, 2.50704022976757, 2.60120582374815, 2.48030852436464, - 2.58234455069583, 2.54629314447072, 2.52650700793897, 2.4871602238994, - 2.50569757079671, 2.49183442063104, 2.50165889380711, 2.47934668379978, - 2.47510756679179, 2.53369127110563, 2.46868451852079, 2.61321699644183, - 2.52987952199996, 2.58987810707128, 2.46777896999791, 2.51447342615507, - 2.48618482994608, 2.51794970929166, 2.49716394702713, 2.49218587262049 - )) + data <- data.frame( + Conc = c( + 2.48892649039671, + 2.5258371156749, + 2.51281264491458, + 2.49866046657748, + 2.56572740160664, + 2.49440006912093, + 2.4817062813665, + 2.47546618759501, + 2.53571697416386, + 2.50242492575677, + 2.50112253589808, + 2.5287786019635, + 2.57780684900776, + 2.53608336578284, + 2.58101156958599, + 2.47461770234486, + 2.49063194551244, + 2.5856619890231, + 2.48695693688166, + 2.57378026021983, + 2.51235308389976, + 2.48522032692049, + 2.49973051106759, + 2.53625648406357, + 2.51192819101941, + 2.48564121012588, + 2.47989185141965, + 2.47104478254847, + 2.53704987914894, + 2.48182203478124, + 2.51943279158882, + 2.47875248023764, + 2.52955571948405, + 2.53413505298479, + 2.4857126516631, + 2.55015093854307, + 2.50566701101757, + 2.5134323318284, + 2.49793441210188, + 2.49424215906085, + 2.48960347486455, + 2.55358332496617, + 2.55446292958609, + 2.48210193691792, + 2.46945069890001, + 2.48557684661491, + 2.56460608968987, + 2.53708962699444, + 2.48214951933889, + 2.54412439394134, + 2.59518068845417, + 2.55975671870397, + 2.493434223589, + 2.53455956396635, + 2.49737837236316, + 2.54900643026637, + 2.50513718347292, + 2.54882879624245, + 2.51814393193009, + 2.46420777049251, + 2.46410824439861, + 2.52375449633473, + 2.50472480352834, + 2.47468853687034, + 2.49903375287477, + 2.51052484516152, + 2.52440831022558, + 2.48241564711347, + 2.57274003332032, + 2.48966764017043, + 2.5690823103684, + 2.50354051434315, + 2.57783696959855, + 2.55278129417344, + 2.49091327122561, + 2.4858726676362, + 2.50704022976757, + 2.60120582374815, + 2.48030852436464, + 2.58234455069583, + 2.54629314447072, + 2.52650700793897, + 2.4871602238994, + 2.50569757079671, + 2.49183442063104, + 2.50165889380711, + 2.47934668379978, + 2.47510756679179, + 2.53369127110563, + 2.46868451852079, + 2.61321699644183, + 2.52987952199996, + 2.58987810707128, + 2.46777896999791, + 2.51447342615507, + 2.48618482994608, + 2.51794970929166, + 2.49716394702713, + 2.49218587262049 + ) + ) fit98 <- ssd_fit_dists(data[1:98, , drop = FALSE], dists = "invpareto") expect_equal( estimates(fit98), - list(invpareto.weight = 1, invpareto.scale = 2.61422908501617, invpareto.shape = 26.0909009531098) + list( + invpareto.weight = 1, + invpareto.scale = 2.61422908501617, + invpareto.shape = 26.0909009531098 + ) ) fit99r <- ssd_fit_dists(data, dists = "invpareto", rescale = TRUE) expect_equal( estimates(fit99r), - list(invpareto.weight = 1, invpareto.scale = 1.03020756694085, invpareto.shape = 26.0278618888664) + list( + invpareto.weight = 1, + invpareto.scale = 1.03020756694085, + invpareto.shape = 26.0278618888664 + ) ) }) diff --git a/tests/testthat/test-lnorm-lnorm.R b/tests/testthat/test-lnorm-lnorm.R index 5b71a84a7..74c68ef92 100644 --- a/tests/testthat/test-lnorm-lnorm.R +++ b/tests/testthat/test-lnorm-lnorm.R @@ -49,15 +49,29 @@ test_that("ssd_rlnorm_lnorm allows reversed distributions", { }) test_that("lnorm_lnorm positive q with extreme distribution", { - expect_snapshot_value(qlnorm_lnorm_ssd(0.05, - meanlog1 = -10.39362, sdlog1 = 0.399835, - meanlog2 = -4.76721, sdlog2 = 2.583824, pmix = 0.1308133 - ), style = "deparse") + expect_snapshot_value( + qlnorm_lnorm_ssd( + 0.05, + meanlog1 = -10.39362, + sdlog1 = 0.399835, + meanlog2 = -4.76721, + sdlog2 = 2.583824, + pmix = 0.1308133 + ), + style = "deparse" + ) }) test_that("lnorm_lnorm positive q with extreme large distribution", { - expect_snapshot_value(qlnorm_lnorm_ssd(0.99, - meanlog1 = -4.76721, sdlog1 = 0.399835, - meanlog2 = 100.39362, sdlog2 = 2.583824, pmix = 0.1308133 - ), style = "deparse") + expect_snapshot_value( + qlnorm_lnorm_ssd( + 0.99, + meanlog1 = -4.76721, + sdlog1 = 0.399835, + meanlog2 = 100.39362, + sdlog2 = 2.583824, + pmix = 0.1308133 + ), + style = "deparse" + ) }) diff --git a/tests/testthat/test-logLik.R b/tests/testthat/test-logLik.R index bd49361d8..62e45332e 100644 --- a/tests/testthat/test-logLik.R +++ b/tests/testthat/test-logLik.R @@ -17,8 +17,15 @@ test_that("logLik", { fits <- ssd_fit_dists(ssddata::ccme_boron) - expect_equal(logLik(fits), c( - gamma = -116.81515869884, lgumbel = -120.092975580318, llogis = -118.507435324864, - lnorm = -117.514216489547, lnorm_lnorm = -115.179384580908, weibull = -116.81264387617 - )) + expect_equal( + logLik(fits), + c( + gamma = -116.81515869884, + lgumbel = -120.092975580318, + llogis = -118.507435324864, + lnorm = -117.514216489547, + lnorm_lnorm = -115.179384580908, + weibull = -116.81264387617 + ) + ) }) diff --git a/tests/testthat/test-multi.R b/tests/testthat/test-multi.R index 416fc7ea8..d36b47443 100644 --- a/tests/testthat/test-multi.R +++ b/tests/testthat/test-multi.R @@ -23,23 +23,46 @@ test_that("multi", { }) withr::with_seed(50, { - expect_snapshot_value(ssd_rmulti(1, gamma.weight = 0.5, lnorm.weight = 0.5), style = "deparse") + expect_snapshot_value( + ssd_rmulti(1, gamma.weight = 0.5, lnorm.weight = 0.5), + style = "deparse" + ) }) withr::with_seed(50, { - expect_snapshot_value(ssd_rmulti(1, gamma.weight = 1, lnorm.weight = 1), style = "deparse") + expect_snapshot_value( + ssd_rmulti(1, gamma.weight = 1, lnorm.weight = 1), + style = "deparse" + ) }) - expect_snapshot_value(ssd_qmulti(ssd_pmulti(c(0, 0.1, 0.5, 0.9, 0.99), lnorm.weight = 1), lnorm.weight = 1), + expect_snapshot_value( + ssd_qmulti( + ssd_pmulti(c(0, 0.1, 0.5, 0.9, 0.99), lnorm.weight = 1), + lnorm.weight = 1 + ), style = "deparse" ) - expect_snapshot_value(ssd_pmulti(ssd_qmulti(c(0, 0.1, 0.5, 0.9, 0.99), lnorm.weight = 1), lnorm.weight = 1), + expect_snapshot_value( + ssd_pmulti( + ssd_qmulti(c(0, 0.1, 0.5, 0.9, 0.99), lnorm.weight = 1), + lnorm.weight = 1 + ), style = "deparse" ) - expect_error(ssd_pmulti(0.5), "^At least one distribution must have a positive weight\\.$") - expect_error(ssd_qmulti(0.75), "^At least one distribution must have a positive weight\\.$") - expect_error(ssd_rmulti(1), "^At least one distribution must have a positive weight\\.$") + expect_error( + ssd_pmulti(0.5), + "^At least one distribution must have a positive weight\\.$" + ) + expect_error( + ssd_qmulti(0.75), + "^At least one distribution must have a positive weight\\.$" + ) + expect_error( + ssd_rmulti(1), + "^At least one distribution must have a positive weight\\.$" + ) test_dist("multi", multi = TRUE) }) @@ -54,9 +77,18 @@ test_that("ssd_pmulti", { expect_snapshot_value(ssd_pmulti_fitdists(10000, fit), style = "deparse") expect_snapshot_value(ssd_pmulti_fitdists(c(1, 2), fit), style = "deparse") expect_snapshot_value(ssd_pmulti_fitdists(c(1, NA), fit), style = "deparse") - expect_snapshot_value(ssd_pmulti_fitdists(1, fit, lower.tail = FALSE), style = "deparse") - expect_snapshot_value(ssd_pmulti_fitdists(1, fit, log.p = TRUE), style = "deparse") - expect_snapshot_value(ssd_pmulti_fitdists(1, fit, lower.tail = FALSE, log.p = TRUE), style = "deparse") + expect_snapshot_value( + ssd_pmulti_fitdists(1, fit, lower.tail = FALSE), + style = "deparse" + ) + expect_snapshot_value( + ssd_pmulti_fitdists(1, fit, log.p = TRUE), + style = "deparse" + ) + expect_snapshot_value( + ssd_pmulti_fitdists(1, fit, lower.tail = FALSE, log.p = TRUE), + style = "deparse" + ) }) test_that("ssd_pmulti weights", { @@ -71,7 +103,10 @@ test_that("ssd_pmulti weights", { args$weibull.weight <- 0 expect_snapshot_value(do.call("ssd_pmulti", args), style = "deparse") args$lnorm.weight <- 0 - expect_error(do.call("ssd_pmulti", args), "^At least one distribution must have a positive weight\\.$") + expect_error( + do.call("ssd_pmulti", args), + "^At least one distribution must have a positive weight\\.$" + ) args$lnorm.weight <- 1.1 expect_snapshot_value(do.call("ssd_pmulti", args), style = "deparse") args$lnorm.weight <- 1 @@ -88,10 +123,22 @@ test_that("ssd_qmulti", { expect_identical(ssd_qmulti_fitdists(1, fit), Inf) expect_equal(ssd_qmulti_fitdists(0, fit), 0) expect_snapshot_value(ssd_qmulti_fitdists(0.5, fit), style = "deparse") - expect_snapshot_value(ssd_qmulti_fitdists(c(0.5, 0.75), fit), style = "deparse") - expect_snapshot_value(ssd_qmulti_fitdists(0.25, fit, lower.tail = FALSE), style = "deparse") - expect_snapshot_value(ssd_qmulti_fitdists(log(0.75), fit, log.p = TRUE), style = "deparse") - expect_snapshot_value(ssd_qmulti_fitdists(log(0.25), fit, lower.tail = FALSE, log.p = TRUE), style = "deparse") + expect_snapshot_value( + ssd_qmulti_fitdists(c(0.5, 0.75), fit), + style = "deparse" + ) + expect_snapshot_value( + ssd_qmulti_fitdists(0.25, fit, lower.tail = FALSE), + style = "deparse" + ) + expect_snapshot_value( + ssd_qmulti_fitdists(log(0.75), fit, log.p = TRUE), + style = "deparse" + ) + expect_snapshot_value( + ssd_qmulti_fitdists(log(0.25), fit, lower.tail = FALSE, log.p = TRUE), + style = "deparse" + ) }) test_that("ssd_qmulti weights", { @@ -106,7 +153,10 @@ test_that("ssd_qmulti weights", { args$weibull.weight <- 0 expect_snapshot_value(do.call("ssd_qmulti", args), style = "deparse") args$lnorm.weight <- 0 - expect_error(do.call("ssd_qmulti", args), "^At least one distribution must have a positive weight\\.$") + expect_error( + do.call("ssd_qmulti", args), + "^At least one distribution must have a positive weight\\.$" + ) args$lnorm.weight <- 1.1 expect_snapshot_value(do.call("ssd_qmulti", args), style = "deparse") args$lnorm.weight <- 1.0 diff --git a/tests/testthat/test-npars.R b/tests/testthat/test-npars.R index 17f97b20b..37211d6b8 100644 --- a/tests/testthat/test-npars.R +++ b/tests/testthat/test-npars.R @@ -16,6 +16,12 @@ # limitations under the License. test_that("npars", { - fits <- ssd_fit_dists(ssddata::ccme_boron, dists = c("llogis_llogis", "lnorm_lnorm", "lnorm")) - expect_identical(npars(fits), c(llogis_llogis = 5L, lnorm_lnorm = 5L, lnorm = 2L)) + fits <- ssd_fit_dists( + ssddata::ccme_boron, + dists = c("llogis_llogis", "lnorm_lnorm", "lnorm") + ) + expect_identical( + npars(fits), + c(llogis_llogis = 5L, lnorm_lnorm = 5L, lnorm = 2L) + ) }) diff --git a/tests/testthat/test-plot-cdf.R b/tests/testthat/test-plot-cdf.R index d28b189c3..f81fb42b6 100644 --- a/tests/testthat/test-plot-cdf.R +++ b/tests/testthat/test-plot-cdf.R @@ -21,7 +21,10 @@ test_that("ssd_plot_cdf", { expect_snapshot_plot(ssd_plot_cdf(fits), "fits") expect_snapshot_plot(ssd_plot_cdf(fits, average = TRUE), "fits_average") expect_snapshot_plot(ssd_plot_cdf(fits, average = NA), "fits_average_na") - expect_snapshot_plot(ssd_plot_cdf(fits, average = TRUE, est_method = "geometric"), "fits_average_est_method") + expect_snapshot_plot( + ssd_plot_cdf(fits, average = TRUE, est_method = "geometric"), + "fits_average_est_method" + ) }) test_that("ssd_plot_cdf deals with rescaled data", { @@ -42,7 +45,12 @@ test_that("ssd_plot_cdf deals with named list", { test_that("autoplot deals with delta", { dists <- ssd_dists_all() withr::with_seed(50, { - fits <- ssd_fit_dists(ssddata::ccme_boron, dists = dists, at_boundary_ok = TRUE, computable = FALSE) + fits <- ssd_fit_dists( + ssddata::ccme_boron, + dists = dists, + at_boundary_ok = TRUE, + computable = FALSE + ) }) expect_snapshot_plot(ssd_plot_cdf(fits, delta = Inf), "fits_delta") }) @@ -61,5 +69,8 @@ test_that("ssd_plot_cdf small data", { data$Conc <- data$Conc / 1000 fits <- ssd_fit_dists(data) - expect_snapshot_plot(ssd_plot_cdf(fits, decimal.mark = "_"), "fits_decimalmark") + expect_snapshot_plot( + ssd_plot_cdf(fits, decimal.mark = "_"), + "fits_decimalmark" + ) }) diff --git a/tests/testthat/test-plot-data.R b/tests/testthat/test-plot-data.R index 8d3709755..323c6c949 100644 --- a/tests/testthat/test-plot-data.R +++ b/tests/testthat/test-plot-data.R @@ -20,10 +20,17 @@ test_that("ssd_plot_data ccme_boron", { }) test_that("ssd_plot_data ccme_boron color", { - expect_snapshot_plot(ssd_plot_data(ssddata::ccme_boron, - color = "Group", label = "Species", trans = "identity", - shift_x = 1, add_x = 10, - ), "ccme_boron2") + expect_snapshot_plot( + ssd_plot_data( + ssddata::ccme_boron, + color = "Group", + label = "Species", + trans = "identity", + shift_x = 1, + add_x = 10, + ), + "ccme_boron2" + ) }) test_that("ssd_plot_data ccme_boron language", { @@ -37,5 +44,8 @@ test_that("ssd_plot_data ccme_boron language", { test_that("ssd_plot_data ccme_boron small data", { data <- ssddata::ccme_boron data$Conc <- data$Conc / 1000 - expect_snapshot_plot(ssd_plot_data(data, decimal.mark = " "), "decimal_mark_space") -}) \ No newline at end of file + expect_snapshot_plot( + ssd_plot_data(data, decimal.mark = " "), + "decimal_mark_space" + ) +}) diff --git a/tests/testthat/test-predict.R b/tests/testthat/test-predict.R index c108d3868..3ef4f4d31 100644 --- a/tests/testthat/test-predict.R +++ b/tests/testthat/test-predict.R @@ -18,7 +18,11 @@ test_that("predict", { fits <- ssd_fit_dists(ssddata::ccme_boron) - pred <- predict(fits, ci_method = "weighted_samples", est_method = "arithmetic") + pred <- predict( + fits, + ci_method = "weighted_samples", + est_method = "arithmetic" + ) expect_s3_class(pred, "tbl") expect_snapshot_data(pred, "pred_dists") }) @@ -27,7 +31,13 @@ test_that("predict cis", { fits <- ssd_fit_dists(ssddata::ccme_boron) withr::with_seed(50, { - pred <- predict(fits, ci = TRUE, nboot = 10L, ci_method = "MACL", est_method = "arithmetic") + pred <- predict( + fits, + ci = TRUE, + nboot = 10L, + ci_method = "MACL", + est_method = "arithmetic" + ) }) expect_s3_class(pred, "tbl") expect_snapshot_data(pred, "pred_cis") @@ -58,13 +68,25 @@ test_that("predict cis fitburrlioz", { test_that("predict matches ssd_hc with and without average", { data <- ssddata::ccme_glyphosate - use_dists <- c("lnorm", "llogis", "lgumbel", "weibull", "gamma", "lnorm_lnorm") + use_dists <- c( + "lnorm", + "llogis", + "lgumbel", + "weibull", + "gamma", + "lnorm_lnorm" + ) fit <- ssd_fit_dists( data = data, - left = "Conc", dists = use_dists, - silent = TRUE, reweight = FALSE, min_pmix = 0, - computable = TRUE, at_boundary_ok = FALSE, rescale = FALSE + left = "Conc", + dists = use_dists, + silent = TRUE, + reweight = FALSE, + min_pmix = 0, + computable = TRUE, + at_boundary_ok = FALSE, + rescale = FALSE ) ave5 <- ssd_hc(fit, est_method = "arithmetic") diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index 8a1cf3134..131132205 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -30,7 +30,13 @@ test_that("summary fitdists with left censored, rescaled, weighted data", { data$Mass <- seq_len(nrow(data)) data$Other <- data$Conc data$Conc[2] <- NA - fits <- ssd_fit_dists(data, right = "Other", weight = "Mass", rescale = TRUE, dists = "lnorm") + fits <- ssd_fit_dists( + data, + right = "Other", + weight = "Mass", + rescale = TRUE, + dists = "lnorm" + ) expect_snapshot_output(print(fits)) }) @@ -48,7 +54,13 @@ test_that("summary fitdists with right censored, rescaled, weighted data", { data$Mass <- seq_len(nrow(data)) data$Other <- data$Conc data$Other[1] <- Inf - fits <- ssd_fit_dists(data, right = "Other", weight = "Mass", rescale = TRUE, dists = "lnorm") + fits <- ssd_fit_dists( + data, + right = "Other", + weight = "Mass", + rescale = TRUE, + dists = "lnorm" + ) expect_snapshot_output(print(fits)) }) diff --git a/tests/testthat/test-schwarz-tillmans.R b/tests/testthat/test-schwarz-tillmans.R index 0f9e75e7e..af61681c9 100644 --- a/tests/testthat/test-schwarz-tillmans.R +++ b/tests/testthat/test-schwarz-tillmans.R @@ -17,7 +17,12 @@ test_that("schwarz-tillmans", { dists <- c( - "gompertz", "weibull", "gamma", "lnorm", "llogis", "lgumbel" + "gompertz", + "weibull", + "gamma", + "lnorm", + "llogis", + "lgumbel" ) withr::with_seed(50, { fits <- ssd_fit_dists(ssddata::ccme_boron, dists = dists) diff --git a/tests/testthat/test-ssd-plot.R b/tests/testthat/test-ssd-plot.R index 24ad9261e..3f42d535c 100644 --- a/tests/testthat/test-ssd-plot.R +++ b/tests/testthat/test-ssd-plot.R @@ -17,17 +17,26 @@ test_that("ssd_plot", { expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred), "boron_pred") - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, label = "Species"), "boron_pred_label") - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, - label = "Species", - shift_x = 2 - ), "boron_pred_shift_x") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, label = "Species"), + "boron_pred_label" + ) + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, label = "Species", shift_x = 2), + "boron_pred_shift_x" + ) }) test_that("ssd_plot aes", { data <- ssddata::ccme_boron - expect_snapshot_plot(ssd_plot(data, boron_pred, color = "Group"), "boron_color") - expect_snapshot_plot(ssd_plot(data, boron_pred, shape = "Group"), "boron_shape") + expect_snapshot_plot( + ssd_plot(data, boron_pred, color = "Group"), + "boron_color" + ) + expect_snapshot_plot( + ssd_plot(data, boron_pred, shape = "Group"), + "boron_shape" + ) }) test_that("ssd_plot ribbon", { @@ -37,7 +46,10 @@ test_that("ssd_plot ribbon", { }) test_that("ssd_plot xbreaks", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, xbreaks = c(1, 2)), "boron_breaks") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, xbreaks = c(1, 2)), + "boron_breaks" + ) }) test_that("ssd_plot language", { @@ -47,7 +59,10 @@ test_that("ssd_plot language", { boron_pred$est <- boron_pred$est * 100 boron_pred$lcl <- boron_pred$lcl * 100 boron_pred$ucl <- boron_pred$ucl * 100 - expect_snapshot_plot(ssd_plot(data, boron_pred, big.mark = " "), "boron_bigmark") + expect_snapshot_plot( + ssd_plot(data, boron_pred, big.mark = " "), + "boron_bigmark" + ) expect_snapshot_plot(ssd_plot(data, boron_pred, suffix = " %%"), "suffix") }) @@ -70,27 +85,50 @@ test_that("ssd_plot fills in missing order", { }) test_that("ssd_plot xlims", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, xlimits = c(NA, 10000)), "boron_limits") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, xlimits = c(NA, 10000)), + "boron_limits" + ) }) test_that("ssd_plot no hcvalue", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, hc = NULL), "boron_nohc") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, hc = NULL), + "boron_nohc" + ) }) test_that("ssd_plot if hc value also in xbreaks", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, xbreaks = c(1, 1.26, 10, 100)), "boron_hcdup") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, xbreaks = c(1, 1.26, 10, 100)), + "boron_hcdup" + ) }) test_that("ssd_plot text_size", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, text_size = 18), "boron_textsize") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, text_size = 18), + "boron_textsize" + ) }) test_that("ssd_plot label_size", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, label_size = 5), "boron_labelsize") + expect_snapshot_plot( + ssd_plot(ssddata::ccme_boron, boron_pred, label_size = 5), + "boron_labelsize" + ) }) test_that("ssd_plot label_size", { - expect_snapshot_plot(ssd_plot(ssddata::ccme_boron, boron_pred, label_size = 5, theme_classic = TRUE), "boron_themeclassic") + expect_snapshot_plot( + ssd_plot( + ssddata::ccme_boron, + boron_pred, + label_size = 5, + theme_classic = TRUE + ), + "boron_themeclassic" + ) }) test_that("ssd_plot deci mark", { @@ -100,8 +138,11 @@ test_that("ssd_plot deci mark", { boron_pred$est <- boron_pred$est boron_pred$lcl <- boron_pred$lcl boron_pred$ucl <- boron_pred$ucl - expect_snapshot_plot(ssd_plot(data, boron_pred, decimal.mark = "-"), "boron_decimark") + expect_snapshot_plot( + ssd_plot(data, boron_pred, decimal.mark = "-"), + "boron_decimark" + ) withr::with_options(list(OutDec = ":"), { - expect_snapshot_plot(ssd_plot(data, boron_pred), "boron_decimark2") + expect_snapshot_plot(ssd_plot(data, boron_pred), "boron_decimark2") }) }) diff --git a/tests/testthat/test-subset.R b/tests/testthat/test-subset.R index 4eb54e4f7..3220bc4f9 100644 --- a/tests/testthat/test-subset.R +++ b/tests/testthat/test-subset.R @@ -24,11 +24,23 @@ test_that("subset", { expect_identical(subset(fits), fits) expect_error(names(subset(fits, c("lnorm", "fubar")))) - expect_identical(names(subset(fits, c("lnorm", "fubar"), strict = FALSE)), "lnorm") - expect_identical(names(subset(fits, c("fubar"), strict = FALSE)), character(0)) - expect_identical(names(subset(fits, c("lnorm", "gamma"))), c("gamma", "lnorm")) + expect_identical( + names(subset(fits, c("lnorm", "fubar"), strict = FALSE)), + "lnorm" + ) + expect_identical( + names(subset(fits, c("fubar"), strict = FALSE)), + character(0) + ) + expect_identical( + names(subset(fits, c("lnorm", "gamma"))), + c("gamma", "lnorm") + ) expect_identical(subset(fits, delta = 10), fits) expect_identical(names(subset(fits, delta = 0)), "weibull") expect_identical(names(subset(fits, delta = 0.01)), c("gamma", "weibull")) - expect_identical(names(subset(fits, c("gamma", "lnorm"), delta = 1.5)), c("gamma", "lnorm")) + expect_identical( + names(subset(fits, c("gamma", "lnorm"), delta = 1.5)), + c("gamma", "lnorm") + ) }) diff --git a/tests/testthat/test-summary.R b/tests/testthat/test-summary.R index 487ad57c9..21d0e4b16 100644 --- a/tests/testthat/test-summary.R +++ b/tests/testthat/test-summary.R @@ -27,13 +27,21 @@ test_that("summary tmbfit", { test_that("summary fitdists", { data <- ssddata::ccme_boron - fits <- ssd_fit_dists(data, - dists = "lnorm", rescale = FALSE, - min_pmix = 0.01 - ) + fits <- ssd_fit_dists(data, dists = "lnorm", rescale = FALSE, min_pmix = 0.01) summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_identical(summary$censoring, c(0, Inf)) expect_identical(summary$nrow, 28L) expect_identical(summary$min_pmix, 0.01) @@ -50,7 +58,18 @@ test_that("summary partially left censored", { fits <- ssd_fit_dists(data, dists = "lnorm", right = "right") summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_identical(summary$censoring, c(NA_real_, NA_real_)) expect_identical(summary$nrow, 28L) expect_equal(summary$min_pmix, 0.107142857) @@ -67,7 +86,18 @@ test_that("summary partiaally right censored", { fits <- ssd_fit_dists(data, dists = "lnorm", right = "right") summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_identical(summary$censoring, c(NA_real_, NA_real_)) expect_identical(summary$nrow, 28L) expect_equal(summary$min_pmix, 0.107142857) @@ -81,7 +111,18 @@ test_that("summary fitdists with multiple dists", { fits <- ssd_fit_dists(data, rescale = TRUE) summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_identical(summary$censoring, c(0, Inf)) expect_identical(summary$nrow, 28L) expect_equal(summary$rescaled, 8.40832920383116) @@ -94,10 +135,27 @@ test_that("summary fitdists with partially censored, rescaled, unequally weighte data$Mass <- seq_len(nrow(data)) data$Other <- data$Conc data$Conc[2] <- NA - fits <- ssd_fit_dists(data, right = "Other", weight = "Mass", rescale = TRUE, dists = "lnorm") + fits <- ssd_fit_dists( + data, + right = "Other", + weight = "Mass", + rescale = TRUE, + dists = "lnorm" + ) summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_equal(summary$censoring, c(NA_real_, NA_real_)) expect_identical(summary$nrow, 28L) expect_equal(summary$rescaled, 8.40832920383116) @@ -110,10 +168,27 @@ test_that("summary fitdists with left censored, rescaled, unequally weighted dat data$Mass <- seq_len(nrow(data)) data$Other <- data$Conc data <- ssd_censor_data(data, right = "Other", censoring = c(2.5, Inf)) - fits <- ssd_fit_dists(data, right = "Other", weight = "Mass", rescale = TRUE, dists = "lnorm") + fits <- ssd_fit_dists( + data, + right = "Other", + weight = "Mass", + rescale = TRUE, + dists = "lnorm" + ) summary <- summary(fits) expect_s3_class(summary, "summary_fitdists") - expect_identical(names(summary), c("fits", "censoring", "nrow", "rescaled", "weighted", "unequal", "min_pmix")) + expect_identical( + names(summary), + c( + "fits", + "censoring", + "nrow", + "rescaled", + "weighted", + "unequal", + "min_pmix" + ) + ) expect_equal(summary$censoring, c(2.5, Inf)) expect_identical(summary$nrow, 28L) expect_equal(summary$rescaled, 13.2947358003083) diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index 1827acb69..f9ea19eb5 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -38,5 +38,15 @@ test_that("tidy fit all with also doesn't reorder dists (but does reorder pars)" tidy <- tidy(fit, all = TRUE) expect_identical(colnames(tidy), c("dist", "term", "est", "se")) expect_identical(tidy$dist, c(rep("lnorm", 3), rep("llogis", 3))) - expect_identical(tidy$term, c("log_sdlog", "meanlog", "sdlog", "locationlog", "log_scalelog", "scalelog")) + expect_identical( + tidy$term, + c( + "log_sdlog", + "meanlog", + "sdlog", + "locationlog", + "log_scalelog", + "scalelog" + ) + ) }) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 50df9ad57..5b2fcea86 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -21,16 +21,29 @@ test_that("ssd_ecd", { expect_equal(ssd_ecd(1), 0.5) expect_equal(ssd_ecd(1:2), c(0.277777777777778, 0.722222222222222)) expect_equal(ssd_ecd(c(1, NA_real_)), c(NA_real_, NA_real_)) - expect_equal(ssd_ecd(1:10), c( - 0.0609756097560976, 0.158536585365854, 0.25609756097561, 0.353658536585366, - 0.451219512195122, 0.548780487804878, 0.646341463414634, 0.74390243902439, - 0.841463414634146, 0.939024390243902 - )) + expect_equal( + ssd_ecd(1:10), + c( + 0.0609756097560976, + 0.158536585365854, + 0.25609756097561, + 0.353658536585366, + 0.451219512195122, + 0.548780487804878, + 0.646341463414634, + 0.74390243902439, + 0.841463414634146, + 0.939024390243902 + ) + ) expect_equal(ssd_ecd(1:100), seq(0.005, 0.995, by = 0.01)) }) test_that("ssd_ecd ties.method argument deprecated", { - lifecycle::expect_deprecated(expect_equal(ssd_ecd(1, ties.method = "first"), 0.5)) + lifecycle::expect_deprecated(expect_equal( + ssd_ecd(1, ties.method = "first"), + 0.5 + )) }) test_that("ssd_ecd_data", { @@ -67,7 +80,10 @@ test_that("comma_signif", { }) test_that("ssd_sort_data works conc", { - expect_identical(ssd_sort_data(ssddata::ccme_boron), ssddata::ccme_boron[order(ssddata::ccme_boron$Conc), ]) + expect_identical( + ssd_sort_data(ssddata::ccme_boron), + ssddata::ccme_boron[order(ssddata::ccme_boron$Conc), ] + ) }) test_that("ssd_sort_data works no rows", { diff --git a/tests/testthat/test-weibull.R b/tests/testthat/test-weibull.R index b30340f7b..9856da5ab 100644 --- a/tests/testthat/test-weibull.R +++ b/tests/testthat/test-weibull.R @@ -52,7 +52,13 @@ test_that("weibull works anon_e", { test_that("weibull bootstraps anona", { fit <- ssd_fit_dists(ssddata::anon_a, dists = "weibull") withr::with_seed(50, { - hc <- ssd_hc(fit, nboot = 1000, ci = TRUE, ci_method = "weighted_samples", samples = TRUE) + hc <- ssd_hc( + fit, + nboot = 1000, + ci = TRUE, + ci_method = "weighted_samples", + samples = TRUE + ) }) expect_snapshot_data(hc, "hc_anona") }) diff --git a/tests/testthat/test-weighted.R b/tests/testthat/test-weighted.R index 0863b554b..1a77c20ec 100644 --- a/tests/testthat/test-weighted.R +++ b/tests/testthat/test-weighted.R @@ -55,7 +55,11 @@ test_that("weighted works", { hc1 <- ssd_hc(fit1) expect_snapshot_data(hc1, "hc1") - fit1w <- ssd_fit_dists(subset(data, Weight == 1), dists = "lnorm", weight = "Weight") + fit1w <- ssd_fit_dists( + subset(data, Weight == 1), + dists = "lnorm", + weight = "Weight" + ) hc1w <- ssd_hc(fit1w) expect_snapshot_data(hc1w, "hc1w")