implement unweighted

R/hcp.R

@@ -173,25 +173,22 @@ hcp_average <- function(hcp, weight, value, method, nboot) {
   dplyr::arrange(tib, .data$value)
 }
 
-hcp_weighted <- function(hcp, weight, value, method, nboot) {
-  samples <- group_samples(hcp)
-
+hcp_weighted <- function(hcp, level, samples, min_pboot) {
 
-  # TODO: implement so that gets estimate from multi and then
-  # se, lcl, ucl etc from 
-
-  tibble(
-    dist = "weighted", 
-    value = value, 
-    # est = hcp$est, 
-    # se = hcp$se,
-    # lcl = hcp$lcl, 
-    # ucl = hcp$ucl, 
-    # wt = rep(1, length(value)),
-    method = method, 
-    nboot = nboot, 
-    #  pboot = min$pboot
-  )
+  quantiles <- purrr::map(hcp$samples, stats::quantile, probs = probs(level))
+  quantiles <- purrr::transpose(quantiles)
+  hcp$lcl <- unlist(quantiles[[1]])
+  hcp$ucl <- unlist(quantiles[[2]])
+  hcp$se <- purrr::map_dbl(hcp$samples, sd)
+  hcp$pboot <- pmin(purrr::map_dbl(hcp$samples, length) / hcp$nboot, 1)
+  fail <- hcp$pboot < min_pboot
+  hcp$lcl[fail] <- NA_real_
+  hcp$ucl[fail] <- NA_real_
+  hcp$se[fail] <- NA_real_
+  if(!samples) {
+    hcp$samples <- I(list(numeric(0)))
+  }
+  hcp
 }
 
 .ssd_hcp_ind <- function(x, value, ci, level, nboot, min_pboot, estimates, 
@@ -250,12 +247,18 @@ hcp_weighted <- function(hcp, weight, value, method, nboot) {
                      data = data, rescale = rescale, weighted = weighted, censoring = censoring,
                      min_pmix = min_pmix, range_shape1 = range_shape1, range_shape2 = range_shape2,
                      parametric = parametric, fix_weights = fix_weights, average = TRUE, control = control,
-                     hc = hc, save_to = save_to, samples = samples, fun = fun)
+                     hc = hc, save_to = save_to, samples = samples || fix_weights, fun = fun)
 
   method <- if (parametric) "parametric" else "non-parametric"
-
-  # TODO: implement hcp_weighted
-  hcp_average(hcp, weight, value, method, nboot)
+
+  hcp <- hcp_average(hcp, weight, value, method, nboot)  
+  if(!fix_weights) {
+    if(!samples) {
+      hcp$samples <- I(list(numeric(0)))
+    }
+    return(hcp)
+  }
+  hcp_weighted(hcp, level = level, samples = samples, min_pboot = min_pboot)
 }
 
 .ssd_hcp_fitdists <- function(

tests/testthat/_snaps/hc/hc_unweighted2.csv

@@ -0,0 +1,5 @@
+dist,percent,est,se,lcl,ucl,wt,method,nboot,samples
+average,5,1.24152,0.886733,0.806142,3.20382,1,parametric,10,"c(`000000001_gamma` = 0.987785, `000000002_gamma` = 3.15112, `000000003_gamma` = 0.84656, `000000004_gamma` = 0.70604, `000000005_gamma` = 1.98672, `000000006_gamma` = 0.873452, `000000007_gamma` = 1.18798, `000000008_gamma` = 0.836688, `000000009_gamma` = 0.719689, `000000010_gamma` = 3.20738, `000000001_lgumbel` = 2.2833, `000000002_lgumbel` = 1.48094, `000000003_lgumbel` = 2.12922, `000000004_lgumbel` = 2.36856, `000000005_lgumbel` = 1.81154, `000000006_lgumbel` = 1.96535, `000000007_lgumbel` = 1.36401, 
+`000000008_lgumbel` = 1.93797, `000000009_lgumbel` = 2.70632, `000000010_lgumbel` = 2.09232, `000000001_llogis` = 0.751505, `000000002_llogis` = 3.04268, `000000003_llogis` = 2.10953, `000000004_llogis` = 2.22634, `000000005_llogis` = 1.30249, `000000006_llogis` = 2.52802, `000000007_llogis` = 3.46857, `000000008_llogis` = 2.04533, `000000009_llogis` = 1.85618, `000000010_llogis` = 1.19654, `000000001_lnorm` = 3.09183, `000000002_lnorm` = 2.42899, `000000003_lnorm` = 1.325, `000000004_lnorm` = 1.61081, 
+`000000005_lnorm` = 2.60329, `000000006_lnorm` = 0.865973, `000000007_lnorm` = 2.77742, `000000008_lnorm` = 1.19715, `000000009_lnorm` = 2.45546, `000000010_lnorm` = 0.970094, `000000001_lnorm_lnorm` = 1.64166, `000000002_lnorm_lnorm` = 1.67909, `000000003_lnorm_lnorm` = 1.80876, `000000004_lnorm_lnorm` = 0.921821, `000000005_lnorm_lnorm` = 1.68365, `000000006_lnorm_lnorm` = 1.28523, `000000007_lnorm_lnorm` = 1.82578, `000000008_lnorm_lnorm` = 1.05663, `000000009_lnorm_lnorm` = 1.20995, `000000010_lnorm_lnorm` = 1.67578, 
+`000000001_weibull` = 1.67077, `000000002_weibull` = 0.93999, `000000003_weibull` = 1.45323, `000000004_weibull` = 3.60435, `000000005_weibull` = 1.0464, `000000006_weibull` = 1.48364, `000000007_weibull` = 2.08463, `000000008_weibull` = 1.05416, `000000009_weibull` = 2.73428, `000000010_weibull` = 0.784157)"

tests/testthat/_snaps/hc/hc_weighted2.csv

@@ -0,0 +1,2 @@
+dist,percent,est,se,lcl,ucl,wt,method,nboot,samples
+average,5,1.24152,1.00597,0.71968,3.46838,1,parametric,10,"c(`000000001_gamma` = 0.987785, `000000002_gamma` = 3.15112, `000000003_gamma` = 0.84656, `000000004_gamma` = 0.70604, `000000001_lgumbel` = 2.2833, `000000001_llogis` = 0.751505, `000000001_lnorm` = 3.09183, `000000002_lnorm` = 2.42899, `000000001_lnorm_lnorm` = 1.64166, `000000001_weibull` = 1.67077, `000000002_weibull` = 0.93999, `000000003_weibull` = 1.45323, `000000004_weibull` = 3.60435)"

tests/testthat/_snaps/hc/hc_weighted_bootstrap.csv

@@ -1,2 +1,2 @@
 dist,percent,est,se,lcl,ucl,wt,method,nboot,pboot,samples
-average,5,1.27578,0.335857,0.760257,1.5259,1,parametric,10,1,"c(`000000001_lnorm` = 1.29091, `000000002_lnorm` = 2.32183, `000000003_lnorm` = 1.62344, `000000004_lnorm` = 1.434, `000000001_gamma` = 0.508842, `000000002_gamma` = 1.14031, `000000003_gamma` = 0.859883, `000000004_gamma` = 0.65392, `000000005_gamma` = 0.488042, `000000006_gamma` = 1.15914, `000000007_gamma` = 0.732169)"
+average,5,1.27578,0.550884,0.493242,2.14723,1,parametric,10,1,"c(`000000001_lnorm` = 1.29091, `000000002_lnorm` = 2.32183, `000000003_lnorm` = 1.62344, `000000004_lnorm` = 1.434, `000000001_gamma` = 0.508842, `000000002_gamma` = 1.14031, `000000003_gamma` = 0.859883, `000000004_gamma` = 0.65392, `000000005_gamma` = 0.488042, `000000006_gamma` = 1.15914, `000000007_gamma` = 0.732169)"

tests/testthat/_snaps/hp/hp_unweighted2.csv

@@ -0,0 +1,5 @@
+dist,conc,est,se,lcl,ucl,wt,method,nboot,samples
+average,1,3.89879,1.97678,0.750221,6.12673,1,parametric,10,"c(`000000001_gamma` = 5.0567, `000000002_gamma` = 0.957638, `000000003_gamma` = 5.80091, `000000004_gamma` = 6.58178, `000000005_gamma` = 2.53177, `000000006_gamma` = 5.72599, `000000007_gamma` = 4.16365, `000000008_gamma` = 5.81366, `000000009_gamma` = 6.46855, `000000010_gamma` = 1.1192, `000000001_lgumbel` = 0.50565, `000000002_lgumbel` = 1.51489, `000000003_lgumbel` = 0.169421, `000000004_lgumbel` = 0.110891, `000000005_lgumbel` = 0.432524, `000000006_lgumbel` = 0.711895, `000000007_lgumbel` = 2.41432, 
+`000000008_lgumbel` = 0.475696, `000000009_lgumbel` = 0.0499396, `000000010_lgumbel` = 0.565725, `000000001_llogis` = 6.68504, `000000002_llogis` = 0.735387, `000000003_llogis` = 1.95738, `000000004_llogis` = 1.47453, `000000005_llogis` = 3.6057, `000000006_llogis` = 1.42314, `000000007_llogis` = 0.380529, `000000008_llogis` = 1.73678, `000000009_llogis` = 1.66622, `000000010_llogis` = 4.06367, `000000001_lnorm` = 0.370445, `000000002_lnorm` = 0.794097, `000000003_lnorm` = 3.24612, `000000004_lnorm` = 2.22354, 
+`000000005_lnorm` = 0.690973, `000000006_lnorm` = 6.0503, `000000007_lnorm` = 0.545626, `000000008_lnorm` = 3.83028, `000000009_lnorm` = 0.850279, `000000010_lnorm` = 5.22532, `000000001_lnorm_lnorm` = 0.507611, `000000002_lnorm_lnorm` = 0.317895, `000000003_lnorm_lnorm` = 1.60692, `000000004_lnorm_lnorm` = 6.18731, `000000005_lnorm_lnorm` = 1.4108, `000000006_lnorm_lnorm` = 1.36404, `000000007_lnorm_lnorm` = 0.232118, `000000008_lnorm_lnorm` = 4.11746, `000000009_lnorm_lnorm` = 1.46202, `000000010_lnorm_lnorm` = 0.413229, 
+`000000001_weibull` = 2.94983, `000000002_weibull` = 5.27778, `000000003_weibull` = 3.42488, `000000004_weibull` = 0.677379, `000000005_weibull` = 4.77613, `000000006_weibull` = 3.38944, `000000007_weibull` = 1.97221, `000000008_weibull` = 4.7655, `000000009_weibull` = 1.20551, `000000010_weibull` = 6.22875)"

tests/testthat/_snaps/hp/hp_weighted2.csv

@@ -0,0 +1,2 @@
+dist,conc,est,se,lcl,ucl,wt,method,nboot,samples
+average,1,3.89879,2.5431,0.411007,6.65406,1,parametric,10,"c(`000000001_gamma` = 5.0567, `000000002_gamma` = 0.957638, `000000003_gamma` = 5.80091, `000000004_gamma` = 6.58178, `000000001_lgumbel` = 0.50565, `000000001_llogis` = 6.68504, `000000001_lnorm` = 0.370445, `000000002_lnorm` = 0.794097, `000000001_lnorm_lnorm` = 0.507611, `000000001_weibull` = 2.94983, `000000002_weibull` = 5.27778, `000000003_weibull` = 3.42488, `000000004_weibull` = 0.677379)"

tests/testthat/test-hc.R

@@ -711,3 +711,19 @@ test_that("hc multis match", {
   expect_identical(hc_ft$se, hc_tt$se)
   expect_identical(hc_ff$se, hc_tf$se)
 })
+
+test_that("hc weighted bootie", {
+  fits <- ssd_fit_dists(ssddata::ccme_boron)
+  set.seed(102)
+  hc_weighted2 <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, multi_est = FALSE, multi_ci = FALSE,
+                        samples = TRUE)
+  set.seed(102)
+  hc_unweighted2 <- ssd_hc(fits, ci = TRUE, nboot = 10, average = TRUE, multi_est = FALSE, multi_ci = FALSE, weighted = FALSE, samples = TRUE)
+
+  expect_identical(hc_weighted2$est, hc_unweighted2$est)
+  expect_identical(length(hc_weighted2$samples[[1]]), 13L)
+  expect_identical(length(hc_unweighted2$samples[[1]]), 60L)
+
+  expect_snapshot_boot_data(hc_weighted2, "hc_weighted2")
+  expect_snapshot_boot_data(hc_unweighted2, "hc_unweighted2")
+})

tests/testthat/test-hp.R

@@ -346,3 +346,19 @@ test_that("hp multis match", {
   expect_identical(hp_ft$se, hp_tt$se)
   expect_identical(hp_ff$se, hp_tf$se)
 })
+
+test_that("hp weighted bootie", {
+  fits <- ssd_fit_dists(ssddata::ccme_boron)
+  set.seed(102)
+  hp_weighted2 <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, multi_est = FALSE, multi_ci = FALSE,
+                         samples = TRUE)
+  set.seed(102)
+  hp_unweighted2 <- ssd_hp(fits, ci = TRUE, nboot = 10, average = TRUE, multi_est = FALSE, multi_ci = FALSE, weighted = FALSE, samples = TRUE)
+
+  expect_identical(hp_weighted2$est, hp_unweighted2$est)
+  expect_identical(length(hp_weighted2$samples[[1]]), 13L)
+  expect_identical(length(hp_unweighted2$samples[[1]]), 60L)
+
+  expect_snapshot_boot_data(hp_weighted2, "hp_weighted2")
+  expect_snapshot_boot_data(hp_unweighted2, "hp_unweighted2")
+})