Merge pull request #345 from poissonconsulting/main

Only weighting lnorm by default in multi

DESCRIPTION

@@ -100,4 +100,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(augment,fitdists)
 S3method(autoplot,fitdists)
 S3method(coef,fitdists)
+S3method(dist,tmbfit)
 S3method(estimates,fitdists)
 S3method(estimates,tmbfit)
 S3method(glance,fitdists)
@@ -155,6 +156,7 @@ importFrom(generics,glance)
 importFrom(generics,tidy)
 importFrom(ggplot2,autoplot)
 importFrom(ggplot2,sym)
+importFrom(ggplot2,waiver)
 importFrom(goftest,ad.test)
 importFrom(goftest,cvm.test)
 importFrom(graphics,par)

R/dist.R

@@ -1,5 +1,6 @@
 dist <- function(x, ...) UseMethod("dist")
 
+#' @export
 dist.tmbfit <- function(x, ...) {
   .dist_tmbfit(x)
 }

R/multi.R

@@ -25,7 +25,7 @@ ssd_pmulti <- function(
     burrIII3.shape1 = 1, 
     burrIII3.shape2 = 1, 
     burrIII3.scale = 1, 
-    gamma.weight = 1/6, 
+    gamma.weight = 0, 
     gamma.shape = 1, 
     gamma.scale = 1, 
     gompertz.weight = 0, 
@@ -34,10 +34,10 @@ ssd_pmulti <- function(
     invpareto.weight = 0, 
     invpareto.shape = 3, 
     invpareto.scale = 1, 
-    lgumbel.weight = 1/6, 
+    lgumbel.weight = 0, 
     lgumbel.locationlog = 0, 
     lgumbel.scalelog = 1, 
-    llogis.weight = 1/6, 
+    llogis.weight = 0, 
     llogis.locationlog = 0, 
     llogis.scalelog = 1, 
     llogis_llogis.weight = 0, 
@@ -46,16 +46,16 @@ ssd_pmulti <- function(
     llogis_llogis.locationlog2 = 1, 
     llogis_llogis.scalelog2 = 1, 
     llogis_llogis.pmix = 0.5, 
-    lnorm.weight = 1/6, 
+    lnorm.weight = 1, 
     lnorm.meanlog = 0, 
     lnorm.sdlog = 1, 
-    lnorm_lnorm.weight = 1/6, 
+    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 = 1/6, 
+    weibull.weight = 0, 
     weibull.shape = 1, 
     weibull.scale = 1,  
     lower.tail = TRUE, log.p = FALSE) {
@@ -114,7 +114,7 @@ ssd_qmulti <- function(
     burrIII3.shape1 = 1, 
     burrIII3.shape2 = 1, 
     burrIII3.scale = 1, 
-    gamma.weight = 1/6, 
+    gamma.weight = 0, 
     gamma.shape = 1, 
     gamma.scale = 1, 
     gompertz.weight = 0, 
@@ -123,10 +123,10 @@ ssd_qmulti <- function(
     invpareto.weight = 0, 
     invpareto.shape = 3, 
     invpareto.scale = 1, 
-    lgumbel.weight = 1/6, 
+    lgumbel.weight = 0, 
     lgumbel.locationlog = 0, 
     lgumbel.scalelog = 1, 
-    llogis.weight = 1/6, 
+    llogis.weight = 0, 
     llogis.locationlog = 0, 
     llogis.scalelog = 1, 
     llogis_llogis.weight = 0, 
@@ -135,16 +135,16 @@ ssd_qmulti <- function(
     llogis_llogis.locationlog2 = 1, 
     llogis_llogis.scalelog2 = 1, 
     llogis_llogis.pmix = 0.5, 
-    lnorm.weight = 1/6, 
+    lnorm.weight = 1, 
     lnorm.meanlog = 0, 
     lnorm.sdlog = 1, 
-    lnorm_lnorm.weight = 1/6, 
+    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 = 1/6, 
+    weibull.weight = 0, 
     weibull.shape = 1, 
     weibull.scale = 1, 
     lower.tail = TRUE, log.p = FALSE) {
@@ -204,7 +204,7 @@ ssd_rmulti <- function(
     burrIII3.shape1 = 1, 
     burrIII3.shape2 = 1, 
     burrIII3.scale = 1, 
-    gamma.weight = 1/6, 
+    gamma.weight = 0, 
     gamma.shape = 1, 
     gamma.scale = 1, 
     gompertz.weight = 0, 
@@ -213,10 +213,10 @@ ssd_rmulti <- function(
     invpareto.weight = 0, 
     invpareto.shape = 3, 
     invpareto.scale = 1, 
-    lgumbel.weight = 1/6, 
+    lgumbel.weight = 0, 
     lgumbel.locationlog = 0, 
     lgumbel.scalelog = 1, 
-    llogis.weight = 1/6, 
+    llogis.weight = 0, 
     llogis.locationlog = 0, 
     llogis.scalelog = 1, 
     llogis_llogis.weight = 0, 
@@ -225,16 +225,16 @@ ssd_rmulti <- function(
     llogis_llogis.locationlog2 = 1, 
     llogis_llogis.scalelog2 = 1, 
     llogis_llogis.pmix = 0.5, 
-    lnorm.weight = 1/6, 
+    lnorm.weight = 1, 
     lnorm.meanlog = 0, 
     lnorm.sdlog = 1, 
-    lnorm_lnorm.weight = 1/6, 
+    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 = 1/6, 
+    weibull.weight = 0, 
     weibull.shape = 1, 
     weibull.scale = 1, 
     chk = TRUE) {
@@ -292,23 +292,23 @@ ssd_emulti <- function() {
 }
 
 .ssd_pmulti_fitdists <- function(q, fitdists, lower.tail = TRUE, log.p = FALSE) {
-  args <- estimates(fitdists)
+  args <- estimates(fitdists, all_estimates = TRUE)
   args$q <- q
   args$lower.tail <- lower.tail
   args$log.p <- log.p
   do.call("ssd_pmulti", args)
 }
 
 .ssd_qmulti_fitdists <- function(p, fitdists, lower.tail = TRUE, log.p = FALSE) {
-  args <- estimates(fitdists)
+  args <- estimates(fitdists, all_estimates = TRUE)
   args$p <- p
   args$lower.tail <- lower.tail
   args$log.p <- log.p  
   do.call("ssd_qmulti", args)
 }
 
 .ssd_rmulti_fitdists <- function(n, fitdists, chk = TRUE) {
-  args <- estimates(fitdists)
+  args <- estimates(fitdists, all_estimates = TRUE)
   args$n <- n
   args$chk <- chk
   do.call("ssd_rmulti", args)

tests/testthat/_snaps/weighted/hc1.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,1.04177,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/_snaps/weighted/hc1w.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,1.04177,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/_snaps/weighted/hcall.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,1.68117,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/_snaps/weighted/hcallw10.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,0.546531,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/_snaps/weighted/hcallw100.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,0.809411,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/_snaps/weighted/hcallw1000.csv

@@ -0,0 +1,2 @@
+dist,proportion,est,se,lcl,ucl,wt,method,nboot,pboot,samples
+average,0.05,1.00633,NA,NA,NA,1,parametric,0,NA,numeric(0)

tests/testthat/test-multi.R

@@ -15,10 +15,10 @@
 
 test_that("multi", {
   test_dist("multi", multi = TRUE)
-  expect_equal(ssd_pmulti(1), 0.493574697632382)
-  expect_equal(ssd_qmulti(0.75), 2.21920363150895)
+  expect_equal(ssd_pmulti(1), 0.5)
+  expect_equal(ssd_qmulti(0.75), 1.96303108415826)
   set.seed(42)
-  expect_equal(ssd_rmulti(2), c(5.53136180221693, 7.1105492251209))
+  expect_equal(ssd_rmulti(2), c(3.93912428813385, 4.62130564767823))
 
   expect_equal(ssd_qmulti(ssd_pmulti(c(0, 0.1, 0.5, 0.9, 0.99))), 
                c(0, 0.1, 0.5, 0.9, 0.99), tolerance = 1e-5)

tests/testthat/test-weighted.R

@@ -0,0 +1,34 @@
+test_that("weighted works", {
+  data <- ssddata::ccme_boron
+
+  data$Weight <- 1
+  data$Weight[rank(data$Conc) > 6] <- 1/10
+
+  fitall <- ssd_fit_dists(data, dists="lnorm")
+  hcall <- ssd_hc(fitall)
+  expect_snapshot_data(hcall, "hcall")
+
+  fit1 <- ssd_fit_dists(subset(data, Weight == 1), dists="lnorm")
+  hc1 <- ssd_hc(fit1)
+  expect_snapshot_data(hc1, "hc1")
+
+  fit1w <- ssd_fit_dists(subset(data, Weight == 1), dists="lnorm", weight = "Weight")
+  hc1w <- ssd_hc(fit1w)
+  expect_snapshot_data(hc1w, "hc1w")
+
+  fitallw10 <- ssd_fit_dists(data, dists="lnorm", weight = "Weight")
+  hcallw10 <- ssd_hc(fitallw10)
+  expect_snapshot_data(hcallw10, "hcallw10")
+
+  data$Weight[rank(data$Conc) > 6] <- 1/100
+
+  fitallw100 <- ssd_fit_dists(data, dists="lnorm", weight = "Weight")
+  hcallw100 <- ssd_hc(fitallw100)
+  expect_snapshot_data(hcallw100, "hcallw100")
+
+  data$Weight[rank(data$Conc) > 6] <- 1/1000
+
+  fitallw1000 <- ssd_fit_dists(data, dists="lnorm", weight = "Weight")
+  hcallw1000 <- ssd_hc(fitallw1000)
+  expect_snapshot_data(hcallw1000, "hcallw1000")
+})