Skip to content

Commit

Permalink
Merge pull request #312 from poissonconsulting/dev
Browse files Browse the repository at this point in the history 
Added `ssd_rmulti()` etc
  • Loading branch information
@joethorley
joethorley authored Nov 8, 2023
2 parents 00ce732 + 534816c commit bce6151
Show file tree
Hide file tree
Showing 32 changed files with 948 additions and 236 deletions.
5 changes: 5 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,6 +97,7 @@ export(ssd_plot)
export(ssd_plot_cdf)
export(ssd_plot_cf)
export(ssd_plot_data)
export(ssd_pmulti)
export(ssd_pweibull)
export(ssd_qburrIII3)
export(ssd_qgamma)
Expand All @@ -107,6 +108,7 @@ export(ssd_qllogis)
export(ssd_qllogis_llogis)
export(ssd_qlnorm)
export(ssd_qlnorm_lnorm)
export(ssd_qmulti)
export(ssd_qweibull)
export(ssd_rburrIII3)
export(ssd_rgamma)
Expand All @@ -117,10 +119,12 @@ export(ssd_rllogis)
export(ssd_rllogis_llogis)
export(ssd_rlnorm)
export(ssd_rlnorm_lnorm)
export(ssd_rmulti)
export(ssd_rweibull)
export(ssd_sort_data)
export(ssd_wqg_bc)
export(ssd_wqg_burrlioz)
export(ssd_wt_est)
export(stat_ssd)
export(tidy)
export(waiver)
Expand Down Expand Up @@ -175,6 +179,7 @@ importFrom(stats,qlogis)
importFrom(stats,runif)
importFrom(stats,sd)
importFrom(stats,setNames)
importFrom(stats,uniroot)
importFrom(stats,weighted.mean)
importFrom(stringr,str_order)
importFrom(tibble,as_tibble)
Expand Down
1 change: 0 additions & 1 deletion R/ggplot.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,6 @@ scale_color_ssd <- function(...) {
#' Uses the empirical cumulative distribution to create scatterplot of points `x`.
#'
#' `geom_ssd()` has been deprecated for `geom_ssdpoint()`.
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @seealso [`ssd_plot_cdf()`]
Expand Down
136 changes: 96 additions & 40 deletions R/hc.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -67,7 +67,7 @@ no_ssd_hc <- function() {
args$p <- proportion
dist <- .dist_tmbfit(x)
what <- paste0("ssd_q", dist)

est <- do.call(what, args)
if (!ci) {
na <- rep(NA_real_, length(proportion))
Expand All @@ -86,14 +86,14 @@ no_ssd_hc <- function() {
censoring <- censoring / rescale
fun <- safely(fit_tmb)
estimates <- boot_estimates(x,
fun = fun, nboot = nboot, data = data, weighted = weighted,
censoring = censoring, min_pmix = min_pmix,
range_shape1 = range_shape1,
range_shape2 = range_shape2,
parametric = parametric,
control = control
fun = fun, nboot = nboot, data = data, weighted = weighted,
censoring = censoring, min_pmix = min_pmix,
range_shape1 = range_shape1,
range_shape2 = range_shape2,
parametric = parametric,
control = control
)

cis <- cis_estimates(estimates, what, level = level, x = proportion)
hc <- tibble(
dist = dist,
Expand All @@ -105,16 +105,26 @@ no_ssd_hc <- function() {
replace_min_pboot_na(hc, min_pboot)
}

.ssd_hc_fitdists <- function(x, percent, ci, level, nboot,
average, min_pboot, parametric, control) {
.ssd_hc_fitdists <- function(
x,
percent,
ci,
level,
nboot,
average,
min_pboot,
parametric,
root,
control) {

if (!length(x) || !length(percent)) {
return(no_ssd_hc())
}

if (is.null(control)) {
control <- .control_fitdists(x)
}

data <- .data_fitdists(x)
rescale <- .rescale_fitdists(x)
censoring <- .censoring_fitdists(x)
Expand All @@ -123,30 +133,58 @@ no_ssd_hc <- function() {
range_shape2 <- .range_shape2_fitdists(x)
weighted <- .weighted_fitdists(x)
unequal <- .unequal_fitdists(x)

wt_est_nest <- wt_est_nest(x)

if (parametric && ci && identical(censoring, c(NA_real_, NA_real_))) {
wrn("Parametric CIs cannot be calculated for inconsistently censored data.")
ci <- FALSE
}

if (parametric && ci && unequal) {
wrn("Parametric CIs cannot be calculated for unequally weighted data.")
ci <- FALSE
}

if (!ci) {
nboot <- 0L
}

if(root && average) {
seeds <- seed_streams(length(percent))
hcs <- future_map(
percent / 100, .ssd_hc_root,
wt_est_nest = wt_est_nest, 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,
.options = furrr::furrr_options(seed = seeds))

hc <- dplyr::bind_rows(hcs)

method <- if (parametric) "parametric" else "non-parametric"

return(
tibble(
dist = "average", percent = percent, est = hc$est, se = hc$se,
lcl = hc$lcl, ucl = hc$ucl, wt = rep(1, length(percent)),
method = method, nboot = nboot, pboot = hc$pboot
)
)
}

seeds <- seed_streams(length(x))

hc <- future_map(x, .ssd_hc_tmbfit,
proportion = percent / 100, 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,
.options = furrr::furrr_options(seed = seeds)
proportion = percent / 100, 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,
.options = furrr::furrr_options(seed = seeds)
)

weight <- glance(x)$weight
weight <- wt_est_nest$weight
if (!average) {
hc <- mapply(
function(x, y) {
Expand Down Expand Up @@ -185,23 +223,33 @@ ssd_hc.list <- function(x, percent = 5, ...) {
chk_named(x)
chk_unique(names(x))
chk_unused(...)

if (!length(x)) {
return(no_ssd_hc())
}
hc <- mapply(.ssd_hc_dist, x, names(x),
MoreArgs = list(proportion = percent / 100),
SIMPLIFY = FALSE
MoreArgs = list(proportion = percent / 100),
SIMPLIFY = FALSE
)
bind_rows(hc)
}

#' @describeIn ssd_hc Hazard Concentrations for fitdists Object
#' @export
ssd_hc.fitdists <- function(x, percent = 5, ci = FALSE, level = 0.95, nboot = 1000,
average = TRUE, delta = 7, min_pboot = 0.99,
parametric = TRUE,
control = NULL, ...) {
ssd_hc.fitdists <- function(
x,
percent = 5,
ci = FALSE,
level = 0.95,
nboot = 1000,
average = TRUE,
delta = 7,
min_pboot = 0.99,
parametric = TRUE,
root = FALSE,
control = NULL,
...) {

chk_vector(percent)
chk_numeric(percent)
chk_range(percent, c(0, 100))
Expand All @@ -216,19 +264,27 @@ ssd_hc.fitdists <- function(x, percent = 5, ci = FALSE, level = 0.95, nboot = 10
chk_number(min_pboot)
chk_range(min_pboot)
chk_flag(parametric)
chk_flag(root)
chk_null_or(control, vld = vld_list)
chk_unused(...)

x <- subset(x, delta = delta)
hc <- .ssd_hc_fitdists(x, percent,
ci = ci, level = level, nboot = nboot, min_pboot = min_pboot, control = control,
average = average, parametric = parametric
hc <- .ssd_hc_fitdists(
x,
percent,
ci = ci,
level = level,
nboot = nboot,
average = average,
min_pboot = min_pboot,
parametric = parametric,
root = root,
control = control
)
warn_min_pboot(hc, min_pboot)
}

#' @describeIn ssd_hc Hazard Concentrations for fitburrlioz Object
#' '
#' @export
#' @examples
#' fit <- ssd_fit_burrlioz(ssddata::ccme_boron)
Expand All @@ -252,18 +308,18 @@ ssd_hc.fitburrlioz <- function(x, percent = 5, ci = FALSE, level = 0.95, nboot =
chk_range(min_pboot)
chk_flag(parametric)
chk_unused(...)

if (names(x) != "burrIII3" || !ci || !length(percent)) {
class(x) <- class(x)[-1]
return(ssd_hc(x,
percent = percent, ci = ci, level = level,
nboot = nboot, min_pboot = min_pboot,
average = FALSE, parametric = parametric
percent = percent, ci = ci, level = level,
nboot = nboot, min_pboot = min_pboot,
average = FALSE, parametric = parametric
))
}
hc <- .ssd_hc_burrlioz_fitdists(x,
percent = percent, level = level, nboot = nboot,
min_pboot = min_pboot, parametric = parametric
percent = percent, level = level, nboot = nboot,
min_pboot = min_pboot, parametric = parametric
)
warn_min_pboot(hc, min_pboot)
}
Loading

0 comments on commit bce6151

Please sign in to comment.