From 870948eeee6e5469ba03a08f28ca36e03268a96e Mon Sep 17 00:00:00 2001 From: Joe Thorley Date: Tue, 9 Jan 2024 00:22:25 -0600 Subject: [PATCH] implement unweighted --- R/hcp.R | 47 ++++++++++--------- tests/testthat/_snaps/hc/hc_unweighted2.csv | 5 ++ tests/testthat/_snaps/hc/hc_weighted2.csv | 2 + .../_snaps/hc/hc_weighted_bootstrap.csv | 2 +- tests/testthat/_snaps/hp/hp_unweighted2.csv | 5 ++ tests/testthat/_snaps/hp/hp_weighted2.csv | 2 + tests/testthat/test-hc.R | 16 +++++++ tests/testthat/test-hp.R | 16 +++++++ 8 files changed, 72 insertions(+), 23 deletions(-) create mode 100644 tests/testthat/_snaps/hc/hc_unweighted2.csv create mode 100644 tests/testthat/_snaps/hc/hc_weighted2.csv create mode 100644 tests/testthat/_snaps/hp/hp_unweighted2.csv create mode 100644 tests/testthat/_snaps/hp/hp_weighted2.csv diff --git a/R/hcp.R b/R/hcp.R index 47dbb687d..4f4c56751 100644 --- a/R/hcp.R +++ b/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( diff --git a/tests/testthat/_snaps/hc/hc_unweighted2.csv b/tests/testthat/_snaps/hc/hc_unweighted2.csv new file mode 100644 index 000000000..52156d530 --- /dev/null +++ b/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)" diff --git a/tests/testthat/_snaps/hc/hc_weighted2.csv b/tests/testthat/_snaps/hc/hc_weighted2.csv new file mode 100644 index 000000000..42debb4ff --- /dev/null +++ b/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)" diff --git a/tests/testthat/_snaps/hc/hc_weighted_bootstrap.csv b/tests/testthat/_snaps/hc/hc_weighted_bootstrap.csv index 24c8c6583..64c9f0dc0 100644 --- a/tests/testthat/_snaps/hc/hc_weighted_bootstrap.csv +++ b/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)" diff --git a/tests/testthat/_snaps/hp/hp_unweighted2.csv b/tests/testthat/_snaps/hp/hp_unweighted2.csv new file mode 100644 index 000000000..bc0bfd117 --- /dev/null +++ b/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)" diff --git a/tests/testthat/_snaps/hp/hp_weighted2.csv b/tests/testthat/_snaps/hp/hp_weighted2.csv new file mode 100644 index 000000000..83a737467 --- /dev/null +++ b/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)" diff --git a/tests/testthat/test-hc.R b/tests/testthat/test-hc.R index f58db02ba..e69d22a36 100644 --- a/tests/testthat/test-hc.R +++ b/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") +}) diff --git a/tests/testthat/test-hp.R b/tests/testthat/test-hp.R index 9c8dc905f..b9f002720 100644 --- a/tests/testthat/test-hp.R +++ b/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") +})