Add log-triangular (ltriangle) distribution

.Rbuildignore

@@ -25,3 +25,4 @@
 .devcontainer
 ^\.vscode$
 ^[.]?air[.]toml$
+^\.claude$

.github/workflows/test-coverage.yaml

@@ -38,7 +38,7 @@ jobs:
           covr::to_cobertura(cov)
         shell: Rscript {0}
 
-      - uses: codecov/codecov-action@v5
+      - uses: codecov/codecov-action@v7
         with:
           # Fail if error if not on PR, or if on PR and token is given
           fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }}

DESCRIPTION

@@ -51,6 +51,7 @@ Depends:
 Imports:
     abind,
     chk,
+    dplyr,
     furrr,
     generics,
     ggplot2,
@@ -61,7 +62,6 @@ Imports:
     grid,
     lifecycle,
     parallel,
-    plyr,
     purrr,
     Rcpp,
     readr,
@@ -73,27 +73,22 @@ Imports:
     tibble,
     TMB,
     universals,
-    utils
+    utils,
+    VGAM
 Suggests:
     actuar,
     covr,
-    dplyr,
     EnvStats,
     extraDistr,
     fitdistrplus,
     grDevices,
     knitr,
     latex2exp,
-    magrittr,
-    mle.tools,
     patchwork,
-    reshape2,
     rmarkdown,
     testthat (>= 3.0.0),
     tidyr,
-    tidyselect,
     tinytex,
-    VGAM,
     withr
 LinkingTo: 
     Rcpp,
@@ -106,4 +101,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.3.9000
+Config/roxygen2/version: 8.0.0.9000

NAMESPACE

@@ -96,6 +96,7 @@ export(ssd_ellogis)
 export(ssd_ellogis_llogis)
 export(ssd_elnorm)
 export(ssd_elnorm_lnorm)
+export(ssd_eltriangle)
 export(ssd_emulti)
 export(ssd_est_methods)
 export(ssd_eweibull)
@@ -129,6 +130,7 @@ export(ssd_plot)
 export(ssd_plot_cdf)
 export(ssd_plot_cf)
 export(ssd_plot_data)
+export(ssd_pltriangle)
 export(ssd_pmulti)
 export(ssd_pmulti_fitdists)
 export(ssd_pweibull)
@@ -141,6 +143,7 @@ export(ssd_qllogis)
 export(ssd_qllogis_llogis)
 export(ssd_qlnorm)
 export(ssd_qlnorm_lnorm)
+export(ssd_qltriangle)
 export(ssd_qmulti)
 export(ssd_qmulti_fitdists)
 export(ssd_qweibull)
@@ -153,6 +156,7 @@ export(ssd_rllogis)
 export(ssd_rllogis_llogis)
 export(ssd_rlnorm)
 export(ssd_rlnorm_lnorm)
+export(ssd_rltriangle)
 export(ssd_rmulti)
 export(ssd_rmulti_fitdists)
 export(ssd_rweibull)
@@ -197,7 +201,6 @@ importFrom(lifecycle,expect_defunct)
 importFrom(lifecycle,expect_deprecated)
 importFrom(parallel,nextRNGStream)
 importFrom(parallel,nextRNGSubStream)
-importFrom(plyr,summarise)
 importFrom(purrr,list_assign)
 importFrom(purrr,transpose)
 importFrom(scales,label_percent)

R/boot.R

@@ -30,12 +30,7 @@ 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, weighted, censoring) {
   what <- paste0("ssd_r", dist)
   args$chk <- FALSE
   sample <- do.call(what, args)

R/burrrIII3.R

@@ -98,7 +98,7 @@ sburrIII3 <- function(data, pars = NULL) {
   list(log_scale = 0, log_shape1 = 0, log_shape2 = 0)
 }
 
-bburrIII3 <- function(x, range_shape1, range_shape2, ...) {
+bburrIII3 <- function(range_shape1, range_shape2, ...) {
   log_range_shape1 <- log(range_shape1)
   log_range_shape2 <- log(range_shape2)
   list(

R/devtools-helpers.R

@@ -20,7 +20,6 @@ release_questions <- function() {
     "Have you fixed all the `FIXME`s?",
     "Have you run `data-raw/data-raw.R`?",
     "Have you tested using `ssdtests` package?",
-    "Have you run `vignettestatic/small-sample-bias.Rmd`?",
     "Have you confirmed all images in .Rmd files have alternative text defined using the `fig.alt` argument?",
     "Have you confirmed updated Apache 2.0 license at the top of all code files?",
     "Have you confirmed update Creative Commons license for all non-code files?"

R/estimates.R

@@ -60,6 +60,8 @@ estimates.fitdists <- function(x, all_estimates = FALSE, ...) {
 }
 
 .relist_estimates <- function(x) {
-  list <- relist(x, skeleton = emulti_ssd())
+  skeleton <- emulti_ssd()
+  x <- unlist(x)[names(unlist(skeleton))]
+  list <- relist(x, skeleton = skeleton)
   purrr::map(list, function(x) as.list(unlist(x)))
 }

R/ggproto.R

@@ -27,7 +27,7 @@ StatSsdpoint <- ggproto(
   "StatSsdpoint",
   Stat,
   required_aes = "x",
-  default_aes = aes(y = ..density..),
+  default_aes = aes(y = after_stat(density)),
   compute_panel = function(data, scales) {
     data$density <- ssd_ecd(data$x)
     data
@@ -40,7 +40,7 @@ StatSsdsegment <- ggproto(
   "StatSsdsegment",
   Stat,
   required_aes = c("x", "xend"),
-  default_aes = aes(y = ..density.., yend = ..density..),
+  default_aes = aes(y = after_stat(density), yend = after_stat(density)),
   compute_panel = function(data, scales) {
     data$density <- ssd_ecd(rowMeans(data[c("x", "xend")], na.rm = TRUE))
     data
@@ -114,18 +114,17 @@ GeomXribbon <- ggproto(
     # Check that aesthetics are constant
     aes <- unique(data[c("colour", "fill", "linewidth", "linetype", "alpha")])
     if (nrow(aes) > 1) {
-      err("Aesthetics can not vary with a ribbon.")
+      err("Aesthetics cannot vary with a ribbon.")
     }
     aes <- as.list(aes)
 
     missing_pos <- !complete.cases(data[c("y", "xmin", "xmax")])
     ids <- cumsum(missing_pos) + 1
     ids[missing_pos] <- NA
 
-    positions <- plyr::summarise(
-      data,
-      y = c(y, rev(y)),
-      x = c(xmax, rev(xmin)),
+    positions <- data.frame(
+      y = c(data$y, rev(data$y)),
+      x = c(data$xmax, rev(data$xmin)),
       id = c(ids, rev(ids))
     )
     munched <- coord_munch(coord, positions, panel_params)

R/gompertz.R

@@ -141,7 +141,6 @@ rgompertz <- function(n, llocation = 0, lshape = 0) {
 }
 
 sgompertz <- function(data, pars = NULL) {
-  rlang::check_installed("VGAM")
   x <- mean_weighted_values(data)
 
   if (!is.null(pars)) {

R/hc.R

@@ -65,6 +65,27 @@ ssd_hc <- function(x, ...) {
   )
 }
 
+# Resolve the deprecated `percent` argument into a `proportion` and
+# validate it. Shared by the ssd_hc() and predict() methods.
+.hc_proportion <- function(percent, proportion) {
+  if (lifecycle::is_present(percent)) {
+    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))
+    proportion <- percent / 100
+  }
+  chk_vector(proportion)
+  chk_numeric(proportion)
+  chk_range(proportion)
+  proportion
+}
+
 #' @describeIn ssd_hc Hazard Concentrations for Distributional Estimates
 #' @export
 #' @examples
@@ -81,22 +102,7 @@ ssd_hc.list <- function(
   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"
-    )
-    chk_vector(percent)
-    chk_numeric(percent)
-    chk_range(percent, c(0, 100))
-    proportion <- percent / 100
-  }
-
-  chk_vector(proportion)
-  chk_numeric(proportion)
-  chk_range(proportion)
+  proportion <- .hc_proportion(percent, proportion)
 
   if (!length(x)) {
     hc <- no_hcp()
@@ -140,22 +146,7 @@ ssd_hc.fitdists <- function(
 ) {
   chk_unused(...)
 
-  if (lifecycle::is_present(percent)) {
-    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))
-    proportion <- percent / 100
-  }
-
-  chk_vector(proportion)
-  chk_numeric(proportion)
-  chk_range(proportion)
+  proportion <- .hc_proportion(percent, proportion)
 
   if (lifecycle::is_present(multi_est)) {
     lifecycle::deprecate_soft(
@@ -229,22 +220,7 @@ ssd_hc.fitburrlioz <- function(
   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"
-    )
-    chk_vector(percent)
-    chk_numeric(percent)
-    chk_range(percent, c(0, 100))
-    proportion <- percent / 100
-  }
-
-  chk_vector(proportion)
-  chk_numeric(proportion)
-  chk_range(proportion)
+  proportion <- .hc_proportion(percent, proportion)
 
   fun <- if (names(x) == "burrIII3") fit_burrlioz else fit_tmb
 

R/hcp-average.R

@@ -25,7 +25,7 @@ hcp_noci <- function(value, est_method, ci_method, ...) {
   tibble(
     value = value,
     est_method = est_method,
-    ci_method = ci_method,
+    ci_method = ci_method
   )
 }
 

R/hcp-samples.R

@@ -55,15 +55,14 @@ combine_samples <- function(samples, weight, nboot, geometric) {
 hcp_combine_samples <- function(hcp, weight, ci_method, level, nboot) {
   geometric <- ci_method == "geometric_samples"
 
-  nboot1 <- nboot
   hcp <- hcp |>
     dplyr::bind_rows() |>
     dplyr::group_by(.data$value) |>
     dplyr::summarise(
       samples = list(combine_samples(
         .data$samples,
         weight,
-        nboot = nboot1,
+        nboot = .env$nboot,
         geometric = geometric
       ))
     ) |>

R/hcp.R

@@ -29,7 +29,7 @@ hcp_unscale <- function(hcp, rescale) {
 }
 
 ## no_hcp is returned without tidying so must be complete
-no_hcp <- function(hc) {
+no_hcp <- function() {
   tibble(
     dist = character(0),
     value = numeric(0),
@@ -74,8 +74,8 @@ clean_hcp <- function(
     hcp$pboot <- 1
   }
 
-  if (any(hcp$pboot < min_pboot)) {
-    fail <- hcp$pboot < min_pboot
+  fail <- !is.na(hcp$pboot) & hcp$pboot < min_pboot
+  if (any(fail)) {
     hcp$lcl[fail] <- NA_real_
     hcp$ucl[fail] <- NA_real_
     hcp$se[fail] <- NA_real_

R/helpers.R

@@ -186,14 +186,13 @@ adjust_data <- function(data, rescale, reweight, odds_max, silent) {
 }
 
 mean_weighted_values <- function(data, weight = TRUE) {
-  data <- as.matrix(data[c("left", "right")])
-  x <- rowMeans(data, na.rm = TRUE)
+  x <- rowMeans(as.matrix(data[c("left", "right")]), na.rm = TRUE)
   if (!weight) {
     return(x)
   }
-  x <- x[weight > 0]
-  weight <- weight[weight > 0]
-  weight <- weight / min(weight)
-  weight <- round(weight)
-  rep(x, weight)
+  w <- data$weight
+  x <- x[w > 0]
+  w <- w[w > 0]
+  w <- round(w / min(w))
+  rep(x, w)
 }

R/hp.R

@@ -68,8 +68,8 @@ ssd_hp.fitdists <- function(
   if (lifecycle::is_present(multi_est)) {
     lifecycle::deprecate_soft(
       "2.3.1",
-      "ssd_hc(multi_est)",
-      "ssd_hc(est_method)"
+      "ssd_hp(multi_est)",
+      "ssd_hp(est_method)"
     )
 
     chk_flag(multi_est)
@@ -156,7 +156,7 @@ ssd_hp.fitburrlioz <- function(
       "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.",
+      "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"
     )
   }

R/lgumbel.R

@@ -50,15 +50,6 @@ ssd_plgumbel <- function(
   )
 }
 
-#' @describeIn ssd_e Default Parameter Values for Log-Gumbel Distribution
-#' @export
-#' @examples
-#'
-#' ssd_einvpareto()
-ssd_elgumbel <- function() {
-  list(locationlog = 0, scalelog = 1)
-}
-
 #' Cumulative Distribution Function for Log-Gumbel Distribution
 #' `r lifecycle::badge("deprecated")`
 #'