From 57380239223cf54dabee004721d2e0163ab6def9 Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Mon, 13 Jan 2025 13:14:12 +0100 Subject: [PATCH 1/6] Added trendtTest and monotonicityTest --- .DS_Store | Bin 6148 -> 6148 bytes .Rbuildignore | 1 + .gitignore | 1 + DESCRIPTION | 4 +- NAMESPACE | 2 +- R/bartholomewTest.R | 57 +++++++++++++++++++ R/jonckheereTest.R | 104 ++++++++++++++++++++++++++++++++++ R/monotonicityTest.R | 41 ++++++++++++++ R/pava.R | 34 ++++++++++++ R/shirleyTest.R | 120 ++++++++++++++++++++++++++++++++++++++++ R/trendTest.R | 37 +++++++++++++ R/tukeytrendfit.R | 60 ++++++++++++++++++++ R/tukeytrendtest.R | 7 +++ R/williamsTest.R | 118 +++++++++++++++++++++++++++++++++++++++ bmd.Rproj | 1 + data/.DS_Store | Bin 0 -> 6148 bytes data/TabCrit.RData | Bin 0 -> 1104 bytes man/monotonicityTest.Rd | 56 +++++++++++++++++++ man/trendTest.Rd | 56 +++++++++++++++++++ 19 files changed, 696 insertions(+), 3 deletions(-) create mode 100644 R/bartholomewTest.R create mode 100644 R/jonckheereTest.R create mode 100644 R/monotonicityTest.R create mode 100644 R/pava.R create mode 100644 R/shirleyTest.R create mode 100644 R/trendTest.R create mode 100644 R/tukeytrendfit.R create mode 100644 R/tukeytrendtest.R create mode 100644 R/williamsTest.R create mode 100644 data/.DS_Store create mode 100644 data/TabCrit.RData create mode 100644 man/monotonicityTest.Rd create mode 100644 man/trendTest.Rd diff --git a/.DS_Store b/.DS_Store index 19582aa423afc60ecf4884f412f52689a4e5081f..941bfc8e46184250f42c0b16b53c4979e5049e64 100644 GIT binary patch delta 220 zcmZoMXfc=|#>B`mF;R?_gMono$Pkfa0y02=6^I!b7z7w{(hY-?^K%O(Ca$gr39>Mx zFeEaRFeJhxK&qhtE|;6{;*yk;p9B==u>SIRNyn^XjzBh&duIiU@D^5ZS{F0M;TfNB{r; delta 104 zcmZoMXfc=|#>AjHF;Q5Tk%57Mks+uoxF|0tKQA530}^1s1f?Nr7z7wLPhc!(+q{9% mf^joD2R{eUh|LQbzcWwf7g6K{DM|oom~6tMyg5c>1v3DYs}bA) diff --git a/.Rbuildignore b/.Rbuildignore index 91114bf..1fb6b40 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,2 +1,3 @@ ^.*\.Rproj$ ^\.Rproj\.user$ +cache/ \ No newline at end of file diff --git a/.gitignore b/.gitignore index 5b6a065..61fb704 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ .Rhistory .RData .Ruserdata +cache/ \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 644782d..9ddec51 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: bmd Type: Package Title: Benchmark dose estimation for dose-response data -Version: 2.6.5 +Version: 2.6.6 Date: 2024-12-11 Author: Signe M.Jensen, Christian Ritz and Jens Riis Baalkilde Maintainer: Signe M. Jensen @@ -10,4 +10,4 @@ Imports: drc, ggplot2, dplyr Suggests: CVXR, multcomp License: GPL Encoding: UTF-8 -LazyData: true \ No newline at end of file +LazyData: true diff --git a/NAMESPACE b/NAMESPACE index d20517b..48dbaed 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,7 @@ import(drc, ggplot2, dplyr) export(bmd, bmdBoot, bmdIso, bmdIsoBoot, PAV, bmdMA, bootDataGen, bmdMACurve, BCa, invBmd, expandBinomial, getStackingWeights, drmOrdinal, bmdOrdinal, bmdOrdinalMA, expandOrdinal, bootDataGenOrdinal, - qplotDrc, qplotBmd, MACurve) + qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest) ## S3 methods S3method(logLik, drcOrdinal) diff --git a/R/bartholomewTest.R b/R/bartholomewTest.R new file mode 100644 index 0000000..6bd5aca --- /dev/null +++ b/R/bartholomewTest.R @@ -0,0 +1,57 @@ +.bartholomewTest <- function (y, x, alternative = c("auto", "greater", "less"), number.of.bootstrap.samples = 1000, + plot = NULL, seed = NULL) +{ + alternative <- match.arg(alternative) + if(alternative == "auto"){ + lm_slope <- lm(y ~ x)$coef[["x"]] + slope <- ifelse(lm_slope > 0, "greater", "less") + } + + # Summarised vector + xFac <- factor(x) + lm0 <- lm(y ~ xFac - 1) + x <- y_mean <- summary(lm0)$coef[,"Estimate"] + sigma <- summary(lm0)$coef[,"Std. Error"] + + # Start of LRT.trend function + a <- 1/sigma^2 + xbar <- sum(a * x)/sum(a) + k <- length(x) + if(!is.null(seed)){ + set.seed(seed) + } + r <- matrix(stats::rnorm(k * number.of.bootstrap.samples), + ncol = k) + r <- sweep(r, 2, sigma, "*") + r <- sweep(r, 2, xbar, "+") + + if(alternative == "greater") { + LRT.value.trend <- function (x, sigma) { + a <- 1/sigma^2 + xbar <- sum(a * x)/sum(a) + s <- seq_along(x) + Atot <- cbind(s[-length(s)], s[-1]) + fit.ls1 <- isotone::activeSet(Atot, "LS", y = x, weights = a) + LRT.increasing <- sum(a * (x - xbar)^2) - fit.ls1$fval + return(LRT.increasing) + } + } else { + LRT.value.trend <- function (x, sigma) { + a <- 1/sigma^2 + xbar <- sum(a * x)/sum(a) + s <- seq_along(x) + Atot <- cbind(s[-1], s[-length(s)]) + fit.ls2 <- isotone::activeSet(Atot, "LS", y = x, weights = a) + LRT.decreasing <- sum(a * (x - xbar)^2) - fit.ls2$fval + return(LRT.decreasing) + } + } + + L <- t(apply(r, 1, LRT.value.trend, sigma = sigma)) + obsL <- LRT.value.trend(x, sigma) + + STATISTIC = obsL + PVAL <- mean(obsL <= L) + + RET <- list(statistic = STATISTIC, p.value = PVAL, alternative = alternative) +} diff --git a/R/jonckheereTest.R b/R/jonckheereTest.R new file mode 100644 index 0000000..2b91519 --- /dev/null +++ b/R/jonckheereTest.R @@ -0,0 +1,104 @@ +.jonckheereTest <- function (x, g, alternative = c("auto", "two.sided", "greater", "less"), + continuity = FALSE, ...) +{ + # Prepare observations + if (length(x) != length(g)) + stop("'x' and 'g' must have the same length") + DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(g))) + OK <- complete.cases(x, g) + x <- x[OK] + g <- g[OK] + if (!all(is.finite(g))) + stop("all group levels must be finite") + + # Find trend direction + alternative <- match.arg(alternative) + if(alternative == "auto"){ + lm0 <- lm(x ~ g)$coef[["g"]] + alternative <- ifelse(lm0 > 0, "greater", "less") + } + + g <- factor(g) + k <- nlevels(g) + if (k < 2) + stop("all observations are in the same group") + if (!is.logical(continuity)) + stop("'continuity' must be 'FALSE' or 'TRUE'") + # alternative <- match.arg(alternative) + n <- length(x) + if (n < 2) + stop("needs at least 3 observations") + o <- order(g) + g <- g[o] + x <- x[o] + nij <- tapply(x, g, length) + X <- matrix(NA, ncol = k, nrow = max(nij)) + j <- 0 + for (i in 1:k) { + for (l in 1:nij[i]) { + j = j + 1 + X[l, i] <- x[j] + } + } + psi.f <- function(u) { + psi <- (sign(u) + 1)/2 + psi + } + Uij <- function(i, j, X) { + ni <- nij[i] + nj <- nij[j] + sumUij <- 0 + for (s in (1:ni)) { + for (t in (1:nj)) { + sumUij <- sumUij + psi.f(X[t, j] - X[s, i]) + } + } + sumUij + } + J <- 0 + for (i in (1:(k - 1))) { + for (j in ((i + 1):k)) { + J = J + Uij(i, j, X) + } + } + mu <- (n^2 - sum(nij^2))/4 + st <- 0 + for (i in (1:k)) { + st <- st + nij[i]^2 * (2 * nij[i] + 3) + st + } + TIES <- FALSE + TIES <- (sum(table(rank(x)) - 1) > 0) + if (!TIES) { + s <- sqrt((n^2 * (2 * n + 3) - st)/72) + S <- J - mu + } else { + # warning("Ties are present. Jonckheere z was corrected for ties.") + S <- J - mu + nt <- as.vector(table(x)) + s <- sqrt((n * (n - 1) * (2 * n + 5) - sum(nij * (nij - + 1) * (2 * nij + 5)) - sum(nt * (nt - 1) * (2 * nt + + 5)))/72 + (sum(nij * (nij - 1) * (nij - 2)) * sum(nt * + (nt - 1) * (nt - 2)))/(36 * n * (n - 1) * (n - 2)) + + (sum(nij * (nij - 1)) * sum(nt * (nt - 1)))/(8 * + n * (n - 1))) + } + if (continuity) { + S <- sign(S) * (abs(S) - 0.5) + } + STATISTIC <- S/s + if (alternative == "two.sided") { + PVAL <- 2 * min(pnorm(abs(STATISTIC), lower.tail = FALSE), + 0.5) + } else if (alternative == "greater") { + PVAL <- pnorm(STATISTIC, lower.tail = FALSE) + } else { + PVAL <- pnorm(STATISTIC) + } + ESTIMATES <- J + names(ESTIMATES) <- "JT" + names(STATISTIC) <- "z" + RVAL <- list(statistic = STATISTIC, p.value = PVAL, method = "Jonckheere-Terpstra test", + data.name = DNAME, alternative = alternative, estimates = ESTIMATES) + return(RVAL) +} diff --git a/R/monotonicityTest.R b/R/monotonicityTest.R new file mode 100644 index 0000000..4fccaae --- /dev/null +++ b/R/monotonicityTest.R @@ -0,0 +1,41 @@ +monotonicityTest <- function(x, y, data, test = c("jonckheere", "bartholomew"), level = 0.05, ...){ # , "drc", "quad" + if(!missing(data)){ + x <- data[[x]] + y <- data[[y]] + } + + + xFac <- factor(x) + + lm_alternative <- lm(y ~ x)$coef[["x"]] + alternative <- ifelse(lm_alternative > 0, "greater", "less") + + test <- match.arg(test) + if(test == "jonckheere"){ + p.value <- .jonckheereTest(x = y, g = x, alternative = alternative)$p.value + names(p.value) <- NULL + acceptMonotonicity = p.value < level + } + + if(test == "bartholomew"){ + p.value <- .bartholomewTest(y = y, x = x, alternative = alternative, ...)$p.value + names(p.value) <- NULL + acceptMonotonicity = p.value < level + } + + # if(test == "drc"){ + # capture.output({ + # p.value <- .drcMonotonicityTest(y = y, x = x, alternative = alternative, ...)$p.value + # }) + # names(p.value) <- NULL + # acceptMonotonicity = p.value > level + # } + # + # if(test == "quad"){ + # p.value <- .quadMonotonicityTest(y = y, x = x, ...)$p.value + # names(p.value) <- NULL + # acceptMonotonicity = p.value > level + # } + + list(p.value = p.value, acceptMonotonicity = acceptMonotonicity) +} diff --git a/R/pava.R b/R/pava.R new file mode 100644 index 0000000..eb6e289 --- /dev/null +++ b/R/pava.R @@ -0,0 +1,34 @@ +.pava <- function(y, w, kt) { + n <- length(y) + + # Initialize kt + kt <- 1:n + + if (n > 1) { + for (i in 2:n) { + if (y[i - 1] > y[i]) { + k1 <- kt[i] + k2 <- kt[i - 1] + + # Update kt + for (j in 1:n) { + if (kt[j] == k1) { + kt[j] <- k2 + } + } + + # Update y and w + wnew <- w[i - 1] + w[i] + ynew <- (w[i - 1] * y[i - 1] + w[i] * y[i]) / wnew + for (j in 1:n) { + if (kt[j] == k2) { + y[j] <- ynew + w[j] <- wnew + } + } + } + } + } + + return(list(y = y, w = w, kt = kt)) +} diff --git a/R/shirleyTest.R b/R/shirleyTest.R new file mode 100644 index 0000000..c6fb520 --- /dev/null +++ b/R/shirleyTest.R @@ -0,0 +1,120 @@ +.shirleyTest <- function (x, g, alternative = c("auto", "greater", "less"), nperm = 10000, ...) +{ + # if (is.list(x)) { + # if (length(x) < 2L) + # stop("'x' must be a list with at least 2 elements") + # DNAME <- deparse(substitute(x)) + # x <- lapply(x, function(u) u <- u[complete.cases(u)]) + # k <- length(x) + # l <- sapply(x, "length") + # if (any(l == 0)) + # stop("all groups must contain data") + # g <- factor(rep(1:k, l)) + # alternative <- x$alternative + # nperm <- x$nperm + # method <- x$method + # x <- unlist(x) + # } + # else { + if (length(x) != length(g)) { + stop("'x' and 'g' must have the same length") + } + DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(g))) + OK <- complete.cases(x, g) + x <- x[OK] + g <- g[OK] + if (!all(is.finite(g))) { + stop("all group levels must be finite") + } + g.old <- g + g <- factor(g) + k <- nlevels(g) + if (k < 2) { + stop("all observations are in the same group") + } + # } + alternative <- match.arg(alternative) + if(alternative == "auto"){ + lm0 <- lm(x ~ g.old)$coef[["g.old"]] + alternative <- ifelse(lm0 > 0, "greater", "less") + } + + xold <- x + if (alternative == "less") { + x <- -x + } + nj <- tapply(x, g, length) + k <- nlevels(g) + kk <- k - 1 + if (kk > 10) + stop("Critical t-values are only available for up to 10 dose levels.") + N <- sum(nj) + compfn <- function(x, ix, g, nj) { + k <- length(nj) + ti <- rep(NA, k) + x <- x[ix] + for (i in 2:k) { + N <- sum(nj[1:i]) + r <- rank(x[1:N]) + gg <- g[1:N] + Rj <- tapply(r, gg, mean) + t <- table(r) + names(t) <- NULL + T <- sum((t^3 - t)/(12 * (N - 1))) + Vi <- N * (N + 1)/12 - T + u <- 2:i + j <- u + enum <- sapply(j, function(j) sum(nj[j:i] * Rj[j:i])) + denom <- sapply(j, function(j) sum(nj[j:i])) + ti[i] <- (max(enum/denom) - Rj[1])/sqrt(Vi * (1/nj[i] + + 1/nj[1])) + } + return(ti[2:k]) + } + l <- 1:N + STATISTIC <- compfn(x, l, g, nj) + + extrapolFN <- function(Tki, beta, r, c) { + out <- Tki - 0.01 * beta * (1 - r/c) + return(out) + } + df <- 1000000 + c <- nj[1] + r <- nj[2:k] + nrows <- nrow(williams.tk005) # PMCMRplus:::TabCrit$williams.tk005 + Tkdf <- numeric(kk) + dft <- as.numeric(williams.tk005$rowname) # PMCMRplus:::TabCrit$williams.tk005 # as.numeric(rownames(williams.tk005)) + xx <- c(2:6, 8, 10) + for (i in 2:kk) { + if (i <= 6 | i == 8 | i == 10) { + yt <- williams.tk005[, paste0("X", i)] # PMCMRplus:::TabCrit$williams.tk005 + yb <- williams.beta005[, paste0("X", i)] # PMCMRplus:::TabCrit$williams.beta005 + } + else { + yt <- sapply(1:nrows, function(j) { + approx(x = xx, y = williams.tk005[j,-1], xout = i)$y # PMCMRplus:::TabCrit$williams.tk005 + }) + yb <- sapply(1:nrows, function(j) { + approx(x = xx, y = williams.beta005[j,-1], xout = i)$y # PMCMRplus:::TabCrit$williams.tk005 + }) + } + tt <- approx(x = dft, y = yt, xout = df)$y + tb <- approx(x = dft, y = yb, xout = df)$y + Tkdf[i] <- extrapolFN(tt, tb, r[i], c) + } + Tkdf[1] <- qnorm(0.05, lower.tail = FALSE) + STAT <- cbind(ctr = STATISTIC) + row.names(STAT) <- sapply(1:(k - 1), function(i) paste0("mu", + i)) + STATCRIT <- cbind(ctr = Tkdf) + row.names(STATCRIT) <- row.names(STAT) + DAT <- data.frame(xold, g) + METHOD <- c("Shirley-Williams test") + parameter <- Inf + names(parameter) <- "df" + ans <- list(method = METHOD, data.name = DNAME, crit.value = STATCRIT, + statistic = STAT, parameter = parameter, alternative = alternative, + dist = "t'", model = DAT) + class(ans) <- "osrt" + return(ans) +} \ No newline at end of file diff --git a/R/trendTest.R b/R/trendTest.R new file mode 100644 index 0000000..b73dd76 --- /dev/null +++ b/R/trendTest.R @@ -0,0 +1,37 @@ +trendTest <- function(x, y, data, test = c("william", "shirley", "tukey"), level = 0.05){ + if(!missing(data)){ + x <- data[[x]] + y <- data[[y]] + } + + lm_slope <- lm(y ~ x)$coef[["x"]] + slope <- ifelse(lm_slope > 0, "greater", "less") + + test <- match.arg(test) + if(test == "william"){ + res <- .williamsTest(y, x, alternative = slope) + p.values <- NULL + decisions <- ifelse(res$statistic > res$crit.value, "accept", "reject") + acceptTrend <- any(res$statistic > res$crit.value) + } + + if(test == "shirley"){ + res <- .shirleyTest(y, x, alternative = slope, method = "look-up") + p.values <- NULL + decisions <- ifelse(res$statistic > res$crit.value, "accept", "reject") + acceptTrend <- any(res$statistic > res$crit.value) + } + + if(test == "tukey"){ + fitw <- lm(y ~ x) + ttw <- .tukeytrendfit(y, x) + res <- multcomp:::summary.glht(multcomp:::glht(model=ttw$mmm, linfct=ttw$mlf)) + + p.values <- as.numeric(res$test$pvalues) + names(p.values) <- names(res$test$tstat) + decisions <- ifelse(p.values < level, "accept", "reject") + acceptTrend <- any(p.values < level) + } + + list(p.values = p.values, decisions = decisions, acceptTrend = acceptTrend) +} \ No newline at end of file diff --git a/R/tukeytrendfit.R b/R/tukeytrendfit.R new file mode 100644 index 0000000..570f98a --- /dev/null +++ b/R/tukeytrendfit.R @@ -0,0 +1,60 @@ +.tukeytrendfit <- function (y, x, scaling = c("ari", "ord", "arilog"), ctype = NULL, ddf = c("residual", + "KR", "PB"), d0shift = 1) +{ + fit <- lm(y ~ x) + # dose <- x + ddf <- "residual" + if(min(x) > 0){ + x.log <- x + arilog <- log + } else { + x.log <- x - min(x) + d0shift = d0shift + arilog <- function(z){ + if(z == 0){ + x.unique <- sort(unique(x.log)) + log(x.unique[2]) - d0shift * (x.unique[2] - x.unique[1]) / (x.unique[3] - x.unique[2]) * (log(x.unique[3]) - log(x.unique[2])) + } else + log(z) + } + arilog <- Vectorize(arilog) + } + + DAT <- data.frame(x=x,y=y) + TDAT <- cbind(DAT, + xari=x, + xord=as.numeric(factor(x))-1, + xarilog=arilog(x.log)) + TNAM <- colnames(TDAT)[-(1:2)] + SCAL <- scaling + + MLIST <- list() + for (i in seq(along.with = SCAL)) { + FORMI <- as.formula(paste(". ~ . - x + ", TNAM[i], + sep = "")) + MLIST[[i]] <- update(fit, FORMI, data = TDAT, na.action = "na.exclude") + } + names(MLIST) <- TNAM + + MMM <- MLIST + class(MMM) <- "mmm" + + MLF <- as.list(paste(TNAM, " = 0", sep = "")) + for (i in 1:3) { + MLF[[i]] <- multcomp::glht(model = MMM[[i]], linfct = MLF[[i]])$linfct + } + names(MLF) <- TNAM + class(MLF) <- "mlf" + DF <- unlist(lapply(MLIST, df.residual)) + + CALL <- fit$call + cCALL <- as.character(CALL) + cCALL[2] <- strsplit(cCALL[2], split = "[ ~ ]")[[1]][1] + INFO <- paste(cCALL[1:2], collapse = ".") + MODINFO <- list(modelinfo = INFO, initcall = CALL) + + # MODINFO <- getmodelinfo(fit) + OUT <- c(list(mmm = MMM, mlf = MLF, df = DF), MODINFO) + class(OUT) <- "tukeytrend" + return(OUT) +} \ No newline at end of file diff --git a/R/tukeytrendtest.R b/R/tukeytrendtest.R new file mode 100644 index 0000000..b2de48c --- /dev/null +++ b/R/tukeytrendtest.R @@ -0,0 +1,7 @@ +.tukeytrendtest <- function(y,x){ + ttw <- .tukeytrendfit(y, x) + res <- multcomp:::summary.glht(multcomp:::glht(model=ttw$mmm, linfct=ttw$mlf)) + + res +} + diff --git a/R/williamsTest.R b/R/williamsTest.R new file mode 100644 index 0000000..b951eef --- /dev/null +++ b/R/williamsTest.R @@ -0,0 +1,118 @@ +.williamsTest <- function(x, g, alternative = c("auto", "greater", "less"), ...) +{ + # if (is.list(x)) { + # if (length(x) < 2L) + # stop("'x' must be a list with at least 2 elements") + # DNAME <- deparse(substitute(x)) + # x <- lapply(x, function(u) u <- u[complete.cases(u)]) + # k <- length(x) + # l <- sapply(x, "length") + # if (any(l == 0)) + # stop("all groups must contain data") + # g <- factor(rep(1:k, l)) + # alternative <- x$alternative + # x <- unlist(x) + # } + # else { + if (length(x) != length(g)) { + stop("'x' and 'g' must have the same length") + } + DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(g))) + OK <- complete.cases(x, g) + x <- x[OK] + g <- g[OK] + if (!all(is.finite(g))) { + stop("all group levels must be finite") + } + g.old <- g + g <- factor(g) + k <- nlevels(g) + if (k < 2) { + stop("all observations are in the same group") + } + # } + alternative <- match.arg(alternative) + if(alternative == "auto"){ + lm0 <- lm(x ~ g.old)$coef[["g.old"]] + alternative <- ifelse(lm0 > 0, "greater", "less") + } + + xold <- x + if (alternative == "less") { + x <- -x + } + xi <- tapply(x, g, mean, na.rm = T) + ni <- tapply(x, g, length) + k <- nlevels(g) + kk <- k - 1 + if (kk > 10) + stop("Critical t-values are only available for up to 10 dose levels.") + N <- sum(ni) + df <- N - k + s2i <- tapply(x, g, var) + s2in <- 1/df * sum(s2i * (ni - 1)) + # xiiso <- .Fortran("pava", y = as.double(xi), w = as.double(ni), + # kt = integer(k), n = as.integer(k))$y + xiiso <- .pava(y = as.double(xi), w = as.double(ni), + kt = integer(k))$y + mui <- rep(NA, k) + for (i in 1:k) { + v <- k + tmp <- rep(NA, length(1:i)) + for (u in 1:i) { + j <- u + tmp01 <- sapply(i:k, function(v) sum(ni[j:v] * xiiso[j:v])/sum(ni[j:v])) + tmp[u] <- min(tmp01) + } + mui[i] <- max(tmp, na.rm = TRUE) + } + Tk <- sapply(2:k, function(i) { + (mui[i] - xi[1])/sqrt((s2in/ni[i] + s2in/ni[1])) + }) + extrapolFN <- function(Tki, beta, r, c) { + out <- Tki - 0.01 * beta * (1 - r/c) + return(out) + } + c <- ni[1] + r <- ni[2:k] + o <- c/r + for (i in 1:kk) { + if (o[i] < 1 | o[i] > 6) { + warning(paste0("Ratio n0 / n", i, " is ", o[i], " and outside the range.\n\n Test results may not be accurate.")) + } + } + nrows <- nrow(williams.tk005) # PMCMRplus:::TabCrit$williams.tk005 + Tkdf <- numeric(kk) + dft <- as.numeric(williams.tk005$rowname) # PMCMRplus:::TabCrit$williams.tk005 + xx <- c(2:6, 8, 10) + for (i in 2:kk) { + if (i <= 6 | i == 8 | i == 10) { + yt <- williams.tk005[, paste0("X", i)] # PMCMRplus:::TabCrit$williams.tk005 # williams.tk005[, paste0(i)] + yb <- williams.beta005[, paste0("X", i)] # PMCMRplus:::TabCrit$williams.beta005 + } + else { + yt <- sapply(1:nrows, function(j) { + approx(x = xx, y = williams.tk005[j,-1], xout = i)$y # PMCMRplus:::TabCrit$williams.tk005 + }) + yb <- sapply(1:nrows, function(j) { + approx(x = xx, y = williams.beta005[j,-1], xout = i)$y # PMCMRplus:::TabCrit$williams.beta005 + }) + } + tt <- approx(x = dft, y = yt, xout = df)$y + tb <- approx(x = dft, y = yb, xout = df)$y + Tkdf[i] <- extrapolFN(tt, tb, r[i], c) + } + Tkdf[1] <- qt(0.05, df = df, lower.tail = FALSE) + STAT <- cbind(ctr = Tk) + row.names(STAT) <- sapply(1:(k - 1), function(i) paste0("mu", i)) + STATCRIT <- cbind(ctr = Tkdf) + row.names(STATCRIT) <- row.names(STAT) + parameter = c(df) + names(parameter) <- c("df") + METHOD <- paste("Williams trend test") + ans <- list(method = METHOD, data.name = DNAME, crit.value = STATCRIT, + statistic = STAT, parameter = parameter, alternative = alternative, + dist = "t'") + class(ans) <- "osrt" + ans +} \ No newline at end of file diff --git a/bmd.Rproj b/bmd.Rproj index b1ded45..c88d76d 100644 --- a/bmd.Rproj +++ b/bmd.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 17a33614-0dad-4a73-9ef1-82328c71af7f RestoreWorkspace: Default SaveWorkspace: Default diff --git a/data/.DS_Store b/data/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..5008ddfcf53c02e82d7eee2e57c38e5672ef89f6 GIT binary patch literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0#egMEWo*v$*G+xAXD5 z?_rz$>HMR?+3(!A)G~6OE{Zw4q-jvO@y})-b&c`q{Alqy_j&h!^X@rE+FESsQmJW`x>9)Y~7K) zH)cyY3nsnL`@w32oy#hA71uzSyK@&pZJv?5j&0-3OUid;7$nn$G+z6pFx~je_U@N z4s9D4YW*9+L|2tSnAaWL3bA2u!S1rhAXabs=ex?UAey%y{qX6_AgW5*bcra~@HQ08 z|KLg#bkRD}^V;~!^DDdeaAs+BaCX=CH+L?(3ZY4V^dp2+XP9mRmN?`VD&R>#s%eXK%6i)`XF?Y zH7{?0*klEOAYBDx!+l8SlyG`;=JIi-i(7wOA*8zEbEAC9xTyI}C}X2@UqF#xloq$; z@J`RKa5CRN?-}%{C|$>7vLdl6)PXU*uEU zCIO`D2T0?(mQP0Wvu*VVgt1$`-}^G^KjY5!>7JL1;|W&>XHG}XoPRl^z6otu6T((Y z)b|_tKR&mp@9blbL%Dpu|3>oLXASJ@xEp8L}~$XsIa6 We-5!AWaph(O#KVErMskw3;+N#3O`o> literal 0 HcmV?d00001 diff --git a/man/monotonicityTest.Rd b/man/monotonicityTest.Rd new file mode 100644 index 0000000..16b5c0d --- /dev/null +++ b/man/monotonicityTest.Rd @@ -0,0 +1,56 @@ +\name{monotonicityTest} +\alias{monotonicityTest} +\title{Test for Monotonicity of Relationship Between Two Variables} +\description{ + Conducts a test for monotonicity between a numeric independent variable \code{x} and a numeric dependent variable \code{y} using specified statistical tests. +} +\usage{ +monotonicityTest(x, y, data, test = c("jonckheere", "bartholomew"), level = 0.05, ...) +} +\arguments{ + \item{x}{A numeric vector or the name of the independent variable (if \code{data} is provided).} + \item{y}{A numeric vector or the name of the dependent variable (if \code{data} is provided).} + \item{data}{An optional data frame containing the variables \code{x} and \code{y}. If provided, \code{x} and \code{y} should be column names in \code{data}.} + \item{test}{A character string specifying the test to use. Must be one of \code{"jonckheere"} (default) or \code{"bartholomew"}.} + \item{level}{Significance level for the test. Defaults to 0.05.} + \item{...}{Additional arguments passed to the underlying test functions.} +} +\details{ + The function tests the monotonicity of the relationship between \code{x} and \code{y} based on the specified test: + \itemize{ + \item \code{"jonckheere"}: Uses the Jonckheere-Terpstra test to assess monotonic trends. + \item \code{"bartholomew"}: Uses Bartholomew's test to assess monotonicity. + } + + The direction of the monotonicity (increasing or decreasing) is determined by the sign of the coefficient from a simple linear model \code{lm(y ~ x)}. +} +\value{ + A list with the following components: + \item{p.value}{The p-value of the test.} + \item{acceptMonotonicity}{A logical value indicating whether monotonicity is accepted (\code{TRUE}) or rejected (\code{FALSE}) based on the specified significance level.} +} +\examples{ +# Example with custom data +x <- c(1, 2, 3, 4, 5) +y <- c(2, 4, 6, 8, 10) +result <- monotonicityTest(x, y, test = "jonckheere") +print(result) + +# Example with a data frame +data <- data.frame(x = c(1, 2, 3, 4, 5), y = c(10, 9, 8, 7, 6)) +result <- monotonicityTest("x", "y", data = data, test = "bartholomew") +print(result) +} + +\author{Jens Riis Baalkilde} + +\seealso{ + \code{.jonckheereTest}, \code{.bartholomewTest} +} + +\references{ + A. R. Jonckheere (1954). "A Distribution-Free k-Sample Test Against Ordered Alternatives." + D. J. Bartholomew (1961). "Ordered tests in the analysis of variance." + OECD (2006). Rapport No. 54, Annexes. +} +\keywords{monotonicity, trend test} diff --git a/man/trendTest.Rd b/man/trendTest.Rd new file mode 100644 index 0000000..6ce9520 --- /dev/null +++ b/man/trendTest.Rd @@ -0,0 +1,56 @@ +\name{trendTest} +\alias{trendTest} +\title{Test for Trend in Relationship Between Two Variables} +\description{ + Conducts a test for trends between a numeric independent variable \code{x} and a numeric dependent variable \code{y} using specified statistical tests. +} +\usage{ +trendTest(x, y, data, test = c("william", "shirley", "tukey"), level = 0.05) +} +\arguments{ + \item{x}{A numeric vector or the name of the independent variable (if \code{data} is provided).} + \item{y}{A numeric vector or the name of the dependent variable (if \code{data} is provided).} + \item{data}{An optional data frame containing the variables \code{x} and \code{y}. If provided, \code{x} and \code{y} should be column names in \code{data}.} + \item{test}{A character string specifying the test to use. Must be one of \code{"william"}, \code{"shirley"}, or \code{"tukey"} (default).} + \item{level}{Significance level for the test. Defaults to 0.05.} +} +\details{ + The function tests for a trend in the relationship between \code{x} and \code{y} based on the specified test: + \itemize{ + \item \code{"william"}: Applies Williams' test to assess trend significance. + \item \code{"shirley"}: Uses Shirley's test for trend analysis with ordered alternatives. + \item \code{"tukey"}: Implements the Tukey trend test using multiple marginal models. + } + + The direction of the trend (increasing or decreasing) is determined by the slope of the linear model \code{lm(y ~ x)}. +} +\value{ + A list with the following components: + \item{p.values}{A numeric vector of p-values for the tests (if applicable).} + \item{decisions}{A character vector indicating whether the trend is \code{"accept"} or \code{"reject"} based on the test results.} + \item{acceptTrend}{A logical value indicating whether a trend is accepted (\code{TRUE}) or rejected (\code{FALSE}) based on the specified significance level.} +} +\examples{ +# Example with custom data +x <- c(1, 2, 3, 4, 5) +y <- c(2, 4, 6, 8, 10) +result <- trendTest(x, y, test = "tukey") +print(result) + +# Example with a data frame +data <- data.frame(x = c(1, 2, 3, 4, 5), y = c(10, 9, 8, 7, 6)) +result <- trendTest("x", "y", data = data, test = "shirley") +print(result) +} +\seealso{ + \code{.williamsTest}, \code{.shirleyTest}, \code{.tukeytrendfit} +} +\references{ + Williams, D. A. (1971). "A test for differences between treatment means when several dose levels are compared with a zero dose control." Biometrics, 27(1), 103-117. + Shirley, E. (1977). "A non-parametric equivalent of Williams' test for contrasting increasing dose levels of a treatment." Biometrics, 33(2), 386-389. + Schaarschmidt, F. et al. (2021). "The Tukey trend test: Multiplicity adjustment using multiple marginal models" Biometrics, 78(2), 789-797. +} +\author{ + Jens Riis Baalkilde +} +\keywords{trend, statistical test} From 8f6f1e62895983d1a1ed8724ac140440930cfe57 Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Mon, 13 Jan 2025 13:28:51 +0100 Subject: [PATCH 2/6] Fixed misspelling of "\keyword" in trendTest.Rd and monotonicityTest.Rd --- man/monotonicityTest.Rd | 2 +- man/trendTest.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/man/monotonicityTest.Rd b/man/monotonicityTest.Rd index 16b5c0d..eb37752 100644 --- a/man/monotonicityTest.Rd +++ b/man/monotonicityTest.Rd @@ -53,4 +53,4 @@ print(result) D. J. Bartholomew (1961). "Ordered tests in the analysis of variance." OECD (2006). Rapport No. 54, Annexes. } -\keywords{monotonicity, trend test} +\keyword{monotonicity, trend test} diff --git a/man/trendTest.Rd b/man/trendTest.Rd index 6ce9520..172bf5e 100644 --- a/man/trendTest.Rd +++ b/man/trendTest.Rd @@ -53,4 +53,4 @@ print(result) \author{ Jens Riis Baalkilde } -\keywords{trend, statistical test} +\keyword{trend, statistical test} From 45a45771dea24772279f80d216b687641b6b40ec Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Thu, 16 Jan 2025 09:08:56 +0100 Subject: [PATCH 3/6] Added development version of bmdHetVar --- DESCRIPTION | 4 +- NAMESPACE | 5 +- R/bmdHetVar.R | 164 +++++++++++++++++++++++++++++++++++++++++++++++ R/sigmaFun.R | 92 ++++++++++++++++++++++++++ man/bmdHetVar.Rd | 113 ++++++++++++++++++++++++++++++++ 5 files changed, 374 insertions(+), 4 deletions(-) create mode 100644 R/bmdHetVar.R create mode 100644 R/sigmaFun.R create mode 100644 man/bmdHetVar.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 9ddec51..fb4968b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,13 @@ Package: bmd Type: Package Title: Benchmark dose estimation for dose-response data -Version: 2.6.6 +Version: 2.6.7 Date: 2024-12-11 Author: Signe M.Jensen, Christian Ritz and Jens Riis Baalkilde Maintainer: Signe M. Jensen Description: Benchmark dose analysis for continuous, quantal, count and ordinal dose-response data Imports: drc, ggplot2, dplyr -Suggests: CVXR, multcomp +Suggests: CVXR, multcomp, gridExtra License: GPL Encoding: UTF-8 LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 48dbaed..abf77b9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,7 @@ import(drc, ggplot2, dplyr) export(bmd, bmdBoot, bmdIso, bmdIsoBoot, PAV, bmdMA, bootDataGen, bmdMACurve, BCa, invBmd, expandBinomial, getStackingWeights, drmOrdinal, bmdOrdinal, bmdOrdinalMA, expandOrdinal, bootDataGenOrdinal, - qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest) + qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest, bmdHetVar, sigmaFun) ## S3 methods S3method(logLik, drcOrdinal) @@ -9,4 +9,5 @@ S3method(AIC, drcOrdinal) S3method(plot, drcOrdinal) S3method(print, drcOrdinal) S3method(print, bmdOrdinal) -S3method(plot, bmd) \ No newline at end of file +S3method(plot, bmd) +S3method(plot, drc.sigma.fun) \ No newline at end of file diff --git a/R/bmdHetVar.R b/R/bmdHetVar.R new file mode 100644 index 0000000..92372aa --- /dev/null +++ b/R/bmdHetVar.R @@ -0,0 +1,164 @@ +bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), backg = NA, def = c("hybridExc", "hybridAdd"), interval = c("boot", "none"), R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE){ + ### Assertions ### + # object + if(!identical(class(object),"drc")){ + stop('object must be a dose-response model of class "drc" ') + } + if(length(unique(object$dataList$curveid)) != 1){ + stop("dose-response models with multiple curves not supported for heteroscedasticity analysis") + } + + # var.formula + if(!identical(class(var.formula), "formula")){ + stop('argument "formula" must be of class "formula"') + } + + # bmr + if(missing(bmr)){ + stop('argument "bmr" needs to be specified as a number between 0 and 1') + } + if(!is.numeric(bmr)){ + stop('argument "bmr" needs to be specified as a number between 0 and 1') + } + if(bmr <= 0 | bmr >=1){ + stop('argument "bmr" needs to be specified as a number between 0 and 1') + } + + # backgType + if (missing(backgType)) { + stop(paste("backgType is missing", sep="")) + } + if (!(def %in% c("hybridExc", "hybridAdd"))) { + stop(paste("Could not recognize def", sep="")) + } + if (!(backgType %in% c("absolute","hybridSD","hybridPercentile"))) { + stop(paste("Could not recognize backgType", sep="")) + } + + level <- 1-2*(1-level) + + # SLOPE + slope <- drop(ifelse(object$curve[[1]](0)-object$curve[[1]](Inf)>0,"decreasing","increasing")) + if(is.na(object$curve[[1]](0)-object$curve[[1]](Inf))){ + slope <- drop(ifelse(object$curve[[1]](0.00000001)-object$curve[[1]](100000000)>0,"decreasing","increasing")) + } + + # sigmaFun + sigmaFun0 <- sigmaFun(object, var.formula) + + # bmrScaled + if(slope == "increasing"){ + # BACKGROUND + if (identical(backgType,"absolute")) { + if(is.na(backg)){ + stop('backgType = absolute, but backg not supplied') + } + p0 <- 1 - pnorm((backg - object$curve[[1]](0)) / sigmaFun0$ret.fun(0)) + } + if(identical(backgType, "hybridPercentile")) { + p0 <- ifelse(is.na(backg),1-0.9,1-backg) + } + if (identical(backgType,"hybridSD")) { + p0 <- ifelse(is.na(backg), 1-pnorm(2), 1-pnorm(backg)) + } + + # BMRSCALED + bmrScaled <- switch( + def, + hybridExc = function(x){ sigmaFun0$ret.fun(x) * + (qnorm(1 - p0) - qnorm(1 - p0 - (1 - p0)*bmr)) + object$curve[[1]](0)}, + hybridAdd = function(x){ sigmaFun0$ret.fun(x) * + (qnorm(1 - p0) - qnorm(1 - (p0 + bmr))) + object$curve[[1]](0)} + ) + } else { + # BACKGROUND + if (identical(backgType,"absolute")) { + if(is.na(backg)){ + stop('backgType = absolute, but backg not supplied') + } + p0 <- pnorm((backg - object$curve[[1]](0)) / sigmaFun0$ret.fun(0)) + } + if(identical(backgType, "hybridPercentile")) { + p0 <- ifelse(is.na(backg),0.1,backg) + } + if (identical(backgType,"hybridSD")) { + p0 <- ifelse(is.na(backg), pnorm(-2), pnorm(-backg)) + } + + # BMRSCALED + bmrScaled <- switch( + def, + hybridExc = function(x){ sigmaFun0$ret.fun(x) * + (qnorm(p0) - qnorm(bmr + (1-bmr) * p0)) + object$curve[[1]](0)}, + hybridAdd = function(x){ sigmaFun0$ret.fun(x) * + (qnorm(p0) - qnorm(bmr + p0)) + object$curve[[1]](0)} + ) + } + + # BMD ESTIMATION + f0 <- function(x) object$curve[[1]](x) - bmrScaled(x) + interval0 <- range(object$dataList$dose, na.rm = TRUE) + uniroot0 <- try(uniroot(f = f0, interval = interval0), silent = TRUE) + + if(inherits(uniroot0, "try-error")){ + bmdEst <- NA + warning('error when estimating bmd. Root not found.\n') + } else { + bmdEst <- uniroot0$root + } + + # INTERVAL + interval <- match.arg(interval) + if(identical(interval, "none")){ + BMDL <- NA + BMDU <- NA + } else { + bootDataList <- bootDataGen(object, R=R, bootType="nonparametric",aggregated=TRUE) + + bmdHetVarBoot <- function(bootData){ + bootObject <- update(object, data = bootData) + bootBmdEst <- bmdHetVar(object = bootObject, var.formula = var.formula, bmr = bmr, + backgType = backgType, backg = backg, def = def, interval = "none", display = FALSE)$Results[,1] + bootBmdEst + } + + if(progressInfo){ + cat("Performing bootstrap\n") + pb <- txtProgressBar(min = 0, max = R, style = 3) + } + + bootBmdEst <- numeric(R) + for(i in 1:R){ + bootBmdEst[i] <- suppressWarnings(as.numeric(try(bmdHetVarBoot(bootDataList[[i]]), silent = TRUE))) + if(progressInfo) setTxtProgressBar(pb, i) + } + if(progressInfo) close(pb) + + boot0<-bootBmdEst[!is.na(bootBmdEst)] + + if(length(boot0) == 0){ + BMDL <- NA + BMDU <- NA + } else { + BMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. + BMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + } + } + + resMat <- matrix(c(bmdEst, BMDL), nrow = 1, ncol = 2, dimnames = list(NULL, c("BMD", "BMDL"))) + bmrScaled <- matrix(object$curve[[1]](bmdEst), nrow = 1, ncol = 1, dimnames = list("", "bmrScaled")) + bmdInterval <- matrix(c(BMDL, BMDU), nrow = 1, ncol = 2, dimnames = list("", c("Lower", "Upper"))) + + # GATHER RESULTS + if (display) { + print(resMat) + } + + resBMD<-list(Results = resMat, + bmrScaled = bmrScaled, + interval = bmdInterval, + sigmaFun = sigmaFun0, + model = object) + class(resBMD) <- "bmdHetVar" + invisible(resBMD) +} diff --git a/R/sigmaFun.R b/R/sigmaFun.R new file mode 100644 index 0000000..cf079e0 --- /dev/null +++ b/R/sigmaFun.R @@ -0,0 +1,92 @@ +sigmaFun <- function(object, formula){ + # Assertions + if(!class(object) == "drc"){ + stop('object must be a dose-response model of class "drc" ') + } + if(length(unique(object$dataList$curveid)) != 1){ + stop("dose-response models with multiple curves not supported for heteroscedasticity analysis") + } + + if(class(formula) != "formula"){ + stop('argument "formula" must be of class "formula"') + } + + # Add fitted values and residuals to data + data <- object$data |> + dplyr::mutate(fitted = fitted(object), + residuals = residuals(object)) + + # Aggregate data + data.agg <- data |> + dplyr::group_by(fitted) |> + dplyr::summarise(dose0 = mean(.data[[object$dataList$names$dName]]), + sigma0 = sqrt(mean(residuals^2))) + colnames(data.agg)[2] <- object$dataList$names$dName + + + formula <- as.formula(formula) + formula0 <- reformulate(attr(terms(formula), "term.labels"), response = "sigma0") + + sigma.mod <- lm(formula0, data = data.agg) + + ret.fun <- function(x){ + newdata0 <- data.frame(dose0 = x, fitted = object$curve[[1]](x)) + colnames(newdata0)[1] <- object$dataList$names$dName + + predict(sigma.mod, newdata0) + } + + # Checking for roots. + # NOT STABLE IF THERE ARE MULTIPLE ROOTS IN DOSE RANGE! + interval0 <- range(data[[object$dataList$names$dName]], na.rm = TRUE) + root.try <- try(uniroot(ret.fun, + interval = interval0), silent = TRUE) + + if(!inherits(root.try, "try-error")){ + stop("Root detected in variance function. Choose a different model for the variance. \n") + } + + # Return object + ret.list <- list(ret.fun = ret.fun, sigma.mod = sigma.mod, data.agg = data.agg, model = object) + class(ret.list) <- "drc.sigma.fun" + ret.list +} + +plot.drc.sigma.fun <- function(object, gridsize = 300){ + # Add assertion of gridExtra + + dName <- colnames(object$data.agg)[2] + + # Plot of model + dose <- object$model$dataList[["dose"]] + resp <- object$model$dataList[["origResp"]] + doseName <- object$model$dataList$names$dName + respName <- object$model$dataList$names$orName + + xLimits <- range(dose) + xLimits0 <- pmax(xLimits, 1e-8) + dosePts <- c(0,exp(seq(log(xLimits0[1]), log(xLimits0[2]), length = gridsize-1))) + dosePts[1] <- max(xLimits[1],0) + dosePts[gridsize] <- xLimits[2] + + curveFun <- object$model$curve[[1]] + + polygonX <- c(dosePts, rev(dosePts)) + polygonY <- c(curveFun(dosePts) + 1.96*object$ret.fun(dosePts), + rev(curveFun(dosePts) - 1.96*object$ret.fun(dosePts)) ) + + p1 <- ggplot() + + geom_polygon(aes(x = polygonX, y = polygonY), alpha = 0.1) + + geom_line(aes(x = dosePts, y = curveFun(dosePts))) + + geom_point(aes(x = dose, y = resp)) + + scale_x_continuous(trans = "pseudo_log") + + labs(x = doseName, y = respName) + + p2 <- ggplot(object$data.agg) + + geom_point(aes(x = .data[[dName]], y = sigma0)) + + geom_function(fun = object$ret.fun) + + scale_x_continuous(trans = "pseudo_log") + + (gridExtra::grid.arrange(p1, p2)) + invisible(list(p1,p2)) +} \ No newline at end of file diff --git a/man/bmdHetVar.Rd b/man/bmdHetVar.Rd new file mode 100644 index 0000000..3821ad9 --- /dev/null +++ b/man/bmdHetVar.Rd @@ -0,0 +1,113 @@ +\name{bmd} +\alias{bmd} +\title{ +Benchmark dose estimation with heterogeneous variance +} +\description{Estimation of benchmark doses and benchmark dose lower limit based on the hybrid method from dose response model fits with the option to specify a heterogeneous variance structure, where the variance depends on the dose level and/or the fitted values +} +\usage{ +bmdHetVar(object, var.formula, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), + backg = NA, def = c("hybridExc", "hybridAdd"), interval = c("boot", "none"), + R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +} + +\arguments{ + \item{object}{object of class \code{drc}} + \item{var.formula}{object of class \code{drc}} + \item{bmr}{numeric value of benchmark response level for which to calculate the benchmark dose} + \item{backgType}{character string specifying how the background level is specified. For binomial data the options are "modelBased" and "absolute". For continuous data the options are "modelBased","absolute", "hybridSD" and "hybridPercentile". For count data (Poisson, negbin1 or negbin2) the options are "modelBased" and "absolute". + + "absolute" - the background level is specified by the user through the backg argument: + p0 = 1 - phi((back - f(0))/sigma(0)) for "hybridExc" and "hybridAdd" definitions. + + "hybridSD" - the background risk is specified by the user in terms of number of SDs from the mean of the control group. + p0 = 1 - phi(((backg*sigma(0) + f(0)) - f(0))/sigma(0)) = 1 - phi(backg), + where phi is the normal distribution function and sigma(0) is the SD for the control group. + + "hybridPercentile" - the background risk is specified by the user in terms of percentile from the control group distribution (assuming a normal distribution). + p0 = 1 - phi((x0 - f(0))/sigma(0)) = 1 - backg. + where x0 is the level for which the response is considered adverse, phi is the normal distribution function and sigma(0) is the SD for the control group} + + \item{backg}{numeric value specifying the background level. Defaults to 0 for "absolute" background risk for binomial response (1 for decreasing dose-response models), 2 SD for "hybridSD" background and 0.9 for "hybridPercentile"} + + \item{def}{character string specifying the definition of the benchmark dose to use in the calculations. "hybridExc" (excess hybrid), "hybridAdd" (additional hybrid), available. + + "hybridExc" - BMR is defined as: BMR = (1 - phi((x0 - f(BMD))/sigma(BMD)) - p0)/ (1- p0), + where x0 is the level for which the response is considered adverse, phi is the normal distribution function and sigma(BMD) is the SD at the benchmark dose. + + "hybridAdd" - BMR is defined as: BMR = 1 - phi((x0 - f(BMD))/sigma(BMD)) - p0, + where x0 is the level for which the response is considered adverse, phi is the normal distribution function and sigma(BMD) is the SD at the benchmark dose. } + + \item{interval}{character string specifying the type of confidence interval to use: "boot" (default) or "none" + + "boot" - BMDL is based on non-parametric bootstrapping. + + "none" - no confidence interval is computed.} + + \item{R}{Number of bootstrap samples. Ignored if \code{interval = "none"}} + + \item{level}{numeric value specifying the levle of the confidence interval underlying BMDL. Default is 0.95} + + \item{progressInfo}{logical. If TRUE, progress info is be printed while bootstrap confidence intervals are estimated. Default is TRUE.} + + \item{display}{logical. If TRUE the results are displayed; otherwise they are not} +} + +\details{ +The aim to provide an R package + calculating the benchmark dose (BMD) and the lower limit of the corresponding 95\% confidence interval (BMDL) + for continuous and quantal dose-response data for a range of dose-response models based on the available + definitions of the benchmark dose concepts. + + REFERENCES TO BE ADDED/WRITTEN +} +\value{ +A list of five elements: Results contain the estimated BMD and BMDL, bmrScaled is the response value corresponding to the BMD, interval gives the lower (BMDL) and upper (BMDU) end of the confidence interval of BMD, sigmaFun is the estimated standard deviation function, and model returns the supplied model. +} +\references{ +} + +\author{ Signe M. Jensen and Jens Riis Baalkilde +} +\note{ +} + +\seealso{ +} +\examples{ +library(drc) +library(drcData) +library(bmd) +# install.packages("gridExtra") # OPTIONAL - USED FOR PLOTTING sigmaFun + +# ryegrass data +ryegrass.LL.4 <- drm(rootl ~ conc, data = ryegrass, fct = LL.4()) +set.seed(123) +plot(sigmaFun(ryegrass.LL.4, ~ fitted + I(fitted^2))) +bmdHetVar(ryegrass.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(ryegrass.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +# barley data +barley.LL.4 <- drm(weight ~ Dose, data = barley, fct = LL.4()) +set.seed(123) +plot(sigmaFun(barley.LL.4, ~ fitted + I(fitted^2))) +bmdHetVar(barley.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(barley.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +# GiantKelp data +GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = GiantKelp, fct = LL.4()) +set.seed(123) +plot(sigmaFun(GiantKelp.LL.4, ~ fitted + I(fitted^2))) +bmdHetVar(GiantKelp.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +plot(sigmaFun(GiantKelp.LL.4, ~ log(dose+1) + I(log(dose+1)^2) )) +bmdHetVar(GiantKelp.LL.4, var.formula = ~ log(dose+1) + I(log(dose+1)^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4, var.formula = ~ log(dose+1) + I(log(dose+1)^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + + +} +\keyword{models} +\keyword{nonlinear} + +\concept{BMD BMDL benchmark dose-response} \ No newline at end of file From 311896990f8e7ab010908480bc4db0f654b6bf33 Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Tue, 28 Jan 2025 14:59:58 +0100 Subject: [PATCH 4/6] Changed workflow of using bmdHetVar --- NAMESPACE | 4 +- R/bmdHetVar.R | 55 +++++++++++++-------------- R/drmHetVar.R | 54 +++++++++++++++++++++++++++ R/plot.drcHetVar.R | 38 +++++++++++++++++++ R/sigmaFun.R | 92 ---------------------------------------------- man/bmdHetVar.Rd | 34 +++++++++-------- man/drmHetVar.Rd | 82 +++++++++++++++++++++++++++++++++++++++++ 7 files changed, 220 insertions(+), 139 deletions(-) create mode 100644 R/drmHetVar.R create mode 100644 R/plot.drcHetVar.R delete mode 100644 R/sigmaFun.R create mode 100644 man/drmHetVar.Rd diff --git a/NAMESPACE b/NAMESPACE index abf77b9..d78da81 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,7 @@ import(drc, ggplot2, dplyr) export(bmd, bmdBoot, bmdIso, bmdIsoBoot, PAV, bmdMA, bootDataGen, bmdMACurve, BCa, invBmd, expandBinomial, getStackingWeights, drmOrdinal, bmdOrdinal, bmdOrdinalMA, expandOrdinal, bootDataGenOrdinal, - qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest, bmdHetVar, sigmaFun) + qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest, bmdHetVar, drmHetVar) ## S3 methods S3method(logLik, drcOrdinal) @@ -10,4 +10,4 @@ S3method(plot, drcOrdinal) S3method(print, drcOrdinal) S3method(print, bmdOrdinal) S3method(plot, bmd) -S3method(plot, drc.sigma.fun) \ No newline at end of file +S3method(plot, drcHetVar) \ No newline at end of file diff --git a/R/bmdHetVar.R b/R/bmdHetVar.R index 92372aa..7be5d51 100644 --- a/R/bmdHetVar.R +++ b/R/bmdHetVar.R @@ -1,18 +1,13 @@ -bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), backg = NA, def = c("hybridExc", "hybridAdd"), interval = c("boot", "none"), R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE){ +bmdHetVar <- function(object, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), backg = NA, def = c("hybridExc", "hybridAdd"), interval = c("boot", "none"), R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE){ ### Assertions ### # object - if(!identical(class(object),"drc")){ - stop('object must be a dose-response model of class "drc" ') + if(!identical(class(object),"drcHetVar")){ + stop('object must be a dose-response model with a heterogeneous variance structure of class "drcHetVar" ') } - if(length(unique(object$dataList$curveid)) != 1){ + if(length(unique(object$model$dataList$curveid)) != 1){ stop("dose-response models with multiple curves not supported for heteroscedasticity analysis") } - # var.formula - if(!identical(class(var.formula), "formula")){ - stop('argument "formula" must be of class "formula"') - } - # bmr if(missing(bmr)){ stop('argument "bmr" needs to be specified as a number between 0 and 1') @@ -38,13 +33,13 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri level <- 1-2*(1-level) # SLOPE - slope <- drop(ifelse(object$curve[[1]](0)-object$curve[[1]](Inf)>0,"decreasing","increasing")) - if(is.na(object$curve[[1]](0)-object$curve[[1]](Inf))){ - slope <- drop(ifelse(object$curve[[1]](0.00000001)-object$curve[[1]](100000000)>0,"decreasing","increasing")) + slope <- drop(ifelse(object$model$curve[[1]](0)-object$model$curve[[1]](Inf)>0,"decreasing","increasing")) + if(is.na(object$model$curve[[1]](0)-object$model$curve[[1]](Inf))){ + slope <- drop(ifelse(object$model$curve[[1]](0.00000001)-object$model$curve[[1]](100000000)>0,"decreasing","increasing")) } # sigmaFun - sigmaFun0 <- sigmaFun(object, var.formula) + sigmaFun0 <- object$sigmaFun # sigmaFun(object, var.formula) # bmrScaled if(slope == "increasing"){ @@ -53,7 +48,7 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri if(is.na(backg)){ stop('backgType = absolute, but backg not supplied') } - p0 <- 1 - pnorm((backg - object$curve[[1]](0)) / sigmaFun0$ret.fun(0)) + p0 <- 1 - pnorm((backg - object$model$curve[[1]](0)) / sigmaFun0(0)) } if(identical(backgType, "hybridPercentile")) { p0 <- ifelse(is.na(backg),1-0.9,1-backg) @@ -65,10 +60,10 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri # BMRSCALED bmrScaled <- switch( def, - hybridExc = function(x){ sigmaFun0$ret.fun(x) * - (qnorm(1 - p0) - qnorm(1 - p0 - (1 - p0)*bmr)) + object$curve[[1]](0)}, - hybridAdd = function(x){ sigmaFun0$ret.fun(x) * - (qnorm(1 - p0) - qnorm(1 - (p0 + bmr))) + object$curve[[1]](0)} + hybridExc = function(x){ sigmaFun0(x) * + (qnorm(1 - p0) - qnorm(1 - p0 - (1 - p0)*bmr)) + object$model$curve[[1]](0)}, + hybridAdd = function(x){ sigmaFun0(x) * + (qnorm(1 - p0) - qnorm(1 - (p0 + bmr))) + object$model$curve[[1]](0)} ) } else { # BACKGROUND @@ -76,7 +71,7 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri if(is.na(backg)){ stop('backgType = absolute, but backg not supplied') } - p0 <- pnorm((backg - object$curve[[1]](0)) / sigmaFun0$ret.fun(0)) + p0 <- pnorm((backg - object$model$curve[[1]](0)) / sigmaFun0(0)) } if(identical(backgType, "hybridPercentile")) { p0 <- ifelse(is.na(backg),0.1,backg) @@ -88,16 +83,16 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri # BMRSCALED bmrScaled <- switch( def, - hybridExc = function(x){ sigmaFun0$ret.fun(x) * - (qnorm(p0) - qnorm(bmr + (1-bmr) * p0)) + object$curve[[1]](0)}, - hybridAdd = function(x){ sigmaFun0$ret.fun(x) * - (qnorm(p0) - qnorm(bmr + p0)) + object$curve[[1]](0)} + hybridExc = function(x){ sigmaFun0(x) * + (qnorm(p0) - qnorm(bmr + (1-bmr) * p0)) + object$model$curve[[1]](0)}, + hybridAdd = function(x){ sigmaFun0(x) * + (qnorm(p0) - qnorm(bmr + p0)) + object$model$curve[[1]](0)} ) } # BMD ESTIMATION - f0 <- function(x) object$curve[[1]](x) - bmrScaled(x) - interval0 <- range(object$dataList$dose, na.rm = TRUE) + f0 <- function(x) object$model$curve[[1]](x) - bmrScaled(x) + interval0 <- range(object$model$dataList$dose, na.rm = TRUE) uniroot0 <- try(uniroot(f = f0, interval = interval0), silent = TRUE) if(inherits(uniroot0, "try-error")){ @@ -113,11 +108,12 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri BMDL <- NA BMDU <- NA } else { - bootDataList <- bootDataGen(object, R=R, bootType="nonparametric",aggregated=TRUE) + bootDataList <- bootDataGen(object$model, R=R, bootType="nonparametric",aggregated=TRUE) bmdHetVarBoot <- function(bootData){ - bootObject <- update(object, data = bootData) - bootBmdEst <- bmdHetVar(object = bootObject, var.formula = var.formula, bmr = bmr, + bootMod <- update(object$model, data = bootData) + bootModHetVar <- drmHetVar(bootMod, object$var.formula) + bootBmdEst <- bmdHetVar(object = bootModHetVar, bmr = bmr, backgType = backgType, backg = backg, def = def, interval = "none", display = FALSE)$Results[,1] bootBmdEst } @@ -146,7 +142,7 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri } resMat <- matrix(c(bmdEst, BMDL), nrow = 1, ncol = 2, dimnames = list(NULL, c("BMD", "BMDL"))) - bmrScaled <- matrix(object$curve[[1]](bmdEst), nrow = 1, ncol = 1, dimnames = list("", "bmrScaled")) + bmrScaled <- matrix(object$model$curve[[1]](bmdEst), nrow = 1, ncol = 1, dimnames = list("", "bmrScaled")) bmdInterval <- matrix(c(BMDL, BMDU), nrow = 1, ncol = 2, dimnames = list("", c("Lower", "Upper"))) # GATHER RESULTS @@ -157,7 +153,6 @@ bmdHetVar <- function(object, var.formula, bmr, backgType = c("absolute", "hybri resBMD<-list(Results = resMat, bmrScaled = bmrScaled, interval = bmdInterval, - sigmaFun = sigmaFun0, model = object) class(resBMD) <- "bmdHetVar" invisible(resBMD) diff --git a/R/drmHetVar.R b/R/drmHetVar.R new file mode 100644 index 0000000..c361fdf --- /dev/null +++ b/R/drmHetVar.R @@ -0,0 +1,54 @@ +drmHetVar <- function(object, var.formula){ + # Assertions + if(!class(object) == "drc"){ + stop('object must be a dose-response model of class "drc" ') + } + if(length(unique(object$dataList$curveid)) != 1){ + stop("dose-response models with multiple curves not supported for heteroscedasticity analysis") + } + + if(class(var.formula) != "formula"){ + stop('argument "formula" must be of class "formula"') + } + + # Add fitted values and residuals to data + data <- object$data |> + dplyr::mutate(fitted = fitted(object), + residuals = residuals(object)) + + # Aggregate data + data.agg <- data |> + dplyr::group_by(fitted) |> + dplyr::summarise(dose0 = mean(.data[[object$dataList$names$dName]]), + sigma0 = sqrt(mean(residuals^2))) + colnames(data.agg)[2] <- object$dataList$names$dName + + + formula <- as.formula(var.formula) + formula0 <- reformulate(attr(terms(formula), "term.labels"), response = "sigma0") + + sigma.mod <- lm(formula0, data = data.agg) + + sigma.fun <- function(x){ + newdata0 <- data.frame(dose0 = x, fitted = object$curve[[1]](x)) + colnames(newdata0)[1] <- object$dataList$names$dName + + predict(sigma.mod, newdata0) + } + + # Checking for roots. + # NOT STABLE IF THERE ARE MULTIPLE ROOTS IN DOSE RANGE! + interval0 <- range(data[[object$dataList$names$dName]], na.rm = TRUE) + root.try <- try(uniroot(ret.fun, + interval = interval0), silent = TRUE) + + if(!inherits(root.try, "try-error")){ + stop("Root detected in variance function. Choose a different model for the variance. \n") + } + + # Return object + ret.list <- list(model = object, sigmaFun = sigma.fun, var.formula = var.formula, sigmaMod = sigma.mod, data.agg = data.agg) + class(ret.list) <- "drcHetVar" + ret.list +} + diff --git a/R/plot.drcHetVar.R b/R/plot.drcHetVar.R new file mode 100644 index 0000000..10fb69e --- /dev/null +++ b/R/plot.drcHetVar.R @@ -0,0 +1,38 @@ +plot.drcHetVar <- function(object, gridsize = 300){ + # Add assertion of gridExtra + + dName <- colnames(object$data.agg)[2] + + # Plot of model + dose <- object$model$dataList[["dose"]] + resp <- object$model$dataList[["origResp"]] + doseName <- object$model$dataList$names$dName + respName <- object$model$dataList$names$orName + + xLimits <- range(dose) + xLimits0 <- pmax(xLimits, 1e-8) + dosePts <- c(0,exp(seq(log(xLimits0[1]), log(xLimits0[2]), length = gridsize-1))) + dosePts[1] <- max(xLimits[1],0) + dosePts[gridsize] <- xLimits[2] + + curveFun <- object$model$curve[[1]] + + polygonX <- c(dosePts, rev(dosePts)) + polygonY <- c(curveFun(dosePts) + 1.96*object$sigmaFun(dosePts), + rev(curveFun(dosePts) - 1.96*object$sigmaFun(dosePts)) ) + + p1 <- ggplot() + + geom_polygon(aes(x = polygonX, y = polygonY), alpha = 0.1) + + geom_line(aes(x = dosePts, y = curveFun(dosePts))) + + geom_point(aes(x = dose, y = resp)) + + scale_x_continuous(trans = "pseudo_log") + + labs(x = doseName, y = respName) + + p2 <- ggplot(object$data.agg) + + geom_point(aes(x = .data[[dName]], y = sigma0)) + + geom_function(fun = object$sigmaFun) + + scale_x_continuous(trans = "pseudo_log") + + (gridExtra::grid.arrange(p1, p2)) + invisible(list(p1,p2)) +} \ No newline at end of file diff --git a/R/sigmaFun.R b/R/sigmaFun.R deleted file mode 100644 index cf079e0..0000000 --- a/R/sigmaFun.R +++ /dev/null @@ -1,92 +0,0 @@ -sigmaFun <- function(object, formula){ - # Assertions - if(!class(object) == "drc"){ - stop('object must be a dose-response model of class "drc" ') - } - if(length(unique(object$dataList$curveid)) != 1){ - stop("dose-response models with multiple curves not supported for heteroscedasticity analysis") - } - - if(class(formula) != "formula"){ - stop('argument "formula" must be of class "formula"') - } - - # Add fitted values and residuals to data - data <- object$data |> - dplyr::mutate(fitted = fitted(object), - residuals = residuals(object)) - - # Aggregate data - data.agg <- data |> - dplyr::group_by(fitted) |> - dplyr::summarise(dose0 = mean(.data[[object$dataList$names$dName]]), - sigma0 = sqrt(mean(residuals^2))) - colnames(data.agg)[2] <- object$dataList$names$dName - - - formula <- as.formula(formula) - formula0 <- reformulate(attr(terms(formula), "term.labels"), response = "sigma0") - - sigma.mod <- lm(formula0, data = data.agg) - - ret.fun <- function(x){ - newdata0 <- data.frame(dose0 = x, fitted = object$curve[[1]](x)) - colnames(newdata0)[1] <- object$dataList$names$dName - - predict(sigma.mod, newdata0) - } - - # Checking for roots. - # NOT STABLE IF THERE ARE MULTIPLE ROOTS IN DOSE RANGE! - interval0 <- range(data[[object$dataList$names$dName]], na.rm = TRUE) - root.try <- try(uniroot(ret.fun, - interval = interval0), silent = TRUE) - - if(!inherits(root.try, "try-error")){ - stop("Root detected in variance function. Choose a different model for the variance. \n") - } - - # Return object - ret.list <- list(ret.fun = ret.fun, sigma.mod = sigma.mod, data.agg = data.agg, model = object) - class(ret.list) <- "drc.sigma.fun" - ret.list -} - -plot.drc.sigma.fun <- function(object, gridsize = 300){ - # Add assertion of gridExtra - - dName <- colnames(object$data.agg)[2] - - # Plot of model - dose <- object$model$dataList[["dose"]] - resp <- object$model$dataList[["origResp"]] - doseName <- object$model$dataList$names$dName - respName <- object$model$dataList$names$orName - - xLimits <- range(dose) - xLimits0 <- pmax(xLimits, 1e-8) - dosePts <- c(0,exp(seq(log(xLimits0[1]), log(xLimits0[2]), length = gridsize-1))) - dosePts[1] <- max(xLimits[1],0) - dosePts[gridsize] <- xLimits[2] - - curveFun <- object$model$curve[[1]] - - polygonX <- c(dosePts, rev(dosePts)) - polygonY <- c(curveFun(dosePts) + 1.96*object$ret.fun(dosePts), - rev(curveFun(dosePts) - 1.96*object$ret.fun(dosePts)) ) - - p1 <- ggplot() + - geom_polygon(aes(x = polygonX, y = polygonY), alpha = 0.1) + - geom_line(aes(x = dosePts, y = curveFun(dosePts))) + - geom_point(aes(x = dose, y = resp)) + - scale_x_continuous(trans = "pseudo_log") + - labs(x = doseName, y = respName) - - p2 <- ggplot(object$data.agg) + - geom_point(aes(x = .data[[dName]], y = sigma0)) + - geom_function(fun = object$ret.fun) + - scale_x_continuous(trans = "pseudo_log") - - (gridExtra::grid.arrange(p1, p2)) - invisible(list(p1,p2)) -} \ No newline at end of file diff --git a/man/bmdHetVar.Rd b/man/bmdHetVar.Rd index 3821ad9..0a8a601 100644 --- a/man/bmdHetVar.Rd +++ b/man/bmdHetVar.Rd @@ -6,14 +6,13 @@ Benchmark dose estimation with heterogeneous variance \description{Estimation of benchmark doses and benchmark dose lower limit based on the hybrid method from dose response model fits with the option to specify a heterogeneous variance structure, where the variance depends on the dose level and/or the fitted values } \usage{ -bmdHetVar(object, var.formula, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), +bmdHetVar(object, bmr, backgType = c("absolute", "hybridSD", "hybridPercentile"), backg = NA, def = c("hybridExc", "hybridAdd"), interval = c("boot", "none"), R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) } \arguments{ - \item{object}{object of class \code{drc}} - \item{var.formula}{object of class \code{drc}} + \item{object}{dose-response model with a heterogeneous variance structure of class \code{drcHetVar}} \item{bmr}{numeric value of benchmark response level for which to calculate the benchmark dose} \item{backgType}{character string specifying how the background level is specified. For binomial data the options are "modelBased" and "absolute". For continuous data the options are "modelBased","absolute", "hybridSD" and "hybridPercentile". For count data (Poisson, negbin1 or negbin2) the options are "modelBased" and "absolute". @@ -83,27 +82,32 @@ library(bmd) # ryegrass data ryegrass.LL.4 <- drm(rootl ~ conc, data = ryegrass, fct = LL.4()) set.seed(123) -plot(sigmaFun(ryegrass.LL.4, ~ fitted + I(fitted^2))) -bmdHetVar(ryegrass.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) -bmdHetVar(ryegrass.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +ryegrass.LL.4.hetVar <- drmHetVar(ryegrass.LL.4, ~ fitted + I(fitted^2)) +plot(ryegrass.LL.4.hetVar) +bmdHetVar(ryegrass.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(ryegrass.LL.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) # barley data barley.LL.4 <- drm(weight ~ Dose, data = barley, fct = LL.4()) set.seed(123) -plot(sigmaFun(barley.LL.4, ~ fitted + I(fitted^2))) -bmdHetVar(barley.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) -bmdHetVar(barley.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +barley.LL.4.hetVar <- drmHetVar(barley.LL.4, ~ fitted + I(fitted^2)) +plot(barley.LL.4.hetVar) +bmdHetVar(barley.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(barley.LL.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) # GiantKelp data GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = GiantKelp, fct = LL.4()) set.seed(123) -plot(sigmaFun(GiantKelp.LL.4, ~ fitted + I(fitted^2))) -bmdHetVar(GiantKelp.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) -bmdHetVar(GiantKelp.LL.4, var.formula = ~ fitted + I(fitted^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +GiantKelp.LL.4.hetVarSq <- drmHetVar(GiantKelp.LL.4, ~ fitted + I(fitted^2)) +plot(GiantKelp.LL.4.hetVarSq) +bmdHetVar(GiantKelp.LL.4.hetVarSq, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4.hetVarSq, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +GiantKelp.LL.4.hetVarLogSq <- drmHetVar(GiantKelp.LL.4, ~ log(dose+1) + I(log(dose+1)^2)) +plot(GiantKelp.LL.4.hetVarLogSq) +bmdHetVar(GiantKelp.LL.4.hetVarLogSq, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4.hetVarLogSq, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) -plot(sigmaFun(GiantKelp.LL.4, ~ log(dose+1) + I(log(dose+1)^2) )) -bmdHetVar(GiantKelp.LL.4, var.formula = ~ log(dose+1) + I(log(dose+1)^2), bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) -bmdHetVar(GiantKelp.LL.4, var.formula = ~ log(dose+1) + I(log(dose+1)^2), bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) } diff --git a/man/drmHetVar.Rd b/man/drmHetVar.Rd new file mode 100644 index 0000000..bbdfc8f --- /dev/null +++ b/man/drmHetVar.Rd @@ -0,0 +1,82 @@ +\name{bmd} +\alias{bmd} +\title{ +Dose response modeling with heterogeneous variance +} +\description{Add a heterogeneous variance structure to an existing \code{drc} object. +} +\usage{ +drmHetVar(object, var.formula) +} + +\arguments{ + \item{object}{dose-response model of class \code{drcHetVar}} + \item{var.formula}{one-sided formula specifying the dependance of the dose values and/or the fitted values on the point-wise standard error} +} + +\details{ +The aim to provide an R package + calculating the benchmark dose (BMD) and the lower limit of the corresponding 95\% confidence interval (BMDL) + for continuous and quantal dose-response data for a range of dose-response models based on the available + definitions of the benchmark dose concepts. + + REFERENCES TO BE ADDED/WRITTEN +} +\value{ +dose-response model with a heterogeneous variance structure of class \code{drcHetVar}. + +The primary objective is to use this model for benchmark dose estimation based on the hybrid method with a heterogeneous variance structure. + +A plot method is available, which can be useful for assessing the fit of the variance structure. +} +\references{ +} + +\author{ Signe M. Jensen and Jens Riis Baalkilde +} +\note{ +} + +\seealso{ +} +\examples{ +library(drc) +library(drcData) +library(bmd) +# install.packages("gridExtra") # OPTIONAL - USED FOR PLOTTING A drcHetVar OBJECT. + +# ryegrass data +ryegrass.LL.4 <- drm(rootl ~ conc, data = ryegrass, fct = LL.4()) +set.seed(123) +ryegrass.LL.4.hetVar <- drmHetVar(ryegrass.LL.4, ~ fitted + I(fitted^2)) +plot(ryegrass.LL.4.hetVar) +bmdHetVar(ryegrass.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +# barley data +barley.LL.4 <- drm(weight ~ Dose, data = barley, fct = LL.4()) +set.seed(123) +barley.LL.4.hetVar <- drmHetVar(barley.LL.4, ~ fitted + I(fitted^2)) +plot(barley.LL.4.hetVar) +bmdHetVar(barley.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(barley.LL.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +# GiantKelp data +GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = GiantKelp, fct = LL.4()) +set.seed(123) +GiantKelp.LL.4.hetVarSq <- drmHetVar(GiantKelp.LL.4, ~ fitted + I(fitted^2)) +plot(GiantKelp.LL.4.hetVarSq) +bmdHetVar(GiantKelp.LL.4.hetVarSq, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4.hetVarSq, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + +GiantKelp.LL.4.hetVarLogSq <- drmHetVar(GiantKelp.LL.4, ~ log(dose+1) + I(log(dose+1)^2)) +plot(GiantKelp.LL.4.hetVarLogSq) +bmdHetVar(GiantKelp.LL.4.hetVarLogSq, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) +bmdHetVar(GiantKelp.LL.4.hetVarLogSq, bmr = 0.1, backgType = "hybridSD", backg = 1, def = "hybridExc", R = 1000, level = 0.95, progressInfo = TRUE, display = TRUE) + + + +} +\keyword{models} +\keyword{nonlinear} + +\concept{BMD BMDL benchmark dose-response} \ No newline at end of file From 2993a29c173aed91991cc04c7e6e37fc117e04ea Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Wed, 29 Jan 2025 15:34:58 +0100 Subject: [PATCH 5/6] Fixed error in bmdProfileGrid() Fixed object assertion in bmd() Changed "name" and "alias" in bmdHetVar, drmHetVar and bootDataGenOrdinal manuals --- .Rbuildignore | 5 ++++- DESCRIPTION | 7 ++++++- R/bmd.R | 5 +++++ R/bmdProfileCIgrid.R | 1 + man/bmdHetVar.Rd | 4 ++-- man/bootDataGenOrdinal.Rd | 4 ++-- man/drmHetVar.Rd | 4 ++-- 7 files changed, 22 insertions(+), 8 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 1fb6b40..23bb4bb 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,6 @@ ^.*\.Rproj$ ^\.Rproj\.user$ -cache/ \ No newline at end of file +cache/ +README.Rmd +README.md +README_files/ \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index fb4968b..e109f69 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,12 @@ Author: Signe M.Jensen, Christian Ritz and Jens Riis Baalkilde Maintainer: Signe M. Jensen Description: Benchmark dose analysis for continuous, quantal, count and ordinal dose-response data Imports: drc, ggplot2, dplyr -Suggests: CVXR, multcomp, gridExtra +Suggests: + CVXR, + multcomp, + gridExtra, + testthat (>= 3.0.0) License: GPL Encoding: UTF-8 LazyData: true +Config/testthat/edition: 3 diff --git a/R/bmd.R b/R/bmd.R index 292aad9..3c4091e 100644 --- a/R/bmd.R +++ b/R/bmd.R @@ -5,6 +5,11 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " respTrans = c("none", "log", "sqrt"), interval = c("delta", "sandwich", "inv", "profile", "profileGrid"), sandwich.vcov=FALSE, display = TRUE, level=0.95, profileGridSize = NA, profileProgressInfo = TRUE) { + if (missing(object)){ + stop(paste("object is missing", sep="")) + } else { + if(!inherits(object, "drc")){ stop('object must be of type "drc"')} + } if (missing(def)) { stop(paste("def is missing", sep="")) } diff --git a/R/bmdProfileCIgrid.R b/R/bmdProfileCIgrid.R index 3e3f8df..248fc31 100644 --- a/R/bmdProfileCIgrid.R +++ b/R/bmdProfileCIgrid.R @@ -91,6 +91,7 @@ bmdProfileCIgrid <- function(object, bmr, backgType = c("modelBased", "absolute" names(object0$coefficients) <- coefNames object0$curve[[1]] <- object$pfFct(parmMat = matrix(par, nrow = 1)) object0$parmMat <- matrix(par, nrow = length(par)) + colnames(object0$parmMat) <- 1 bmd(object0, bmr = bmr, backgType = backgType, backg = backg, controlSD = controlSD, def = def, interval = "delta", display = FALSE) } diff --git a/man/bmdHetVar.Rd b/man/bmdHetVar.Rd index 0a8a601..31aa26d 100644 --- a/man/bmdHetVar.Rd +++ b/man/bmdHetVar.Rd @@ -1,5 +1,5 @@ -\name{bmd} -\alias{bmd} +\name{bmdHetVar} +\alias{bmdHetVar} \title{ Benchmark dose estimation with heterogeneous variance } diff --git a/man/bootDataGenOrdinal.Rd b/man/bootDataGenOrdinal.Rd index 7155ead..f900b14 100644 --- a/man/bootDataGenOrdinal.Rd +++ b/man/bootDataGenOrdinal.Rd @@ -1,5 +1,5 @@ -\name{bootDataGen} -\alias{bootDataGen} +\name{bootDataGenOrdinal} +\alias{bootDataGenOrdinal} \title{ Help funtion to bmdOrdinal and bmdOrdinalMA } diff --git a/man/drmHetVar.Rd b/man/drmHetVar.Rd index bbdfc8f..47595bb 100644 --- a/man/drmHetVar.Rd +++ b/man/drmHetVar.Rd @@ -1,5 +1,5 @@ -\name{bmd} -\alias{bmd} +\name{drmHetVar} +\alias{drmHetVar} \title{ Dose response modeling with heterogeneous variance } From ed28db0a31997657c1baa1921ab77bdf2b7c19be Mon Sep 17 00:00:00 2001 From: Jens Riis Baalkilde Date: Tue, 25 Mar 2025 13:22:33 +0100 Subject: [PATCH 6/6] *** V2.7.1 *** - Fixes to several functions including bmd, bmdMA, bmdBoot and many more - qplotBmd works for multiple curves - Added tests using testthat --- DESCRIPTION | 12 +- NAMESPACE | 4 +- R/BIC.drcOrdinal.R | 5 + R/ED.bmd.R | 354 +++--- R/MACurve.R | 12 +- R/bmd.R | 24 +- R/bmdBoot.R | 85 +- R/bmdHetVar.R | 15 +- R/bmdIsoBoot.R | 4 +- R/bmdMA.R | 1175 ++++++-------------- R/bmdOrdinalDeltaCI.R | 296 ++--- R/bmdOrdinalMA.R | 196 +++- R/bootDataGenOrdinal.R | 7 + R/drmHetVar.R | 4 + R/getProfileLogLikFixedBmd.R | 14 +- R/getStackingWeights.R | 4 + R/mjust.R | 386 +++---- R/monotonicityTest.R | 3 + R/plot.drcHetVar.R | 3 + R/plot.drcOrdinal.R | 4 + R/print.bmdHetVar.R | 16 + R/qplotBmd.R | 102 +- R/qplotDrc.R | 22 +- R/trendTest.R | 3 + R/tukeytrendtest.R | 14 +- man/bmdMA.Rd | 2 +- tests/.DS_Store | Bin 0 -> 6148 bytes tests/testthat.R | 12 + tests/testthat/_snaps/bmd.md | 13 + tests/testthat/_snaps/bmdBoot.md | 50 + tests/testthat/_snaps/bmdMA.md | 13 + tests/testthat/test-MACurve.R | 42 + tests/testthat/test-bmd.R | 1367 ++++++++++++++++++++++++ tests/testthat/test-bmdBoot.R | 841 +++++++++++++++ tests/testthat/test-bmdHetVar.R | 150 +++ tests/testthat/test-bmdIso.R | 132 +++ tests/testthat/test-bmdIsoBoot.R | 271 +++++ tests/testthat/test-bmdMA.R | 1103 +++++++++++++++++++ tests/testthat/test-bmdOrdinal.R | 83 ++ tests/testthat/test-bmdOrdinalMA.R | 107 ++ tests/testthat/test-drmHetVar.R | 84 ++ tests/testthat/test-drmOrdinal.R | 48 + tests/testthat/test-monotonicityTest.R | 109 ++ tests/testthat/test-qplotBmd.R | 64 ++ tests/testthat/test-qplotDrc.R | 61 ++ tests/testthat/test-trendTest.R | 162 +++ 46 files changed, 5988 insertions(+), 1490 deletions(-) create mode 100644 R/BIC.drcOrdinal.R create mode 100644 R/print.bmdHetVar.R create mode 100644 tests/.DS_Store create mode 100644 tests/testthat.R create mode 100644 tests/testthat/_snaps/bmd.md create mode 100644 tests/testthat/_snaps/bmdBoot.md create mode 100644 tests/testthat/_snaps/bmdMA.md create mode 100644 tests/testthat/test-MACurve.R create mode 100644 tests/testthat/test-bmd.R create mode 100644 tests/testthat/test-bmdBoot.R create mode 100644 tests/testthat/test-bmdHetVar.R create mode 100644 tests/testthat/test-bmdIso.R create mode 100644 tests/testthat/test-bmdIsoBoot.R create mode 100644 tests/testthat/test-bmdMA.R create mode 100644 tests/testthat/test-bmdOrdinal.R create mode 100644 tests/testthat/test-bmdOrdinalMA.R create mode 100644 tests/testthat/test-drmHetVar.R create mode 100644 tests/testthat/test-drmOrdinal.R create mode 100644 tests/testthat/test-monotonicityTest.R create mode 100644 tests/testthat/test-qplotBmd.R create mode 100644 tests/testthat/test-qplotDrc.R create mode 100644 tests/testthat/test-trendTest.R diff --git a/DESCRIPTION b/DESCRIPTION index e109f69..3f35205 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,16 +1,24 @@ Package: bmd Type: Package Title: Benchmark dose estimation for dose-response data -Version: 2.6.7 -Date: 2024-12-11 +Version: 2.7.1 +Date: 2025-03-24 Author: Signe M.Jensen, Christian Ritz and Jens Riis Baalkilde Maintainer: Signe M. Jensen Description: Benchmark dose analysis for continuous, quantal, count and ordinal dose-response data Imports: drc, ggplot2, dplyr Suggests: + sandwich, CVXR, multcomp, gridExtra, + isotone, + reshape2, + dplyr, + car, + Matrix, + RLRsim, + scales, testthat (>= 3.0.0) License: GPL Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index d78da81..a1e6ce4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,11 +1,13 @@ import(drc, ggplot2, dplyr) export(bmd, bmdBoot, bmdIso, bmdIsoBoot, PAV, bmdMA, bootDataGen, bmdMACurve, BCa, invBmd, expandBinomial, - getStackingWeights, drmOrdinal, bmdOrdinal, bmdOrdinalMA, expandOrdinal, bootDataGenOrdinal, + getStackingWeights, drmOrdinal, bmdOrdinal, bmdOrdinalMA, + expandOrdinal, bootDataGenOrdinal, qplotDrc, qplotBmd, MACurve, monotonicityTest, trendTest, bmdHetVar, drmHetVar) ## S3 methods S3method(logLik, drcOrdinal) S3method(AIC, drcOrdinal) +S3method(BIC, drcOrdinal) S3method(plot, drcOrdinal) S3method(print, drcOrdinal) S3method(print, bmdOrdinal) diff --git a/R/BIC.drcOrdinal.R b/R/BIC.drcOrdinal.R new file mode 100644 index 0000000..d804be5 --- /dev/null +++ b/R/BIC.drcOrdinal.R @@ -0,0 +1,5 @@ +BIC.drcOrdinal <- function(object, epsilon = 10^(-16)){ + n.parameters <- sum(sapply(object$drmList, function(mod) length(mod$coefficients))) + n.obs <- sum(object$data[[object$weights]]) + n.parameters * log(n.obs) - 2 * logLik(object, epsilon) +} diff --git a/R/ED.bmd.R b/R/ED.bmd.R index e5d19fe..72df021 100644 --- a/R/ED.bmd.R +++ b/R/ED.bmd.R @@ -1,177 +1,177 @@ -ED.bmd <- function(object, - respLev, - interval = c("none", "delta", "fls", "tfls", "inv"), - clevel = NULL, - level = ifelse(!(interval == "none"), 0.95, NULL), - reference = c("control", "upper"), - type = c("relative", "absolute"), - lref, uref, bound = TRUE, - vcov. = vcov, - display = TRUE, - logBase = NULL, - multcomp = FALSE, - intType = "confidence", ...) -{ - interval <- match.arg(interval) - reference <- match.arg(reference) - type <- match.arg(type) - - ## Checking 'respLev' vector: it should be numbers between 0 and 100 - if ( (type == "relative") && (bound) ) - { - if (any(respLev <= 0 | respLev >= 100)) - { - stop("Response levels (percentages) outside the interval ]0, 100[ not allowed") - } - } - - ## Retrieving relevant quantities - EDlist <- object$fct[["edfct"]] - if (is.null(EDlist)) {stop("ED values cannot be calculated")} - indexMat <- object[["indexMat"]] - parmMat <- object[["parmMat"]] - - curveNames <- colnames(parmMat) # colnames(object$"parmMat") - options(warn = -1) # switching off warnings caused by coercion in the if statement - if (any(is.na(as.numeric(curveNames)))) - { - curveOrder <- order(curveNames) - } else { # if names are numbers then skip re-ordering - curveOrder <- 1:length(curveNames) - } - options(warn = 0) # normalizing behaviour of warnings - - strParm0 <- curveNames[curveOrder] - indexMat <- indexMat[, curveOrder, drop = FALSE] - parmMat <- parmMat[, curveOrder, drop = FALSE] - - strParm <- strParm0 - #vcMat <- vcov.(object) - if (is.function(vcov.)) # following a suggestion by Andrea Onofri - { - vcMat <- vcov.(object) - } else { - vcMat <- vcov. - } - - ## Defining vectors and matrices needed - ncolIM <- ncol(indexMat) - indexVec <- 1:ncolIM - # lenEB <- ncolIM - lenPV <- length(respLev) # used twice below - noRows <- ncolIM * lenPV - dimNames <- rep("", noRows) # lenEB*lenPV, 2) - EDmat <- matrix(0, noRows, 2) # lenEB*lenPV, 2) - oriMat <- matrix(0, noRows, 2) # lenEB*lenPV, 2) - pmodelsMatrixList <- getpmodelsMatrixList(object) - - ## Skipping curve id if only one curve is present - if (identical(length(unique(strParm)), 1)) - { - strParm[indexVec] <- rep("", ncolIM) - } else { - strParm <- paste(strParm, ":", sep = "") - } - - ## Calculating estimates and estimated standard errors - rowIndex <- 1 - lenIV <- length(indexVec) - # dEDmat <- matrix(0, lenPV * lenIV, nrow(vcMat)) - intMat <- NULL - for (i in indexVec) - { - parmChosen <- parmMat[, i] - #parmInd <- indexMat[, i] - #varCov <- vcMat[parmInd, parmInd] - varCov <- pmodelsMatrixList[[curveNames[i]]] %*% vcMat %*% t(pmodelsMatrixList[[curveNames[i]]]) - - if ((is.null(clevel)) || (strParm0[i] %in% clevel)) - { - for (j in 1:lenPV) - { - EDeval <- EDlist(parmChosen, respLev[j], reference = reference, type = type, ...) - EDval <- EDeval[[1]] - dEDval <- EDeval[[2]] - # dEDmat[(i-1)*lenPV + j, parmInd] <- dEDval - - oriMat[rowIndex, 1] <- EDval - oriMat[rowIndex, 2] <- sqrt(dEDval %*% varCov %*% dEDval) - - if (!is.null(logBase)) - { - EDval <- logBase^(EDval) - dEDval <- EDval * log(logBase) * dEDval - } - EDmat[rowIndex, 1] <- EDval - EDmat[rowIndex, 2] <- sqrt(dEDval %*% varCov %*% dEDval) - - dimNames[rowIndex] <- paste(strParm[i], respLev[j], sep = "") - rowIndex <- rowIndex + 1 - } - if (interval == "inv") - { - intMat <- rbind(intMat, t(EDinvreg1(object, respLev, strParm0[i], - intType = intType, level = level, type = type))) - } - - } else { - rowsToRemove <- rowIndex:(rowIndex + lenPV - 1) - EDmat <- EDmat[-rowsToRemove, , drop = FALSE] - dimNames <- dimNames[-rowsToRemove] - } - - } - - ## Defining column names - colNames <- c("Estimate", "Std. Error") - - ## Calculating the confidence intervals - if (interval == "delta") - { - intMat <- drc:::confint.basic(EDmat, level, object$"type", df.residual(object), FALSE) - intLabel <- "Delta method" - } - - if (interval == "tfls") - { - intMat <- exp(drc:::confint.basic(matrix(c(log(oriMat[, 1]), oriMat[, 2] / oriMat[, 1]), ncol = 2), - level, object$"type", df.residual(object), FALSE)) - intLabel <- "To and from log scale" - } - - if (interval == "fls") - { - if (is.null(logBase)) - { - logBase <- exp(1) - EDmat[, 1] <- exp(EDmat[, 1]) # back-transforming log ED values - } - - intMat <- logBase^(drc:::confint.basic(oriMat, level, object$"type", df.residual(object), FALSE)) - intLabel <- "Back-transformed from log scale" - - ## Dropping estimated standard errors (not relevant after back transformation) - EDmat <- EDmat[, -2, drop = FALSE] - colNames <- colNames[-2] - # colNames <- c(colNames[-2], "Lower", "Upper") # standard errors not relevant - } - - if (interval == "inv") - { - EDmat <- EDmat[, -2, drop = FALSE] - colNames <- colNames[-2] - intLabel <- "Inverse regression" - } - - if (identical(interval, "none")) - { - intLabel <- NULL - } else { - EDmat <- as.matrix(cbind(EDmat, intMat)) - colNames <- c(colNames, "Lower", "Upper") - } - dimnames(EDmat) <- list(dimNames, colNames) - rownames(EDmat) <- paste("e", rownames(EDmat), sep = ":") - - EDmat -} +# ED.bmd <- function(object, +# respLev, +# interval = c("none", "delta", "fls", "tfls", "inv"), +# clevel = NULL, +# level = ifelse(!(interval == "none"), 0.95, NULL), +# reference = c("control", "upper"), +# type = c("relative", "absolute"), +# lref, uref, bound = TRUE, +# vcov. = vcov, +# display = TRUE, +# logBase = NULL, +# multcomp = FALSE, +# intType = "confidence", ...) +# { +# interval <- match.arg(interval) +# reference <- match.arg(reference) +# type <- match.arg(type) +# +# ## Checking 'respLev' vector: it should be numbers between 0 and 100 +# if ( (type == "relative") && (bound) ) +# { +# if (any(respLev <= 0 | respLev >= 100)) +# { +# stop("Response levels (percentages) outside the interval ]0, 100[ not allowed") +# } +# } +# +# ## Retrieving relevant quantities +# EDlist <- object$fct[["edfct"]] +# if (is.null(EDlist)) {stop("ED values cannot be calculated")} +# indexMat <- object[["indexMat"]] +# parmMat <- object[["parmMat"]] +# +# curveNames <- colnames(parmMat) # colnames(object$"parmMat") +# options(warn = -1) # switching off warnings caused by coercion in the if statement +# if (any(is.na(as.numeric(curveNames)))) +# { +# curveOrder <- order(curveNames) +# } else { # if names are numbers then skip re-ordering +# curveOrder <- 1:length(curveNames) +# } +# options(warn = 0) # normalizing behaviour of warnings +# +# strParm0 <- curveNames[curveOrder] +# indexMat <- indexMat[, curveOrder, drop = FALSE] +# parmMat <- parmMat[, curveOrder, drop = FALSE] +# +# strParm <- strParm0 +# #vcMat <- vcov.(object) +# if (is.function(vcov.)) # following a suggestion by Andrea Onofri +# { +# vcMat <- vcov.(object) +# } else { +# vcMat <- vcov. +# } +# +# ## Defining vectors and matrices needed +# ncolIM <- ncol(indexMat) +# indexVec <- 1:ncolIM +# # lenEB <- ncolIM +# lenPV <- length(respLev) # used twice below +# noRows <- ncolIM * lenPV +# dimNames <- rep("", noRows) # lenEB*lenPV, 2) +# EDmat <- matrix(0, noRows, 2) # lenEB*lenPV, 2) +# oriMat <- matrix(0, noRows, 2) # lenEB*lenPV, 2) +# pmodelsMatrixList <- getpmodelsMatrixList(object) +# +# ## Skipping curve id if only one curve is present +# if (identical(length(unique(strParm)), 1)) +# { +# strParm[indexVec] <- rep("", ncolIM) +# } else { +# strParm <- paste(strParm, ":", sep = "") +# } +# +# ## Calculating estimates and estimated standard errors +# rowIndex <- 1 +# lenIV <- length(indexVec) +# # dEDmat <- matrix(0, lenPV * lenIV, nrow(vcMat)) +# intMat <- NULL +# for (i in indexVec) +# { +# parmChosen <- parmMat[, i] +# #parmInd <- indexMat[, i] +# #varCov <- vcMat[parmInd, parmInd] +# varCov <- pmodelsMatrixList[[curveNames[i]]] %*% vcMat %*% t(pmodelsMatrixList[[curveNames[i]]]) +# +# if ((is.null(clevel)) || (strParm0[i] %in% clevel)) +# { +# for (j in 1:lenPV) +# { +# EDeval <- EDlist(parmChosen, respLev[j], reference = reference, type = type, ...) +# EDval <- EDeval[[1]] +# dEDval <- EDeval[[2]] +# # dEDmat[(i-1)*lenPV + j, parmInd] <- dEDval +# +# oriMat[rowIndex, 1] <- EDval +# oriMat[rowIndex, 2] <- sqrt(dEDval %*% varCov %*% dEDval) +# +# if (!is.null(logBase)) +# { +# EDval <- logBase^(EDval) +# dEDval <- EDval * log(logBase) * dEDval +# } +# EDmat[rowIndex, 1] <- EDval +# EDmat[rowIndex, 2] <- sqrt(dEDval %*% varCov %*% dEDval) +# +# dimNames[rowIndex] <- paste(strParm[i], respLev[j], sep = "") +# rowIndex <- rowIndex + 1 +# } +# if (interval == "inv") +# { +# intMat <- rbind(intMat, t(EDinvreg1(object, respLev, strParm0[i], +# intType = intType, level = level, type = type))) +# } +# +# } else { +# rowsToRemove <- rowIndex:(rowIndex + lenPV - 1) +# EDmat <- EDmat[-rowsToRemove, , drop = FALSE] +# dimNames <- dimNames[-rowsToRemove] +# } +# +# } +# +# ## Defining column names +# colNames <- c("Estimate", "Std. Error") +# +# ## Calculating the confidence intervals +# if (interval == "delta") +# { +# intMat <- drc:::confint.basic(EDmat, level, object$"type", df.residual(object), FALSE) +# intLabel <- "Delta method" +# } +# +# if (interval == "tfls") +# { +# intMat <- exp(drc:::confint.basic(matrix(c(log(oriMat[, 1]), oriMat[, 2] / oriMat[, 1]), ncol = 2), +# level, object$"type", df.residual(object), FALSE)) +# intLabel <- "To and from log scale" +# } +# +# if (interval == "fls") +# { +# if (is.null(logBase)) +# { +# logBase <- exp(1) +# EDmat[, 1] <- exp(EDmat[, 1]) # back-transforming log ED values +# } +# +# intMat <- logBase^(drc:::confint.basic(oriMat, level, object$"type", df.residual(object), FALSE)) +# intLabel <- "Back-transformed from log scale" +# +# ## Dropping estimated standard errors (not relevant after back transformation) +# EDmat <- EDmat[, -2, drop = FALSE] +# colNames <- colNames[-2] +# # colNames <- c(colNames[-2], "Lower", "Upper") # standard errors not relevant +# } +# +# if (interval == "inv") +# { +# EDmat <- EDmat[, -2, drop = FALSE] +# colNames <- colNames[-2] +# intLabel <- "Inverse regression" +# } +# +# if (identical(interval, "none")) +# { +# intLabel <- NULL +# } else { +# EDmat <- as.matrix(cbind(EDmat, intMat)) +# colNames <- c(colNames, "Lower", "Upper") +# } +# dimnames(EDmat) <- list(dimNames, colNames) +# rownames(EDmat) <- paste("e", rownames(EDmat), sep = ":") +# +# EDmat +# } diff --git a/R/MACurve.R b/R/MACurve.R index d88e555..46d219d 100644 --- a/R/MACurve.R +++ b/R/MACurve.R @@ -1,13 +1,13 @@ -MACurve <- function(x, modelList, modelWeights, stackingSeed = 1){ +MACurve <- function(x, modelList, modelWeights, stackingSeed = 1, stackingSplits = 2){ # compute weights if(identical(modelWeights,"AIC")){ - modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))/ - sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))) + modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)/ + sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)) } else if(identical(modelWeights,"BIC")){ - modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))/ - sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))) + modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)/ + sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)) } else if(identical(modelWeights, "Stack")){ # If stackingSeed supplied, save initial seed for later, and set seed for stacking if (!is.null(stackingSeed)) { @@ -16,7 +16,7 @@ MACurve <- function(x, modelList, modelWeights, stackingSeed = 1){ } # estimate weights - modelWeights0 <- getStackingWeights(modelList) + modelWeights0 <- getStackingWeights(modelList, nSplits = stackingSplits) # If stackingSeed supplied, restore initial seed if (!is.null(stackingSeed)) { diff --git a/R/bmd.R b/R/bmd.R index 3c4091e..de49a1f 100644 --- a/R/bmd.R +++ b/R/bmd.R @@ -8,7 +8,7 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " if (missing(object)){ stop(paste("object is missing", sep="")) } else { - if(!inherits(object, "drc")){ stop('object must be of type "drc"')} + if(!inherits(object, "drc")){ stop('object must be of class "drc"')} } if (missing(def)) { stop(paste("def is missing", sep="")) @@ -33,10 +33,18 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " sandwich.vcov <- TRUE interval <- "delta" } + if(sandwich.vcov & !require("sandwich")){ + stop('package "sandwich" must be installed to compute sandwich confidence intervals') + } respTrans <- match.arg(respTrans) - # if(!identical(respTrans, "none") & (def %in% c("hybridExc","hybridAdd"))){ - # stop(paste("Transformed response not available when using the hybrid method.", sep="")) - # } + + if(class(object$fct) == "braincousens" & is.null(object$fct$fixed)){ + if(object$fct$name == "BC.4"){ + object$fct$fixed <- c(NA, 0, NA, NA, NA) + } else if(object$fct$name == "BC.5"){ + object$fct$fixed <- c(NA, NA, NA, NA, NA) + } + } # Extract information from model # EDlist <- object$fct[["edfct"]] # Change after drc package has been updated with with edfct @@ -68,7 +76,7 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " if(interval == "delta"){ if(sandwich.vcov){ - varCov <- sandwich(object) + varCov <- sandwich::sandwich(object) } else { varCov <- vcov(object) } @@ -82,6 +90,10 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " if(is.na(object$curve[[1]](0)-object$curve[[1]](Inf))){ slope <- drop(ifelse(object$curve[[1]](0.00000001)-object$curve[[1]](100000000)>0,"decreasing","increasing")) } + # useSD + if(def %in% c("hybridAdd","hybridExc")){ + useSD <- ifelse(!is.na(controlSD),controlSD,sqrt(summary(object)$resVar)) + } intMat <- invBmd(object, bmr, level = level, slope=slope, backgType=backgType, backg=backg, catLev=NA, extFactor=10, def=def, useSD=useSD, @@ -131,7 +143,7 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", " # CURVES ARE NOT FITTED INDEPENDENTLY curveNames <- colnames(parmMat) if(sandwich.vcov){ - vcMat <- sandwich(object) + vcMat <- sandwich::sandwich(object) } else { vcMat <- vcov(object) } diff --git a/R/bmdBoot.R b/R/bmdBoot.R index 118a232..dfebee3 100644 --- a/R/bmdBoot.R +++ b/R/bmdBoot.R @@ -7,17 +7,59 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or respTrans = c("none", "log", "sqrt"), bootInterval = c("percentile","BCa"), display=TRUE, level=0.95){ + # Assertions + if (missing(object)){ + stop(paste("object is missing", sep="")) + } else { + if(!inherits(object, "drc")){ stop('object must be of class "drc"')} + } + if (missing(def)) { + stop(paste("def is missing", sep="")) + } + if(def=="point"){ + backgType <- "modelBased" + } + if (missing(backgType)) { + stop(paste("backgType is missing", sep="")) + } + if (!(def %in% c("excess", "additional", "relative", "extra", "added", "hybridExc", "hybridAdd", "point"))) { + stop(paste("Could not recognize def", sep="")) + } + if (!(backgType %in% c("modelBased","absolute","hybridSD","hybridPercentile"))) { + stop(paste("Could not recognize backgType", sep="")) + } + if (identical(object$type,"binomial") & bootType=="semiparametric") { - stop(paste("\"Semiparametric bootstrap does not work for quantal data\"", sep="")) + stop(paste("\"Semiparametric bootstrap does not work for quantal data", sep="")) } if (object$type %in% c("Poisson","negbin1","negbin2") & bootType!="nonparametric") { - stop(paste("\"",object$type,"\" only works with nonparametric bootstrap\"", sep="")) + stop(paste("\"",object$type,"\" only works with nonparametric bootstrap", sep="")) + } + + respTrans <- match.arg(respTrans) + + if(class(object$fct) == "braincousens" & is.null(object$fct$fixed)){ + if(object$fct$name == "BC.4"){ + object$fct$fixed <- c(NA, 0, NA, NA, NA) + } else if(object$fct$name == "BC.5"){ + object$fct$fixed <- c(NA, NA, NA, NA, NA) + } } + # Set level + level <- 1-2*(1-level) + + # bmd on original data + bmd0 <- bmd(object = object, bmr = bmr, backgType = backgType, + backg=backg, controlSD=controlSD, def = def, respTrans = respTrans, + interval = "delta", display = FALSE) + get.drm.list <- function(tmp.data){ if(ncol(object$parmMat) == 1){ drm.list.tmp <- lapply(tmp.data, function(x){ - try(drm(object$call$formula, data = x, type = object$type, fct = object[["fct"]]), TRUE) + try(eval(substitute(drm(formula0, data = x, type = object$type, fct = object[["fct"]]), + list(formula0 = object$call$formula) + )), TRUE) } ) } else if(is.null(object$call$pmodels)){ @@ -39,9 +81,10 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or x[[as.character(object$call$curveid)]] <- x[[paste0("orig.", as.character(object$call$curveid))]] } try( - eval(substitute(drm(object$call$formula, weights = weights0, curveid = curveid0,pmodels = pmodels0, + eval(substitute(drm(formula0, weights = weights0, curveid = curveid0,pmodels = pmodels0, data = x, type = object$type, fct = object$fct, control = drmc(noMessage = TRUE)), - list(weights0 = object$call$weights, + list(formula0 = object$call$formula, + weights0 = object$call$weights, curveid0 = object$call$curveid, pmodels0 = object$call$pmodels) )), @@ -69,7 +112,7 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or drm.list <- drm.list.tmp[list.condition] bmd.list.try <- lapply(drm.list,get.bmd) - bmd.list <- bmd.list.try[!sapply(bmd.list.try, function(x) any(is.na(x)))] + bmd.list <- suppressWarnings(bmd.list.try[!sapply(bmd.list.try, function(x) any(is.na(as.numeric(x))))]) } if (object$type %in% c("Poisson","negbin1","negbin2")) { @@ -169,12 +212,13 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or jackData <- list() for(i in 1:(dim(data.e)[1])){ - jackData[[i]] <- data.e[-i,] + # jackData[[i]] <- data.e[-i,] + jackData[[i]] <- df[-i,] } - bootJack.drm.tmp <- lapply(jackData, function(x){ - try(drm(number~dose, data = x, type = "binomial", fct = object[["fct"]]),TRUE) - }) + # bootJack.drm.tmp <- lapply(jackData, function(x){ + # try(drm(as.formula(paste0("number~", as.character(object$call$formula[[3]]))), data = x, type = "binomial", fct = object[["fct"]]),TRUE) # number~dose + # }) bootJack.drm.tmp <- get.drm.list(jackData) list.condition <- sapply(bootJack.drm.tmp, function(x) class(x)=="drc") bootJack.drm<- bootJack.drm.tmp[list.condition] @@ -194,9 +238,9 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or use.bmd <- get.bmd(object) if(ncol(object$parmMat)==1){ - BCaBMDL <- as.numeric(BCa(obs = use.bmd, data = object$data, unlist(bmd.list), unlist(bootJack.list), level=level)[1]) + BCaBMDL <- as.numeric(BCa(obs = use.bmd, data = df, unlist(bmd.list), unlist(bootJack.list), level=level)[1]) } else { - BCaBMDL <- sapply(1:ncol(object$parmMat), function(i) as.numeric(BCa(obs = use.bmd[i], data = object$data, + BCaBMDL <- sapply(1:ncol(object$parmMat), function(i) as.numeric(BCa(obs = use.bmd[i], data = df, sapply(bmd.list, function(x) x[i]), sapply(bootJack.list, function(x) x[i]), level = level)[1])) } @@ -240,7 +284,11 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or } } if(bmdType == "orig"){ - use.bmd <- get.bmd(object) # bmd(object, bmr = bmr, backgType = backgType, backg=backg, def=def, controlSD=controlSD, respTrans = respTrans, display=FALSE, level=level)[["Results"]][,1] + if(ncol(object$parmMat) == 1){ + use.bmd <- bmd0[["Results"]][1] + } else { + use.bmd <- bmd0[["Results"]][colnames(object$parmMat), 1] + } } else if(bmdType == "mean"){ if(ncol(object$parmMat) == 1){ use.bmd <- mean(unlist(bmd.list)) @@ -282,18 +330,25 @@ bmdBoot <- function(object, bmr, R=1000, bootType="nonparametric", bmdType = "or if(ncol(object$parmMat) == 1){ rownames(resMat) <- c("") rownames(intMat) <- c("") + bootEst = unlist(bmd.list) + used.Boot <- sum(!is.na(bootEst)) } else { rownames(resMat) <- colnames(object$parmMat) rownames(intMat) <- colnames(object$parmMat) + bootEst <- matrix(unlist(bmd.list), byrow = TRUE, ncol = ncol(object$parmMat), dimnames = list(NULL, colnames(object$parmMat))) + used.Boot <- sum(sapply(bmd.list, function(x) all(!is.na(x)))) } if(display){ print(resMat) } + used.Boot <- sum(sapply(bmd.list, function(x) all(!is.na(x)))) + resBMD<-list(Results = resMat, - bootEst = unlist(bmd.list), - Interval = intMat) + Boot.samples.used = used.Boot, + bootEst = bootEst, + interval = intMat) class(resBMD) <- "bmd" invisible(resBMD) } \ No newline at end of file diff --git a/R/bmdHetVar.R b/R/bmdHetVar.R index 7be5d51..4135b85 100644 --- a/R/bmdHetVar.R +++ b/R/bmdHetVar.R @@ -21,13 +21,18 @@ bmdHetVar <- function(object, bmr, backgType = c("absolute", "hybridSD", "hybrid # backgType if (missing(backgType)) { - stop(paste("backgType is missing", sep="")) - } - if (!(def %in% c("hybridExc", "hybridAdd"))) { - stop(paste("Could not recognize def", sep="")) + stop('backgType is missing. Options are "absolute", "hybridSD" or "hybridPercentile"') } if (!(backgType %in% c("absolute","hybridSD","hybridPercentile"))) { - stop(paste("Could not recognize backgType", sep="")) + stop('Could not recognize backgType. Options are "absolute", "hybridSD" or "hybridPercentile"') + } + + # def + if(missing(def)){ + stop('def is missing. Options are "hybridExc" or "hybridAdd"') + } + if(!def %in% c("hybridExc", "hybridAdd")){ + stop('Could not recognize def. Options are "hybridExc" or "hybridAdd"') } level <- 1-2*(1-level) diff --git a/R/bmdIsoBoot.R b/R/bmdIsoBoot.R index b2343fa..b2b1498 100644 --- a/R/bmdIsoBoot.R +++ b/R/bmdIsoBoot.R @@ -67,11 +67,11 @@ bmdIsoBoot <- function(object, data, type, bmr, R=1000, boot="resample", bmdIso(object, data=x, type=type, bmr = bmr, backgType = backgType, backg=backg,def=def)}) resMat <- matrix(NA,1,2) - resMat[1,] <- quantile(unlist(bmd.list),c(0.5,0.05)) + resMat[1,1] <- bmdIso(object, data=data, type=type, bmr = bmr, backgType = backgType, backg=backg,def=def) # quantile(unlist(bmd.list),0.5) + resMat[1,2] <- quantile(unlist(bmd.list),0.05) colnames(resMat) <- c("BMD", "BMDL") rownames(resMat) <- c("") cat("\n\n") resMat - } diff --git a/R/bmdMA.R b/R/bmdMA.R index 28afcea..0365aae 100644 --- a/R/bmdMA.R +++ b/R/bmdMA.R @@ -12,21 +12,38 @@ bmdMA <- function(modelList, modelWeights, bmr, level=0.95, stackingSeed = NULL, stackingSplits = 2, display=TRUE, progressInfo = TRUE){ + # assertions + if(!all(sapply(modelList, function(x) inherits(x, "drc")))){ + stop('modelList must be a list of models of class "drc"') + } + + if(missing(def)) { + stop(paste("def is missing", sep="")) + } + + if(!modelWeights[1] %in% c("AIC", "BIC", "Stack", "Stacking")){ + if(!(inherits(modelWeights, "numeric") & length(modelWeights) == length(modelList))){ + stop('modelWeights must either be "AIC", "BIC", "Stack", "Stacking" or a numeric vector of same length as modelList') + } + } + + if(all(type == c("curve","bootstrap","Kang","Buckland")) | sum(type[1] == c("curve","bootstrap", "Bootstrap", "Kang","Buckland")) != 1){ + stop('Specify model averaging type. Options are "curve", "bootstrap", "Kang" and "Buckland"') + } + + nCurves <- ncol(modelList[[1]]$parmMat) bmdList<-lapply(modelList, FUN=function(object){bmd(object, bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, - interval = interval, display=FALSE, level=level)}) - if(sum(type == c("curve","bootstrap", "Bootstrap","Kang","Buckland")) != 1){ - cat('Specify model averaging type. Options are "curve", "bootstrap", "Kang" and "Buckland"\n') - } + interval = interval, display=FALSE, level=level)}) if(nCurves == 1){ # Estimate weights if(identical(modelWeights,"AIC")){ - modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))/ - sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))) + modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)/ + sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)) } else if(identical(modelWeights,"BIC")){ - modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))/ - sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))) + modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)/ + sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)) } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ # If stackingSeed supplied, save initial seed for later, and set seed for stacking if (!is.null(stackingSeed)) { @@ -82,201 +99,74 @@ bmdMA <- function(modelList, modelWeights, bmr, bootData <- bootDataGen(modelList[[1]],R=R,boot="parametric") } - # if(!oldbootstrap){ - bmdMAboot <- function(data){ - bootModelList <- lapply(modelList, function(model) try( - eval(substitute(drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0), - list(formula0 = model$call$formula, - weights0 = model$call$weights, - start0 = coef(model)))), - silent = TRUE)) - - modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - - bootModelList <- bootModelList[!modelConvergenceError] - - if(length(modelWeights) > 1){ - bootModelWeights <- modelWeights[!modelConvergenceError] - } else { - bootModelWeights <- modelWeights - } - - bmdEst <- try(bmdMA(bootModelList, bootModelWeights, bmr = bmr, backgType = backgType, - backg = backg, def = def, respTrans = respTrans, interval = "delta", - type = "Kang", stackingSplits = stackingSplits, display = FALSE)$Results[,1], silent = TRUE) - as.numeric(bmdEst) - } + bmdMAboot <- function(data){ + bootModelList <- lapply(modelList, function(model) try( + eval(substitute(drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0), + list(formula0 = model$call$formula, + weights0 = model$call$weights, + start0 = coef(model)))), + silent = TRUE)) - bootBmdEst <- numeric(length(bootData)) + modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - if(progressInfo){ - cat("Performing bootstrap\n") - maxIter <- ifelse(bootInterval == "BCa", R + modelList[[1]]$sumList$lenData, R) - pb <- txtProgressBar(min = 0, max = maxIter, style = 3) - } + bootModelList <- bootModelList[!modelConvergenceError] - for(i in 1:length(bootData)){ - bootBmdEst[i] <- bmdMAboot(bootData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i) + if(length(modelWeights) > 1){ + bootModelWeights <- modelWeights[!modelConvergenceError] + } else { + bootModelWeights <- modelWeights } - if(progressInfo & (bootInterval != "BCa")) close(pb) - boot0<-bootBmdEst[!is.na(bootBmdEst)] + bmdEst <- try(bmdMA(bootModelList, bootModelWeights, bmr = bmr, backgType = backgType, + backg = backg, def = def, respTrans = respTrans, interval = "delta", + type = "Kang", stackingSplits = stackingSplits, display = FALSE)$Results[,1], silent = TRUE) + as.numeric(bmdEst) + } + + bootBmdEst <- numeric(length(bootData)) + + if(progressInfo){ + cat("Performing bootstrap\n") + maxIter <- ifelse(bootInterval == "BCa", R + modelList[[1]]$sumList$lenData, R) + pb <- txtProgressBar(min = 0, max = maxIter, style = 3) + } + + for(i in 1:length(bootData)){ + bootBmdEst[i] <- bmdMAboot(bootData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i) + } + if(progressInfo & (bootInterval != "BCa")) close(pb) + + boot0<-bootBmdEst[!is.na(bootBmdEst)] + + if(length(boot0) == 0){ + maBMDL <- NA + maBMDU <- NA + } else { + if(bootInterval %in% c("percentile","Percentile")){ + maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. + maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + } - if(length(boot0) == 0){ - maBMDL <- NA - maBMDU <- NA - } else { - if(bootInterval %in% c("percentile","Percentile")){ - maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + if(identical(bootInterval,"BCa")){ + jackData <- list() + for(i in 1:(dim(modelList[[1]]$data)[1])){ + jackData[[i]] <- modelList[[1]]$data[-i,] } - if(identical(bootInterval,"BCa")){ - jackData <- list() - for(i in 1:(dim(modelList[[1]]$data)[1])){ - jackData[[i]] <- modelList[[1]]$data[-i,] - } - - jackBmdEst <- numeric(length(jackData)) - for(i in 1:length(jackData)){ - jackBmdEst[i] <- bmdMAboot(jackData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i + R) - } - if(progressInfo) close(pb) - - bootjack<-jackBmdEst[!is.na(jackBmdEst)] - - maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - maBMDU <- "Not available for BCa bootstrap" + jackBmdEst <- numeric(length(jackData)) + for(i in 1:length(jackData)){ + jackBmdEst[i] <- bmdMAboot(jackData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i + R) } + if(progressInfo) close(pb) + + bootjack<-jackBmdEst[!is.na(jackBmdEst)] + + maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) + maBMDU <- "Not available for BCa bootstrap" } - # } - - # if(oldbootstrap){ - # drmModelListTmp <-list() - # for(i in 1:length(modelList)){ - # drmModelListTmp[[i]] <- which(!sapply(lapply(bootData, function(x){ - # try(drm(modelList[[i]]$call$formula, data = x, fct = modelList[[i]][["fct"]]),TRUE) - # } - # ),function(x) class(x)=="drc")) - # } - # - # non.convergence<-unique(unlist(drmModelListTmp)) - # if(length(non.convergence)>0){ - # bootData<-bootData[-non.convergence] - # } - # bootModelList <-list() - # for(i in 1:length(modelList)){ - # bootModelList[[i]] <- lapply(bootData, function(x){ - # suppressWarnings( - # eval(substitute(drm(formula, data = x, fct = fct0), - # list(formula = modelList[[i]]$call$formula, - # fct0 = modelList[[i]][["fct"]])) - # ) # Fitting models using substitute is necessary for Stacking weights - # ) - # } - # ) - # } - # - # bootModelListTrans <- lapply(1:length(bootModelList[[1]]), function(i) lapply(bootModelList, "[[", i)) - # - # # Compute weights on boot samples - # if(identical(modelWeights,"AIC")){ - # AICList <-suppressWarnings(lapply(bootData, function(x) sapply(modelList, function(y) {AIC(my.fun(x,y))}))) - # AICtmp <- do.call(rbind,AICList) - # modelWeights0 <- t(t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # } else if(identical(modelWeights,"BIC")){ - # BICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(BIC(my.fun(x,y))))) - # BICtmp <- do.call(rbind,BICList) - # modelWeights0 <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else if(identical(modelWeights, "Stack")){ - # StackList <- lapply(bootModelListTrans, function(x) getStackingWeights(x, stackingSplits)) - # modelWeights0 <- do.call(cbind, StackList) - # } else { - # modelWeights0 <- do.call(cbind,rep(list(modelWeights),R)) - # } - # - # # Estimate BMD in all models on boot samples - # bootbmdList<-list() - # for(i in 1:length(modelList)){ - # bootbmdList[[i]] <- lapply(bootModelList[[i]], function(bootMod){ - # try(bmd(bootMod, - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$Results[1,1], silent = TRUE) - # } - # ) - # } - # bootbmdErrorList <- list() - # for(i in 1:length(modelList)){ - # bootbmdErrorList[[i]] <- which(!sapply(bootbmdList[[i]],function(x) class(x)=="numeric")) - # } - # - # bmd.non.convergence<-unique(unlist(bootbmdErrorList)) - # if(length(bmd.non.convergence) == length(bootData)){ - # maBMDL <- NA - # maBMDU <- NA - # } else { - # if(length(bmd.non.convergence)>0){ - # for(i in 1:length(modelList)){ - # bootbmdList[[i]]<-bootbmdList[[i]][-bmd.non.convergence] - # modelWeights0 <- modelWeights0[,-bmd.non.convergence] - # } - # } - # - # boot<-diag(t(matrix(unlist(bootbmdList), ncol = R - length(bmd.non.convergence), byrow = TRUE)) %*% modelWeights0) - # boot0<-boot[!is.na(boot)] - # - # if(bootInterval %in% c("percentile","Percentile")){ - # maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - # maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) - # } - # if(identical(bootInterval,"BCa")){ - # jackData <- list() - # for(i in 1:(dim(modelList[[1]]$data)[1])){ - # jackData[[i]] <- modelList[[1]]$data[-i,] - # } - # bootJackList <-list() - # for(i in 1:length(modelList)){ - # bootJackList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(bmd(drm(modelList[[i]]$call$formula, data = x, type = modelList[[i]]$type, - # fct = modelList[[i]][["fct"]]), - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$Results[1]) - # } - # ) - # } - # if(identical(modelWeights,"AIC")){ - # AICJackList <-list() - # for(i in 1:length(modelList)){ - # AICJackList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(AIC(drm(modelList[[i]]$call$formula, data = x, type = modelList[[i]]$type, fct = modelList[[i]][["fct"]]))) - # } - # ) - # } - # AICtmp <- do.call(rbind,AICJackList) - # modelWeightsJack <- t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp))))) - # } else if(identical(modelWeights,"BIC")){ - # BICJackList <-list() - # for(i in 1:length(modelList)){ - # BICJackList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(BIC(drm(modelList[[i]]$call$formula, data = x, type = modelList[[i]]$type, fct = modelList[[i]][["fct"]]))) - # } - # ) - # } - # BICtmp <- do.call(rbind,BICJackList) - # modelWeightsJack <- t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp))))) - # } else { - # modelWeightsJack <- do.call(cbind,rep(list(modelWeights),dim(modelList[[1]]$data)[1])) - # } - # - # bootjack<-diag(t(do.call(rbind,bootJackList)) %*% modelWeightsJack) - # - # maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - # maBMDU <- "Not available for BCa bootstrap" - # } - # } - # } + } } if(identical(type,"curve")){ @@ -292,213 +182,91 @@ bmdMA <- function(modelList, modelWeights, bmr, bootData <- bootDataGen(modelList[[1]],R=R,boot="parametric") } - # if(!oldbootstrap){ - bmdMACurveboot <- function(data){ - bootModelList <- lapply(modelList, function(model){try( - eval(substitute( - drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = model$type), - list(formula0 = model$call$formula, - weights0 = model$call$weights, - start0 = coef(model)))), - silent = TRUE) - }) - - modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - - bootModelList <- bootModelList[!modelConvergenceError] - bootBmdList <- lapply(bootModelList, - function(object){ - try(bmd(object, bmr = bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, - interval = "delta", display=FALSE), silent = TRUE)}) - - # Estimate weights - if(identical(modelWeights,"AIC")){ - bootModelWeights0<-exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))/ - sum(exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))) - } else if(identical(modelWeights,"BIC")){ - bootModelWeights0<-exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))/ - sum(exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))) - } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ - # estimate weights - bootModelWeights0 <- getStackingWeights(bootModelList, stackingSplits) - } else { - bootModelWeights0 <- modelWeights[!modelConvergenceError] - } - - # bootBmrScaled0 <- colSums(bootModelWeights0 * t(sapply(bootBmdList, function(x){x$bmrScaled}))) - bootBmrScaled0 <- sum(sapply(bootBmdList, function(x){as.numeric(try(x$bmrScaled, TRUE))})*bootModelWeights0) - - # bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[,1], silent = TRUE) - bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[1], silent = TRUE) - as.numeric(bootBmdEst) - } + bmdMACurveboot <- function(data){ + bootModelList <- lapply(modelList, function(model){try( + eval(substitute( + drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = model$type), + list(formula0 = model$call$formula, + weights0 = model$call$weights, + start0 = coef(model)))), + silent = TRUE) + }) - bootBmdEst <- numeric(length(bootData)) + modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - if(progressInfo){ - cat("Performing bootstrap\n") - maxIter <- ifelse(bootInterval == "BCa", R + modelList[[1]]$sumList$lenData, R) - pb <- txtProgressBar(min = 0, max = maxIter, style = 3) - } + bootModelList <- bootModelList[!modelConvergenceError] + bootBmdList <- lapply(bootModelList, + function(object){ + try(bmd(object, bmr = bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, + interval = "delta", display=FALSE), silent = TRUE)}) - for(i in 1:length(bootData)){ - bootBmdEst[i] <- bmdMACurveboot(bootData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i) + # Estimate weights + if(identical(modelWeights,"AIC")){ + bootModelWeights0<-exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))/ + sum(exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))) + } else if(identical(modelWeights,"BIC")){ + bootModelWeights0<-exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))/ + sum(exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))) + } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ + # estimate weights + bootModelWeights0 <- getStackingWeights(bootModelList, stackingSplits) + } else { + bootModelWeights0 <- modelWeights[!modelConvergenceError] } - if(progressInfo & (bootInterval != "BCa")) close(pb) - boot0 <- bootBmdEst[!is.na(bootBmdEst)] + # bootBmrScaled0 <- colSums(bootModelWeights0 * t(sapply(bootBmdList, function(x){x$bmrScaled}))) + bootBmrScaled0 <- sum(sapply(bootBmdList, function(x){as.numeric(try(x$bmrScaled, TRUE))})*bootModelWeights0) - if(length(boot0) == 0){ - maBMDL <- NA - maBMDU <- NA - } else { - if(bootInterval %in% c("percentile","Percentile")){ - maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + # bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[,1], silent = TRUE) + bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[1], silent = TRUE) + as.numeric(bootBmdEst) + } + + bootBmdEst <- numeric(length(bootData)) + + if(progressInfo){ + cat("Performing bootstrap\n") + maxIter <- ifelse(bootInterval == "BCa", R + modelList[[1]]$sumList$lenData, R) + pb <- txtProgressBar(min = 0, max = maxIter, style = 3) + } + + for(i in 1:length(bootData)){ + bootBmdEst[i] <- bmdMACurveboot(bootData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i) + } + if(progressInfo & (bootInterval != "BCa")) close(pb) + + boot0 <- bootBmdEst[!is.na(bootBmdEst)] + + if(length(boot0) == 0){ + maBMDL <- NA + maBMDU <- NA + } else { + if(bootInterval %in% c("percentile","Percentile")){ + maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. + maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + } + + if(identical(bootInterval,"BCa")){ + jackData <- list() + for(i in 1:(dim(modelList[[1]]$data)[1])){ + jackData[[i]] <- modelList[[1]]$data[-i,] } - if(identical(bootInterval,"BCa")){ - jackData <- list() - for(i in 1:(dim(modelList[[1]]$data)[1])){ - jackData[[i]] <- modelList[[1]]$data[-i,] - } - - jackBmdEst <- numeric(length(jackData)) - - for(i in 1:length(jackData)){ - jackBmdEst[i] <- bmdMACurveboot(jackData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i + R) - } - if(progressInfo) close(pb) - - bootjack <- jackBmdEst[!is.na(jackBmdEst)] - - maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - maBMDU <- "Not available for BCa bootstrap" + jackBmdEst <- numeric(length(jackData)) + + for(i in 1:length(jackData)){ + jackBmdEst[i] <- bmdMACurveboot(jackData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i + R) } + if(progressInfo) close(pb) + + bootjack <- jackBmdEst[!is.na(jackBmdEst)] + + maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) + maBMDU <- "Not available for BCa bootstrap" } - # } - - # if(oldbootstrap){ - # drmModelListTmp <-list() - # for(i in 1:length(modelList)){ - # drmModelListTmp[[i]] <- which(!sapply(lapply(bootData, function(x){ - # try(drm(modelList[[i]]$call$formula, data = x, fct = modelList[[i]][["fct"]]),TRUE) - # } - # ),function(x) class(x)=="drc")) - # } - # - # non.convergence<-unique(unlist(drmModelListTmp)) - # if(length(non.convergence)>0){ - # bootData<-bootData[-non.convergence] - # } - # bootModelList <-list() - # for(i in 1:length(modelList)){ - # bootModelList[[i]] <- lapply(bootData, function(x){ - # suppressWarnings( - # eval(substitute(drm(formula, data = x, fct = fct0), - # list(formula = modelList[[i]]$call$formula, - # fct0 = modelList[[i]][["fct"]])) - # ) # Fitting models using substitute is necessary for Stacking weights - # ) - # } - # ) - # } - # - # bootModelListTrans <- lapply(1:length(bootModelList[[1]]), function(i) lapply(bootModelList, "[[", i)) - # - # if(identical(modelWeights,"AIC")){ - # AICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(AIC(my.fun(x,y))))) - # AICtmp <- do.call(rbind,AICList) - # modelWeights0 <- t(t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # } else if(identical(modelWeights,"BIC")){ - # BICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(BIC(my.fun(x,y))))) - # BICtmp <- do.call(rbind,BICList) - # modelWeights0 <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else if(identical(modelWeights, "Stack")){ - # modelWeightsList <- lapply(bootModelListTrans, function(x) getStackingWeights(x, stackingSplits)) - # } else { - # modelWeights0 <- do.call(cbind,rep(list(modelWeights),R)) - # } - # - # if(!identical(modelWeights, "Stack")){ - # modelWeightsList <- lapply(1:ncol(modelWeights0),function(i) modelWeights0[,i]) - # } - # - # bootbmrList<-list() - # for(i in 1:length(modelList)){ - # bootbmrList[[i]] <- sapply(bootModelList[[i]], function(bootMod){ - # as.numeric(try(bmd(bootMod, - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$bmrScaled, silent = TRUE)) - # } - # ) - # } - # bootbmrListTrans <- lapply(1:length(bootbmrList[[1]]), function(i) sapply(bootbmrList, "[[", i)) - # - # LLimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]]))[2]/10000 - # ULimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]],decreasing=TRUE))[1] - # funk<-function(x,y,z){try(bmdMACurve(x,y,z,searchInterval=c(LLimit,ULimit))$Results[1],TRUE)} - # bmrScaledList<-as.list(rowSums(do.call(rbind,modelWeightsList)*do.call(rbind,bootbmrListTrans))) - # - # boot<-mapply(funk,bootModelListTrans,modelWeightsList,bmrScaledList) - # boot0<-suppressWarnings(as.numeric(boot[!is.na(as.numeric(boot))])) - # - # if(bootInterval %in% c("percentile","Percentile")){ - # maBMDL <- quantile(boot0,p=c(1-level), na.rm = FALSE) # ABC percentile lims. - # maBMDU <- quantile(boot0,p=c(level), na.rm = FALSE) - # } - # if(identical(bootInterval,"BCa")){ - # jackData <- list() - # for(i in 1:(dim(modelList[[1]]$data)[1])){ - # jackData[[i]] <- modelList[[1]]$data[-i,] - # } - # - # bootJackModelList <- lapply(jackData, function(x) lapply(modelList, function(y) suppressWarnings(my.fun(x,y)))) - # - # - # if(identical(modelWeights,"AIC")){ - # AICJackList <-lapply(bootJackModelList, function(x) sapply(x, AIC))#lapply(jackData, function(x) sapply(modelList, function(y) suppressWarnings(AIC(my.fun(x,y))))) - # AICtmp <- do.call(rbind,AICJackList) - # modelWeightsJack <- t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp))))) - # } else if(identical(modelWeights,"BIC")){ - # BICJackList <-lapply(bootJackModelList, function(x) sapply(x, BIC))#lapply(jackData, function(x) sapply(modelList, function(y) suppressWarnings(BIC(my.fun(x,y))))) - # BICtmp <- do.call(rbind,BICJackList) - # modelWeightsJack <- t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp))))) - # } else { - # modelWeightsJack <- do.call(cbind,rep(list(modelWeights),dim(modelList[[1]]$data)[1])) - # } - # modelWeightsJackList <- lapply(1:ncol(modelWeightsJack),function(i) modelWeightsJack[,i]) - # modelWeightsJackListTrans <- lapply(1:length(modelWeightsJackList[[1]]), function(i) sapply(modelWeightsJackList, "[[", i)) - # - # jackbmrList<-list() - # for(i in 1:length(modelList)){ - # jackbmrList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(bmd(drm(modelList[[i]]$call$formula, data = x, type = modelList[[i]]$type, - # fct = modelList[[i]][["fct"]]), - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$bmrScaled) - # } - # ) - # } - # - # jackbmrListTrans <- lapply(1:length(jackbmrList[[1]]), function(i) sapply(jackbmrList, "[[", i)) - # - # LLimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]]))[2]/10000 - # ULimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]],decreasing=TRUE))[1] - # funk<-function(x,y,z){ - # as.numeric(try(bmdMACurve(x,y,z,searchInterval=c(LLimit,ULimit))$Results[1], silent = TRUE)) - # } - # - # bmrScaledJackTrans<-as.list(diag(do.call(cbind,modelWeightsJackList) %*% do.call(cbind,jackbmrListTrans))) - # - # bootjack<-mapply(funk,bootJackModelList,modelWeightsJackListTrans,bmrScaledJackTrans) - # - # maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - # maBMDU <- "Not available for BCa bootstrap" - # } - # } + } } } @@ -536,219 +304,87 @@ bmdMA <- function(modelList, modelWeights, bmr, bootData <- bootDataGen(modelList[[1]],R=R,boot="parametric",aggregated = FALSE) } - # if(!oldbootstrap){ - bmdMAboot <- function(data){ - bootModelList <- lapply(modelList, function(model) try( - eval(substitute(drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = "binomial"), - list(formula0 = model$call$formula, - weights0 = model$call$weights, - start0 = coef(model)))), - silent = TRUE)) - - modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - - bootModelList <- bootModelList[!modelConvergenceError] - - if(length(modelWeights) > 1){ - bootModelWeights <- modelWeights[!modelConvergenceError] - } else { - bootModelWeights <- modelWeights - } - - bmdEst <- try(bmdMA(bootModelList, bootModelWeights, bmr = bmr, backgType = backgType, - backg = backg, def = def, respTrans = respTrans, interval = "delta", - type = "Kang", stackingSplits = stackingSplits, display = FALSE)$Results[,1], silent = TRUE) - as.numeric(bmdEst) - } + bmdMAboot <- function(data){ + bootModelList <- lapply(modelList, function(model) try( + eval(substitute(drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = "binomial"), + list(formula0 = model$call$formula, + weights0 = model$call$weights, + start0 = coef(model)))), + silent = TRUE)) - bootBmdEst <- numeric(length(bootData)) + modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - if(progressInfo){ - cat("Performing bootstrap\n") - data.str <- modelList[[1]]$data - maxIter <- ifelse(bootInterval == "BCa", R + sum(data.str[["weights"]]), R) - pb <- txtProgressBar(min = 0, max = maxIter, style = 3) - } + bootModelList <- bootModelList[!modelConvergenceError] - for(i in 1:length(bootData)){ - bootBmdEst[i] <- bmdMAboot(bootData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i) + if(length(modelWeights) > 1){ + bootModelWeights <- modelWeights[!modelConvergenceError] + } else { + bootModelWeights <- modelWeights } - if(progressInfo & (bootInterval != "BCa")) close(pb) - boot0<-bootBmdEst[!is.na(bootBmdEst)] + bmdEst <- try(bmdMA(bootModelList, bootModelWeights, bmr = bmr, backgType = backgType, + backg = backg, def = def, respTrans = respTrans, interval = "delta", + type = "Kang", stackingSplits = stackingSplits, display = FALSE)$Results[,1], silent = TRUE) + as.numeric(bmdEst) + } + + bootBmdEst <- numeric(length(bootData)) + + if(progressInfo){ + cat("Performing bootstrap\n") + data.str <- modelList[[1]]$data + maxIter <- ifelse(bootInterval == "BCa", R + sum(data.str[["weights"]]), R) + pb <- txtProgressBar(min = 0, max = maxIter, style = 3) + } + + for(i in 1:length(bootData)){ + bootBmdEst[i] <- bmdMAboot(bootData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i) + } + if(progressInfo & (bootInterval != "BCa")) close(pb) + + boot0<-bootBmdEst[!is.na(bootBmdEst)] + + if(length(boot0) == 0){ + maBMDL <- NA + maBMDU <- NA + } else { + if(bootInterval %in% c("percentile","Percentile")){ + maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. + maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + } - if(length(boot0) == 0){ - maBMDL <- NA - maBMDU <- NA - } else { - if(bootInterval %in% c("percentile","Percentile")){ - maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + if(identical(bootInterval,"BCa")){ + data.str <- modelList[[1]]$data + data.str[["number"]] <- data.str[,2]*data.str[["weights"]] + data.e<-expandBinomial(data.str, + number = "number", + total = "weights", + dose = as.character(modelList[[1]]$call$formula[[3]])) + df <- data.frame(data.e[,as.character(modelList[[1]]$call$formula[[3]])], + data.e[,"number"], + data.e[,"weights"]) + colnames(df) <- c(as.character(modelList[[1]]$call$formula[[3]]), + as.character(modelList[[1]]$call$formula[[2]])[[2]], + as.character(modelList[[1]]$call$formula[[2]])[[3]]) + jackData <- list() + for(i in 1:(dim(df)[1])){ + jackData[[i]] <- df[-i,] } - if(identical(bootInterval,"BCa")){ - data.str <- modelList[[1]]$data - data.str[["number"]] <- data.str[,2]*data.str[["weights"]] - data.e<-expandBinomial(data.str, - number = "number", - total = "weights", - dose = as.character(modelList[[1]]$call$formula[[3]])) - df <- data.frame(data.e[,as.character(modelList[[1]]$call$formula[[3]])], - data.e[,"number"], - data.e[,"weights"]) - colnames(df) <- c(as.character(modelList[[1]]$call$formula[[3]]), - as.character(modelList[[1]]$call$formula[[2]])[[2]], - as.character(modelList[[1]]$call$formula[[2]])[[3]]) - jackData <- list() - for(i in 1:(dim(df)[1])){ - jackData[[i]] <- df[-i,] - } - - jackBmdEst <- numeric(length(jackData)) - for(i in 1:length(jackData)){ - jackBmdEst[i] <- bmdMAboot(jackData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i + R) - } - if(progressInfo) close(pb) - - bootjack<-jackBmdEst[!is.na(jackBmdEst)] - - maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - maBMDU <- "Not available for BCa bootstrap" + jackBmdEst <- numeric(length(jackData)) + for(i in 1:length(jackData)){ + jackBmdEst[i] <- bmdMAboot(jackData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i + R) } + if(progressInfo) close(pb) + + bootjack<-jackBmdEst[!is.na(jackBmdEst)] + + maBMDL <- as.numeric(BCa(obs = maBMD, data = df, boot0, bootjack, level = level)[1]) # data = modelList[[1]]$data + maBMDU <- "Not available for BCa bootstrap" } - # } - - # if(oldbootstrap){ - # drmModelListTmp <-list() - # for(i in 1:length(modelList)){ - # drmModelListTmp[[i]] <- which(!sapply(lapply(bootData, function(x){ - # try(drm(modelList[[i]]$call$formula, data = x, type="binomial", fct = modelList[[i]][["fct"]]),TRUE) - # } - # ),function(x) class(x)=="drc")) - # } - # - # non.convergence<-unique(unlist(drmModelListTmp)) - # if(length(non.convergence)>0){ - # bootData<-bootData[-non.convergence] - # } - # bootModelList <-list() - # for(i in 1:length(modelList)){ - # bootModelList[[i]] <- lapply(bootData, function(x){ - # suppressWarnings( - # eval(substitute(drm(formula, data = x, fct = fct0, type = "binomial"), - # list(formula = modelList[[i]]$call$formula, - # fct0 = modelList[[i]][["fct"]])) - # ) # Fitting models using substitute is necessary for Stacking weights - # ) - # } - # ) - # } - # - # bootModelListTrans <- lapply(1:length(bootModelList[[1]]), function(i) lapply(bootModelList, "[[", i)) - # - # # Compute weights - # if(identical(modelWeights,"AIC")){ - # AICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(AIC(my.fun(x,y))))) - # AICtmp <- do.call(rbind,AICList) - # modelWeights0 <- t(t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # } else if(identical(modelWeights,"BIC")){ - # BICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(BIC(my.fun(x,y))))) - # BICtmp <- do.call(rbind,BICList) - # modelWeights0 <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else if(identical(modelWeights, "Stack")){ - # StackList <- lapply(bootModelListTrans, function(x) getStackingWeights(x, stackingSplits)) - # modelWeights0 <- do.call(cbind, StackList) - # } else { - # modelWeights0 <- do.call(cbind,rep(list(modelWeights),R)) - # } - # - # # Estimate BMD in all models on boot samples - # bootbmdList<-list() - # for(i in 1:length(modelList)){ - # bootbmdList[[i]] <- lapply(bootModelList[[i]], function(bootMod){ - # try(bmd(bootMod, - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$Results[1,1], silent = TRUE) - # } - # ) - # } - # bootbmdErrorList <- list() - # for(i in 1:length(modelList)){ - # bootbmdErrorList[[i]] <- which(!sapply(bootbmdList[[i]],function(x) class(x)=="numeric")) - # } - # - # bmd.non.convergence<-unique(unlist(bootbmdErrorList)) - # if(length(bmd.non.convergence) == length(bootData)){ - # maBMDL <- NA - # maBMDU <- NA - # } else { - # if(length(bmd.non.convergence)>0){ - # for(i in 1:length(modelList)){ - # bootbmdList[[i]]<-bootbmdList[[i]][-bmd.non.convergence] - # } - # modelWeights0 <- modelWeights0[,-bmd.non.convergence] - # } - # - # boot<-diag(t(matrix(unlist(bootbmdList), ncol = length(bootbmdList[[1]]), byrow = TRUE)) %*% modelWeights0) - # boot0<-boot[!is.na(boot)] - # - # if(bootInterval %in% c("percentile","Percentile")){ - # maBMDL <- quantile(boot0,p=c(1-level), na.rm = FALSE) # ABC percentile lims. - # maBMDU <- quantile(boot0,p=c(level), na.rm = FALSE) - # } - # if(identical(bootInterval,"BCa")){ - # data.str <- modelList[[1]]$data - # data.str[["number"]] <- data.str[,2]*data.str[["weights"]] - # data.e<-expandBinomial(data.str, - # number = "number", - # total = "weights", - # dose = as.character(modelList[[1]]$call$formula[[3]])) - # jackData <- list() - # for(i in 1:(dim(data.e)[1])){ - # jackData[[i]] <- data.e[-i,] - # } - # bootJackList <-list() - # for(i in 1:length(modelList)){ - # bootJackList[[i]] <- sapply(jackData, function(x){ - # as.numeric(try(bmd(my.fun2(x,modelList[[i]]), - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$Results[1], silent = TRUE)) - # } - # ) - # } - # if(identical(modelWeights,"AIC")){ - # AICJackList <-list() - # for(i in 1:length(modelList)){ - # AICJackList[[i]] <- sapply(jackData, function(x){ - # as.numeric(try(AIC(my.fun2(x,modelList[[i]])), silent = TRUE)) - # } - # ) - # } - # AICtmp <- t(do.call(rbind,AICJackList)) - # modelWeightsJack <- t(t(exp(-t(AICtmp - do.call(pmin, (as.data.frame(AICtmp))))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # } else if(identical(modelWeights,"BIC")){ - # BICJackList <-list() - # for(i in 1:length(modelList)){ - # BICJackList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(BIC(my.fun2(x,modelList[[i]]))) - # } - # ) - # } - # BICtmp <- t(do.call(rbind,BICJackList)) - # modelWeightsJack <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else { - # modelWeightsJack <- do.call(cbind,rep(list(modelWeights),dim(modelList[[1]]$data)[1])) - # } - # - # bootjack<-diag(t(do.call(rbind,bootJackList)) %*% modelWeightsJack) - # - # maBMDL <- as.numeric(BCa(obs = maBMD, data = data.e, boot0, bootjack, level = level)[1]) - # maBMDU <- "Not available for BCa bootstrap" - # } - # } - # } + } } if(identical(type,"curve")){ @@ -764,257 +400,103 @@ bmdMA <- function(modelList, modelWeights, bmr, bootData <- bootDataGen(modelList[[1]],R=R,boot="parametric",aggregated=FALSE) } - # if(!oldbootstrap){ - bmdMACurveboot <- function(data){ - bootModelList <- lapply(modelList, function(model){try( - eval(substitute( - drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = model$type), - list(formula0 = model$call$formula, - weights0 = model$call$weights, - start0 = coef(model)))), - silent = TRUE) - }) - - modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - - bootModelList <- bootModelList[!modelConvergenceError] - bootBmdList <- lapply(bootModelList, - function(object){ - try(bmd(object, bmr = bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, - interval = "delta", display=FALSE), silent = TRUE)}) - - # Estimate weights - if(identical(modelWeights,"AIC")){ - bootModelWeights0<-exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))/ - sum(exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))) - } else if(identical(modelWeights,"BIC")){ - bootModelWeights0<-exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))/ - sum(exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))) - } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ - # estimate weights - bootModelWeights0 <- getStackingWeights(bootModelList, stackingSplits) - } else { - bootModelWeights0 <- modelWeights[!modelConvergenceError] - } - - - bootBmrScaled0 <- sum(sapply(bootBmdList, function(x){as.numeric(try(x$bmrScaled, TRUE))})*bootModelWeights0) - - bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[1], silent = TRUE) - as.numeric(bootBmdEst) - } + bmdMACurveboot <- function(data){ + bootModelList <- lapply(modelList, function(model){try( + eval(substitute( + drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, type = model$type), + list(formula0 = model$call$formula, + weights0 = model$call$weights, + start0 = coef(model)))), + silent = TRUE) + }) - bootBmdEst <- numeric(length(bootData)) + modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) - if(progressInfo){ - cat("Performing bootstrap\n") - data.str <- modelList[[1]]$data - maxIter <- ifelse(bootInterval == "BCa", R + sum(data.str[["weights"]]), R) - pb <- txtProgressBar(min = 0, max = maxIter, style = 3) - } + bootModelList <- bootModelList[!modelConvergenceError] + bootBmdList <- lapply(bootModelList, + function(object){ + try(bmd(object, bmr = bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, + interval = "delta", display=FALSE), silent = TRUE)}) - for(i in 1:length(bootData)){ - bootBmdEst[i] <- bmdMACurveboot(bootData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i) + # Estimate weights + if(identical(modelWeights,"AIC")){ + bootModelWeights0<-exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))/ + sum(exp(-(sapply(bootModelList,AIC)-min(sapply(bootModelList,AIC))))) + } else if(identical(modelWeights,"BIC")){ + bootModelWeights0<-exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))/ + sum(exp(-(sapply(bootModelList,BIC)-min(sapply(bootModelList,BIC))))) + } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ + # estimate weights + bootModelWeights0 <- getStackingWeights(bootModelList, stackingSplits) + } else { + bootModelWeights0 <- modelWeights[!modelConvergenceError] } - if(progressInfo & (bootInterval != "BCa")) close(pb) - boot0 <- bootBmdEst[!is.na(bootBmdEst)] - if(length(boot0) == 0){ - maBMDL <- NA - maBMDU <- NA - } else { - if(bootInterval %in% c("percentile","Percentile")){ - maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + bootBmrScaled0 <- sum(sapply(bootBmdList, function(x){as.numeric(try(x$bmrScaled, TRUE))})*bootModelWeights0) + + bootBmdEst <- try(bmdMACurve(bootModelList,bootModelWeights0,bootBmrScaled0)$Results[1], silent = TRUE) + as.numeric(bootBmdEst) + } + + bootBmdEst <- numeric(length(bootData)) + + if(progressInfo){ + cat("Performing bootstrap\n") + data.str <- modelList[[1]]$data + maxIter <- ifelse(bootInterval == "BCa", R + sum(data.str[["weights"]]), R) + pb <- txtProgressBar(min = 0, max = maxIter, style = 3) + } + + for(i in 1:length(bootData)){ + bootBmdEst[i] <- bmdMACurveboot(bootData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i) + } + if(progressInfo & (bootInterval != "BCa")) close(pb) + + boot0 <- bootBmdEst[!is.na(bootBmdEst)] + + if(length(boot0) == 0){ + maBMDL <- NA + maBMDU <- NA + } else { + if(bootInterval %in% c("percentile","Percentile")){ + maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. + maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) + } + + if(identical(bootInterval,"BCa")){ + data.str <- modelList[[1]]$data + data.str[["number"]] <- data.str[,2]*data.str[["weights"]] + data.e<-expandBinomial(data.str, + number = "number", + total = "weights", + dose = as.character(modelList[[1]]$call$formula[[3]])) + df <- data.frame(data.e[,as.character(modelList[[1]]$call$formula[[3]])], + data.e[,"number"], + data.e[,"weights"]) + colnames(df) <- c(as.character(modelList[[1]]$call$formula[[3]]), + as.character(modelList[[1]]$call$formula[[2]])[[2]], + as.character(modelList[[1]]$call$formula[[2]])[[3]]) + jackData <- list() + for(i in 1:nrow(df)){ + jackData[[i]] <- df[-i,] } - if(identical(bootInterval,"BCa")){ - data.str <- modelList[[1]]$data - data.str[["number"]] <- data.str[,2]*data.str[["weights"]] - data.e<-expandBinomial(data.str, - number = "number", - total = "weights", - dose = as.character(modelList[[1]]$call$formula[[3]])) - df <- data.frame(data.e[,as.character(modelList[[1]]$call$formula[[3]])], - data.e[,"number"], - data.e[,"weights"]) - colnames(df) <- c(as.character(modelList[[1]]$call$formula[[3]]), - as.character(modelList[[1]]$call$formula[[2]])[[2]], - as.character(modelList[[1]]$call$formula[[2]])[[3]]) - jackData <- list() - for(i in 1:nrow(df)){ - jackData[[i]] <- df[-i,] - } - - jackBmdEst <- numeric(length(jackData)) - - for(i in 1:length(jackData)){ - jackBmdEst[i] <- bmdMACurveboot(jackData[[i]]) - if(progressInfo) setTxtProgressBar(pb, i + R) - } - if(progressInfo) close(pb) - - bootjack <- jackBmdEst[!is.na(jackBmdEst)] - - maBMDL <- as.numeric(BCa(obs = maBMD, data = modelList[[1]]$data, boot0, bootjack, level = level)[1]) - maBMDU <- "Not available for BCa bootstrap" + jackBmdEst <- numeric(length(jackData)) + + for(i in 1:length(jackData)){ + jackBmdEst[i] <- bmdMACurveboot(jackData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i + R) } + if(progressInfo) close(pb) + + bootjack <- jackBmdEst[!is.na(jackBmdEst)] + + maBMDL <- as.numeric(BCa(obs = maBMD, data = df, boot0, bootjack, level = level)[1]) # data = modelList[[1]]$data + maBMDU <- "Not available for BCa bootstrap" } - # } - - # if(oldbootstrap){ - # drmModelListTmp <-list() - # for(i in 1:length(modelList)){ - # drmModelListTmp[[i]] <- which(!sapply(lapply(bootData, function(x){ - # try(drm(modelList[[i]]$call$formula, data = x, type="binomial", fct = modelList[[i]][["fct"]]),TRUE) - # } - # ),function(x) class(x)=="drc")) - # } - # - # non.convergence<-unique(unlist(drmModelListTmp)) - # if(length(non.convergence)>0){ - # bootData<-bootData[-non.convergence] - # } - # - # bootModelList <-list() - # for(i in 1:length(modelList)){ - # bootModelList[[i]] <- lapply(bootData, function(x){ - # suppressWarnings( - # eval(substitute(drm(formula, data = x, fct = fct0, type = "binomial"), - # list(formula = modelList[[i]]$call$formula, - # fct0 = modelList[[i]][["fct"]])) - # ) - # ) - # } - # ) - # } - # - # bootModelListTrans <- lapply(1:length(bootModelList[[1]]), function(i) lapply(bootModelList, "[[", i)) - # - # if(identical(modelWeights,"AIC")){ - # AICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(AIC(my.fun(x,y))))) - # AICtmp <- do.call(rbind,AICList) - # modelWeights0 <- t(t(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # - # } else if(identical(modelWeights,"BIC")){ - # BICList <-lapply(bootData, function(x) sapply(modelList, function(y) suppressWarnings(BIC(my.fun(x,y))))) - # BICtmp <- do.call(rbind,BICList) - # modelWeights0 <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else if(identical(modelWeights, "Stack")){ - # modelWeightsList <- lapply(bootModelListTrans, function(x) getStackingWeights(x, stackingSplits)) - # } else { - # modelWeights0 <- do.call(cbind,rep(list(modelWeights),R)) - # } - # - # if(!identical(modelWeights, "Stack")){ - # modelWeightsList <- lapply(1:ncol(modelWeights0),function(i) modelWeights0[,i]) - # } - # - # bootbmrList<-list() - # for(i in 1:length(modelList)){ - # bootbmrList[[i]] <- lapply(bootModelList[[i]], function(bootMod){ - # try(bmd(bootMod, - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$bmrScaled, silent = TRUE) - # } - # ) - # } - # bootbmrListTrans <- lapply(1:length(bootbmrList[[1]]), function(i) sapply(bootbmrList, "[[", i)) - # - # bootbmrErrorList <- list() - # for(i in 1:length(modelList)){ - # bootbmrErrorList[[i]] <- which(sapply(bootbmrList[[i]],function(x) is.na(as.numeric(x)))) #class(x)=="numeric" - # } - # - # bmr.non.convergence<-unique(unlist(bootbmrErrorList)) - # if(length(bmr.non.convergence) > 0){ - # bootbmrListTrans <- bootbmrListTrans[-bmr.non.convergence] - # modelWeightsList <- modelWeightsList[-bmr.non.convergence] - # bootModelListTrans <- bootModelListTrans[-bmr.non.convergence] - # } - # - # LLimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]]))[2]/10000 - # ULimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]],decreasing=TRUE))[1] - # funk<-function(x,y,z){ - # try(bmdMACurve(x,y,z,searchInterval=c(LLimit,ULimit))$Results[1], silent = TRUE)} - # bmrScaledList<-as.list(rowSums(do.call(rbind,modelWeightsList)*do.call(rbind,bootbmrListTrans))) - # - # boot<-mapply(funk,bootModelListTrans,modelWeightsList,bmrScaledList) - # boot0<-suppressWarnings(as.numeric(boot[!is.na(as.numeric(boot))])) - # - # if(bootInterval %in% c("percentile","Percentile")){ - # maBMDL <- quantile(boot0,p=c(1-level), na.rm = TRUE) # ABC percentile lims. - # maBMDU <- quantile(boot0,p=c(level), na.rm = TRUE) - # } - # if(identical(bootInterval,"BCa")){ - # data.str <- modelList[[1]]$data - # data.str[["number"]] <- data.str[,2]*data.str[["weights"]] - # data.e<-expandBinomial(data.str, - # number = "number", - # total = "weights", - # dose = as.character(modelList[[1]]$call$formula[[3]])) - # - # jackData <- list() - # for(i in 1:(dim(data.e)[1])){ - # jackData[[i]] <- data.e[-i,] - # } - # - # bootJackModelList <- lapply(jackData, function(x) lapply(modelList, function(y) suppressWarnings(my.fun2(x,y)))) - # - # if(identical(modelWeights,"AIC")){ - # AICJackList <-list() - # for(i in 1:length(modelList)){ - # AICJackList[[i]] <- sapply(jackData, function(x){ - # as.numeric(try(AIC(my.fun2(x,modelList[[i]])), silent = TRUE)) - # } - # ) - # } - # AICtmp <- t(do.call(rbind,AICJackList)) - # modelWeightsJack <- t(t(exp(-t(AICtmp - do.call(pmin, (as.data.frame(AICtmp))))))/colSums(exp(-t(AICtmp - do.call(pmin, as.data.frame(AICtmp)))))) - # } else if(identical(modelWeights,"BIC")){ - # BICJackList <-list() - # for(i in 1:length(modelList)){ - # BICJackList[[i]] <- sapply(jackData, function(x){ - # suppressWarnings(BIC(my.fun2(x,modelList[[i]]))) - # } - # ) - # } - # BICtmp <- t(do.call(rbind,BICJackList)) - # modelWeightsJack <- t(t(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))/colSums(exp(-t(BICtmp - do.call(pmin, as.data.frame(BICtmp)))))) - # } else { - # modelWeightsJack <- do.call(cbind,rep(list(modelWeights),dim(modelList[[1]]$data)[1])) - # } - # - # # modelWeightsJackList <- lapply(1:ncol(modelWeightsJack),function(i) modelWeightsJack[,i]) - # # modelWeightsJackListTrans <- lapply(1:length(modelWeightsJackList[[1]]), function(i) sapply(modelWeightsJackList, "[[", i)) - # - # jackbmrList<-list() - # for(i in 1:length(modelList)){ - # jackbmrList[[i]] <- sapply(jackData, function(x){ - # as.numeric(try(bmd(my.fun2(x,modelList[[i]]), - # bmr, backgType = backgType, backg = backg, def = def, respTrans = respTrans, interval = interval, - # display=FALSE, level=level)$bmrScaled,silent=TRUE)) - # } - # ) - # } - # - # jackbmrListTrans <- lapply(1:length(jackbmrList[[1]]), function(i) sapply(jackbmrList, "[[", i)) - # - # LLimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]]))[2]/10000 - # ULimit<-unique(sort(modelList[[1]]$data[[as.character(modelList[[1]]$call$formula)[[3]]]],decreasing=TRUE))[1] - # funk<-function(x,y,z){ - # as.numeric(try(bmdMACurve(x,y,z,searchInterval=c(LLimit,ULimit))$Results[1], silent = TRUE)) - # } - # bmrScaledJack<-as.list(diag(do.call(cbind,modelWeightsJackList) %*% do.call(cbind,jackbmrListTrans))) - # - # bootjack<-mapply(funk,bootJackModelList,modelWeightsJackListTrans,bmrScaledJack) - # - # maBMDL <- as.numeric(BCa(obs = maBMD, data = data.e, boot0, bootjack, level = level)[1]) - # maBMDU <- "Not available for BCa bootstrap" - # } - # } + } } } } @@ -1023,11 +505,11 @@ bmdMA <- function(modelList, modelWeights, bmr, if(is.null(modelList[[1]]$objList)){ # Estimate weights if(identical(modelWeights,"AIC")){ - modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))/ - sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC))))) + modelWeights0<-exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)/ + sum(exp(-(sapply(modelList,AIC)-min(sapply(modelList,AIC)))/2)) } else if(identical(modelWeights,"BIC")){ - modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))/ - sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC))))) + modelWeights0<-exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)/ + sum(exp(-(sapply(modelList,BIC)-min(sapply(modelList,BIC)))/2)) } else if(identical(modelWeights,"Stack")|identical(modelWeights, "Stacking")){ # If stackingSeed supplied, save initial seed for later, and set seed for stacking if (!is.null(stackingSeed)) { @@ -1088,7 +570,7 @@ bmdMA <- function(modelList, modelWeights, bmr, bootModelList <- lapply(modelList, function(model){try( eval(substitute( drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, - curveid = model$call$curveid, type = model$type, control = drmc(noMessage = TRUE)), + curveid = curveid0, type = model$type, control = drmc(noMessage = TRUE)), list(formula0 = model$call$formula, weights0 = model$call$weights, curveid0 = model$call$curveid, @@ -1193,7 +675,7 @@ bmdMA <- function(modelList, modelWeights, bmr, bootModelList <- lapply(modelList, function(model){try( eval(substitute( drm(formula = formula0, data = data, fct = model$fct, weights = weights0, start = start0, - curveid = model$call$curveid, type = model$type, control = drmc(noMessage = TRUE)), + curveid = curveid0, type = model$type, control = drmc(noMessage = TRUE)), list(formula0 = model$call$formula, weights0 = model$call$weights, curveid0 = model$call$curveid, @@ -1427,7 +909,7 @@ bmdMA <- function(modelList, modelWeights, bmr, jackBmdError <- apply(jackBmdEst, 1, function(x) any(is.na(x))) bootjack <- jackBmdEst[!jackBmdError,] - maBMDL <- sapply(1:nCurves, function(i) as.numeric(BCa(obs = maBMD[i], data = modelList[[1]]$data, boot0[,i], bootjack[,i], level = level)[1])) + maBMDL <- sapply(1:nCurves, function(i) as.numeric(BCa(obs = maBMD[i], data = df, boot0[,i], bootjack[,i], level = level)[1])) # data = modelList[[1]]$data maBMDU <- rep("Not available for BCa bootstrap", nCurves) } } @@ -1562,7 +1044,7 @@ bmdMA <- function(modelList, modelWeights, bmr, jackBmdError <- apply(jackBmdEst, 1, function(x) any(is.na(x))) bootjack <- jackBmdEst[!jackBmdError,] - maBMDL <- sapply(1:nCurves, function(i) as.numeric(BCa(obs = maBMD[i], data = modelList[[1]]$data, boot0[,i], bootjack[,i], level = level)[1])) + maBMDL <- sapply(1:nCurves, function(i) as.numeric(BCa(obs = maBMD[i], data = df, boot0[,i], bootjack[,i], level = level)[1])) # data = modelList[[1]]$data maBMDU <- rep("Not available for BCa bootstrap", nCurves) } } @@ -1580,9 +1062,12 @@ bmdMA <- function(modelList, modelWeights, bmr, bmdMAList <- lapply(modelListList, bmdMACall) maBMD <- sapply(bmdMAList, function(x) x$Results[,1]) - maBMDL <- sapply(bmdMAList, function(x) x$Interval[,1]) - maBMDU <- sapply(bmdMAList, function(x) x$Interval[,2]) + maBMDL <- sapply(bmdMAList, function(x) x$interval[,1]) + maBMDU <- sapply(bmdMAList, function(x) x$interval[,2]) maBMDse <- sapply(bmdMAList, function(x) x$SE[,1]) + + modelWeights0 <- do.call(rbind, lapply(bmdMAList, function(x) x$modelWeights)) + rownames(modelWeights0) <- names(modelList[[1]]$objList) } } @@ -1612,7 +1097,7 @@ bmdMA <- function(modelList, modelWeights, bmr, floor(length(boot0)/nCurves),NA) resBMD<-list(Results = resMat, Boot.samples.used = used.Boot, - Interval = intMat, + interval = intMat, SE = seMat, modelWeights = modelWeights0) if(display){ diff --git a/R/bmdOrdinalDeltaCI.R b/R/bmdOrdinalDeltaCI.R index 7362210..5ae560f 100644 --- a/R/bmdOrdinalDeltaCI.R +++ b/R/bmdOrdinalDeltaCI.R @@ -1,148 +1,148 @@ -bmdOrdinalDeltaCI <- function(object, bmr, backgType, backg, def, level){ - if(substr(object$drmList[[1]]$fct$name, 1,2) %in% c("FP") || (object$drmList[[1]]$fct$name %in% c("LN.3", "LN.4"))){ - warning("delta CI not available for FPL or LN.3 and LN.4 models.") - CI <- NA - } else { - if(backgType == "modelBased"){ - # log-logistic - if(object$drmList[[1]]$fct$name == "LL.2"){ - closedExpression <- paste0("exp(log(1/",bmr,"-1)/b)*e") - } else if(object$drmList[[1]]$fct$name == "LL.3"){ - closedExpression <- paste0("exp(log(d/",bmr,"-1)/b)*e") - } else if(object$drmList[[1]]$fct$name == "LL.3u"){ - if(def == "excess"){ - closedExpression <- paste0("exp(log(1/",bmr,"-1)/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("exp(log((1-c)/",bmr,"-1)/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("exp(log((1-c)/(",bmr,"-c)-1)/b)*e") - } - } else if(object$drmList[[1]]$fct$name == "LL.4"){ - if(def == "excess"){ - closedExpression <- paste0("exp(log((d-c)/((1-c)*",bmr,")-1)/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("exp(log((d-c)/",bmr,"-1)/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("exp(log((d-c)/(",bmr,"-c)-1)/b)*e") - } - } - # log-normal - else if(object$drmList[[1]]$fct$name == "LN.2"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") - } else if(object$drmList[[1]]$fct$name == "LN.3"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong - } else if(object$drmList[[1]]$fct$name == "LN.3u"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") - } else if(object$drmList[[1]]$fct$name == "LN.4"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong - } - # weibull 1 - else if(object$drmList[[1]]$fct$name == "W1.2"){ - closedExpression <- paste0("(-log(",bmr,"))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W1.3"){ - closedExpression <- paste0("(-log(",bmr,"/d))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W1.3u"){ - if(def == "excess"){ - closedExpression <- paste0("(-log(",bmr,"))^(1/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("(-log(",bmr,"/(1-c)))^(1/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("(-log((",bmr,"-c)/(1-c)))^(1/b)*e") - } - } else if(object$drmList[[1]]$fct$name == "W1.4"){ - if(def == "excess"){ - closedExpression <- paste0("(-log((1-c)*",bmr,"/(d-c)))^(1/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("(-log(",bmr,"/(d-c)))^(1/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("(-log((",bmr,"-c)/(d-c)))^(1/b)*e") - } - } - # weibull 2 - else if(object$drmList[[1]]$fct$name == "W2.2"){ - closedExpression <- paste0("(-log(1-",bmr,"))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W2.3"){ - closedExpression <- paste0("(-log(1-",bmr,"/d))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W2.3u"){ - if(def == "excess"){ - closedExpression <- paste0("(-log(1-",bmr,"))^(1/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("(-log(1-",bmr,"/(1-c)))^(1/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("(-log(1-(",bmr,"-c)/(1-c)))^(1/b)*e") - } - } else if(object$drmList[[1]]$fct$name == "W2.4"){ - if(def == "excess"){ - closedExpression <- paste0("(-log(1-(1-c)*",bmr,"/(d-c)))^(1/b)*e") - } else if(def == "additional"){ - closedExpression <- paste0("(-log(1-",bmr,"/(d-c)))^(1/b)*e") - } else if(def == "point"){ - closedExpression <- paste0("(-log(1-(",bmr,"-c)/(d-c)))^(1/b)*e") - } - } - } else if(backgType == "absolute"){ - p0 <- ifelse(is.na(backg), 0, backg) - if(def == "excess"){ - z <- (1-p0)*bmr + p0 - } else if(def == "additional"){ - z <- bmr + p0 - } - # log-logistic - if(object$drmList[[1]]$fct$name == "LL.2"){ - closedExpression <- paste0("exp(log(1/",z, "-1)/b)*e") - } else if(object$drmList[[1]]$fct$name == "LL.3"){ - closedExpression <- paste0("exp(log(d/",z,"-1)/b)*e") - } else if(object$drmList[[1]]$fct$name == "LL.3u"){ - closedExpression <- paste0("exp(log((1-c)/(",z,"-c)-1)/b)*e") - } else if(object$drmList[[1]]$fct$name == "LL.4"){ - closedExpression <- paste0("exp(log((d-c)/(",z,"-c)-1)/b)*e") - } - # log-normal - else if(object$drmList[[1]]$fct$name == "LN.2"){ - constant <- qnorm(z) - closedExpression <- paste0("exp(",constant,"/b)*e") - } else if(object$drmList[[1]]$fct$name == "LN.3"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong - } else if(object$drmList[[1]]$fct$name == "LN.3u"){ - constant <- qnorm(z) - closedExpression <- paste0("exp(",constant,"/b)*e") - } else if(object$drmList[[1]]$fct$name == "LN.4"){ - constant <- qnorm(bmr) - closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong - } - # weibull 1 - else if(object$drmList[[1]]$fct$name == "W1.2"){ - closedExpression <- paste0("(-log(",z,"))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W1.3"){ - closedExpression <- paste0("(-log(",z,"/d))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W1.3u"){ - closedExpression <- paste0("(-log((",z,"-c)/(1-c)))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W1.4"){ - closedExpression <- paste0("(-log((",z,"-c)/(d-c)))^(1/b)*e") - } - # weibull 2 - else if(object$drmList[[1]]$fct$name == "W2.2"){ - closedExpression <- paste0("(-log(1-",z,"))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W2.3"){ - closedExpression <- paste0("(-log(1-",z,"/d))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W2.3u"){ - closedExpression <- paste0("(-log(1-(",z,"-c)/(1-c)))^(1/b)*e") - } else if(object$drmList[[1]]$fct$name == "W2.4"){ - closedExpression <- paste0("(-log(1-(",z,"-c)/(d-c)))^(1/b)*e") - } - } - BMD.pooled <- mjust(object$drmList, - as.list(rep(closedExpression, length(object$drmList))), - seType = "san") - tmp <- confint(multcomp:::glht(multcomp:::parm(BMD.pooled[["coef"]][,1], - BMD.pooled[["covar"]]), linfct = matrix(rep(1/length(object$drmList), length(object$drmList)),1,length(object$drmList))), - level = 1 - (1-level)*2) - CI <- tmp$confint[1,2:3] - } - CI -} \ No newline at end of file +# bmdOrdinalDeltaCI <- function(object, bmr, backgType, backg, def, level){ +# if(substr(object$drmList[[1]]$fct$name, 1,2) %in% c("FP") || (object$drmList[[1]]$fct$name %in% c("LN.3", "LN.4"))){ +# warning("delta CI not available for FPL or LN.3 and LN.4 models.") +# CI <- NA +# } else { +# if(backgType == "modelBased"){ +# # log-logistic +# if(object$drmList[[1]]$fct$name == "LL.2"){ +# closedExpression <- paste0("exp(log(1/",bmr,"-1)/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LL.3"){ +# closedExpression <- paste0("exp(log(d/",bmr,"-1)/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LL.3u"){ +# if(def == "excess"){ +# closedExpression <- paste0("exp(log(1/",bmr,"-1)/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("exp(log((1-c)/",bmr,"-1)/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("exp(log((1-c)/(",bmr,"-c)-1)/b)*e") +# } +# } else if(object$drmList[[1]]$fct$name == "LL.4"){ +# if(def == "excess"){ +# closedExpression <- paste0("exp(log((d-c)/((1-c)*",bmr,")-1)/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("exp(log((d-c)/",bmr,"-1)/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("exp(log((d-c)/(",bmr,"-c)-1)/b)*e") +# } +# } +# # log-normal +# else if(object$drmList[[1]]$fct$name == "LN.2"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LN.3"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong +# } else if(object$drmList[[1]]$fct$name == "LN.3u"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LN.4"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong +# } +# # weibull 1 +# else if(object$drmList[[1]]$fct$name == "W1.2"){ +# closedExpression <- paste0("(-log(",bmr,"))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W1.3"){ +# closedExpression <- paste0("(-log(",bmr,"/d))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W1.3u"){ +# if(def == "excess"){ +# closedExpression <- paste0("(-log(",bmr,"))^(1/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("(-log(",bmr,"/(1-c)))^(1/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("(-log((",bmr,"-c)/(1-c)))^(1/b)*e") +# } +# } else if(object$drmList[[1]]$fct$name == "W1.4"){ +# if(def == "excess"){ +# closedExpression <- paste0("(-log((1-c)*",bmr,"/(d-c)))^(1/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("(-log(",bmr,"/(d-c)))^(1/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("(-log((",bmr,"-c)/(d-c)))^(1/b)*e") +# } +# } +# # weibull 2 +# else if(object$drmList[[1]]$fct$name == "W2.2"){ +# closedExpression <- paste0("(-log(1-",bmr,"))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W2.3"){ +# closedExpression <- paste0("(-log(1-",bmr,"/d))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W2.3u"){ +# if(def == "excess"){ +# closedExpression <- paste0("(-log(1-",bmr,"))^(1/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("(-log(1-",bmr,"/(1-c)))^(1/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("(-log(1-(",bmr,"-c)/(1-c)))^(1/b)*e") +# } +# } else if(object$drmList[[1]]$fct$name == "W2.4"){ +# if(def == "excess"){ +# closedExpression <- paste0("(-log(1-(1-c)*",bmr,"/(d-c)))^(1/b)*e") +# } else if(def == "additional"){ +# closedExpression <- paste0("(-log(1-",bmr,"/(d-c)))^(1/b)*e") +# } else if(def == "point"){ +# closedExpression <- paste0("(-log(1-(",bmr,"-c)/(d-c)))^(1/b)*e") +# } +# } +# } else if(backgType == "absolute"){ +# p0 <- ifelse(is.na(backg), 0, backg) +# if(def == "excess"){ +# z <- (1-p0)*bmr + p0 +# } else if(def == "additional"){ +# z <- bmr + p0 +# } +# # log-logistic +# if(object$drmList[[1]]$fct$name == "LL.2"){ +# closedExpression <- paste0("exp(log(1/",z, "-1)/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LL.3"){ +# closedExpression <- paste0("exp(log(d/",z,"-1)/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LL.3u"){ +# closedExpression <- paste0("exp(log((1-c)/(",z,"-c)-1)/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LL.4"){ +# closedExpression <- paste0("exp(log((d-c)/(",z,"-c)-1)/b)*e") +# } +# # log-normal +# else if(object$drmList[[1]]$fct$name == "LN.2"){ +# constant <- qnorm(z) +# closedExpression <- paste0("exp(",constant,"/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LN.3"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong +# } else if(object$drmList[[1]]$fct$name == "LN.3u"){ +# constant <- qnorm(z) +# closedExpression <- paste0("exp(",constant,"/b)*e") +# } else if(object$drmList[[1]]$fct$name == "LN.4"){ +# constant <- qnorm(bmr) +# closedExpression <- paste0("exp(",constant,"/b)*e") # this is wrong +# } +# # weibull 1 +# else if(object$drmList[[1]]$fct$name == "W1.2"){ +# closedExpression <- paste0("(-log(",z,"))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W1.3"){ +# closedExpression <- paste0("(-log(",z,"/d))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W1.3u"){ +# closedExpression <- paste0("(-log((",z,"-c)/(1-c)))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W1.4"){ +# closedExpression <- paste0("(-log((",z,"-c)/(d-c)))^(1/b)*e") +# } +# # weibull 2 +# else if(object$drmList[[1]]$fct$name == "W2.2"){ +# closedExpression <- paste0("(-log(1-",z,"))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W2.3"){ +# closedExpression <- paste0("(-log(1-",z,"/d))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W2.3u"){ +# closedExpression <- paste0("(-log(1-(",z,"-c)/(1-c)))^(1/b)*e") +# } else if(object$drmList[[1]]$fct$name == "W2.4"){ +# closedExpression <- paste0("(-log(1-(",z,"-c)/(d-c)))^(1/b)*e") +# } +# } +# BMD.pooled <- mjust(object$drmList, +# as.list(rep(closedExpression, length(object$drmList))), +# seType = "san") +# tmp <- confint(multcomp:::glht(multcomp:::parm(BMD.pooled[["coef"]][,1], +# BMD.pooled[["covar"]]), linfct = matrix(rep(1/length(object$drmList), length(object$drmList)),1,length(object$drmList))), +# level = 1 - (1-level)*2) +# CI <- tmp$confint[1,2:3] +# } +# CI +# } \ No newline at end of file diff --git a/R/bmdOrdinalMA.R b/R/bmdOrdinalMA.R index b5a9b87..778f4c7 100644 --- a/R/bmdOrdinalMA.R +++ b/R/bmdOrdinalMA.R @@ -1,45 +1,171 @@ -bmdOrdinalMA <- function(modelList, bmr=0.1, backgType = "modelBased", def="excess", level = 0.95, R = 500, bootType = "nonparametric", MAType = "postBmdEst", display = TRUE){ - MABmdEst <- function(modelList){ - bmdAllMods <- lapply(modelList, function(object) bmdOrdinal(object, bmr=bmr, backgType = backgType, def=def, interval = "none", display = FALSE)) +bmdOrdinalMA <- function(modelList, modelWeights = c("AIC", "BIC"), bmr=0.1, backgType = "modelBased", def="excess", type = c("bootstrap", "Kang"), level = 0.95, R = 500, bootType = "nonparametric", progressInfo = TRUE, display = TRUE){ + # assertions + if(!all(sapply(modelList, function(object) inherits(object, "drcOrdinal")))){ + stop('"modelList" must be a list of ordinal dose-response models of type "drcOrdinal"') + } + + # bmdEstimates on all models + bmdList <- lapply(modelList, function(object) bmdOrdinal(object, bmr=bmr, backgType = backgType, def=def, interval = "delta", display = FALSE)) + + # modelWeights + if(missing(modelWeights)){ + stop("missing argument \"modelWeights\". Options are \"AIC\", \"BIC\" or a numeric vector of same lenght as modelList.") + } else if(length(modelWeights) > 1){ + if(!identical(length(modelWeights), length(modelList))){ + stop("misspecified argument \"modelWeights\". Options are \"AIC\", \"BIC\" or a numeric vector of same lenght as modelList.") + } else { + modelWeights0 <- modelWeights / sum(modelWeights) + } + } else if(length(modelWeights) == 1){ + if(identical(modelWeights, "AIC")){ + AICVals <- sapply(modelList, AIC) + modelWeights0 <- exp(-1/2*(AICVals - min(AICVals)))/sum(exp(-1/2*(AICVals - min(AICVals)))) + } else if(identical(modelWeights, "BIC")){ + BICVals <- sapply(modelList, BIC) + modelWeights0 <- exp(-1/2*(BICVals - min(BICVals)))/sum(exp(-1/2*(BICVals - min(BICVals)))) + } + } + + if(all(type == c("bootstrap","Kang")) | sum(type[1] == c("bootstrap","Kang")) != 1){ + stop('Specify model averaging type. Options are "bootstrap" and "Kang"') + } + + if(identical(type,"Kang")){ + maBMD <- colSums(modelWeights0 * t(sapply(bmdList, function(x) x$Results[,1]))) + maBMDL <- colSums(modelWeights0 * t(sapply(bmdList, function(x) x$interval[,1]))) + maBMDU <- colSums(modelWeights0 * t(sapply(bmdList, function(x) x$interval[,2]))) + } else if(identical(type, "bootstrap")){ + maBMD <- colSums(modelWeights0 * t(sapply(bmdList, function(x) x$Results[,1]))) - AICVals <- sapply(modelList, AIC) - AICWeights <- exp(-1/2*(AICVals - min(AICVals)))/sum(exp(-1/2*(AICVals - min(AICVals)))) + # bootstrap + bootData <- bootDataGenOrdinal(modelList[[1]],R=R, bootType = bootType) - if(MAType == "postBmdEst"){ - BMD.tmp <- sapply(bmdAllMods, function(object) object$Results[1]) - bmdVal <- sum(BMD.tmp*AICWeights) - } else if (MAType == "preBmdEst"){ - bmdEachCat <- sapply(1:length(modelList[[1]]$drmList), function(cat_i){ - bmdAllMods0 <- sapply(bmdAllMods, - function(object){ - object$bmdList[[cat_i]]$Results[1] - }) - sum(AICWeights*bmdAllMods0) - }) + bmdMAboot <- function(data){ + bootModelList <- lapply(modelList, function(model) try( + eval(substitute(drmOrdinal(levels = levels0, dose = dose0, weights = weights0, blocks = blocks0, data = bootData[[i]], fct = model$fct), + list(levels0 = modelList[[1]]$levels, + dose0 = modelList[[1]]$dose, + weights0 = modelList[[1]]$weights, + blocks0 = modelList[[1]]$blocks))), + silent = TRUE)) + + modelConvergenceError <- sapply(bootModelList, function(mod_try) inherits(mod_try, "try-error")) + + bootModelList <- bootModelList[!modelConvergenceError] + + if(length(modelWeights) > 1){ + bootModelWeights0 <- modelWeights0[!modelConvergenceError] + } else if(length(modelWeights) == 1){ + if(identical(modelWeights, "AIC")){ + BootAICVals <- sapply(bootModelList, AIC) + bootModelWeights0 <- exp(-1/2*(BootAICVals - min(BootAICVals)))/sum(exp(-1/2*(BootAICVals - min(BootAICVals)))) + } else if(identical(modelWeights, "BIC")){ + BootBICVals <- sapply(bootModelList, BIC) + bootModelWeights0 <- exp(-1/2*(BootBICVals - min(BootBICVals)))/sum(exp(-1/2*(BootBICVals - min(BootBICVals)))) + } + } - bmdVal <- mean(bmdEachCat) + bootBmdList <- lapply(bootModelList, function(object) bmdOrdinal(object, bmr=bmr, backgType = backgType, def=def, interval = "delta", display = FALSE)) + + bootMaBMD <- colSums(bootModelWeights0 * t(sapply(bootBmdList, function(x) x$Results[,1]))) + bootMaBMD + } + + bootBmdEst <- matrix(NA, nrow = length(bootData), ncol = length(modelList[[1]]$levelsMerged)) + + if(progressInfo){ + cat("Performing bootstrap\n") + pb <- txtProgressBar(min = 0, max = R, style = 3) + } + + for(i in 1:length(bootData)){ + bootBmdEst[i,] <- bmdMAboot(bootData[[i]]) + if(progressInfo) setTxtProgressBar(pb, i) } - bmdVal + if(progressInfo) close(pb) + + bootBmdError <- apply(bootBmdEst, 1, function(x) any(is.na(x))) + boot0 <- bootBmdEst[!bootBmdError,] + + if(length(boot0) == 0){ + maBMDL <- NA + maBMDU <- NA + } else { + maBMDL <- apply(boot0, 2, quantile, p=c(1-level), na.rm = TRUE) # ABC percentile lims. + maBMDU <- apply(boot0, 2, quantile, p=c(level), na.rm = TRUE) + } + # end bootstrap } - BMD <- MABmdEst(modelList) + resMat<-matrix(c(maBMD,maBMDL), nrow = length(modelList[[1]]$levelsMerged), ncol = 2, byrow = FALSE) + colnames(resMat) <- c("BMD_MA", "BMDL_MA") + rownames(resMat) <- modelList[[1]]$levelsMerged - # bootstrap - bootData <- bootDataGenOrdinal(modelList[[1]],R=R, bootType = bootType) + intMat<-matrix(c(maBMDL,maBMDU), nrow = length(modelList[[1]]$levelsMerged), ncol = 2, byrow = FALSE) + colnames(intMat) <- c("BMDL_MA", "BMDU_MA") + rownames(intMat) <- modelList[[1]]$levelsMerged - bmdBoot <- numeric(R) - for(i in 1:R){ - modelListBoot <- lapply(modelList, - function(object) suppressWarnings(try(drmOrdinal(object$levels, object$dose, object$weights, bootData[[i]], object$fct), silent = TRUE)) - ) - bmdBoot[i] <- suppressWarnings(as.numeric(try(MABmdEst(modelListBoot), silent = TRUE))) + used.Boot<-ifelse(identical(type,"bootstrap")|identical(type,"Bootstrap"), + floor(length(boot0)/length(modelList[[1]]$levelsMerged)),NA) + + resBMD<-list(Results = resMat, + Boot.samples.used = used.Boot, + interval = intMat, + modelWeights = modelWeights0, + bmdList = bmdList) + + if(display){ + print(resMat) } - CI <- quantile(bmdBoot, c(1-level, level), na.rm = TRUE) - Results = c(BMD = BMD, BMDL = CI[1]) - - bmdRes <- list(Results = Results, - interval = CI - ) - if(display) print(Results) - invisible(bmdRes) + + class(resBMD) <- "bmdOrdinal" + invisible(resBMD) } + +# old bmdOrdinalMA function ----------------------------------------------- + +# bmdOrdinalMA <- function(modelList, bmr=0.1, backgType = "modelBased", def="excess", level = 0.95, R = 500, bootType = "nonparametric", MAType = "postBmdEst", display = TRUE){ +# MABmdEst <- function(modelList){ +# bmdAllMods <- lapply(modelList, function(object) bmdOrdinal(object, bmr=bmr, backgType = backgType, def=def, interval = "none", display = FALSE)) +# +# AICVals <- sapply(modelList, AIC) +# AICWeights <- exp(-1/2*(AICVals - min(AICVals)))/sum(exp(-1/2*(AICVals - min(AICVals)))) +# +# if(MAType == "postBmdEst"){ +# BMD.tmp <- sapply(bmdAllMods, function(object) object$Results[1]) +# bmdVal <- sum(BMD.tmp*AICWeights) +# } else if (MAType == "preBmdEst"){ +# bmdEachCat <- sapply(1:length(modelList[[1]]$drmList), function(cat_i){ +# bmdAllMods0 <- sapply(bmdAllMods, +# function(object){ +# object$bmdList[[cat_i]]$Results[1] +# }) +# sum(AICWeights*bmdAllMods0) +# }) +# +# bmdVal <- mean(bmdEachCat) +# } +# bmdVal +# } +# +# BMD <- MABmdEst(modelList) +# +# # bootstrap +# bootData <- bootDataGenOrdinal(modelList[[1]],R=R, bootType = bootType) +# +# bmdBoot <- numeric(R) +# for(i in 1:R){ +# modelListBoot <- lapply(modelList, +# function(object) suppressWarnings(try(drmOrdinal(object$levels, object$dose, object$weights, bootData[[i]], object$fct), silent = TRUE)) +# ) +# bmdBoot[i] <- suppressWarnings(as.numeric(try(MABmdEst(modelListBoot), silent = TRUE))) +# } +# CI <- quantile(bmdBoot, c(1-level, level), na.rm = TRUE) +# Results = c(BMD = BMD, BMDL = CI[1]) +# +# bmdRes <- list(Results = Results, +# interval = CI +# ) +# if(display) print(Results) +# invisible(bmdRes) +# } diff --git a/R/bootDataGenOrdinal.R b/R/bootDataGenOrdinal.R index 98afb4f..ef901a1 100644 --- a/R/bootDataGenOrdinal.R +++ b/R/bootDataGenOrdinal.R @@ -1,6 +1,13 @@ bootDataGenOrdinal <- function(object, R = 500, bootType = c("nonparametric", "parametric", "model", "hierarchical")){ bootType <- match.arg(bootType) + if(!require("reshape2")){ + stop('package "reshape2" must be installed to use bootstrapping with ordinal dose-response model') + } + if(!require("dplyr")){ + stop('package "dplyr" must be installed to use bootstrapping with ordinal dose-response model') + } + if (bootType == "nonparametric") { data.e <- expandOrdinal(object) data.e[, "row.num"] <- 1:nrow(data.e) diff --git a/R/drmHetVar.R b/R/drmHetVar.R index c361fdf..f5d4535 100644 --- a/R/drmHetVar.R +++ b/R/drmHetVar.R @@ -11,6 +11,10 @@ drmHetVar <- function(object, var.formula){ stop('argument "formula" must be of class "formula"') } + if(!require("dplyr")){ + stop('package "dplyr" must be installed to fit dose-response model with heterogeneous variance') + } + # Add fitted values and residuals to data data <- object$data |> dplyr::mutate(fitted = fitted(object), diff --git a/R/getProfileLogLikFixedBmd.R b/R/getProfileLogLikFixedBmd.R index cef666c..2f9c864 100644 --- a/R/getProfileLogLikFixedBmd.R +++ b/R/getProfileLogLikFixedBmd.R @@ -4,6 +4,7 @@ getProfileLogLikFixedBmd <- function(object, curveRepar, bmr, start){ response <- object$dataList$resp weights <- object$dataList$weights + use_constrOptim <- TRUE # constrOptim options to ensure c < d when profiling likelihood (particularly important for Weibull models) if(all(is.na(object$fct$fixed[1:3]))){ # b,c,d not fixed ui <- matrix(c(0,-1,1), nrow = 1, byrow = TRUE) @@ -21,6 +22,7 @@ getProfileLogLikFixedBmd <- function(object, curveRepar, bmr, start){ ui <- matrix(c(0,1), nrow = 1) ci <- object$fct$fixed[2] } else if(is.na(object$fct$fixed[1]) & !is.na(object$fct$fixed[2]) & !is.na(object$fct$fixed[3])){ # c,d fixed + use_constrOptim <- FALSE ui <- matrix(0, nrow = 1) ci <- 0 } else if(is.na(object$fct$fixed[1]) & is.na(object$fct$fixed[2]) & !is.na(object$fct$fixed[3])){ # d fixed @@ -32,12 +34,18 @@ getProfileLogLikFixedBmd <- function(object, curveRepar, bmr, start){ if(identical(object$type, "continuous")){ profileLogLikFixedBmd <- function(BMD){ fn0 <- function(par){sum(((response - curveRepar(BMD, par, bmr)(dose))/weights)^2)} - constrOptim0 <- constrOptim(theta=start, + if(use_constrOptim){ + constrOptim0 <- constrOptim(theta=start, f = fn0, grad = NULL, ui = ui, ci = ci) - SSD <- constrOptim0$value + SSD <- constrOptim0$value + } else { + int0 <- confint(object,level = 0.99)[1,] + optim0 <- optim(par = start, f = fn0, method = "Brent", lower = int0[1], upper = int0[2]) + SSD <- optim0$value + } #sigmaSqHat <- object$fit$value/n # #llVal <- -n/2 * log(2*pi*sigmaSqHat) - SSD / (2*sigmaSqHat) @@ -70,7 +78,7 @@ getProfileLogLikFixedBmd <- function(object, curveRepar, bmr, start){ } } else if(identical(object$type, "Poisson")){ profileLogLikFixedBmd <- function(BMD){ - fn0 <- function(par){sum(response * log(curveRepar(BMD, par, bmr)(dose)) - curveRepar(BMD, par, bmr)(dose) - log(foctorial(response)) )} + fn0 <- function(par){sum(response * log(curveRepar(BMD, par, bmr)(dose)) - curveRepar(BMD, par, bmr)(dose) )} # sum(response * log(curveRepar(BMD, par, bmr)(dose)) - curveRepar(BMD, par, bmr)(dose) - log(foctorial(response)) ) constrOptim0 <- constrOptim(theta=start, f = fn0, grad = NULL, diff --git a/R/getStackingWeights.R b/R/getStackingWeights.R index 6a66771..4851707 100644 --- a/R/getStackingWeights.R +++ b/R/getStackingWeights.R @@ -201,6 +201,10 @@ getDataSplits <- function(object, nSplits){ } getStackingWeights <- function(modelList, nSplits = 2){ + if(!require("CVXR")){ + stop('package "CVXR" must be installed to estimate stacking weights') + } + if(nSplits %in% c("LOO")){ nSplits <- ifelse(modelList[[1]]$type == "binomial", sum(modelList[[1]]$data$weights), modelList[[1]]$sumList$lenData) } else if(!is.numeric(nSplits)){ diff --git a/R/mjust.R b/R/mjust.R index 031a40b..a9ccb87 100644 --- a/R/mjust.R +++ b/R/mjust.R @@ -1,193 +1,193 @@ -mjust<-function (modelList,expressions, dataused, level=0.95, seType="san") { - require(sandwich, quietly = TRUE) - require(car, quietly = TRUE) - require(RLRsim, quietly = TRUE) - require(Matrix, quietly = TRUE) - deltab<-function (object, g, func = g, ...) - { - if (!is.character(g)) - stop("The argument 'g' must be a character string") - if(inherits(object,c("lmerMod","lme"))){ - para<-fixef(object) - coefVec<-fixef(object) - para.names<-sapply(strsplit(names(coefVec), ":"), "[[", 1) - para.names[1] <- gsub("\\(Intercept\\)", "Intercept", para.names[1]) - names(para)<-para.names - }else{ - para <- coef(object) - if(inherits(object,"lm")){ - para.names <- names(coef(object)) - para.names[1] <- gsub("\\(Intercept\\)", "Intercept", para.names[1]) - names(para) <- para.names - }else{ - if(inherits(object,"drc")){ - coefVec<-coef(object) - #para.names<-sapply(strsplit(names(coefVec), ":"), "[[", 1) - para.names.tmp<-gsub(":", "_",names(coefVec)) - para.names<-sapply(strsplit(para.names.tmp, "_\\(Intercept\\)"), "[[", 1) - names(para)<-para.names - }else{ - para.names <- names(para) - }}} - g <- parse(text = g) - q <- length(para) - for (i in 1:q) { - assign(names(para)[i], para[i]) - } - gd <- rep(0,q) - for (i in 1:q) { - gd[i] <- eval(D(g, names(para)[i])) - } - gd - } - makeIIDdecomp <- function(modelObject,g) - { - if(inherits(modelObject, "lmerMod")){ - numObsUsed <- length(predict(modelObject)) - #data.tmp<-dataused - #data.tmp[is.na(data.tmp)]<-10 - allRepUnits<-unique(dataused[,names(getME(modelObject,"flist"))]) - repUnitsUsed<-unique(unlist(getME(modelObject,"flist"))) - naRepUnits<-as.numeric(setdiff(allRepUnits, repUnitsUsed)) - numInd<-length(repUnitsUsed) - beta<-getME(modelObject,"beta") - X<-getME(modelObject,"X") - Y<-getME(modelObject,"y") - Z<-getME(modelObject,"Z") - A<-getME(modelObject,"A") - Sigma<-sigma(modelObject) - R<-diag(Sigma^2,numObsUsed) - V<-sigma(modelObject)^2*t(A)%*%A+R - Vminus<-solve(V) - f<-function(i){ - if(allRepUnits[i]%in%repUnitsUsed){ - tmpList<-which(getME(modelObject,"flist")[[1]]==allRepUnits[i]) - Xi<-matrix(X[tmpList,],nrow=length(tmpList)) - Zi<-matrix(Z[tmpList,],nrow=length(tmpList)) - Vi<-V[tmpList,tmpList] - Yi<-matrix(Y[tmpList],nrow=length(tmpList)) - as.matrix(-t(Xi)%*%solve(Vi)%*%(Yi-Xi%*%beta))} else{matrix(rep(0,ncol(X)),ncol=1)}} - EstFun<-matrix(unlist(lapply(seq_along(allRepUnits),f)),nrow=length(allRepUnits),byrow=T) - db<-deltab(modelObject,g) - iidVec0<-as.matrix(-db%*%solve(t(X)%*%Vminus%*%X)*length(repUnitsUsed))%*%t(EstFun) - if (!is.null(naRepUnits)) { - iidVec <- sqrt(length(allRepUnits)/numInd) * iidVec0 - } else { - iidVec <- iidVec0 - } - }else{ - if(inherits(modelObject, "lme")){ - numObsUsed <- length(predict(modelObject)) - allRepUnits<-unique(modelObject$data[,attr(getGroups(modelObject),"label")]) - repUnitsUsed<-unique(getGroups(modelObject)) - naRepUnits<-as.numeric(setdiff(allRepUnits, repUnitsUsed)) - numInd<-length(repUnitsUsed) - beta<-fixed.effects(modelObject) - X<-extract.lmeDesign(modelObject)$X - Y<-as.matrix(extract.lmeDesign(modelObject)$y) - Z<-extract.lmeDesign(modelObject)$Z - GB<-getVarCov(modelObject) - G.Block<-matrix(as.numeric(GB),nrow=sqrt(length(GB))) - G<-bdiag(rep(list(G.Block),numInd)) - Sigma<-modelObject$sigma - if(is.null(modelObject$modelStruct$corStruct)){ - R<-diag(Sigma^2,numObsUsed) - }else{ - R<-Sigma^2*bdiag(corMatrix(modelObject$modelStruct$corStruct)) - } - V<-Z%*%G%*%t(Z)+R - Vminus<-solve(V) - f<-function(i){ - if(allRepUnits[i]%in%repUnitsUsed){ - tmpList<-which(getGroups(modelObject)==allRepUnits[i]) - Xi<-matrix(X[tmpList,],nrow=length(tmpList)) - Zi<-matrix(Z[tmpList,],nrow=length(tmpList)) - Vi<-V[tmpList,tmpList] - Yi<-matrix(Y[tmpList],nrow=length(tmpList)) - as.matrix(-t(Xi)%*%solve(Vi)%*%(Yi-Xi%*%beta))} else{matrix(rep(0,ncol(X)),ncol=1)}} - EstFun<-matrix(unlist(lapply(seq_along(allRepUnits),f)),nrow=length(allRepUnits),byrow=T) - db<-deltab(modelObject,g) - iidVec0<-as.matrix(-db%*%solve(t(X)%*%Vminus%*%X)*length(repUnitsUsed))%*%t(EstFun) - if (!is.null(naRepUnits)) { - iidVec <- sqrt(length(allRepUnits)/numInd) * iidVec0 - } else { - iidVec <- iidVec0 - } - }else{ - numObsUsed <- ifelse(inherits(modelObject, "coxph"), - modelObject$n, ifelse(inherits(modelObject,"nls"), - length(predict(modelObject)),ifelse(inherits(modelObject,"drc"), - length(predict(modelObject)), nrow(modelObject$model)))) - db<-deltab(modelObject,g) - iidVec0 <- db %*%bread(modelObject) %*% t(estfun(modelObject)) - moNAac <- modelObject$na.action - numObs <- numObsUsed + length(moNAac) - numInd<-numObs - iidVec <- rep(0, numObs) - if (!is.null(moNAac)) { - iidVec[-moNAac] <- sqrt(numObs/numObsUsed) * iidVec0[!is.na(iidVec0)] - } else { - iidVec <- iidVec0 - }}} - list(iidVec = iidVec, numObsUsed = numObsUsed, numInd = numInd) - } - iidList <- list() - numModels <- length(modelList) - for(i in 1:numModels) - { - iidList[[i]]<- makeIIDdecomp(modelList[[i]], expressions[[i]]) - } - iidresp <- matrix(as.vector(unlist(lapply(iidList, function(listElt){listElt[[1]]}))), nrow = numModels, byrow = TRUE) - numObsUsed <- as.vector(unlist(lapply(iidList, function(listElt) { - listElt[[2]]}))) - thetaEst <- rep(NA, numModels) - thetaSe <- rep(NA, numModels) - for(i in 1:numModels) - { - if (inherits(modelList[[i]], "drc")){ - coefVec <- coef(modelList[[i]]) - #names(coefVec) <- sapply(strsplit(names(coefVec), ":"), "[[", 1) - para.names.tmp<-gsub(":", "_",names(coefVec)) - names(coefVec)<-sapply(strsplit(para.names.tmp, "_\\(Intercept\\)"), "[[", 1) - deltaRes <- deltaMethod(coefVec,expressions[[i]],vcov(modelList[[i]])) - } else { - if (inherits(modelList[[i]], "lmerMod")){ - coefVec <- fixef(modelList[[i]]) - names(coefVec) <- sapply(strsplit(names(coefVec), ":"), "[[", 1) - deltaRes <- deltaMethod(coefVec,expressions[[i]],vcov(modelList[[i]])) - }else{ - deltaRes <- deltaMethod(modelList[[i]],expressions[[i]]) - }} - thetaEst[i] <- deltaRes[1] - thetaSe[i] <- deltaRes[2] - } - thetaEst <- unlist(thetaEst) - thetaSe <- unlist(thetaSe) - ## Calculating the estimated variance-covariance matrix of the parameter estimates - numInd <- iidList[[1]]$numInd - covar <- (iidresp %*% t(iidresp)) / numInd - vcMat <- covar / numInd # Defining the finite-sample variance-covariance matrix - ## Replacing sandwich estimates by model-based standard errors - modbas <- seType == "mod" - if (any(modbas)) - { - corMat <- cov2cor(vcMat) - ## Retrieving standard errors for the specified estimate from the individual fits - modSE <- thetaSe - sanSE <- sqrt(diag(vcMat)) - sanSE[modbas] <- modSE[modbas] - vcMat <- diag(sanSE,nrow=length(sanSE)) %*% corMat %*% diag(sanSE,nrow=length(sanSE)) - } - quant <- qnorm(1 - (1 - level)/2) - numInd <- iidList[[1]]$numInd - varMA <- vcMat - seMA <- sqrt(diag(varMA)) - quantVal <- quant * seMA - zVec <- thetaEst*(1/seMA) - pvals <- 1 - pchisq(zVec * zVec, 1) - retMat <- as.matrix(cbind(thetaEst, seMA, thetaEst - quantVal, thetaEst + quantVal,pvals)) - colnames(retMat) <- c("Estimate", "Std. Error", "Lower", "Upper", "Pr(>|z|)") - output<-list(retMat,varMA) - names(output)<-c("coef","covar") - return(invisible(output)) -} +# mjust<-function (modelList,expressions, dataused, level=0.95, seType="san") { +# require(sandwich, quietly = TRUE) +# require(car, quietly = TRUE) +# require(RLRsim, quietly = TRUE) +# require(Matrix, quietly = TRUE) +# deltab<-function (object, g, func = g, ...) +# { +# if (!is.character(g)) +# stop("The argument 'g' must be a character string") +# if(inherits(object,c("lmerMod","lme"))){ +# para<-fixef(object) +# coefVec<-fixef(object) +# para.names<-sapply(strsplit(names(coefVec), ":"), "[[", 1) +# para.names[1] <- gsub("\\(Intercept\\)", "Intercept", para.names[1]) +# names(para)<-para.names +# }else{ +# para <- coef(object) +# if(inherits(object,"lm")){ +# para.names <- names(coef(object)) +# para.names[1] <- gsub("\\(Intercept\\)", "Intercept", para.names[1]) +# names(para) <- para.names +# }else{ +# if(inherits(object,"drc")){ +# coefVec<-coef(object) +# #para.names<-sapply(strsplit(names(coefVec), ":"), "[[", 1) +# para.names.tmp<-gsub(":", "_",names(coefVec)) +# para.names<-sapply(strsplit(para.names.tmp, "_\\(Intercept\\)"), "[[", 1) +# names(para)<-para.names +# }else{ +# para.names <- names(para) +# }}} +# g <- parse(text = g) +# q <- length(para) +# for (i in 1:q) { +# assign(names(para)[i], para[i]) +# } +# gd <- rep(0,q) +# for (i in 1:q) { +# gd[i] <- eval(D(g, names(para)[i])) +# } +# gd +# } +# makeIIDdecomp <- function(modelObject,g) +# { +# if(inherits(modelObject, "lmerMod")){ +# numObsUsed <- length(predict(modelObject)) +# #data.tmp<-dataused +# #data.tmp[is.na(data.tmp)]<-10 +# allRepUnits<-unique(dataused[,names(getME(modelObject,"flist"))]) +# repUnitsUsed<-unique(unlist(getME(modelObject,"flist"))) +# naRepUnits<-as.numeric(setdiff(allRepUnits, repUnitsUsed)) +# numInd<-length(repUnitsUsed) +# beta<-getME(modelObject,"beta") +# X<-getME(modelObject,"X") +# Y<-getME(modelObject,"y") +# Z<-getME(modelObject,"Z") +# A<-getME(modelObject,"A") +# Sigma<-sigma(modelObject) +# R<-diag(Sigma^2,numObsUsed) +# V<-sigma(modelObject)^2*t(A)%*%A+R +# Vminus<-solve(V) +# f<-function(i){ +# if(allRepUnits[i]%in%repUnitsUsed){ +# tmpList<-which(getME(modelObject,"flist")[[1]]==allRepUnits[i]) +# Xi<-matrix(X[tmpList,],nrow=length(tmpList)) +# Zi<-matrix(Z[tmpList,],nrow=length(tmpList)) +# Vi<-V[tmpList,tmpList] +# Yi<-matrix(Y[tmpList],nrow=length(tmpList)) +# as.matrix(-t(Xi)%*%solve(Vi)%*%(Yi-Xi%*%beta))} else{matrix(rep(0,ncol(X)),ncol=1)}} +# EstFun<-matrix(unlist(lapply(seq_along(allRepUnits),f)),nrow=length(allRepUnits),byrow=T) +# db<-deltab(modelObject,g) +# iidVec0<-as.matrix(-db%*%solve(t(X)%*%Vminus%*%X)*length(repUnitsUsed))%*%t(EstFun) +# if (!is.null(naRepUnits)) { +# iidVec <- sqrt(length(allRepUnits)/numInd) * iidVec0 +# } else { +# iidVec <- iidVec0 +# } +# }else{ +# if(inherits(modelObject, "lme")){ +# numObsUsed <- length(predict(modelObject)) +# allRepUnits<-unique(modelObject$data[,attr(getGroups(modelObject),"label")]) +# repUnitsUsed<-unique(getGroups(modelObject)) +# naRepUnits<-as.numeric(setdiff(allRepUnits, repUnitsUsed)) +# numInd<-length(repUnitsUsed) +# beta<-fixed.effects(modelObject) +# X<-extract.lmeDesign(modelObject)$X +# Y<-as.matrix(extract.lmeDesign(modelObject)$y) +# Z<-extract.lmeDesign(modelObject)$Z +# GB<-getVarCov(modelObject) +# G.Block<-matrix(as.numeric(GB),nrow=sqrt(length(GB))) +# G<-bdiag(rep(list(G.Block),numInd)) +# Sigma<-modelObject$sigma +# if(is.null(modelObject$modelStruct$corStruct)){ +# R<-diag(Sigma^2,numObsUsed) +# }else{ +# R<-Sigma^2*bdiag(corMatrix(modelObject$modelStruct$corStruct)) +# } +# V<-Z%*%G%*%t(Z)+R +# Vminus<-solve(V) +# f<-function(i){ +# if(allRepUnits[i]%in%repUnitsUsed){ +# tmpList<-which(getGroups(modelObject)==allRepUnits[i]) +# Xi<-matrix(X[tmpList,],nrow=length(tmpList)) +# Zi<-matrix(Z[tmpList,],nrow=length(tmpList)) +# Vi<-V[tmpList,tmpList] +# Yi<-matrix(Y[tmpList],nrow=length(tmpList)) +# as.matrix(-t(Xi)%*%solve(Vi)%*%(Yi-Xi%*%beta))} else{matrix(rep(0,ncol(X)),ncol=1)}} +# EstFun<-matrix(unlist(lapply(seq_along(allRepUnits),f)),nrow=length(allRepUnits),byrow=T) +# db<-deltab(modelObject,g) +# iidVec0<-as.matrix(-db%*%solve(t(X)%*%Vminus%*%X)*length(repUnitsUsed))%*%t(EstFun) +# if (!is.null(naRepUnits)) { +# iidVec <- sqrt(length(allRepUnits)/numInd) * iidVec0 +# } else { +# iidVec <- iidVec0 +# } +# }else{ +# numObsUsed <- ifelse(inherits(modelObject, "coxph"), +# modelObject$n, ifelse(inherits(modelObject,"nls"), +# length(predict(modelObject)),ifelse(inherits(modelObject,"drc"), +# length(predict(modelObject)), nrow(modelObject$model)))) +# db<-deltab(modelObject,g) +# iidVec0 <- db %*%bread(modelObject) %*% t(estfun(modelObject)) +# moNAac <- modelObject$na.action +# numObs <- numObsUsed + length(moNAac) +# numInd<-numObs +# iidVec <- rep(0, numObs) +# if (!is.null(moNAac)) { +# iidVec[-moNAac] <- sqrt(numObs/numObsUsed) * iidVec0[!is.na(iidVec0)] +# } else { +# iidVec <- iidVec0 +# }}} +# list(iidVec = iidVec, numObsUsed = numObsUsed, numInd = numInd) +# } +# iidList <- list() +# numModels <- length(modelList) +# for(i in 1:numModels) +# { +# iidList[[i]]<- makeIIDdecomp(modelList[[i]], expressions[[i]]) +# } +# iidresp <- matrix(as.vector(unlist(lapply(iidList, function(listElt){listElt[[1]]}))), nrow = numModels, byrow = TRUE) +# numObsUsed <- as.vector(unlist(lapply(iidList, function(listElt) { +# listElt[[2]]}))) +# thetaEst <- rep(NA, numModels) +# thetaSe <- rep(NA, numModels) +# for(i in 1:numModels) +# { +# if (inherits(modelList[[i]], "drc")){ +# coefVec <- coef(modelList[[i]]) +# #names(coefVec) <- sapply(strsplit(names(coefVec), ":"), "[[", 1) +# para.names.tmp<-gsub(":", "_",names(coefVec)) +# names(coefVec)<-sapply(strsplit(para.names.tmp, "_\\(Intercept\\)"), "[[", 1) +# deltaRes <- deltaMethod(coefVec,expressions[[i]],vcov(modelList[[i]])) +# } else { +# if (inherits(modelList[[i]], "lmerMod")){ +# coefVec <- fixef(modelList[[i]]) +# names(coefVec) <- sapply(strsplit(names(coefVec), ":"), "[[", 1) +# deltaRes <- deltaMethod(coefVec,expressions[[i]],vcov(modelList[[i]])) +# }else{ +# deltaRes <- deltaMethod(modelList[[i]],expressions[[i]]) +# }} +# thetaEst[i] <- deltaRes[1] +# thetaSe[i] <- deltaRes[2] +# } +# thetaEst <- unlist(thetaEst) +# thetaSe <- unlist(thetaSe) +# ## Calculating the estimated variance-covariance matrix of the parameter estimates +# numInd <- iidList[[1]]$numInd +# covar <- (iidresp %*% t(iidresp)) / numInd +# vcMat <- covar / numInd # Defining the finite-sample variance-covariance matrix +# ## Replacing sandwich estimates by model-based standard errors +# modbas <- seType == "mod" +# if (any(modbas)) +# { +# corMat <- cov2cor(vcMat) +# ## Retrieving standard errors for the specified estimate from the individual fits +# modSE <- thetaSe +# sanSE <- sqrt(diag(vcMat)) +# sanSE[modbas] <- modSE[modbas] +# vcMat <- diag(sanSE,nrow=length(sanSE)) %*% corMat %*% diag(sanSE,nrow=length(sanSE)) +# } +# quant <- qnorm(1 - (1 - level)/2) +# numInd <- iidList[[1]]$numInd +# varMA <- vcMat +# seMA <- sqrt(diag(varMA)) +# quantVal <- quant * seMA +# zVec <- thetaEst*(1/seMA) +# pvals <- 1 - pchisq(zVec * zVec, 1) +# retMat <- as.matrix(cbind(thetaEst, seMA, thetaEst - quantVal, thetaEst + quantVal,pvals)) +# colnames(retMat) <- c("Estimate", "Std. Error", "Lower", "Upper", "Pr(>|z|)") +# output<-list(retMat,varMA) +# names(output)<-c("coef","covar") +# return(invisible(output)) +# } diff --git a/R/monotonicityTest.R b/R/monotonicityTest.R index 4fccaae..e0da1a0 100644 --- a/R/monotonicityTest.R +++ b/R/monotonicityTest.R @@ -18,6 +18,9 @@ monotonicityTest <- function(x, y, data, test = c("jonckheere", "bartholomew"), } if(test == "bartholomew"){ + if(!require("isotone")){ + stop('package "isotone" must be installed to use bartolomew monotonicity test') + } p.value <- .bartholomewTest(y = y, x = x, alternative = alternative, ...)$p.value names(p.value) <- NULL acceptMonotonicity = p.value < level diff --git a/R/plot.drcHetVar.R b/R/plot.drcHetVar.R index 10fb69e..89fdf57 100644 --- a/R/plot.drcHetVar.R +++ b/R/plot.drcHetVar.R @@ -1,5 +1,8 @@ plot.drcHetVar <- function(object, gridsize = 300){ # Add assertion of gridExtra + if(!require("gridExtra")){ + stop('package "gridExtra" must be installed to plot drcHetVar object') + } dName <- colnames(object$data.agg)[2] diff --git a/R/plot.drcOrdinal.R b/R/plot.drcOrdinal.R index 643772f..51507cb 100644 --- a/R/plot.drcOrdinal.R +++ b/R/plot.drcOrdinal.R @@ -1,4 +1,8 @@ plot.drcOrdinal <- function(object, col_pal = NULL, xlim = NULL){ + if(!require("scales")){ + stop('package "scales" must be installed to plot drcOrdinal object') + } + if(is.null(col_pal)){ col_pal <- scales::grey_pal(start = 0.9, end = 0)(length(object$levels)) } diff --git a/R/print.bmdHetVar.R b/R/print.bmdHetVar.R new file mode 100644 index 0000000..065455b --- /dev/null +++ b/R/print.bmdHetVar.R @@ -0,0 +1,16 @@ +"print.bmdHetVar" <- function(x, ..., digits = max(3, getOption("digits") - 3)) +{ + object <- x + classList <- class(object) + + if (length(object$Results)>0) + { + cat("\n") + print(object$Results) + } else { + cat("Problem occured. Please check whether the choice of bmr is meaningful\n") + } + cat("\n") + + invisible(object) +} \ No newline at end of file diff --git a/R/qplotBmd.R b/R/qplotBmd.R index 55f2ead..85947b3 100644 --- a/R/qplotBmd.R +++ b/R/qplotBmd.R @@ -1,36 +1,92 @@ -qplotBmd <- function(x, ..., interval = c("BMDL", "twosided", "none"), add = FALSE){ +qplotBmd <- function(x, ..., interval = c("BMDL", "twosided", "none"), col = FALSE, add = FALSE){ object <- x - model <- object$model - interval <- match.arg(interval) - xVert <- rep(object$Results[1],2) - yVert <- c(model$curve[[1]](object$Results[1]), 0) + if(!inherits(object, "bmd")){ + stop('qplotBmd only works for plotting objects of type "bmd"') + } - xHoriz <- c(0, ifelse(interval != "none", object$interval[1], object$Results[1])) - yHoriz <- rep(model$curve[[1]](object$Results[1]),2) + if(!is.null(object$modelWeights)){ + stop('qplotBmd does not for for model-averaged BMD') + } - xInt <- c(object$interval[1], ifelse(interval == "twosided", object$interval[2], object$Results[1])) - xLow <- rep(object$interval[1],2) - xUpp <- rep(object$interval[2],2) - returnLayers <- list(geom_line(aes(x = xHoriz, y = yHoriz), linetype = 2), - geom_line(aes(x = xVert, y = yVert))) + model <- object$model + interval <- match.arg(interval) - if(interval == "BMDL"){ - returnLayers <- c(returnLayers, - geom_line(aes(x = xInt, y = yHoriz)), - geom_line(aes(x = xLow, y = yVert))) - } else if(interval == "twosided"){ - returnLayers <- c(returnLayers, - geom_line(aes(x = xInt, y = yHoriz)), - geom_line(aes(x = xLow, y = yVert)), - geom_line(aes(x = xUpp, y = yVert))) + if(nrow(object$Results) == 1){ + # One curve + xVert <- rep(object$Results[1],2) + yVert <- c(model$curve[[1]](object$Results[1]), 0) + + xHoriz <- c(0, ifelse(interval != "none", object$interval[1], object$Results[1])) + yHoriz <- rep(model$curve[[1]](object$Results[1]),2) + + xInt <- c(object$interval[1], ifelse(interval == "twosided", object$interval[2], object$Results[1])) + xLow <- rep(object$interval[1],2) + xUpp <- rep(object$interval[2],2) + + returnLayers <- list(geom_line(aes(x = xHoriz, y = yHoriz), linetype = 2), + geom_line(aes(x = xVert, y = yVert))) + + if(interval == "BMDL"){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz)), + geom_line(aes(x = xLow, y = yVert))) + } else if(interval == "twosided"){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz)), + geom_line(aes(x = xLow, y = yVert)), + geom_line(aes(x = xUpp, y = yVert))) + } + } else { + # Multiple curves + curveLevels <- unique(model$dataList$curveid) + + xVert <- rep(object$Results[,1],each = 2) + curveID <- names(xVert) + yVertVal <- diag(model$curve[[1]](object$Results[,1])[,match(rownames(object$Results), curveLevels)]) + yVert <- numeric(nrow(object$Results)*2) + yVert[1:nrow(object$Results)*2 - 1] <- yVertVal + + xHoriz <- unlist(lapply(1:nrow(object$Results), function(row) c(0, ifelse(interval != "none", object$interval[row, 1], object$Results[row, 1])))) + yHoriz <- rep(diag(model$curve[[1]](object$Results[,1])[,match(rownames(object$Results), curveLevels)]), each = 2) + + xInt <- unlist(lapply(1:nrow(object$Results), function(row) c(object$interval[row, 1], ifelse(interval == "twosided", object$interval[row, 2], object$Results[row, 1])))) + xLow <- rep(object$interval[,1],each = 2) + xUpp <- rep(object$interval[,2], each = 2) + + if(col){ + returnLayers <- list(geom_line(aes(x = xHoriz, y = yHoriz, col = curveID, group = curveID), linetype = 2), + geom_line(aes(x = xVert, y = yVert, col = curveID, group = curveID))) + } else { + returnLayers <- list(geom_line(aes(x = xHoriz, y = yHoriz, linetype = curveID, group = curveID)), + geom_line(aes(x = xVert, y = yVert, linetype = curveID, group = curveID))) + } + + if(interval == "BMDL" & col){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz, col = curveID, group = curveID)), + geom_line(aes(x = xLow, y = yVert, col = curveID, group = curveID))) + } else if(interval == "BMDL" & !col){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz, linetype = curveID, group = curveID)), + geom_line(aes(x = xLow, y = yVert, linetype = curveID, group = curveID))) + } else if(interval == "twosided" & col){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz, col = curveID, group = curveID)), + geom_line(aes(x = xLow, y = yVert, col = curveID, group = curveID)), + geom_line(aes(x = xUpp, y = yVert, col = curveID, group = curveID))) + } else if(interval == "twosided" & !col){ + returnLayers <- c(returnLayers, + geom_line(aes(x = xInt, y = yHoriz, linetype = curveID, group = curveID)), + geom_line(aes(x = xLow, y = yVert, linetype = curveID, group = curveID)), + geom_line(aes(x = xUpp, y = yVert, linetype = curveID, group = curveID))) + } } - if(add){ returnLayers } else { - qplotDrc(model, ...) + + qplotDrc(model, ..., col = col) + returnLayers } } diff --git a/R/qplotDrc.R b/R/qplotDrc.R index 4891dcf..c9a2feb 100644 --- a/R/qplotDrc.R +++ b/R/qplotDrc.R @@ -77,27 +77,7 @@ qplotDrc <- function(x, add = FALSE, level = NULL, type = c("average", "all", "b xLimits0 <- pmax(xLimits, 1e-8) } - # Handling small dose values - ## Constructing appropriate break on dose axis - # if (!is.null(logDose)) # natural logarithm - # { - # conLevel <- round(min(dose[is.finite(dose)])) - 1 - # } else { - # log10cl <- round(log10(min(dose[dose > 0]))) - 1 - # conLevel <- 10^(log10cl) - # } - # - # if ((xLimits[1] < conLevel) && (logX || (!is.null(logDose)))) - # { - # xLimits[1] <- conLevel - # smallDoses <- (dose < conLevel) - # dose[smallDoses] <- conLevel - # } - # if (xLimits[1] >= xLimits[2]) {stop("Argument 'conLevel' is set too high")} - - ## Constructing dose values for plotting - # if (doseDim == 1) - # { + # Constructing dose values for plotting if ((is.null(logDose)) && (logX)) { dosePts <- c(0,exp(seq(log(xLimits0[1]), log(xLimits0[2]), length = gridsize-1))) diff --git a/R/trendTest.R b/R/trendTest.R index b73dd76..4a6699b 100644 --- a/R/trendTest.R +++ b/R/trendTest.R @@ -23,6 +23,9 @@ trendTest <- function(x, y, data, test = c("william", "shirley", "tukey"), level } if(test == "tukey"){ + if(!require("multcomp")){ + stop('package "multcomp" must be installed to use tukey trend test') + } fitw <- lm(y ~ x) ttw <- .tukeytrendfit(y, x) res <- multcomp:::summary.glht(multcomp:::glht(model=ttw$mmm, linfct=ttw$mlf)) diff --git a/R/tukeytrendtest.R b/R/tukeytrendtest.R index b2de48c..3961f50 100644 --- a/R/tukeytrendtest.R +++ b/R/tukeytrendtest.R @@ -1,7 +1,7 @@ -.tukeytrendtest <- function(y,x){ - ttw <- .tukeytrendfit(y, x) - res <- multcomp:::summary.glht(multcomp:::glht(model=ttw$mmm, linfct=ttw$mlf)) - - res -} - +# .tukeytrendtest <- function(y,x){ +# ttw <- .tukeytrendfit(y, x) +# res <- multcomp:::summary.glht(multcomp:::glht(model=ttw$mmm, linfct=ttw$mlf)) +# +# res +# } +# diff --git a/man/bmdMA.Rd b/man/bmdMA.Rd index 1ef8a43..2ddfe44 100644 --- a/man/bmdMA.Rd +++ b/man/bmdMA.Rd @@ -8,7 +8,7 @@ Model-averaged benchmark dose estimation \usage{ bmdMA(modelList, modelWeights, bmr, backgType = c("modelBased", "absolute", "hybridSD", "hybridPercentile"), backg = NA, def = c("excess", "additional", "relative", "extra", "added", "hybridExc", "hybridAdd", "point"),respTrans = c("none", "log", "sqrt"), -interval = c("delta","sandwich","inv", “profile”), +interval = c("delta","sandwich","inv", "profile"), type = c("curve","bootstrap","Kang","Buckland"), bootstrapType, R=1000, bootInterval, level=0.95, stackingSeed, stackingSplits, display = TRUE, progressInfo = TRUE) } \arguments{ diff --git a/tests/.DS_Store b/tests/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..a1f14fc996c94393571c403f477527957a961f64 GIT binary patch literal 6148 zcmeHKJ8Hu~5S_7I2;8W2xmU;y7UP^i7f8S%DS{1-lUkL}m80d&2NSVMV{jARz|7m7 zowq`-&}c+Nx1ak5kzPbPxS?Duv}Wh#jV&^xKsfF=%bPsQ`D-{Gn(Fz4aXau{sQ?wA0#^m>`%vJ9HE|5|PX~gJ0KgT} zZdm&)0W6jP*2FOo8JGqY7*x#>LxYZd$-0_21_oU;hY!ssYfdQYPsjbm%SCG-BNd?XCYm!vC26rzGyE02TOG3g~J#?6!EN?5)kqS+6bdC%Dyo!_BaE3WB#|ptoae ftQ~K>DC&x>ab6S0K&K<`bRd5QOcxpzxVHj7>hcx4 literal 0 HcmV?d00001 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..b00de44 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(bmd) + +test_check("bmd") diff --git a/tests/testthat/_snaps/bmd.md b/tests/testthat/_snaps/bmd.md new file mode 100644 index 0000000..5bf162b --- /dev/null +++ b/tests/testthat/_snaps/bmd.md @@ -0,0 +1,13 @@ +# bmd function output remains consistent + + list(Results = list(1.46370565552042, 1.09762076180767), bmrScaled = list( + 7.06180378317457), interval = list(1.09762076180767, 1.82979054923317), + SE = list(0.212257796434502)) + +# bmd function output remains consistent with model with multiple curves + + list(Results = list(27.6431334479098, 19.0792672089108, 15.4192368012224, + 14.5843698054813), bmrScaled = list(3.57730673289523, 3.49339602606279), + interval = list(15.4192368012224, 14.5843698054813, 39.8670300945973, + 23.5741646123403), SE = list(7.31685568612001, 2.69050995565491)) + diff --git a/tests/testthat/_snaps/bmdBoot.md b/tests/testthat/_snaps/bmdBoot.md new file mode 100644 index 0000000..2ea8855 --- /dev/null +++ b/tests/testthat/_snaps/bmdBoot.md @@ -0,0 +1,50 @@ +# bmdBoot function output remains consistent + + list(Results = list(1.46370565552042, 1.34582379343345), Boot.samples.used = list( + 50L), bootEst = list(1.61798756159097, 1.41235289955296, + 1.34891786747405, 1.56084609147602, 1.4589995594648, 1.58462479569707, + 1.59808627530537, 1.57624280402295, 1.78554315897185, 1.47047532159475, + 1.54076779834889, 1.30458061288242, 1.71121522929186, 1.48085242130152, + 1.41105731597124, 1.29867412186265, 1.41525015132566, 1.59179836185334, + 1.36222074511543, 1.45333042624506, 1.39234075348772, 1.44244934031635, + 1.51013314618521, 1.4094275338799, 1.61510439487498, 1.41870192459578, + 1.37747487989361, 1.67184156128739, 1.52809761200927, 1.30882691509647, + 1.72218959612967, 1.43605053580238, 1.65584712042391, 1.69574595450121, + 1.44773553717315, 1.6358811865788, 1.31797712706808, 1.46936230629847, + 1.59318406741886, 1.48528152408138, 1.56481220693063, 1.37298856685247, + 1.64793217864655, 1.36108236389641, 1.57142765971705, 1.22554032024861, + 1.58233765915483, 1.49886973052604, 1.47317687460284, 1.53201417056758), + interval = list(1.34582379343345, 1.65744656451026)) + +# bmdBoot function output remains consistent with model with multiple curves + + list(Results = list(27.6431334479098, 19.0792672089108, 16.0301136700043, + 15.3149707721786), Boot.samples.used = list(50L), bootEst = list( + 25.4354822775776, 27.942138820336, 34.4317998350383, 11.8921276645723, + 33.9838039005983, 27.9620856193367, 21.0456426902723, 31.1037525336926, + 22.5072360411477, 24.1707399127011, 39.0882796135614, 26.4048544806035, + 14.4589469015578, 16.6913076751371, 38.8703467895175, 43.5475899725746, + 32.7919550915751, 39.2360954821873, 27.242859842169, 15.4310129014872, + 22.0155901503782, 18.7716579579422, 35.3288421494031, 33.8866210281641, + 12.2878823580102, 23.658947452723, 13.2256483688195, 16.8507749231681, + 29.4674553717342, 28.707399572218, 21.8996970091451, 29.6745172367917, + 27.046629970096, 25.0301610245813, 18.8437523155041, 18.487747535518, + 16.0966804220617, 24.0527057192132, 22.6456625272293, 24.5664605666236, + 20.961065856008, 35.0205899385843, 17.7110848442554, 18.15689244705, + 30.1510826917904, 23.1232084695916, 19.0179338463447, 28.6173416061988, + 33.381859399473, 19.8872287941957, 20.4930160716829, 18.9259268173792, + 18.9042788479663, 17.6591249802318, 8.01766576766874, 19.9297732221371, + 20.0222583708623, 14.3872708208148, 23.6912799994014, 19.1304484659397, + 16.3041436549771, 18.314628984277, 19.3984464237195, 30.2163468757722, + 19.1083803482074, 18.4825179374548, 15.5920871991184, 18.761054993438, + 15.3453512799772, 16.5554408603265, 17.472159183394, 20.0651043209023, + 20.8891910762864, 21.3408009034559, 18.939356492636, 16.8251418047285, + 20.2886830521809, 19.1706766795621, 16.1534384700393, 15.0415462019912, + 18.1396514453889, 15.9061906922464, 25.9765005222322, 17.3597088678706, + 15.4448594731546, 13.7315902186157, 16.2915407501279, 20.1113257496017, + 14.193300547134, 24.4090073426321, 17.1352190023708, 19.0766611051265, + 20.5547815975659, 29.976691289462, 18.8434148759131, 17.8078847758707, + 17.8225060826609, 26.1400140889292, 19.6848859722448, 21.658176526469), + interval = list(16.0301136700043, 15.3149707721786, 35.0514151596662, + 23.7630527337244)) + diff --git a/tests/testthat/_snaps/bmdMA.md b/tests/testthat/_snaps/bmdMA.md new file mode 100644 index 0000000..abbb5bc --- /dev/null +++ b/tests/testthat/_snaps/bmdMA.md @@ -0,0 +1,13 @@ +# bmdMA function output remains consistent + + list(Results = list(0.471033344305615, 0.352093684112111), Boot.samples.used = list( + NA), interval = list(0.352093684112111, 0.589973004499119), + SE = list(0.0723101789999049)) + +# bmdMA function output remains consistent with model with multiple curves + + list(Results = list(26.217084148886, 18.3083143555412, 13.3896911220017, + 13.9810001207342), Boot.samples.used = list(NA), interval = list( + 13.3896911220017, 13.9810001207342, 39.0444771757703, 22.6356285903482), + SE = list(7.79850122631171, 2.63082025287995)) + diff --git a/tests/testthat/test-MACurve.R b/tests/testthat/test-MACurve.R new file mode 100644 index 0000000..dea9488 --- /dev/null +++ b/tests/testthat/test-MACurve.R @@ -0,0 +1,42 @@ +# Tests for MACurve function +# - Arguments and structure +# - Missing arguments +# - aconiazide models + + +# Arguments and structure ------------------------------------------------- + +test_that("MACurve function handles missing required arguments", { + aconiazide.LL.3 <- drm(weightChange ~ dose,data = drcData::aconiazide,fct = LL.3()) + aconiazide.W2.3 <- drm(weightChange ~ dose,data = drcData::aconiazide,fct = W2.3()) + + expect_error(MACurve(modelList = list(aconiazide.LL.3, aconiazide.W2.3), modelWeights = "AIC"), 'argument "x" is missing, with no default') + expect_error(MACurve(x = 1:10, modelWeights = "AIC"), 'argument "modelList" is missing, with no default') + expect_error(MACurve(x = 1:10, modelList = list(aconiazide.LL.3, aconiazide.W2.3)), 'argument "modelWeights" is missing, with no default') +}) + + +# aconiazide models ------------------------------------------------------- + +test_that("MACurve handles modelWeights argument", { + aconiazide.LL.3 <- drm(weightChange ~ dose,data = drcData::aconiazide, fct = LL.3()) + aconiazide.LN.3 <- drm(weightChange ~ dose,data = drcData::aconiazide, fct = LN.3()) + aconiazide.W1.3 <- drm(weightChange ~ dose,data= drcData::aconiazide, fct = W1.3()) + aconiazide.W2.3 <- drm(weightChange ~ dose,data= drcData::aconiazide, fct = W2.3()) + modelList0 <- list(aconiazide.LL.3, aconiazide.LN.3,aconiazide.W1.3, aconiazide.W2.3) + + # model weights + manWeights0 <- c(0.3, 0.2, 0.2, 0.3) + AICWeights0 <- exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) / sum(exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) ) + BICWeights0 <- exp(-1/2 * sapply(modelList0, BIC)) / sum(exp(-1/2 * sapply(modelList0, BIC)) ) + set.seed(1) + stackingWeights0 <- getStackingWeights(modelList0, nSplits = 3) + + x <- c(0, 50, 100, 150, 200, 250, 300, 350, 400) + curveMat <- sapply(modelList0, function(mod) mod$curve[[1]](x)) + + expect_equal(MACurve(x, modelList0, manWeights0), apply(curveMat, 1, function(z) sum(z * manWeights0))) + expect_equal(MACurve(x, modelList0, "AIC"), apply(curveMat, 1, function(z) sum(z * AICWeights0))) + expect_equal(MACurve(x, modelList0, "BIC"), apply(curveMat, 1, function(z) sum(z * BICWeights0))) + expect_equal(MACurve(x, modelList0, "Stack", stackingSeed = 1, stackingSplits = 3), apply(curveMat, 1, function(z) sum(z * stackingWeights0))) +}) diff --git a/tests/testthat/test-bmd.R b/tests/testthat/test-bmd.R new file mode 100644 index 0000000..be15212 --- /dev/null +++ b/tests/testthat/test-bmd.R @@ -0,0 +1,1367 @@ +# Tests for bmd function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - Simple model +# - correct bmd estimate +# - delta and profile intervals +# - Ryegrass model (continuous) +# - correct bmd estimate (all definitions) +# - delta, inv and profile intervals +# - Ryegrass hormesis model (continuous) +# - correct bmd estimate (all definitions) +# - delta and profile intervals +# - TCDD model (binomial) +# - correct bmd estimate (excess + additional) +# - delta and inv intervals +# - Lemna model (count) +# - correct bmd estimate (all definitions) +# - delta, inv and profile intervals +# - S.alba model (continuous with multiple curves) +# - correct bmd estimate (point, extra, hybridExc) +# - delta and profile intervals +# - Increasing continuous model +# - correct bmd estimate (all definitions) +# - delta, inv and profile intervals +# - Decreasing binomial model with multiple curves +# - correct bmd estimate (point, extra, hybridExc) +# - delta + + +# Arguments and structure ------------------------------------------------- + +test_that("bmd function handles missing required arguments", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + + expect_error(bmd(), "object is missing") + expect_error(bmd(object0), "def is missing") + expect_error(bmd(lm(1:10 ~ 1)), 'object must be of class "drc"') + expect_error(bmd(object0, def = "invalid_def", backgType = "modelBased"), "Could not recognize def") + expect_error(bmd(object0, def = "excess", backgType = "invalid_type"), "Could not recognize backgType") + expect_error(bmd(object0, def = "excess"), "backgType is missing") +}) + + +test_that("bmd function accepts correct def", { + object.cont <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + object.binom <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2(), type = "binomial") + object.poisson <- drm(y ~ x, data = data.frame(x = 1:5, y = c(12,11,3,0,0)), fct = LL.3(), type = "Poisson") + + # Binomial bmd def with continuous model + expect_error(bmd(object.cont, def = "excess", backgType = "modelBased"), '"excess" is not available for continuous data') + expect_error(bmd(object.cont, def = "additional", backgType = "modelBased"), '"additional" is not available for continuous data') + + # Binomial bmd def with Poisson model + expect_error(bmd(object.poisson, def = "excess", backgType = "modelBased"), '"excess" is not available for count data') + expect_error(bmd(object.poisson, def = "additional", backgType = "modelBased"), '"additional" is not available for count data') + + # Cont bmd def with binomial model + expect_error(bmd(object.binom, def = "relative", backgType = "modelBased"), '"relative" is not available for quantal data') + expect_error(bmd(object.binom, def = "extra", backgType = "modelBased"), '"extra" is not available for quantal data') + expect_error(bmd(object.binom, def = "added", backgType = "modelBased"), '"added" is not available for quantal data') + expect_error(bmd(object.binom, def = "hybridExc", backgType = "modelBased"), '"hybridExc" is not available for quantal data') + expect_error(bmd(object.binom, def = "hybridAdd", backgType = "modelBased"), '"hybridAdd" is not available for quantal data') +}) + +test_that("bmd function returns expected structure", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + expect_type(result, "list") + expect_named(result, c("Results", "bmrScaled", "interval", "SE", "model")) + expect_s3_class(result, "bmd") +}) + + +# Simple model results ---------------------------------------------------- + +test_that("bmd function computes BMD (extra, bmr = 0.1) correctly for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 16.4578682695665) + expect_equal(result$bmrScaled[1], 0.9) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) +}) + +test_that("bmd function computes BMD (extra, bmr = 0.05) correctly for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.05, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 15.4022544235763) + expect_equal(result$bmrScaled[1], 0.95) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) +}) + +test_that("bmd function computes correct confidence interval for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$interval[1, "Lower"])) + expect_true(!is.na(result$interval[1, "Upper"])) + expect_equal(result$Results[1, "BMDL"], result$interval[1, "Lower"]) + expect_equal(result$interval[1, "Lower"], 16.0631524054276) + expect_equal(result$interval[1, "Upper"], 16.8525841337055) +}) + +test_that("bmd function computes correct profile confidence interval for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$interval[1, "Lower"])) + expect_true(!is.na(result$interval[1, "Upper"])) + expect_equal(result$Results[1, "BMDL"], result$interval[1, "Lower"]) + expect_equal(result$interval[1, "Lower"], 16.3431132583152) + expect_equal(result$interval[1, "Upper"], 17.2291662734977) +}) + +test_that("bmd function computes correct profile grid confidence interval for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profileGrid", profileGridSize = 50, profileProgressInfo = FALSE, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$interval[1, "Lower"])) + expect_true(!is.na(result$interval[1, "Upper"])) + expect_equal(result$Results[1, "BMDL"], result$interval[1, "Lower"]) + expect_equal(result$interval[1, "Lower"], 16.3452825544063) + expect_equal(result$interval[1, "Upper"], 16.968912613503) +}) + +test_that("bmd function computes correct inverse regression confidence interval for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "inv", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$interval[1, "Lower"])) + expect_true(!is.na(result$interval[1, "Upper"])) + expect_equal(result$Results[1, "BMDL"], result$interval[1, "Lower"]) + expect_equal(result$interval[1, "Lower"], 16.0671734467641) + expect_equal(result$interval[1, "Upper"], 16.8460197017419) +}) + +test_that("bmd function computes correct sandwich confidence interval for a simple model", { + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "sandwich", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$interval[1, "Lower"])) + expect_true(!is.na(result$interval[1, "Upper"])) + expect_equal(result$Results[1, "BMDL"], result$interval[1, "Lower"]) + expect_equal(result$interval[1, "Lower"], 16.1160251608648) + expect_equal(result$interval[1, "Upper"], 16.7997113782683) +}) + + +# Ryegrass results -------------------------------------------------------- + +test_that("bmd function computes BMD (point) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultProfile <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.64586140417992) + expect_equal(result$bmrScaled[1,1], 3.2) + expect_equal(unname(result$interval[1,]), c(3.29979318251471,3.99192962584513)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 3.64586140417992) + expect_equal(resultSandwich$bmrScaled[1,1], 3.2) + expect_equal(unname(resultSandwich$interval[1,]), c(3.05041199694892,4.24131081141093)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 3.64586140417992) + expect_equal(resultProfile$bmrScaled[1,1], 3.2) + expect_equal(unname(resultProfile$interval[1,]), c(3.35333436333173,3.97998278397355)) +}) + +test_that("bmd function computes BMD (extra) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.46370565552042) + expect_equal(result$bmrScaled[1,1], 7.06180378317457) + expect_equal(unname(result$interval[1,]), c(1.09762076180767,1.82979054923317)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.46370565552042) + expect_equal(resultSandwich$bmrScaled[1,1], 7.06180378317457) + expect_equal(unname(resultSandwich$interval[1,]), c(1.20293156219483,1.72447974884601)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 1.46370565552042) + expect_equal(resultInv$bmrScaled[1,1], 7.06180378317457) + expect_equal(unname(resultInv$interval[1,]), c(1.0984899569084,1.78450772463462)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 1.46370565552042) + expect_equal(resultProfile$bmrScaled[1,1], 7.06180378317457) + expect_equal(unname(resultProfile$interval[1,]), c(1.19113157178988,1.77626232094376)) +}) + +test_that("bmd function computes BMD (relative) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.49902599632103) + expect_equal(result$bmrScaled[1,1], 7.01366246432993) + expect_equal(unname(result$interval[1,]), c(1.169727030614,1.82832496202805)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)*0.9)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.49902599632103) + expect_equal(resultSandwich$bmrScaled[1,1], 7.01366246432993) + expect_equal(unname(resultSandwich$interval[1,]), c(1.26495561665339,1.73309637598867)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 1.49902599632103) + expect_equal(resultInv$bmrScaled[1,1], 7.01366246432993) + expect_equal(unname(resultInv$interval[1,]), c(1.22042713497344,1.85131632264505)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 1.49902599632103) + expect_equal(resultProfile$bmrScaled[1,1], 7.01366246432993) + expect_equal(unname(resultProfile$interval[1,]), c(1.21827509151193,1.81632858455702)) +}) + +test_that("bmd function computes BMD (added) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.728443033284576) + expect_equal(result$bmrScaled[1,1], 7.69295829369992) + expect_equal(unname(result$interval[1,]), c(0.430465534681424,1.02642053188773)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)-0.1)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 0.728443033284576) + expect_equal(resultSandwich$bmrScaled[1,1], 7.69295829369992) + expect_equal(unname(resultSandwich$interval[1,]), c(0.488754570273184,0.968131496295969)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 0.728443033284576) + expect_equal(resultInv$bmrScaled[1,1], 7.69295829369992) + expect_equal(unname(resultInv$interval[1,]), c(0.538085589755732,1.22374370219594)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 0.728443033284576) + expect_equal(resultProfile$bmrScaled[1,1], 7.69295829369992) + expect_equal(unname(resultProfile$interval[1,]), c(0.491324061645358,1.03306247242863)) +}) + +test_that("bmd function computes BMD (hybridAdd with hybridSD background) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, interval = "sandwich", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.21255236145362) + expect_equal(result$bmrScaled[1,1], 7.35717345395457) + expect_equal(unname(result$interval[1,]), c(0.873582617250351,1.55152210565689)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.21255236145362) + expect_equal(resultSandwich$bmrScaled[1,1], 7.35717345395457) + expect_equal(unname(resultSandwich$interval[1,]), c(0.963502821126824,1.46160190178042)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 1.21255236145362) + expect_equal(resultInv$bmrScaled[1,1], 7.35717345395457) + expect_equal(unname(resultInv$interval[1,]), c(0.840460235800311,1.67657493370587)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 1.21255236145362) + expect_equal(resultProfile$bmrScaled[1,1], 7.35717345395457) + expect_equal(unname(resultProfile$interval[1,]), c(0.963502821126824,1.46160190178042)) +}) + +test_that("bmd function computes BMD (hybridExc with hybridSD background) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, interval = "inv", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.20672107998472) + expect_equal(result$bmrScaled[1,1], 7.36302788484143) + expect_equal(unname(result$interval[1,]), c(0.867947011182731,1.5454951487867)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.20672107998472) + expect_equal(resultSandwich$bmrScaled[1,1], 7.36302788484143) + expect_equal(unname(resultSandwich$interval[1,]), c(0.95757586537566,1.45586629459377)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 1.20672107998472) + expect_equal(resultInv$bmrScaled[1,1], 7.36302788484143) + expect_equal(unname(resultInv$interval[1,]), c(0.829285739324717,1.6744386486465)) +}) + +test_that("bmd function computes BMD (hybridExc with hybridPercentile background) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, sandwich.vcov = TRUE, display = FALSE) + # resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "profile", profileGridSize = 10, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.06888690340628) + expect_equal(result$bmrScaled[1,1], 7.4880773398374) + expect_equal(unname(result$interval[1,]), c(0.73651603354879,1.40125777326377)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.06888690340628) + expect_equal(resultSandwich$bmrScaled[1,1], 7.4880773398374) + expect_equal(unname(resultSandwich$interval[1,]), c(0.818465022872052,1.31930878394051)) +}) + +test_that("bmd function computes BMD (hybridExc with absolute background) correctly for ryegrass model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 7, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 7, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 7, interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "profile", profileGridSize = 10, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.02463261154772) + expect_equal(result$bmrScaled[1,1], 7.52286309492537) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(0.742468238743962,1.30679698435148)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.02463261154772) + expect_equal(resultSandwich$bmrScaled[1,1], 7.52286309492537) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(0.779180809291058,1.27008441380438)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 1.02463261154772) + expect_equal(resultInv$bmrScaled[1,1], 7.52286309492537) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(0,1.52216300113826)) + +}) + +test_that("bmd function computes BMD (relative) with log-transformed response correctly for ryegrass model", { + object0 <- drm(log(rootl) ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", sandwich.vcov = TRUE, display = FALSE) + expect_error(bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", interval = "inv", display = FALSE), + "inverse regression interval not available for transformed response.") + resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.804218529940602) + expect_equal(result$bmrScaled[1,1], 2.00113913603417) + expect_equal(unname(result$interval[1,]), c(0.334333144874303,1.2741039150069)) + expect_equal(result$bmrScaled[1], log(exp(drop(object0$curve[[1]](0)))*0.9)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 0.804218529940602) + expect_equal(resultSandwich$bmrScaled[1,1], 2.00113913603417) + expect_equal(unname(resultSandwich$interval[1,]), c(0.373462062730365,1.23497499715084)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 0.804218529940602) + expect_equal(resultProfile$bmrScaled[1,1], 2.00113913603417) + expect_equal(unname(resultProfile$interval[1,]), c(0.44414568898271,1.28705989275751)) +}) + +test_that("bmd function computes BMD (relative) with square root-transformed response correctly for ryegrass model", { + object0 <- drm(sqrt(rootl) ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", sandwich.vcov = TRUE, display = FALSE) + expect_error(bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", interval = "inv", display = FALSE), + "inverse regression interval not available for transformed response.") + resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.29590294092622) + expect_equal(result$bmrScaled[1,1], 2.66331630265024) + expect_equal(unname(result$interval[1,]), c(0.905813486374546,1.68599239547789)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 1.29590294092622) + expect_equal(resultSandwich$bmrScaled[1,1], 2.66331630265024) + expect_equal(unname(resultSandwich$interval[1,]), c(1.0388236576693,1.55298222418313)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 1.29590294092622) + expect_equal(resultProfile$bmrScaled[1,1], 2.66331630265024) + expect_equal(unname(resultProfile$interval[1,]), c(0.970730080509468,1.67207902698738)) +}) + + +test_that("bmd function output remains consistent", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + snapshot_data <- list( + Results = as.list(result$Results), + bmrScaled = as.list(result$bmrScaled), + interval = as.list(result$interval), + SE = as.list(result$SE) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + + +# Ryegrass hormesis ------------------------------------------------------- + +test_that("bmd function computes BMD (point) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.63196270261622) + expect_equal(result$bmrScaled[1,1], 3.2) + expect_equal(unname(result$interval[1,]), c(3.26967714112966,3.99424826410278)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (extra) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.53181216366916) + expect_equal(result$bmrScaled[1,1], 7.00907118396823) + expect_equal(unname(result$interval[1,]), c(1.14799694948346,1.91562737785485)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (relative) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.55704870290614) + expect_equal(result$bmrScaled[1,1], 6.96755641076537) + expect_equal(unname(result$interval[1,]), c(1.21211587595366,1.90198152985862)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)*0.9)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (added) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.02789452211147) + expect_equal(result$bmrScaled[1,1], 7.64172934529486) + expect_equal(unname(result$interval[1,]), c(0.31475182419264,1.7410372200303)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)-0.1)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (hybridAdd with hybridSD background) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.33874261053728) + expect_equal(result$bmrScaled[1,1], 7.29834344888762) + expect_equal(unname(result$interval[1,]), c(0.903981308119492,1.77350391295507)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (hybridExc with hybridSD background) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.33434665932782) + expect_equal(result$bmrScaled[1,1], 7.30429999406768) + expect_equal(unname(result$interval[1,]), c(0.897371573938349,1.77132174471728)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (hybridExc with hybridPercentile background) correctly for ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.23434488297234) + expect_equal(result$bmrScaled[1,1], 7.43153058963181) + expect_equal(unname(result$interval[1,]), c(0.736677604412129,1.73201216153255)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (relative) with log-transformed response correctly for ryegrass hormesis model", { + object0 <- drm(log(rootl) ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.44209342953523) + expect_equal(result$bmrScaled[1,1], 1.93422445377383) + expect_equal(unname(result$interval[1,]), c(0.826612118446638,2.05757474062382)) + expect_equal(result$bmrScaled[1], log(exp(drop(object0$curve[[1]](0)))*0.9)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes BMD (relative) with square root-transformed response correctly for ryegrass hormesis model", { + object0 <- drm(sqrt(rootl) ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.52253767591639) + expect_equal(result$bmrScaled[1,1], 2.63448978657361) + expect_equal(unname(result$interval[1,]), c(1.10162097905078,1.943454372782)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"])), tolerance = 1e-4) +}) + +test_that("bmd function computes correct delta confidence interval for a ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.53181216366916) + expect_equal(result$bmrScaled[1,1], 7.00907118396823) + expect_equal(unname(result$interval[1,]), c(1.14799694948346,1.91562737785485)) +}) + +test_that("bmd function computes correct profile confidence interval for a ryegrass hormesis model", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + invisible( + capture.output( + result <- suppressWarnings(bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profile", + profileGridSize = 10, display = FALSE, profileProgressInfo = FALSE)))) + + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.53181216366916) + expect_equal(result$bmrScaled[1,1], 7.00907118396823) + expect_equal(unname(result$interval[1,]), c(1.36199561066341,1.71658644037318)) +}) + + +# TCDD results ------------------------------------------------------------ + +test_that("bmd function computes BMD (point) correctly for TCDD model", { + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- bmd(object0, bmr = 0.22, def = "point", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.22, def = "point", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + expect_error(bmd(object0, bmr = 0.22, def = "point", backgType = "modelBased", interval = "inv", display = FALSE), + "Inverse regression not possible for def=point") + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.77184985530323) + expect_equal(result$bmrScaled[1,1], 0.22) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(-9.09858347336425,24.6422831839707)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 7.77184985530323) + expect_equal(resultSandwich$bmrScaled[1,1], 0.22) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(7.69908281451778,7.84461689608868)) + +}) + +test_that("bmd function computes BMD (excess) correctly for TCDD model", { + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- bmd(object0, bmr = 0.05, def = "excess", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.05, def = "excess", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.05, def = "excess", backgType = "modelBased", interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.05, def = "excess", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 5.56116921034511) + expect_equal(result$bmrScaled[1,1], 0.0709522577318265) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(-30.6802498813352,41.8025883020255)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 5.56116921034511) + expect_equal(resultSandwich$bmrScaled[1,1], 0.0709522577318265) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(5.40992038310958,5.71241803758064)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 5.56116921034511) + expect_equal(resultInv$bmrScaled[1,1], 0.0709522577318265) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(2.58555484830486,14.4423466517269)) + +}) + +test_that("bmd function computes BMD (additional) correctly for TCDD model", { + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- bmd(object0, bmr = 0.1, def = "additional", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "additional", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "additional", backgType = "modelBased", interval = "inv", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)+0.1)) + + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 6.36475841679501) + expect_equal(result$bmrScaled[1,1], 0.122055008138765) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(-12.8633221463079,25.5928389798979)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 6.36475841679501) + expect_equal(resultSandwich$bmrScaled[1,1], 0.122055008138765) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(6.28677997505832,6.4427368585317)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 6.36475841679501) + expect_equal(resultInv$bmrScaled[1,1], 0.122055008138765) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(2.91217704808626,15.3343789956633)) + +}) + + + +# lemna results ----------------------------------------------------------- + +test_that("bmd function computes BMD (point) correctly for lemna model", { + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmd(object0, bmr = 52, def = "point", backgType = "modelBased", display = FALSE) + # resultProfile <- bmd(object0, bmr = 52, def = "point", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.35865965537475) + expect_equal(result$bmrScaled[1,1], 52) + expect_equal(unname(result$interval[1,]), c(2.43392036088582,6.28339894986368)) + # profile + # expect_true(!is.na(resultProfile$Results[1, "BMD"])) + # expect_equal(resultProfile$Results[1, "BMD"], 4.53872215823332) + # expect_equal(resultProfile$bmrScaled[1,1], 52) + # expect_equal(unname(resultProfile$interval[1,]), c(3.67365836642196,5.5477249041543)) +}) + +test_that("bmd function computes BMD (extra) correctly for lemna model", { + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.644966972651776) + expect_equal(result$bmrScaled[1,1], 60.1147293067283) + expect_equal(unname(result$interval[1,]), c(-0.274435904843214,1.56436985014677)) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 0.644966972651776) + expect_equal(resultInv$bmrScaled[1,1], 60.1147293067283) + expect_equal(unname(resultInv$interval[1,]), c(0.224614484009512,1.33997717698247)) + # profile + # expect_true(!is.na(resultProfile$Results[1, "BMD"])) + # expect_equal(resultProfile$Results[1, "BMD"], 0.752514405241496) + # expect_equal(resultProfile$bmrScaled[1,1], 59.8605161777106) + # expect_equal(unname(resultProfile$interval[1,]), c(0.433615751336297,1.25109127057097)) +}) + +test_that("bmd function computes BMD (relative) correctly for lemna model", { + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.644966972651776) + expect_equal(result$bmrScaled[1,1], 60.1147293067283) + expect_equal(unname(result$interval[1,]), c(-0.124767225483307,1.41470117078686)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)*0.9)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # inv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 0.644966972651776) + expect_equal(resultInv$bmrScaled[1,1], 60.1147293067283) + expect_equal(unname(resultInv$interval[1,]), c(0.206536602960556,2.00749707239478)) + # profile + # expect_true(!is.na(resultProfile$Results[1, "BMD"])) + # expect_equal(resultProfile$Results[1, "BMD"], 0.752514405241496) + # expect_equal(resultProfile$bmrScaled[1,1], 59.8605161777106) + # expect_equal(unname(resultProfile$interval[1,]), c(0.433615751336297,1.25109127057097)) +}) + + + + +# S.alba results ---------------------------------------------------------- + +test_that("bmd function computes BMD (point) correctly for S.alba model", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(as.numeric(result$Results[, "BMD"]), c(39.4912945056265, 22.1766859356908)) + expect_equal(as.numeric(result$bmrScaled), c(3.2, 3.2)) + expect_equal(as.numeric(result$bmrScaled), diag(drop(object0$curve[[1]](result$Results[, "BMD"])))) +}) + +test_that("bmd function computes BMD (relative) correctly for S.alba model", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmd(object0, bmr = 0.08, def = "relative", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(as.numeric(result$Results[, "BMD"]), c(28.0790872125237, 18.9735396170819)) + expect_equal(as.numeric(result$bmrScaled), drop(object0$curve[[1]](0))*0.92) + expect_equal(as.numeric(result$bmrScaled), diag(drop(object0$curve[[1]](result$Results[, "BMD"])))) +}) + +test_that("bmd function computes BMD (hybridExc with hybridSD background) correctly for S.alba model", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(as.numeric(result$Results[, "BMD"]), c(28.0253530227688, 19.0291591246355)) + expect_equal(as.numeric(result$bmrScaled), c(3.56714031355548, 3.49717210738578)) + expect_equal(as.numeric(result$bmrScaled), diag(drop(object0$curve[[1]](result$Results[, "BMD"])))) +}) + + +test_that("bmd function computes correct delta confidence interval for a S.alba model", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$interval[, "Lower"]))) + expect_true(all(!is.na(result$interval[, "Upper"]))) + expect_equal(result$Results[, "BMDL"], result$interval[, "Lower"]) + expect_equal(as.numeric(result$interval[, "Lower"]), c(15.4192368012224, 14.5843698054813)) + expect_equal(as.numeric(result$interval[, "Upper"]), c(39.8670300945973, 23.5741646123403)) +}) + +test_that("bmd function computes BMD (point) correctly for S.alba model with independently fitted curves", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4(), separate = TRUE) + + result <- bmd(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(as.numeric(result$Results[, "BMD"]), c(39.4771036152176, 22.1659452714774)) + expect_equal(as.numeric(result$bmrScaled), c(3.2, 3.2)) + expect_equal(as.numeric(result$bmrScaled), diag(drop(object0$curve[[1]](result$Results[, "BMD"])))) +}) + +test_that("bmd function computes BMD (relative) correctly for S.alba model with independently fitted curves", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4(), separate = TRUE) + + result <- bmd(object0, bmr = 0.08, def = "relative", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(as.numeric(result$Results[, "BMD"]), c(28.0694995307095, 18.9558015915458)) + expect_equal(as.numeric(result$bmrScaled), drop(object0$curve[[1]](0))*(1-0.08)) + expect_equal(as.numeric(result$bmrScaled), diag(drop(object0$curve[[1]](result$Results[, "BMD"])))) +}) + + +test_that("bmd function output remains consistent with model with multiple curves", { + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + snapshot_data <- list( + Results = as.list(result$Results), + bmrScaled = as.list(result$bmrScaled), + interval = as.list(result$interval), + SE = as.list(result$SE) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + +# Increasing continuous model results ------------------------------------- + +test_that("bmd function computes BMD (point) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 8, def = "point", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 8, def = "point", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultProfile <- bmd(object0, bmr = 8, def = "point", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # delta + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 12.2806139561059) + expect_equal(result$bmrScaled[1,1], 8) + expect_equal(unname(result$interval[1,]), c(11.1666678007201,13.3945601114917)) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + # sandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 12.2806139561059) + expect_equal(resultSandwich$bmrScaled[1,1], 8) + expect_equal(unname(resultSandwich$interval[1,]), c(11.4480146049373,13.1132133072745)) + # profile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 12.2806139561059) + expect_equal(resultProfile$bmrScaled[1,1], 8) + expect_equal(unname(resultProfile$interval[1,]), c(11.3001432356128,13.2937575997779)) +}) + +test_that("bmd function computes BMD (extra) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "extra", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 10.863484507375) + expect_equal(result$bmrScaled[1,1], 6.98897815306841) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(9.51445066757787,12.212518347172)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 10.863484507375) + expect_equal(resultSandwich$bmrScaled[1,1], 6.98897815306841) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(9.71924181563165,12.0077271991183)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 10.863484507375) + expect_equal(resultInv$bmrScaled[1,1], 6.98897815306841) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(9.56235201149397,12.2278472729667)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 10.863484507375) + expect_equal(resultProfile$bmrScaled[1,1], 6.98897815306841) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(9.67873308726007,12.0916306755198)) +}) + +test_that("bmd function computes BMD (relative) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- suppressWarnings(bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", interval = "profile", display = FALSE)) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 6.41534690365137) + expect_equal(result$bmrScaled[1,1], 4.55693251645292) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)*1.1)) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(4.75431370333604,8.0763801039667)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 6.41534690365137) + expect_equal(resultSandwich$bmrScaled[1,1], 4.55693251645292) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(5.0856776962869,7.74501611101584)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 6.41534690365137) + expect_equal(resultInv$bmrScaled[1,1], 4.55693251645292) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(5.33406644107278,8.89693260160958)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 6.41534690365137) + expect_equal(resultProfile$bmrScaled[1,1], 4.55693251645292) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(4.95263882310625,7.90896048331597)) + +}) + +test_that("bmd function computes BMD (added) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "added", backgType = "modelBased", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_equal(result$bmrScaled[1], drop(object0$curve[[1]](0)+0.1)) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.991720782587) + expect_equal(result$bmrScaled[1,1], 4.24266592404811) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(3.59642761002814,6.38701395514585)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 4.991720782587) + expect_equal(resultSandwich$bmrScaled[1,1], 4.24266592404811) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(3.89836064703559,6.0850809181384)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 4.991720782587) + expect_equal(resultInv$bmrScaled[1,1], 4.24266592404811) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(4.19888523653057,7.381384925039)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 4.991720782587) + expect_equal(resultProfile$bmrScaled[1,1], 4.24266592404811) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(3.78860392475851,6.26909472927828)) +}) + +test_that("bmd function computes BMD (hybridAdd with hybridSD background) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, interval = "inv", display = FALSE) + resultProfile <- bmd(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, interval = "sandwich", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.5727232324071) + expect_equal(result$bmrScaled[1,1], 5.00849387544795) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(6.01581326247664,9.12963320233756)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 7.5727232324071) + expect_equal(resultSandwich$bmrScaled[1,1], 5.00849387544795) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(6.34845172462833,8.79699474018587)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 7.5727232324071) + expect_equal(resultInv$bmrScaled[1,1], 5.00849387544795) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(6.60326087897833,9.815886863626)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 7.5727232324071) + expect_equal(resultProfile$bmrScaled[1,1], 5.00849387544795) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(6.34845172462833,8.79699474018587)) + +}) + +test_that("bmd function computes BMD (hybridExc with hybridSD background) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, interval = "inv", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.54741579253422) + expect_equal(result$bmrScaled[1,1], 4.99686214933204) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(5.9914922536827,9.10333933138575)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 7.54741579253422) + expect_equal(resultSandwich$bmrScaled[1,1], 4.99686214933204) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(6.32405959937184,8.7707719856966)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 7.54741579253422) + expect_equal(resultInv$bmrScaled[1,1], 4.99686214933204) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(6.5795707606519,9.80594198539089)) + +}) + +test_that("bmd function computes BMD (hybridExc with hybridPercentile background) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, sandwich.vcov = TRUE, display = FALSE) + # resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "profile", profileGridSize = 10, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.54226313905066) + expect_equal(result$bmrScaled[1,1], 4.19484787609187) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(3.19216176910602,5.8923645089953)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 4.54226313905066) + expect_equal(resultSandwich$bmrScaled[1,1], 4.19484787609187) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(3.48330453570381,5.60122174239751)) + +}) + +test_that("bmd function computes BMD (hybridExc with absolute background) correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 6, display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 6, sandwich.vcov = TRUE, display = FALSE) + resultInv <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "absolute", backg = 6, interval = "inv", display = FALSE) + # resultProfile <- bmd(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, interval = "profile", profileGridSize = 10, display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.20955143837895) + expect_equal(result$bmrScaled[1,1], 4.84877512350992) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(6.0288331932397,8.3902696835182)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 7.20955143837895) + expect_equal(resultSandwich$bmrScaled[1,1], 4.84877512350992) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(6.40498302800912,8.01411984874878)) + + # resultInv + expect_true(!is.na(resultInv$Results[1, "BMD"])) + expect_equal(resultInv$Results[1, "BMD"], 7.20955143837895) + expect_equal(resultInv$bmrScaled[1,1], 4.84877512350992) + expect_equal(resultInv$bmrScaled[1,1], drop(object0$curve[[1]](resultInv$Results[1, "BMD"]))) + expect_equal(unname(resultInv$interval[1,]), c(6.23979423183327,9.47523222361585)) + +}) + +test_that("bmd function computes BMD (relative) with log-transformed response correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", sandwich.vcov = TRUE, display = FALSE) + expect_error(bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", interval = "inv", display = FALSE), + "inverse regression interval not available for transformed response.") + resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_equal(result$bmrScaled[1], log(exp(drop(object0$curve[[1]](0)))*1.1)) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.95526222076805) + expect_equal(result$bmrScaled[1,1], 4.23797610385243) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(3.56339436443336,6.34713007710273)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 4.95526222076805) + expect_equal(resultSandwich$bmrScaled[1,1], 4.23797610385243) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(3.86451935421879,6.0460050873173)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 4.95526222076805) + expect_equal(resultProfile$bmrScaled[1,1], 4.23797610385243) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(3.75569647489823,6.23001397383884)) + +}) + +test_that("bmd function computes BMD (relative) with square root-transformed response correctly for increasing continuous model", { + data0 <- data.frame(dose = c(0,0,0,0,6.25,6.25,6.25,6.25,12.5,12.5,12.5,12.5, + 25,25,25,25,50,50,50,50,100,100,100,100), + resp = c(3.3735,4.1836,3.1644,5.5953,4.6321,3.4822,4.7901,5.041, + 8.4779,7.5968,9.4139,8.292,15.2536,13.6601,16.9997,15.8299, + 23.2592,24.2193,24.0967,23.8693,28.7189,28.5821,27.8745,25.8106)) + object0 <- drm(resp ~ dose, data = data0, fct = W1.4()) + + result <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", display = FALSE) + resultSandwich <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", sandwich.vcov = TRUE, display = FALSE) + expect_error(bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", interval = "inv", display = FALSE), + "inverse regression interval not available for transformed response.") + resultProfile <- bmd(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", interval = "profile", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 5.60146426427603) + expect_equal(result$bmrScaled[1,1], 4.34486467615463) + expect_equal(result$bmrScaled[1,1], drop(object0$curve[[1]](result$Results[1, "BMD"]))) + expect_equal(unname(result$interval[1,]), c(4.0395612239518,7.16336730460026)) + + # resultSandwich + expect_true(!is.na(resultSandwich$Results[1, "BMD"])) + expect_equal(resultSandwich$Results[1, "BMD"], 5.60146426427603) + expect_equal(resultSandwich$bmrScaled[1,1], 4.34486467615463) + expect_equal(resultSandwich$bmrScaled[1,1], drop(object0$curve[[1]](resultSandwich$Results[1, "BMD"]))) + expect_equal(unname(resultSandwich$interval[1,]), c(4.35735478850823,6.84557374004383)) + + # resultProfile + expect_true(!is.na(resultProfile$Results[1, "BMD"])) + expect_equal(resultProfile$Results[1, "BMD"], 5.60146426427603) + expect_equal(resultProfile$bmrScaled[1,1], 4.34486467615463) + expect_equal(resultProfile$bmrScaled[1,1], drop(object0$curve[[1]](resultProfile$Results[1, "BMD"]))) + expect_equal(unname(resultProfile$interval[1,]), c(4.23995309372506,7.0173030071411)) + +}) + + + + + +# Decreasing binomial model with multiple curves -------------------------- +test_that("bmd function computes BMD (point) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + result <- bmd(object0, bmr = 0.77, def = "point", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(result$Results[, "BMD"], c(Treat1 = 16.7094280948318, Treat2 = 30.2464214935383)) + expect_equal(result$bmrScaled[,1], c(Treat1 = 0.77, Treat2 = 0.77)) + expect_equal(unname(result$bmrScaled[,1]), diag(object0$curve[[1]](result$Results[, "BMD"])[,2:3])) + expect_equal(result$interval[, "Lower"], c(Treat1 = 6.3733358375481, Treat2 = 22.2685483133783)) + expect_equal(result$interval[, "Upper"], c(Treat1 = 27.0455203521155, Treat2 = 38.2242946736982)) +}) + +test_that("bmd function computes BMD (excess) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + result <- bmd(object0, bmr = 0.1, def = "excess", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(result$Results[, "BMD"], c(Treat1 = 12.7945107782873, Treat2 = 25.107888955923)) + expect_equal(result$bmrScaled[,1], c(Treat1 = 0.851586285814034, Treat2 = 0.85158628581403477)) + expect_equal(unname(result$bmrScaled[,1]), diag(object0$curve[[1]](result$Results[, "BMD"])[,2:3])) + expect_equal(result$interval[, "Lower"], c(Treat1 = 1.21746148052096, Treat2 = 16.6628970797628)) + expect_equal(result$interval[, "Upper"], c(Treat1 = 24.3715600760537, Treat2 = 33.5528808320832)) + +}) + +test_that("bmd function computes BMD (additional) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + result <- bmd(object0, bmr = 0.1, def = "additional", backgType = "modelBased", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(result$Results[, "BMD"], c(Treat1 = 13.0508853789932, Treat2 = 25.4655976138905)) + expect_equal(result$bmrScaled[,1], c(Treat1 = 0.846206984237815, Treat2 = 0.846206984237815)) + expect_equal(unname(result$bmrScaled[,1]), diag(object0$curve[[1]](result$Results[, "BMD"])[,2:3])) + expect_equal(result$interval[, "Lower"], c(Treat1 = 1.50118005072325, Treat2 = 16.964077339049)) + expect_equal(result$interval[, "Upper"], c(Treat1 = 24.6005907072632, Treat2 = 33.9671178887321)) + +}) + diff --git a/tests/testthat/test-bmdBoot.R b/tests/testthat/test-bmdBoot.R new file mode 100644 index 0000000..15bee96 --- /dev/null +++ b/tests/testthat/test-bmdBoot.R @@ -0,0 +1,841 @@ +# Tests for bmdBoot function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - Simple model +# - correct bmd estimate +# - Ryegrass model (continuous) +# - correct bmd estimate (all definitions) +# - Ryegrass hormesis model (continuous) +# - correct bmd estimate (all definitions) +# - TCDD model (binomial) +# - correct bmd estimate (excess + additional) +# - Lemna model (count) +# - correct bmd estimate (all definitions) +# - S.alba model (continuous with multiple curves) +# - correct bmd estimate (point, extra, hybridExc) +# - Decreasing binomial model with multiple curves +# - correct bmd estimate (point, extra, hybridExc) + + +# Arguments and structure ------------------------------------------------- + +test_that("bmdBoot function handles missing required arguments", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + + expect_error(bmdBoot(), "object is missing") + expect_error(bmdBoot(object0), "def is missing") + expect_error(bmdBoot(lm(1:10 ~ 1)), 'object must be of class "drc"') + expect_error(bmdBoot(object0, def = "invalid_def", backgType = "modelBased"), "Could not recognize def") + expect_error(bmdBoot(object0, def = "excess", backgType = "invalid_type"), "Could not recognize backgType") + expect_error(bmdBoot(object0, def = "excess"), "backgType is missing") +}) + + +test_that("bmdBoot function accepts correct def", { + object.cont <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + object.binom <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2(), type = "binomial") + object.poisson <- drm(y ~ x, data = data.frame(x = 1:5, y = c(12,11,3,0,0)), fct = LL.3(), type = "Poisson") + + # Binomial bmd def with continuous model + expect_error(bmdBoot(object.cont, def = "excess", backgType = "modelBased", R = 1), '"excess" is not available for continuous data') + expect_error(bmdBoot(object.cont, def = "additional", backgType = "modelBased", R = 1), '"additional" is not available for continuous data') + + # Binomial bmd def with Poisson model + expect_error(bmdBoot(object.poisson, def = "excess", backgType = "modelBased", R = 1), '"excess" is not available for count data') + expect_error(bmdBoot(object.poisson, def = "additional", backgType = "modelBased", R = 1), '"additional" is not available for count data') + + # Cont bmd def with binomial model + expect_error(bmdBoot(object.binom, def = "relative", backgType = "modelBased", R = 1), '"relative" is not available for quantal data') + expect_error(bmdBoot(object.binom, def = "extra", backgType = "modelBased", R = 1), '"extra" is not available for quantal data') + expect_error(bmdBoot(object.binom, def = "added", backgType = "modelBased", R = 1), '"added" is not available for quantal data') + expect_error(bmdBoot(object.binom, def = "hybridExc", backgType = "modelBased", R = 1), '"hybridExc" is not available for quantal data') + expect_error(bmdBoot(object.binom, def = "hybridAdd", backgType = "modelBased", R = 1), '"hybridAdd" is not available for quantal data') +}) + +test_that("bmdBoot function returns expected structure", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 1) + + expect_type(result, "list") + expect_named(result, c("Results", "Boot.samples.used", "bootEst", "interval")) + expect_s3_class(result, "bmd") +}) + + +# Simple model results ---------------------------------------------------- + +test_that("bmdBoot function computes BMD (extra, bmr = 0.1) correctly for a simple model", { + set.seed(1) + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 16.4578682695665) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(16.3490012773168,17.2565658001912)) +}) + +test_that("bmdBoot function computes BMD (extra, bmr = 0.05) correctly for a simple model", { + set.seed(1) + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdBoot(object0, bmr = 0.05, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 15.4022544235763) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(15.2659263161485,16.4325341268289)) +}) + +test_that("bmdBoot function computes BMD (extra, bmr = 0.1, bmdType = \"mean\") correctly for a simple model", { + set.seed(1) + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50, bmdType = "mean") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 16.780508604938) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(16.3490012773168,17.2565658001912)) +}) + +test_that("bmdBoot function computes BMD (extra, bmr = 0.1, bmdType = \"median\") correctly for a simple model", { + set.seed(1) + object0 <- drm(y ~ x, data = data.frame(x = c(0,10,20,40,80), y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50, bmdType = "median") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 16.7232035648742) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(16.3490012773168,17.2565658001912)) +}) + + + +# Ryegrass results -------------------------------------------------------- + +test_that("bmdBoot function computes BMD (point) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.64586140417992) + expect_equal(unname(result$interval[1,]), c(3.26263598876729,3.96031450591884)) +}) + +test_that("bmdBoot function computes BMD (extra) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.46370565552042) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.34582379343345,1.65744656451026)) +}) + +test_that("bmdBoot function computes BMD (relative) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.49902599632103) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.36986151499048,1.69766970621146)) +}) + +test_that("bmdBoot function computes BMD (added) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "added", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.728443033284576) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.601335381833136,0.938357650485433)) +}) + +test_that("bmdBoot function computes BMD (hybridAdd with hybridSD background) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.21255236145362) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.03230812002555,1.38259567213485)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridSD background) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.20672107998472) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.02698170147848,1.37683954154201)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridPercentile background) correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.06888690340628) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.901388142148037,1.24291597301057)) +}) + +test_that("bmdBoot function computes BMD (point, bootInterval = \"BCa\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.64586140417992) + expect_equal(result$Results[1, "BMDL"], 3.40461643409508) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (relative, bootInterval = \"BCa\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.49902599632103) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1,"BMDL"], 1.3364409073126) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridSD background, bootInterval = \"BCa\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.20672107998472) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1,"BMDL"], 1.0046419139129) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridPercentile background, bootInterval = \"BCa\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.06888690340628) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1,"BMDL"], 0.854123185248857) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (point, bootType = \"parametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.64586140417992) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(3.12856944661618,4.34780971634149)) +}) + +test_that("bmdBoot function computes BMD (relative, bootType = \"parametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.49902599632103) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.40708736919832,1.80364105456897)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridSD background, bootType = \"parametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, bootType = "parametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.20672107998472) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.06044718186996,1.69830235608345)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridPercentile background, bootType = \"parametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, bootType = "parametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.06888690340628) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.928960505221601,1.57848224390949)) +}) + +test_that("bmdBoot function computes BMD (point, bootType = \"semiparametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", bootType = "semiparametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 3.64586140417992) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(3.46643051130734,3.82733853806115)) +}) + +test_that("bmdBoot function computes BMD (relative, bootType = \"semiparametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", bootType = "semiparametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.49902599632103) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.33189055276109,1.70994880678072)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridSD background, bootType = \"semiparametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, bootType = "semiparametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.20672107998472) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.942978153279434,1.36895504286135)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridPercentile background, bootType = \"semiparametric\") correctly for ryegrass model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, bootType = "semiparametric", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.06888690340628) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.823230827522055,1.23451763714964)) +}) + +test_that("bmdBoot function computes BMD (relative) correctly for ryegrass hormesis model", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = BC.5()) + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 1.55704870290614) + expect_equal(result$Boot.samples.used, 42) + expect_equal(unname(result$interval[1,]), c(1.44434658745943,1.75290180636397)) +}) + +# test_that("bmdBoot function computes BMD (relative) with log-transformed response correctly for ryegrass model", { +# set.seed(1) +# object0 <- drm(log(rootl) ~ conc, data = drcData::ryegrass, fct = LL.4()) +# +# result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", display = FALSE, R = 50) +# +# # Expected results based on manual calculation (checked in v2.6.7) +# expect_true(!is.na(result$Results[1, "BMD"])) +# expect_equal(result$Results[1, "BMD"], 0.804218529940602) +# expect_equal(result$Boot.samples.used, 0) +# expect_equal(unname(result$interval[1,]), c(NA,NA)) +# }) +# +# test_that("bmdBoot function computes BMD (relative) with square root-transformed response correctly for ryegrass model", { +# set.seed(1) +# object0 <- drm(sqrt(rootl) ~ conc, data = drcData::ryegrass, fct = LL.4()) +# +# result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", display = FALSE, R = 50) +# +# # Expected results based on manual calculation (checked in v2.6.7) +# expect_true(!is.na(result$Results[1, "BMD"])) +# expect_equal(result$Results[1, "BMD"], 1.29590294092622) +# expect_equal(result$Boot.samples.used, 0) +# expect_equal(unname(result$interval[1,]), c(NA,NA)) +# }) + + +test_that("bmdBoot function output remains consistent", { + set.seed(1) + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + snapshot_data <- list( + Results = as.list(result$Results), + Boot.samples.used = as.list(result$Boot.samples.used), + bootEst = as.list(result$bootEst), + interval = as.list(result$interval) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + + +# TCDD results ------------------------------------------------------------ + +test_that("bmdBoot function computes BMD (point) correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.22, def = "point", backgType = "modelBased", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.77184985530323) + expect_equal(result$Boot.samples.used, 49) + expect_equal(unname(result$interval[1,]), c(6.5722041232272,23.4873980148745)) +}) + +test_that("bmdBoot function computes BMD (excess) correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.05, def = "excess", backgType = "modelBased", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 5.56116921034511) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.28179749253742,4.68414395623765)) +}) + +test_that("bmdBoot function computes BMD (additional) correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "additional", backgType = "modelBased", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 6.36475841679501) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(3.18111681473504,6.6921148746103)) +}) + +test_that("bmdBoot function computes BMD (point, bootInterval = \"BCa\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.22, def = "point", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.77184985530323) + expect_equal(result$Boot.samples.used, 49) + expect_equal(result$Results[1, "BMDL"], 5.18330205847931) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (excess, bootInterval = \"BCa\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.05, def = "excess", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 5.56116921034511) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1, "BMDL"], 6.14136910217948) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (additional, bootInterval = \"BCa\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "additional", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 6.36475841679501) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1, "BMDL"], 6.15359416425459) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (point, bootType = \"parametric\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.22, def = "point", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 7.77184985530323) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(6.0472767939815,15.9893339617481)) +}) + +test_that("bmdBoot function computes BMD (excess, bootType = \"parametric\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.05, def = "excess", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 5.56116921034511) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(1.28296661360405,4.74870734366396)) +}) + +test_that("bmdBoot function computes BMD (additional, bootType = \"parametric\") correctly for TCDD model", { + set.seed(1) + object0 <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + + result <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "additional", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 6.36475841679501) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(2.67704520143454,6.38843750211448)) +}) + + + +# lemmna results ---------------------------------------------------------- + +test_that("bmdBoot function computes BMD (point) correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmdBoot(object0, bmr = 52, def = "point", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.35865965537475) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(3.6817392726952,4.96008552694743)) +}) + +test_that("bmdBoot function computes BMD (extra) correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.644966972651776) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.403304817944331,0.819989014246345)) +}) + +test_that("bmdBoot function computes BMD (relative) correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.644966972651776) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[1,]), c(0.403304817944331,0.819989014246345)) +}) + + +test_that("bmdBoot function computes BMD (point, bootInterval = \"BCa\") correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmdBoot(object0, bmr = 52, def = "point", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 4.35865965537475) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1, "BMDL"], 3.89226934419482) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (relative, bootInterval = \"BCa\") correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + result <- bmdBoot(object0, bmr = 0.1, def = "relative", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], 0.644966972651776) + expect_equal(result$Boot.samples.used, 50) + expect_equal(result$Results[1,"BMDL"], 0.46010142747602) + expect_equal(result$interval[1,2], "Not available for BCa bootstrap") +}) + +test_that("bmdBoot function computes BMD (point, bootType = \"parametric\") correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + expect_error(bmdBoot(object0, bmr = 52, def = "point", backgType = "modelBased", bootType = "parametric", display = FALSE, R = 50), + "\"Poisson\" only works with nonparametric bootstrap") +}) + +test_that("bmdBoot function computes BMD (point, bootType = \"semiparametric\") correctly for lemna model", { + set.seed(1) + object0 <- drm(frond.num ~ conc, data = drcData::lemna, fct = LL.3(), type = "Poisson") + + expect_error(bmdBoot(object0, bmr = 52, def = "point", backgType = "modelBased", bootType = "semiparametric", display = FALSE, R = 50), + "\"Poisson\" only works with nonparametric bootstrap") +}) + + + + + +# S.alba results ---------------------------------------------------------- + +test_that("bmdBoot function computes BMD (point) correctly for S.alba model", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE, R = 50) + resultBCa <- suppressWarnings(bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(39.4912945056265, 22.1766859356908)) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[,"Lower"]), c(30.0422707998487,18.5473504361089)) + expect_equal(unname(result$interval[,"Upper"]), c(44.5736649922485,25.8729296047688)) + expect_true(all(!is.na(resultBCa$Results[, "BMD"]))) + expect_equal(unname(resultBCa$Results[, "BMD"]), c(39.4912945056265, 22.1766859356908)) + expect_equal(resultBCa$Boot.samples.used, 50) + expect_equal(unname(resultBCa$Results[,"BMDL"]), c(34.0193865555056,19.45281610897)) + expect_equal(unname(resultBCa$interval[,"Upper"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdBoot function computes BMD (point, bmdType = \"mean\") correctly for S.alba model", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE, R = 50, bmdType = "mean") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(37.5232019182286, 22.061872769014)) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[,"Lower"]), c(30.0422707998487,18.5473504361089)) + expect_equal(unname(result$interval[,"Upper"]), c(44.5736649922485,25.8729296047688)) +}) + +test_that("bmdBoot function computes BMD (point, bmdType = \"median\") correctly for S.alba model", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 3.2, def = "point", backgType = "modelBased", display = FALSE, R = 50, bmdType = "median") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(37.3570289171494, 21.8393124704904)) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[,"Lower"]), c(30.0422707998487,18.5473504361089)) + expect_equal(unname(result$interval[,"Upper"]), c(44.5736649922485,25.8729296047688)) +}) + +test_that("bmdBoot function computes BMD (relative) correctly for S.alba model", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.08, def = "relative", backgType = "modelBased", display = FALSE, R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(28.0790872125237, 18.9735396170819)) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[,"Lower"]), c(15.8093978884084,15.1505752899725)) + expect_equal(unname(result$interval[,"Upper"]), c(35.8713641261381,23.689950459446)) +}) + +test_that("bmdBoot function computes BMD (hybridExc with hybridSD background) correctly for S.alba model", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + result <- bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE, R = 50) + resultBCa <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, bootInterval = "BCa", display = FALSE, R = 50)) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(28.0253530227688, 19.0291591246355)) + expect_equal(result$Boot.samples.used, 50) + expect_equal(unname(result$interval[,"Lower"]), c(13.5226993261253,14.6581794833924)) + expect_equal(unname(result$interval[,"Upper"]), c(36.5969418859266,22.9059472014908)) + expect_true(all(!is.na(resultBCa$Results[, "BMD"]))) + # resultBCa + expect_equal(unname(resultBCa$Results[, "BMD"]), c(28.0253530227688, 19.0291591246355)) + expect_equal(resultBCa$Boot.samples.used, 50) + expect_equal(unname(resultBCa$Results[,"BMDL"]), c(17.8777299232804,14.558986489691)) + expect_equal(unname(resultBCa$interval[,"Upper"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdBoot function output remains consistent with model with multiple curves", { + set.seed(1) + object0 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + result <- bmdBoot(object0, bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE, R = 50) + + snapshot_data <- list( + Results = as.list(result$Results), + Boot.samples.used = as.list(result$Boot.samples.used), + bootEst = as.list(result$bootEst), + interval = as.list(result$interval) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + +# Decreasing binomial model with multiple curves -------------------------- +test_that("bmdBoot function computes BMD (point) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + set.seed(1) + invisible(capture.output({ + result <- suppressWarnings(bmdBoot(object0, bmr = 0.77, def = "point", backgType = "modelBased", display = FALSE, R = 50)) + resultBCa <- suppressWarnings(bmdBoot(object0, bmr = 0.77, def = "point", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + })) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(16.7094280948318, 30.2464214935383)) + expect_equal(result$Boot.samples.used, 44) + expect_equal(unname(result$interval[,"Lower"]), c(2.80478996663512,25.4932116970026)) + expect_equal(unname(result$interval[,"Upper"]), c(20.9736682163773,35.0170372426051)) + # resultBCa + expect_true(all(!is.na(resultBCa$Results[, "BMD"]))) + expect_equal(unname(resultBCa$Results[, "BMD"]), c(16.7094280948318, 30.2464214935383)) + expect_equal(resultBCa$Boot.samples.used, 44) + expect_equal(unname(resultBCa$Results[,"BMDL"]), c(12.2322036611872,25.3303655120452)) + expect_equal(unname(resultBCa$interval[,"Upper"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdBoot function computes BMD (excess) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + set.seed(1) + invisible(capture.output({ + result <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "excess", backgType = "modelBased", display = FALSE, R = 50)) + resultBCa <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "excess", backgType = "modelBased", bootInterval = "BCa", display = FALSE, R = 50)) + })) + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(12.7945107782873, 25.107888955923)) + expect_equal(result$Boot.samples.used, 45) + expect_equal(unname(result$interval[,"Lower"]), c(0.0803383339260978,15.8070091895054)) + expect_equal(unname(result$interval[,"Upper"]), c(16.4173994133493,29.5166318382001)) + # resultBCa + expect_true(all(!is.na(resultBCa$Results[, "BMD"]))) + expect_equal(unname(resultBCa$Results[, "BMD"]), c(12.7945107782873, 25.107888955923)) + expect_equal(resultBCa$Boot.samples.used, 46) + expect_equal(unname(resultBCa$Results[,"BMDL"]), c(14.1406750203466,17.9700937734153)) + expect_equal(unname(resultBCa$interval[,"Upper"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdBoot function computes BMD (additional) correctly for TCDD model", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + + set.seed(1) + invisible(capture.output( + result <- suppressWarnings(bmdBoot(object0, bmr = 0.1, def = "additional", backgType = "modelBased", display = FALSE, R = 50)) + )) + + # Expected results based on manual calculation (checked in v2.6.7) + # result + expect_true(all(!is.na(result$Results[, "BMD"]))) + expect_equal(unname(result$Results[, "BMD"]), c(13.0508853789932, 25.4655976138905)) + expect_equal(result$Boot.samples.used, 45) + expect_equal(unname(result$interval[,"Lower"]), c(0.0542035268237113,15.6266599428455)) + expect_equal(unname(result$interval[,"Upper"]), c(16.8396337661858,30.3505265877131)) +}) diff --git a/tests/testthat/test-bmdHetVar.R b/tests/testthat/test-bmdHetVar.R new file mode 100644 index 0000000..c44b1e0 --- /dev/null +++ b/tests/testthat/test-bmdHetVar.R @@ -0,0 +1,150 @@ +# Tests for bmdHetVar function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - Ryegrass model +# - correct bmd estimate (hybridExc + hybridAdd with hybridPercentile and hybridSD backgType) +# - GiantKelp model +# - correct bmd estimate (hybridExc + hybridAdd with hybridPercentile and hybridSD backgType) + + + + +# Arguments and structure ------------------------------------------------- + +test_that("bmdHetVar handles missing required arguments", { + lm_object <- lm(y ~ x, + data = data.frame(x = 0:4, + y = 1:5 + c(-0.4, 0, 0.2, -0.1, 0.13))) + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + + expect_error(bmdHetVar(lm_object), 'object must be a dose-response model with a heterogeneous variance structure of class "drcHetVar"') + expect_error(bmdHetVar(ryegrass.W2.4), 'object must be a dose-response model with a heterogeneous variance structure of class "drcHetVar"') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, def = "hybridExc"), 'backgType is missing. Options are "absolute", "hybridSD" or "hybridPercentile"') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, def = "hybridExc", backgType = "wrongType"), 'Could not recognize backgType. Options are "absolute", "hybridSD" or "hybridPercentile"') + expect_error(bmdHetVar(bmr = 0.1, backgType = "hybridPercentile", def = "hybridExc"), 'argument "object" is missing, with no default') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, backgType = "hybridPercentile", def = "hybridExc"), 'argument "bmr" needs to be specified as a number between 0 and 1') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, bmr = 1.5, backgType = "hybridPercentile", def = "hybridExc"), 'argument "bmr" needs to be specified as a number between 0 and 1') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridPercentile"), 'def is missing. Options are "hybridExc" or "hybridAdd"') + expect_error(bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", def = "wrongDef"), 'Could not recognize def. Options are "hybridExc" or "hybridAdd"') +}) + + + + + +# Ryegrass model ---------------------------------------------------------- + +test_that("bmdHetVar on Ryegrass model, def = hybridExc, backgtype = hybridPercentile", { + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + set.seed(1) + result <- bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=1.27811671431062)) + expect_equal(result$bmrScaled[1,1], 7.54478765441619) + expect_equal(unname(result$interval[1,]), c(1.12131595768687,1.43679973459246)) +}) + +test_that("bmdHetVar on Ryegrass model, def = hybridExc, backgtype = hybridSD", { + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + set.seed(1) + result <- bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 2, def = "hybridExc", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=1.45386495506409)) + expect_equal(result$bmrScaled[1,1], 7.30984899101547) + expect_equal(unname(result$interval[1,]), c(1.26150389977647,1.57147862329125)) +}) + +test_that("bmdHetVar on Ryegrass model, def = hybridAdd, backgtype = hybridPercentile", { + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + set.seed(1) + result <- bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridAdd", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=1.2951863924654)) + expect_equal(result$bmrScaled[1,1], 7.52658664968204) + expect_equal(unname(result$interval[1,]), c(1.13769226756753,1.45126563749746)) +}) + +test_that("bmdHetVar on Ryegrass model, def = hybridAdd, backgtype = hybridSD", { + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + set.seed(1) + result <- bmdHetVar(ryegrass.W2.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 2, def = "hybridAdd", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=1.45814046464533)) + expect_equal(result$bmrScaled[1,1], 7.30288607148892) + expect_equal(unname(result$interval[1,]), c(1.26409211540589,1.57578126779336)) +}) + + + +# GiantKelp model --------------------------------------------------------- + + +test_that("bmdHetVar on GiantKelp model, def = hybridExc, backgtype = hybridPercentile", { + GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = drcData::GiantKelp, fct = LL.4()) + var.formula0 <- ~ log(dose+1) + I(log(dose+1)^2) + GiantKelp.LL.4.hetVar <- drmHetVar(GiantKelp.LL.4, var.formula0) + set.seed(1) + result <- bmdHetVar(GiantKelp.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridExc", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=5.13707358300282)) + expect_equal(result$bmrScaled[1,1], 17.3098274841786) + expect_equal(unname(result$interval[1,]), c(0.888110687020647,14.4030845590698)) +}) + +test_that("bmdHetVar on GiantKelp model, def = hybridExc, backgtype = hybridSD", { + GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = drcData::GiantKelp, fct = LL.4()) + var.formula0 <- ~ log(dose+1) + I(log(dose+1)^2) + GiantKelp.LL.4.hetVar <- drmHetVar(GiantKelp.LL.4, var.formula0) + set.seed(1) + result <- bmdHetVar(GiantKelp.LL.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 2, def = "hybridExc", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=10.0346000078297)) + expect_equal(result$bmrScaled[1,1], 16.472304344928) + expect_equal(unname(result$interval[1,]), c(3.40106451148093,20.503469300298)) +}) + +test_that("bmdHetVar on GiantKelp model, def = hybridAdd, backgtype = hybridPercentile", { + GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = drcData::GiantKelp, fct = LL.4()) + var.formula0 <- ~ log(dose+1) + I(log(dose+1)^2) + GiantKelp.LL.4.hetVar <- drmHetVar(GiantKelp.LL.4, var.formula0) + set.seed(1) + result <- bmdHetVar(GiantKelp.LL.4.hetVar, bmr = 0.1, backgType = "hybridPercentile", backg = 0.1, def = "hybridAdd", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=5.57094720723732)) + expect_equal(result$bmrScaled[1,1], 17.2358870698386) + expect_equal(unname(result$interval[1,]), c(1.02451690713505,15.0145292097429)) +}) + +test_that("bmdHetVar on GiantKelp model, def = hybridAdd, backgtype = hybridSD", { + GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = drcData::GiantKelp, fct = LL.4()) + var.formula0 <- ~ log(dose+1) + I(log(dose+1)^2) + GiantKelp.LL.4.hetVar <- drmHetVar(GiantKelp.LL.4, var.formula0) + set.seed(1) + result <- bmdHetVar(GiantKelp.LL.4.hetVar, bmr = 0.1, backgType = "hybridSD", backg = 2, def = "hybridAdd", R = 50, level = 0.95, progressInfo = FALSE, display = FALSE) + + expect_true(!is.na(result$Results[1, "BMD"])) + expect_equal(result$Results[1, "BMD"], c("BMD"=10.1611348555932)) + expect_equal(result$bmrScaled[1,1], 16.4508957731788) + expect_equal(unname(result$interval[1,]), c(3.49771946179717,20.6442510937985)) +}) + + + diff --git a/tests/testthat/test-bmdIso.R b/tests/testthat/test-bmdIso.R new file mode 100644 index 0000000..4b8bbb7 --- /dev/null +++ b/tests/testthat/test-bmdIso.R @@ -0,0 +1,132 @@ +# Tests for bmdMA function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - formaldehyde model +# - correct bmd estimate (all definitions for binomial data) +# - ryegrass model +# - correct bmd estimate (all definitions for cts. data) + + +# Arguments and structure ------------------------------------------------- + +## MISSING + + + +# formaldehyde model ------------------------------------------------------ + +## formaldehyde data example from bmdIso.Rd + +test_that("bmdIso function computes BMD (point) correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + + result <- bmdIso(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.18, + backgType = "modelBased", + def = "point") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 7.03841479524439) +}) + +test_that("bmdIso function computes BMD (excess) correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + + result <- bmdIso(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "excess") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 6.36170849845883) +}) + +test_that("bmdIso function computes BMD (additional) correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + + result <- bmdIso(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "additional") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 6.36170849845883) +}) + + + + +# ryegrass model ---------------------------------------------------------- + +## ryegrass example from bmdIso.Rd + +test_that("bmdIso function computes BMD (point) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + result <- bmdIso(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=93, + backgType = "modelBased", + def = "point") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 1.44279529207128) +}) + +test_that("bmdIso function computes BMD (relative) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + result <- bmdIso(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.05, + backgType = "modelBased", + def = "relative") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 3.68282590840032) +}) + +test_that("bmdIso function computes BMD (hybridExc with hydridSD background) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + result <- bmdIso(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.15, + backgType = "hybridSD", + def = "hybridExc", + backg = 2) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(result)) + expect_equal(result, 1.14488103599216) +}) + + + diff --git a/tests/testthat/test-bmdIsoBoot.R b/tests/testthat/test-bmdIsoBoot.R new file mode 100644 index 0000000..669af64 --- /dev/null +++ b/tests/testthat/test-bmdIsoBoot.R @@ -0,0 +1,271 @@ +# Tests for bmdMA function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - formaldehyde model +# - correct bmd estimate (all definitions for binomial data) +# - ryegrass model +# - correct bmd estimate (all definitions for cts. data) + + +# Arguments and structure ------------------------------------------------- + +## MISSING + + + +# formaldehyde model ------------------------------------------------------ + +## formaldehyde data example from bmdIsoBoot.Rd + +test_that("bmdIsoBoot function computes BMD (point, boot = \"resample\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.18, + backgType = "modelBased", + def = "point", + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[,"BMD"], 7.03841479524439) + expect_equal(result[,"BMDL"], 6.80808829160704) +}) + +test_that("bmdIsoBoot function computes BMD (excess, boot = \"resample\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "excess", + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 6.36170849845883) + expect_equal(result[, "BMDL"], 6.20108949416342) +}) + +test_that("bmdIsoBoot function computes BMD (additional, boot = \"resample\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "additional", + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 6.36170849845883) + expect_equal(result[, "BMDL"], 6.20108949416342) +}) + +test_that("bmdIsoBoot function computes BMD (point, boot = \"pseudorandom\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.18, + backgType = "modelBased", + def = "point", + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[,"BMD"], 7.03841479524439) + expect_equal(result[,"BMDL"], 6.84192399708765) +}) + +test_that("bmdIsoBoot function computes BMD (excess, boot = \"pseudorandom\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "excess", + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 6.36170849845883) + expect_equal(result[, "BMDL"], 6.20786436734456) +}) + +test_that("bmdIsoBoot function computes BMD (additional, boot = \"pseudorandom\") correctly for formaldehyde model", { + formaldehyde <- data.frame(conc = c(0.0, 0.7, 2.0, 6.0, 10.0, 15.0), + tumor.incidence = c(0, 0, 0, 3, 21, 150), + total = c(122, 27, 126, 113, 34, 182)) + set.seed(1) + result <- bmdIsoBoot(tumor.incidence/total ~ conc, + data=formaldehyde, + type="binomial", + bmr=0.08, + backgType = "modelBased", + def = "additional", + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 6.36170849845883) + expect_equal(result[, "BMDL"], 6.20786436734456) +}) + + + + +# ryegrass model ---------------------------------------------------------- + +## ryegrass example from bmdIsoBoot.Rd + +test_that("bmdIsoBoot function computes BMD (point) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=93, + backgType = "modelBased", + def = "point", + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 1.44279529207128) + expect_equal(result[, "BMDL"], 1.24074240997315) +}) + +test_that("bmdIsoBoot function computes BMD (relative) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.05, + backgType = "modelBased", + def = "relative", + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 3.68282590840032) + expect_equal(result[, "BMDL"], 3.35376062473603) +}) + +test_that("bmdIsoBoot function computes BMD (hybridExc with hydridSD background) correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.15, + backgType = "hybridSD", + def = "hybridExc", + backg = 2, + R = 50) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 1.14488103599216) + expect_equal(result[, "BMDL"], 0.732577658128982) +}) + +test_that("bmdIsoBoot function computes BMD (point, boot = \"pseudorandom\") correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=93, + backgType = "modelBased", + def = "point", + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 1.44279529207128) + expect_equal(result[, "BMDL"], 0.92019305649066) +}) + +test_that("bmdIsoBoot function computes BMD (relative, boot = \"pseudorandom\") correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.05, + backgType = "modelBased", + def = "relative", + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 3.68282590840032) + expect_equal(result[, "BMDL"], 3.12145839108025) +}) + +test_that("bmdIsoBoot function computes BMD (hybridExc with hydridSD background, boot = \"pseudorandom\") correctly for ryegrass model", { + ryegrass1 <- drcData::ryegrass + ryegrass1$rootl <- 100-ryegrass1$rootl + + # Estimating BMD from isotonic regression using relative risk definition and a BMR=0.05 + set.seed(1) + result <- bmdIsoBoot(rootl ~ conc, + data=ryegrass1, + type="continuous", + bmr=0.15, + backgType = "hybridSD", + def = "hybridExc", + backg = 2, + R = 50, + boot = "pseudorandom") + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(all(!is.na(result))) + expect_equal(result[, "BMD"], 1.14488103599216) + expect_equal(result[, "BMDL"], 0.400880981975031) +}) + + + diff --git a/tests/testthat/test-bmdMA.R b/tests/testthat/test-bmdMA.R new file mode 100644 index 0000000..bb3df10 --- /dev/null +++ b/tests/testthat/test-bmdMA.R @@ -0,0 +1,1103 @@ +# Tests for bmdMA function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - modelWeights argument +# - Simple model +# - correct bmd estimate for all (all definitions) +# - Ryegrass model (continuous) +# - correct bmd estimate (all definitions) +# - TCDD model (binomial) +# - correct bmd estimate (excess + additional) +# - S.alba model (continuous with multiple curves) +# - correct bmd estimate (point, extra, hybridExc) +# - Decreasing binomial model with multiple curves +# - correct bmd estimate (point, extra, hybridExc) + +# Arguments and structure ------------------------------------------------- + +test_that("bmdMA function handles missing required arguments", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + modelList0 <- list(object0) + + expect_error(bmdMA(), 'argument "modelList" is missing, with no default') + expect_error(bmdMA(modelList0), "def is missing") + expect_error(bmdMA(list(lm(1:10 ~ 1))), 'modelList must be a list of models of class "drc"') + expect_error(bmdMA(modelList0, def = "relative", backgType = "modelBased", bmr = 0.1), 'argument "modelWeights" is missing, with no default') + expect_error(bmdMA(modelList0, modelWeights = "invalid_weights", def = "relative", backgType = "modelBased", bmr = 0.1), 'modelWeights must either be "AIC", "BIC", "Stack", "Stacking" or a numeric vector of same length as modelList') + expect_error(bmdMA(modelList0, modelWeights = c(0.1,0.9), def = "relative", backgType = "modelBased", bmr = 0.1), 'modelWeights must either be "AIC", "BIC", "Stack", "Stacking" or a numeric vector of same length as modelList') + expect_error(bmdMA(modelList0, modelWeights = "AIC", def = "relative", backgType = "modelBased", bmr = 0.1), 'Specify model averaging type. Options are "curve", "bootstrap", "Kang" and "Buckland"') + expect_error(bmdMA(modelList0, modelWeights = "AIC", def = "invalid_def", backgType = "modelBased", type = "Kang"), "Could not recognize def") + expect_error(bmdMA(modelList0, modelWeights = "AIC", def = "relative", backgType = "invalid_type", type = "Kang"), "Could not recognize backgType") + expect_error(bmdMA(modelList0, modelWeights = "AIC", def = "relative", backgType = "modelBased", type = "Kang"), 'argument "bmr" is missing, with no default') +}) + + +test_that("bmdMA function accepts correct def", { + object.cont <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + object.binom <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2(), type = "binomial") + object.poisson <- drm(y ~ x, data = data.frame(x = 1:5, y = c(12,11,3,0,0)), fct = LL.3(), type = "Poisson") + + # Binomial bmd def with continuous model + expect_error(bmdMA(list(object.cont), modelWeights = 1, def = "excess", backgType = "modelBased", type = "Kang"), '"excess" is not available for continuous data') + expect_error(bmdMA(list(object.cont), modelWeights = 1, def = "additional", backgType = "modelBased", type = "Kang"), '"additional" is not available for continuous data') + + # Binomial bmd def with Poisson model + expect_error(bmdMA(list(object.poisson), modelWeights = 1, def = "excess", backgType = "modelBased", type = "Kang"), '"excess" is not available for count data') + expect_error(bmdMA(list(object.poisson), modelWeights = 1, def = "additional", backgType = "modelBased", type = "Kang"), '"additional" is not available for count data') + + # Cont bmd def with binomial model + expect_error(bmdMA(list(object.binom), modelWeights = 1, def = "relative", backgType = "modelBased", type = "Kang"), '"relative" is not available for quantal data') + expect_error(bmdMA(list(object.binom), modelWeights = 1, def = "extra", backgType = "modelBased", type = "Kang"), '"extra" is not available for quantal data') + expect_error(bmdMA(list(object.binom), modelWeights = 1, def = "added", backgType = "modelBased", type = "Kang"), '"added" is not available for quantal data') + expect_error(bmdMA(list(object.binom), modelWeights = 1, def = "hybridExc", backgType = "modelBased", type = "Kang"), '"hybridExc" is not available for quantal data') + expect_error(bmdMA(list(object.binom), modelWeights = 1, def = "hybridAdd", backgType = "modelBased", type = "Kang"), '"hybridAdd" is not available for quantal data') +}) + +test_that("bmdMA function returns expected structure", { + object0 <- drm(y ~ x, data = data.frame(x = 1:5, y = c(1,1,0.5,0,0)), fct = LL.2()) + + result <- bmdMA(list(object0), type = "Kang", modelWeights = "AIC", bmr = 0.1, def = "extra", backgType = "modelBased", display = FALSE) + + expect_type(result, "list") + expect_named(result, c("Results", "Boot.samples.used", "interval", "SE", "modelWeights")) + expect_s3_class(result, "bmd") +}) + +test_that("bmdMA function handles modelWeights argument", { + # data and fitted models + data0 <- data.frame(x = rep(c(0,0.5, 1, 2, 4), 3), + y = c(0.990994455038216, 0.743019106108585, 0.166411612682373, 0.0439546959424475, 0.183799321812153, + 0.884930607478322, 1.02159286444501, 0.176423458342167, 0.108887606895092, 0.103881440788692, + 1.06023067243334, 0.921135238829789, 0.371858798338925, -0.0499408692067165, -0.204825758120983)) + object.LL.2 <- drm(y ~ x, data = data0, fct = LL.2()) + object.LN.2 <- drm(y ~ x, data = data0, fct = LN.2()) + object.W1.2 <- drm(y ~ x, data = data0, fct = W1.2()) + object.W2.2 <- drm(y ~ x, data = data0, fct = W2.2()) + modelList0 <- list(object.LL.2, object.LN.2, object.W1.2, object.W2.2) + + # bmd estimates on models + bmdList0 <- lapply(modelList0, function(x) bmd(x, bmr = 0.08, backgType = "modelBased", def = "relative", display = FALSE)) + bmdVals <- sapply(bmdList0, function(x) x$Results[1,1]) + bmdlVals <- sapply(bmdList0, function(x) x$Results[1,2]) + + # model weights + manWeights0 <- c(0.3, 0.2, 0.2, 0.3) + AICWeights0 <- exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) / sum(exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) ) + BICWeights0 <- exp(-1/2 * sapply(modelList0, BIC)) / sum(exp(-1/2 * sapply(modelList0, BIC)) ) + set.seed(1) + stackingWeights0 <- getStackingWeights(modelList0, nSplits = 3) + + # apply bmdMA + bmdMAManWeights <- bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMAAICWeights <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMABICWeights <- bmdMA(modelList0, modelWeights = "BIC", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMAStackingWeights <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSeed = 1, stackingSplits = 3) + + # checks + expect_equal(bmdMAManWeights$modelWeights, manWeights0) + expect_equal(bmdMAManWeights$Results[1,1], sum(bmdVals * manWeights0)) + expect_equal(bmdMAManWeights$Results[1,2], sum(bmdlVals * manWeights0)) + + expect_equal(bmdMAAICWeights$modelWeights, AICWeights0) + expect_equal(bmdMAAICWeights$Results[1,1], sum(bmdVals * AICWeights0)) + expect_equal(bmdMAAICWeights$Results[1,2], sum(bmdlVals * AICWeights0)) + + expect_equal(bmdMABICWeights$modelWeights, BICWeights0) + expect_equal(bmdMABICWeights$Results[1,1], sum(bmdVals * BICWeights0)) + expect_equal(bmdMABICWeights$Results[1,2], sum(bmdlVals * BICWeights0)) + + expect_equal(bmdMAStackingWeights$modelWeights, stackingWeights0, tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$Results[1,1], sum(bmdVals * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$Results[1,2], sum(bmdlVals * stackingWeights0), tolerance = 1e-4) +}) + + +test_that("bmdMA function handles type argument", { + # data and fitted models + data0 <- data.frame(x = rep(c(0,0.5, 1, 2, 4), 3), + y = c(0.990994455038216, 0.743019106108585, 0.166411612682373, 0.0439546959424475, 0.183799321812153, + 0.884930607478322, 1.02159286444501, 0.176423458342167, 0.108887606895092, 0.103881440788692, + 1.06023067243334, 0.921135238829789, 0.371858798338925, -0.0499408692067165, -0.204825758120983)) + object.LL.2 <- drm(y ~ x, data = data0, fct = LL.2()) + object.LN.2 <- drm(y ~ x, data = data0, fct = LN.2()) + object.W1.2 <- drm(y ~ x, data = data0, fct = W1.2()) + object.W2.2 <- drm(y ~ x, data = data0, fct = W2.2()) + object.FPL.4 <- drm(y ~ x, data = data0, fct = FPL.4(p1 = -1, p2 = 1)) + modelList0 <- list(object.LL.2, object.LN.2, object.W1.2, object.W2.2, object.FPL.4) + + # bmd estimates on models + bmdList0 <- lapply(modelList0, function(x) bmd(x, bmr = 0.08, backgType = "modelBased", def = "relative", display = FALSE)) + bmdVals <- sapply(bmdList0, function(x) x$Results[1,1]) + bmrScaledVals <- sapply(bmdList0, function(x) x$bmrScaled[1,1]) + bmdlVals <- sapply(bmdList0, function(x) x$interval[1,1]) + bmduVals <- sapply(bmdList0, function(x) x$interval[1,2]) + + # model weights + manWeights0 <- c(0.3, 0.18, 0.15, 0.22, 0.15) + + # apply bmdMA + bmdMAKang <- bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMABuckland <- bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "Buckland", display = FALSE) + set.seed(123) + bmdMABoot <- suppressWarnings(bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "bootstrap", R = 100, display = FALSE, progressInfo = FALSE)) + set.seed(123) + bmdMABootBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "bootstrap", bootInterval = "BCa", R = 100, display = FALSE, progressInfo = FALSE)) + set.seed(123) + bmdMACurve <- suppressWarnings(bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "curve", R = 100, display = FALSE, progressInfo = FALSE)) + set.seed(123) + bmdMACurveBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "curve", bootInterval = "BCa", R = 100, display = FALSE, progressInfo = FALSE)) + + # checks + expect_equal(bmdMAKang$Results[1,1], sum(manWeights0 * bmdVals)) + expect_equal(bmdMABuckland$Results[1,1], sum(manWeights0 * bmdVals)) + expect_equal(bmdMABoot$Results[1,1], sum(manWeights0 * bmdVals)) + expect_equal(bmdMABootBCa$Results[1,1], sum(manWeights0 * bmdVals)) + expect_equal(bmdMACurve$Results[1,1], 0.475485949896767) # manual calculation checked in v2.6.7 + expect_equal(bmdMACurveBCa$Results[1,1], 0.475485949896767) # manual calculation checked in v2.6.7 + expect_equal(sum(manWeights0 * bmrScaledVals), + sum(manWeights0 * sapply(modelList0, + function(x) x$curve[[1]](bmdMACurve$Results[1,1]))), + tolerance = 1e-4) + + # intervals + expect_equal(c(bmdMAKang$interval[1,1], bmdMAKang$interval[1,2]), + c(sum(manWeights0 * bmdlVals), sum(manWeights0 * bmduVals))) + expect_equal(c(bmdMABuckland$interval[1,1], bmdMABuckland$interval[1,2]), + bmdMABuckland$Results[1,1] + qnorm(c(0.05, 0.95)) * bmdMABuckland$SE[1,1]) + expect_equal(c(bmdMABoot$interval[1,1], bmdMABoot$interval[1,2]), + c(0.367163177724489, 0.63600316417734)) # manual calculation checked in v2.6.7 + expect_equal(bmdMABootBCa$Results[1,2], 0.386237633715302) # manual calculation checked in v2.6.7 + expect_equal(bmdMABootBCa$interval[1,2], "Not available for BCa bootstrap") + expect_equal(c(bmdMACurve$interval[1,1], bmdMACurve$interval[1,2]), + c(0.370341672214575, 0.622868602504527)) # manual calculation checked in v2.6.7 + expect_equal(bmdMACurveBCa$Results[1,2], 0.389400777586158) # manual calculation checked in v2.6.7 + expect_equal(bmdMABootBCa$interval[1,2], "Not available for BCa bootstrap") + + # SE (only for Buckland) + expect_equal(bmdMABuckland$SE[1, 1], 0.0785971536016299) # manual calculation checked in v2.6.7 +}) + +test_that("bmdMA handles seed correctly when using Stacking weights",{ + # data and fitted models + data0 <- data.frame(x = rep(c(0,0.5, 1, 2, 4), 3), + y = c(0.990994455038216, 0.743019106108585, 0.166411612682373, 0.0439546959424475, 0.183799321812153, + 0.884930607478322, 1.02159286444501, 0.176423458342167, 0.108887606895092, 0.103881440788692, + 1.06023067243334, 0.921135238829789, 0.371858798338925, -0.0499408692067165, -0.204825758120983)) + object.LL.2 <- drm(y ~ x, data = data0, fct = LL.2()) + object.LN.2 <- drm(y ~ x, data = data0, fct = LN.2()) + object.W1.2 <- drm(y ~ x, data = data0, fct = W1.2()) + object.W2.2 <- drm(y ~ x, data = data0, fct = W2.2()) + modelList0 <- list(object.LL.2, object.LN.2, object.W1.2, object.W2.2) + + # first seed of seed (1, 123) + set.seed(1) + twoNormalVariables.seed1 <- rnorm(2) + + set.seed(1) + oneNormalVariable.seed1 <- rnorm(1) + bmdMAStackingWeights.seed123.inside <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSeed = 123, stackingSplits = 3) + secondNormalVariable.seed1 <- rnorm(1) + + set.seed(123) + bmdMAStackingWeights.seed123.outside <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSplits = 3) + + expect_equal(twoNormalVariables.seed1, c(oneNormalVariable.seed1, secondNormalVariable.seed1)) + expect_equal(bmdMAStackingWeights.seed123.inside$modelWeights, bmdMAStackingWeights.seed123.outside$modelWeights, tolerance = 1e-4) + + # second set of seed (156, 999) + set.seed(156) + twoNormalVariables.seed156 <- rnorm(2) + + set.seed(156) + oneNormalVariable.seed156 <- rnorm(1) + bmdMAStackingWeights.seed999.inside <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSeed = 999, stackingSplits = 3) + secondNormalVariable.seed156 <- rnorm(1) + + set.seed(999) + bmdMAStackingWeights.seed999.outside <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSplits = 3) + + expect_equal(twoNormalVariables.seed156, c(oneNormalVariable.seed156, secondNormalVariable.seed156)) + expect_equal(bmdMAStackingWeights.seed999.inside$modelWeights, bmdMAStackingWeights.seed999.outside$modelWeights, tolerance = 1e-4) + + # Check that the results are indeed different + expect(all(twoNormalVariables.seed1 != twoNormalVariables.seed156), failure_message = "Variables from different seeds are not different") + expect(all(c(oneNormalVariable.seed1, secondNormalVariable.seed1) != c(oneNormalVariable.seed156, secondNormalVariable.seed156)), + failure_message = "Variables from different seeds are not different") + expect(sum(abs(bmdMAStackingWeights.seed123.inside$modelWeights - bmdMAStackingWeights.seed999.inside$modelWeights)) > 0.01, + failure_message = "Stacking Weights from different seeds are not different") + expect(sum(abs(bmdMAStackingWeights.seed123.outside$modelWeights - bmdMAStackingWeights.seed999.outside$modelWeights)) > 0.01, + failure_message = "Stacking Weights from different seeds are not different") +}) + +test_that("bmdMA function output remains consistent", { + # data and fitted models + data0 <- data.frame(x = rep(c(0,0.5, 1, 2, 4), 3), + y = c(0.990994455038216, 0.743019106108585, 0.166411612682373, 0.0439546959424475, 0.183799321812153, + 0.884930607478322, 1.02159286444501, 0.176423458342167, 0.108887606895092, 0.103881440788692, + 1.06023067243334, 0.921135238829789, 0.371858798338925, -0.0499408692067165, -0.204825758120983)) + object.LL.2 <- drm(y ~ x, data = data0, fct = LL.2()) + object.LN.2 <- drm(y ~ x, data = data0, fct = LN.2()) + object.W1.2 <- drm(y ~ x, data = data0, fct = W1.2()) + object.W2.2 <- drm(y ~ x, data = data0, fct = W2.2()) + modelList0 <- list(object.LL.2, object.LN.2, object.W1.2, object.W2.2) + + bmdMAresult <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Buckland", display = FALSE) + + snapshot_data <- list( + Results = as.list(bmdMAresult$Results), + Boot.samples.used = as.list(bmdMAresult$Boot.samples.used), + interval = as.list(bmdMAresult$interval), + SE = as.list(bmdMAresult$SE) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + + + +# ryegrass models --------------------------------------------------------- + + +test_that("bmdMA function computes BMD (point) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultKang <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "Kang", display = FALSE) + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "Buckland", display = FALSE) + set.seed(1) + resultBoot <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, display = FALSE, progressInfo = FALSE) + set.seed(1) + resultCurve <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "curve", R = 50, display = FALSE, progressInfo = FALSE) + set.seed(1) + resultBootBCa <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "bootstrap", bootInterval = "BCa", R = 50, display = FALSE, progressInfo = FALSE) + set.seed(1) + resultCurveBCa <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "curve", bootInterval = "BCa", R = 50, display = FALSE, progressInfo = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + # Kang + expect_true(!is.na(resultKang$Results[1, "BMD_MA"])) + expect_equal(resultKang$Results[1, "BMD_MA"], 3.62285507866639) + expect_equal(resultKang$interval[1,], c(BMDL_MA = 3.26863980433835, BMDU_MA = 3.97707035299443)) + + # Buckland + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 3.62285507866639) + expect_equal(resultBuckland$SE[1,1], 0.209800492692605) + expect_equal(resultBuckland$interval[1,], c(BMDL_MA = 3.27776397732476, BMDU_MA = 3.96794618000803)) + + # Boot + expect_true(!is.na(resultBoot$Results[1, "BMD_MA"])) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(resultBoot$Results[1, "BMD_MA"], 3.62285507866639) + expect_equal(resultBoot$interval[1,], c(BMDL_MA = 3.15637429751311, BMDU_MA = 4.13206808564422)) + + # Curve + expect_true(!is.na(resultCurve$Results[1, "BMD_MA"])) + expect_equal(resultCurve$Boot.samples.used, 50) + expect_equal(resultCurve$Results[1, "BMD_MA"], 3.62594076228422) + expect_equal(resultCurve$interval[1,], c(BMDL_MA = 3.1364748814186, BMDU_MA = 4.13187952141919)) + + # BootBCa + expect_true(all(!is.na(resultBootBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultBootBCa$Results[, "BMD_MA"]), c(3.62285507866639)) + expect_equal(resultBootBCa$Boot.samples.used, 50) + expect_equal(unname(resultBootBCa$Results[,"BMDL_MA"]), c(3.28847336953601)) + expect_equal(unname(resultBootBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap")) + + # CurveBCa + expect_true(all(!is.na(resultCurveBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurveBCa$Results[, "BMD_MA"]), c(3.62594076228422)) + expect_equal(resultCurveBCa$Boot.samples.used, 50) + expect_equal(unname(resultCurveBCa$Results[,"BMDL_MA"]), c(3.34556336964975)) + expect_equal(unname(resultCurveBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap")) +}) + +test_that("bmdMA function computes BMD (extra) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "extra", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.52703134707651) + expect_equal(resultBuckland$SE[1,1], 0.210054516104069) + expect_equal(unname(resultBuckland$interval[1,]), c(1.1815224144052,1.87254027974782)) +}) + +test_that("bmdMA function computes BMD (relative) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "relative", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.55622345982699) + expect_equal(resultBuckland$SE[1,1], 0.189786051498867) + expect_equal(unname(resultBuckland$interval[1,]), c(1.24405318467428,1.8683937349797)) +}) + +test_that("bmdMA function computes BMD (added) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "added", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 0.930418495860691) + expect_equal(resultBuckland$SE[1,1], 0.264731500303042) + expect_equal(unname(resultBuckland$interval[1,]), c(0.494973927418928,1.36586306430245)) +}) + +test_that("bmdMA function computes BMD (hybridAdd with hybridSD background) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "hybridAdd", backgType = "hybridSD", backg = 2, type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.31942461589965) + expect_equal(resultBuckland$SE[1,1], 0.215846392664226) + expect_equal(unname(resultBuckland$interval[1,]), c(0.964388894061504,1.67446033773779)) +}) + +test_that("bmdMA function computes BMD (hybridExc with hybridSD background) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.31462740464376) + expect_equal(resultBuckland$SE[1,1], 0.216356052118326) + expect_equal(unname(resultBuckland$interval[1,]), c(0.958753367604025,1.67050144168349)) +}) + +test_that("bmdMA function computes BMD (hybridExc with hybridPercentile background) correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(rootl ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(rootl ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(rootl ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(rootl ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "hybridExc", backgType = "hybridPercentile", backg = 0.05, type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.2022469808022) + expect_equal(resultBuckland$SE[1,1], 0.229041579777732) + expect_equal(unname(resultBuckland$interval[1,]), c(0.825507107582098,1.57898685402229)) +}) + +test_that("bmdMA function computes BMD (relative) with log-transformed response correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL <- drm(log(rootl) ~ conc, data = data0, fct = LL.4()) + object.LN <- drm(log(rootl) ~ conc, data = data0, fct = LN.4()) + object.W1 <- drm(log(rootl) ~ conc, data = data0, fct = W1.4()) + object.W2 <- drm(log(rootl) ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "log", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.20542377217772) + expect_equal(resultBuckland$SE[1,1], 0.353626557987876) + expect_equal(unname(resultBuckland$interval[1,]), c(0.623759845685001,1.78708769867044)) +}) + +test_that("bmdMA function computes BMD (relative) with square root-transformed response correctly for ryegrass models", { + # data and fitted models + data0 <- drcData::ryegrass + object.LL.2 <- drm(sqrt(rootl) ~ conc, data = data0, fct = LL.4()) + object.LN.2 <- drm(sqrt(rootl) ~ conc, data = data0, fct = LN.4()) + object.W1.2 <- drm(sqrt(rootl) ~ conc, data = data0, fct = W1.4()) + object.W2.2 <- drm(sqrt(rootl) ~ conc, data = data0, fct = W2.4()) + modelList0 <- list(object.LL.2, object.LN.2, object.W1.2, object.W2.2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "relative", backgType = "modelBased", respTrans = "sqrt", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 1.50354728636659) + expect_equal(resultBuckland$SE[1,1], 0.237926009341212) + expect_equal(unname(resultBuckland$interval[1,]), c(1.11219382695561,1.89490074577758)) +}) + + + + + + +# TCDD models ----------------------------------------------------------- + + +test_that("bmdMA function computes BMD (point) correctly for TCDD models", { + # data and fitted models + data0 <- drcData::TCDD + object.LL <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LL.4(), type = "binomial") + object.LN <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LN.4(), type = "binomial") + object.W1 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W1.4(), type = "binomial") + object.W2 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultKang <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "Kang", display = FALSE) + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "Buckland", display = FALSE) + set.seed(1) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultBootBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "bootstrap", bootInterval = "BCa", R = 50, display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultCurve <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "curve", R = 50, display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultCurveBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.22, def = "point", backgType = "modelBased", type = "curve", bootInterval = "BCa", R = 50, display = FALSE, progressInfo = FALSE)) + + # Expected results based on manual calculation (checked in v2.6.7) + # Kang + expect_true(!is.na(resultKang$Results[1, "BMD_MA"])) + expect_equal(resultKang$Results[1, "BMD_MA"], 8.0976277220152) + expect_equal(resultKang$interval[1,], c(BMDL_MA = -263.257027195816, BMDU_MA = 279.452282639846)) + + # Buckland + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 8.0976277220152) + expect_equal(resultBuckland$SE[1,1], 164.979529539839) + expect_equal(resultBuckland$interval[1,], c(BMDL_MA = 8.0976277220152 + qnorm(0.05) * 164.979529539839, BMDU_MA = 8.0976277220152 + qnorm(0.95) * 164.979529539839)) + + # Boot + expect_true(!is.na(resultBoot$Results[1, "BMD_MA"])) + expect_equal(resultBoot$Boot.samples.used, 48) + expect_equal(resultBoot$Results[1, "BMD_MA"], 8.0976277220152) + expect_equal(resultBoot$interval[1,], c(BMDL_MA = 6.27951876692377, BMDU_MA = 15.8918488967058)) + + # BootBCa + expect_true(all(!is.na(resultBootBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultBootBCa$Results[, "BMD_MA"]), c(8.0976277220152)) + expect_equal(resultBootBCa$Boot.samples.used, 48) + expect_equal(unname(resultBootBCa$Results[,"BMDL_MA"]), c(5.48916035257719)) + expect_equal(unname(resultBootBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap")) + + # Curve + expect_true(!is.na(resultCurve$Results[1, "BMD_MA"])) + expect_equal(resultCurve$Boot.samples.used, 48) + expect_equal(resultCurve$Results[1, "BMD_MA"], 7.93703689546043) + expect_equal(resultCurve$interval[1,], c(BMDL_MA = 6.51501264650305, BMDU_MA = 16.4080707920735)) + + # CurveBCa + expect_true(all(!is.na(resultCurveBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurveBCa$Results[, "BMD_MA"]), c(7.93703689546043)) + expect_equal(resultCurveBCa$Boot.samples.used, 48) + expect_equal(unname(resultCurveBCa$Results[,"BMDL_MA"]), c(5.91280712553062)) + expect_equal(unname(resultCurveBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap")) +}) + +test_that("bmdMA function computes BMD (excess) correctly for TCDD models", { + # data and fitted models + data0 <- drcData::TCDD + object.LL <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LL.4(), type = "binomial") + object.LN <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LN.4(), type = "binomial") + object.W1 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W1.4(), type = "binomial") + object.W2 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 6.01418679961228) + expect_equal(resultBuckland$SE[1,1], 141.305877641293) + expect_equal(unname(resultBuckland$interval[1,]), c(-226.41329854823,238.441672147454)) +}) + +test_that("bmdMA function computes BMD (additional) correctly for TCDD models", { + # data and fitted models + data0 <- drcData::TCDD + object.LL <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LL.4(), type = "binomial") + object.LN <- drm(incidence/total ~ conc, weights = total, data = data0, fct = LN.4(), type = "binomial") + object.W1 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W1.4(), type = "binomial") + object.W2 <- drm(incidence/total ~ conc, weights = total, data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "additional", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Expected results based on manual calculation (checked in v2.6.7) + expect_true(!is.na(resultBuckland$Results[1, "BMD_MA"])) + expect_equal(resultBuckland$Results[1, "BMD_MA"], 6.05421250633682) + expect_equal(resultBuckland$SE[1,1], 137.343568778351) + expect_equal(unname(resultBuckland$interval[1,]), c(-219.855854737192,231.964279749866)) +}) + + + + +# S.alba models ----------------------------------------------------------- + +test_that("bmdMA function computes BMD (point) correctly for S.alba models", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4()) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4()) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4()) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultKang <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "Kang", display = FALSE) + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "Buckland", display = FALSE) + set.seed(1) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultCurve <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "curve", R = 50, display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultBootBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, bootInterval = "BCa", display = FALSE, progressInfo = FALSE)) + set.seed(1) + resultCurveBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "curve", R = 50, bootInterval = "BCa", display = FALSE, progressInfo = FALSE)) + + # Expected results based on manual calculation (checked in v2.6.7) + # Kang + expect_true(all(!is.na(resultKang$Results[, "BMD_MA"]))) + expect_equal(resultKang$Results[, "BMD_MA"], c(Glyphosate = 39.5922313568255, Bentazone = 22.1027508909314)) + expect_equal(resultKang$interval[,1], c(Glyphosate = 31.3181029781253, Bentazone = 18.8097460620025)) + expect_equal(resultKang$interval[,2], c(Glyphosate = 47.8663597355256, Bentazone = 25.3957557198603)) + + # Buckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(resultBuckland$Results[, "BMD_MA"], c(Glyphosate = 39.5922313568255, Bentazone = 22.1027508909314)) + expect_equal(resultBuckland$SE[,1], c(Glyphosate = 4.96856818234909, Bentazone = 2.02139569706442)) + expect_equal(resultBuckland$interval[,1], c(Glyphosate = 39.5922313568255, Bentazone = 22.1027508909314) + + qnorm(0.05) * c(Glyphosate = 4.96856818234909, Bentazone = 2.02139569706442)) + expect_equal(resultBuckland$interval[,2], c(Glyphosate = 39.5922313568255, Bentazone = 22.1027508909314) + + qnorm(0.95) * c(Glyphosate = 4.96856818234909, Bentazone = 2.02139569706442)) + + # Boot + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(resultBoot$Results[, "BMD_MA"], c(Glyphosate = 39.5922313568255, Bentazone = 22.1027508909314)) + expect_equal(resultBoot$interval[,1], c(Glyphosate = 29.4081958504551, Bentazone = 18.318530994358)) + expect_equal(resultBoot$interval[,2], c(Glyphosate = 48.1571285773063, Bentazone = 26.2292827844959)) + + # Curve + expect_true(all(!is.na(resultCurve$Results[, "BMD_MA"]))) + expect_equal(resultCurve$Boot.samples.used, 50) + expect_equal(resultCurve$Results[, "BMD_MA"], c(Glyphosate = 39.6418457928274, Bentazone = 22.0090447085917)) + expect_equal(resultCurve$interval[,1], c(Glyphosate = 29.3925146204986, Bentazone = 18.283216864945)) + expect_equal(resultCurve$interval[,2], c(Glyphosate = 47.0458800892314, Bentazone = 26.2673216228492)) + + # BootBCa + expect_true(all(!is.na(resultBootBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultBootBCa$Results[, "BMD_MA"]), c(39.5922313568255, 22.1027508909314)) + expect_equal(resultBootBCa$Boot.samples.used, 50) + expect_equal(unname(resultBootBCa$Results[,"BMDL_MA"]), c(31.0359096482404,18.5448190488073)) + expect_equal(unname(resultBootBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) + + # CurveBCa + expect_true(all(!is.na(resultCurveBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurveBCa$Results[, "BMD_MA"]), c(39.6418457928274, 22.0090447085917)) + expect_equal(resultCurveBCa$Boot.samples.used, 50) + expect_equal(unname(resultCurveBCa$Results[,"BMDL_MA"]), c(30.9098852016046,18.4608747446523)) + expect_equal(unname(resultCurveBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdMA function computes BMD (relative) correctly for S.alba models", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4()) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4()) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4()) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, def = "relative", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Buckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(resultBuckland$Results[, "BMD_MA"], c(Glyphosate = 28.8918829608504, Bentazone = 19.0370848122154)) + expect_equal(resultBuckland$SE[,1], c(Glyphosate = 6.97566436363773, Bentazone = 2.43528735772882)) + expect_equal(resultBuckland$interval[,1], c(Glyphosate = 28.8918829608504, Bentazone = 19.0370848122154) + + qnorm(0.05) * c(Glyphosate = 6.97566436363773, Bentazone = 2.43528735772882)) + expect_equal(resultBuckland$interval[,2], c(Glyphosate = 28.8918829608504, Bentazone = 19.0370848122154) + + qnorm(0.95) * c(Glyphosate = 6.97566436363773, Bentazone = 2.43528735772882)) +}) + +test_that("bmdMA function computes BMD (hybridExc with hybridSD background) correctly for S.alba models", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4()) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4()) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4()) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, type = "Buckland", display = FALSE) + + # Buckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(resultBuckland$Results[, "BMD_MA"], c(Glyphosate = 28.878538008635, Bentazone = 19.097790315674)) + expect_equal(resultBuckland$SE[,1], c(Glyphosate = 7.15914360496773, Bentazone = 2.48849148981338)) + expect_equal(resultBuckland$interval[,1], c(Glyphosate = 28.878538008635, Bentazone = 19.097790315674) + + qnorm(0.05) * c(Glyphosate = 7.15914360496773, Bentazone = 2.48849148981338)) + expect_equal(resultBuckland$interval[,2], c(Glyphosate = 28.878538008635, Bentazone = 19.097790315674) + + qnorm(0.95) * c(Glyphosate = 7.15914360496773, Bentazone = 2.48849148981338)) +}) + +test_that("bmdMA function handles modelWeights argument on S.alba data with multiple curves", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4()) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4()) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4()) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # bmd estimates on models + bmdList0 <- lapply(modelList0, function(x) bmd(x, bmr = 0.08, backgType = "modelBased", def = "relative", display = FALSE)) + bmdVals <- sapply(bmdList0, function(x) x$Results[,1]) + bmdlVals <- sapply(bmdList0, function(x) x$Results[,2]) + bmduVals <- sapply(bmdList0, function(x) x$interval[,2]) + + # model weights + manWeights0 <- c(0.3, 0.2, 0.2, 0.3) + AICWeights0 <- exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) / sum(exp(-1/2 * (sapply(modelList0, AIC) - min(sapply(modelList0, AIC)))) ) + BICWeights0 <- exp(-1/2 * sapply(modelList0, BIC)) / sum(exp(-1/2 * sapply(modelList0, BIC)) ) + set.seed(1) + stackingWeights0 <- getStackingWeights(modelList0, nSplits = 4) + + # apply bmdMA + bmdMAManWeights <- bmdMA(modelList0, modelWeights = manWeights0, bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMAAICWeights <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMABICWeights <- bmdMA(modelList0, modelWeights = "BIC", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE) + bmdMAStackingWeights <- bmdMA(modelList0, modelWeights = "Stack", bmr = 0.08, backgType = "modelBased", def = "relative", type = "Kang", display = FALSE, stackingSeed = 1, stackingSplits = 4) + + # checks + expect_equal(bmdMAManWeights$modelWeights, manWeights0) + expect_equal(bmdMAManWeights$Results[1,1], sum(bmdVals[1,] * manWeights0)) + expect_equal(bmdMAManWeights$Results[2,1], sum(bmdVals[2,] * manWeights0)) + expect_equal(bmdMAManWeights$Results[1,2], sum(bmdlVals[1,] * manWeights0)) + expect_equal(bmdMAManWeights$Results[2,2], sum(bmdlVals[2,] * manWeights0)) + expect_equal(bmdMAManWeights$interval[1,2], sum(bmduVals[1,] * manWeights0)) + expect_equal(bmdMAManWeights$interval[2,2], sum(bmduVals[2,] * manWeights0)) + + expect_equal(bmdMAAICWeights$modelWeights, AICWeights0) + expect_equal(bmdMAAICWeights$Results[1,1], sum(bmdVals[1,] * AICWeights0)) + expect_equal(bmdMAAICWeights$Results[2,1], sum(bmdVals[2,] * AICWeights0)) + expect_equal(bmdMAAICWeights$Results[1,2], sum(bmdlVals[1,] * AICWeights0)) + expect_equal(bmdMAAICWeights$Results[2,2], sum(bmdlVals[2,] * AICWeights0)) + expect_equal(bmdMAAICWeights$interval[1,2], sum(bmduVals[1,] * AICWeights0)) + expect_equal(bmdMAAICWeights$interval[2,2], sum(bmduVals[2,] * AICWeights0)) + + expect_equal(bmdMABICWeights$modelWeights, BICWeights0) + expect_equal(bmdMABICWeights$Results[1,1], sum(bmdVals[1,] * BICWeights0)) + expect_equal(bmdMABICWeights$Results[2,1], sum(bmdVals[2,] * BICWeights0)) + expect_equal(bmdMABICWeights$Results[1,2], sum(bmdlVals[1,] * BICWeights0)) + expect_equal(bmdMABICWeights$Results[2,2], sum(bmdlVals[2,] * BICWeights0)) + expect_equal(bmdMABICWeights$interval[1,2], sum(bmduVals[1,] * BICWeights0)) + expect_equal(bmdMABICWeights$interval[2,2], sum(bmduVals[2,] * BICWeights0)) + + expect_equal(bmdMAStackingWeights$modelWeights, stackingWeights0) + expect_equal(bmdMAStackingWeights$Results[1,1], sum(bmdVals[1,] * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$Results[2,1], sum(bmdVals[2,] * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$Results[1,2], sum(bmdlVals[1,] * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$Results[2,2], sum(bmdlVals[2,] * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$interval[1,2], sum(bmduVals[1,] * stackingWeights0), tolerance = 1e-4) + expect_equal(bmdMAStackingWeights$interval[2,2], sum(bmduVals[2,] * stackingWeights0), tolerance = 1e-4) +}) + +test_that("bmdMA function computes BMD (relative) correctly for S.alba models fitted separately", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4(), separate = TRUE) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4(), separate = TRUE) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4(), separate = TRUE) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4(), separate = TRUE) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, def = "relative", backgType = "modelBased", type = "Buckland", display = FALSE) + + # Buckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(resultBuckland$Results[, "BMD_MA"], c(Glyphosate = 28.8997770186961, Bentazone = 19.0337863593213)) + expect_equal(resultBuckland$SE[,1], c(Glyphosate = 7.46204086748364, Bentazone = 2.24787601134509)) + expect_equal(resultBuckland$interval[,1], c(Glyphosate = 28.8997770186961, Bentazone = 19.0337863593213) + + qnorm(0.05) * c(Glyphosate = 7.46204086748364, Bentazone = 2.24787601134509)) + expect_equal(resultBuckland$interval[,2], c(Glyphosate = 28.8997770186961, Bentazone = 19.0337863593213) + + qnorm(0.95) * c(Glyphosate = 7.46204086748364, Bentazone = 2.24787601134509)) + expect_equal(resultBuckland$modelWeights, matrix(c(0.289011738824658, 0.252712376289855, + 0.242970006217661, 0.238530168705929, + 0.232912736014905, 0.254486486073599, + 0.235105518942777, 0.254270968930617), + nrow = 2, + dimnames = list(c("Glyphosate", "Bentazone"), NULL))) +}) + + +test_that("bmdMA function output remains consistent with model with multiple curves", { + # data and fitted models + data0 <- drcData::S.alba + object.LL <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LL.4()) + object.LN <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = LN.4()) + object.W1 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W1.4()) + object.W2 <- drm(DryMatter ~ Dose, curveid = Herbicide, data = data0, fct = W2.4()) + modelList0 <- list(object.LL, object.LN, object.W1, object.W2) + + # results + resultBuckland <- bmdMA(modelList0, modelWeights = "AIC", bmr = 0.08, def = "extra", backgType = "modelBased", type = "Buckland", display = FALSE) + + snapshot_data <- list( + Results = as.list(resultBuckland$Results), + Boot.samples.used = as.list(resultBuckland$Boot.samples.used), + interval = as.list(resultBuckland$interval), + SE = as.list(resultBuckland$SE) + ) + + # Store a snapshot of the entire result object + expect_snapshot_value(snapshot_data, style = "deparse") +}) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +# Decreasing binomial model with multiple curves -------------------------- +test_that("bmdMA function computes BMD (point) correctly for Decreasing binomial model with multiple curves", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0.LL.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LL.4(), type = "binomial") + object0.LN.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LN.4(), type = "binomial") + object0.W1.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W1.4(), type = "binomial") + object0.W2.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object0.LL.4, object0.LN.4, object0.W1.4, object0.W2.4) + + set.seed(1) + invisible(capture.output({ + resultKang <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "Kang", display = FALSE)) + resultBuckland <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "Buckland", display = FALSE)) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE)) + resultCurve <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "curve", R = 50, progressInfo = FALSE, display = FALSE)) + resultBootBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "bootstrap", bootInterval = "BCa", R = 50, progressInfo = FALSE, display = FALSE)) + resultCurveBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.77, def = "point", backgType = "modelBased", type = "curve", bootInterval = "BCa", R = 50, progressInfo = FALSE, display = FALSE)) + })) + + # Expected results based on manual calculation (checked in v2.6.7) + # resultKang + expect_true(all(!is.na(resultKang$Results[, "BMD_MA"]))) + expect_equal(unname(resultKang$Results[, "BMD_MA"]), c(16.4767601484833, 30.3381343833517)) + expect_equal(resultKang$Boot.samples.used, NA) + expect_equal(unname(resultKang$interval[,"BMDL_MA"]), c(5.4148182829762,21.1390036616694)) + expect_equal(unname(resultKang$interval[,"BMDU_MA"]), c(27.5387020139904,39.5372651050341)) + # resultBuckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(unname(resultBuckland$Results[, "BMD_MA"]), c(16.4767601484833, 30.3381343833517)) + expect_equal(resultBuckland$Boot.samples.used, NA) + expect_equal(unname(resultBuckland$interval[,"BMDL_MA"]), c(5.40824166637437,21.1373086792919)) + expect_equal(unname(resultBuckland$interval[,"BMDU_MA"]), c(27.5452786305922,39.5389600874116)) + # resultBoot + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(unname(resultBoot$Results[, "BMD_MA"]), c(16.4767601484833, 30.3381343833517)) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(unname(resultBoot$interval[,"BMDL_MA"]), c(1.55114527115658,24.7976584352616)) + expect_equal(unname(resultBoot$interval[,"BMDU_MA"]), c(28.447104103199,39.2750258645232)) + # resultCurve + expect_true(all(!is.na(resultCurve$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurve$Results[, "BMD_MA"]), c(16.5073556830358, 30.3309353075015)) + expect_equal(resultCurve$Boot.samples.used, 50) + expect_equal(unname(resultCurve$interval[,"BMDL_MA"]), c(1.45044325358349,26.3872029783547)) + expect_equal(unname(resultCurve$interval[,"BMDU_MA"]), c(23.4835755264987,39.9141782740096)) + # resultBootBCa + expect_true(all(!is.na(resultBootBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultBootBCa$Results[, "BMD_MA"]), c(16.4767601484833, 30.3381343833517)) + expect_equal(resultBootBCa$Boot.samples.used, 49) + expect_equal(unname(resultBootBCa$Results[,"BMDL_MA"]), c(3.3270653573855,16.8290145235522)) + expect_equal(unname(resultBootBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) + # resultCurveBCa + expect_true(all(!is.na(resultCurveBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurveBCa$Results[, "BMD_MA"]), c(16.5073556830358, 30.3309353075015)) + expect_equal(resultCurveBCa$Boot.samples.used, 50) + expect_equal(unname(resultCurveBCa$Results[,"BMDL_MA"]), c(0.361186441608513,21.6147459158837)) + expect_equal(unname(resultCurveBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdMA function computes BMD (excess) correctly for Decreasing binomial model with multiple curves", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0.LL.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LL.4(), type = "binomial") + object0.LN.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LN.4(), type = "binomial") + object0.W1.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W1.4(), type = "binomial") + object0.W2.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object0.LL.4, object0.LN.4, object0.W1.4, object0.W2.4) + + set.seed(1) + invisible(capture.output({ + resultKang <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "Kang", display = FALSE)) + resultBuckland <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "Buckland", display = FALSE)) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE)) + resultCurve <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "curve", R = 50, progressInfo = FALSE, display = FALSE)) + resultBootBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "bootstrap", R = 50, bootInterval = "BCa", progressInfo = FALSE, display = FALSE)) + resultCurveBCa <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "excess", backgType = "modelBased", type = "curve", R = 50, bootInterval = "BCa", progressInfo = FALSE, display = FALSE)) + })) + + # Expected results based on manual calculation (checked in v2.6.7) + # resultKang + expect_true(all(!is.na(resultKang$Results[, "BMD_MA"]))) + expect_equal(unname(resultKang$Results[, "BMD_MA"]), c(11.7349943036545, 23.7533160131826)) + expect_equal(resultKang$Boot.samples.used, NA) + expect_equal(unname(resultKang$interval[,"BMDL_MA"]), c(0.0079507187171709,13.7125460518548)) + expect_equal(unname(resultKang$interval[,"BMDU_MA"]), c(23.4620378885919,33.7940859745104)) + # resultBuckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(unname(resultBuckland$Results[, "BMD_MA"]), c(11.7349943036545, 23.7533160131826)) + expect_equal(resultBuckland$Boot.samples.used, NA) + expect_equal(unname(resultBuckland$interval[,"BMDL_MA"]), c(-0.114127421954805,13.4685618858526)) + expect_equal(unname(resultBuckland$interval[,"BMDU_MA"]), c(23.5841160292639,34.0380701405126)) + # resultBoot + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(unname(resultBoot$Results[, "BMD_MA"]), c(11.7349943036545, 23.7533160131826)) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(unname(resultBoot$interval[,"BMDL_MA"]), c(0.176508789719701,7.73106039713397)) + expect_equal(unname(resultBoot$interval[,"BMDU_MA"]), c(24.7982532099151,32.7273607506471)) + # resultCurve + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(unname(resultBoot$Results[, "BMD_MA"]), c(11.7349943036545, 23.7533160131826)) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(unname(resultBoot$interval[,"BMDL_MA"]), c(0.176508789719701,7.73106039713397)) + expect_equal(unname(resultBoot$interval[,"BMDU_MA"]), c(24.7982532099151,32.7273607506471)) + # resultBootBCa + expect_true(all(!is.na(resultBootBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultBootBCa$Results[, "BMD_MA"]), c(11.7349943036545, 23.7533160131826)) + expect_equal(resultBootBCa$Boot.samples.used, 49) + expect_equal(unname(resultBootBCa$Results[,"BMDL_MA"]), c(0.422313711087127,2.45309962249564)) + expect_equal(unname(resultBootBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) + # ResultCurveBCa + expect_true(all(!is.na(resultCurveBCa$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurveBCa$Results[, "BMD_MA"]), c(11.9000482326248, 24.0167032503988)) + expect_equal(resultCurveBCa$Boot.samples.used, 49) + expect_equal(unname(resultCurveBCa$Results[,"BMDL_MA"]), c(1.01766053328384,11.5161237490573)) + expect_equal(unname(resultCurveBCa$interval[,"BMDU_MA"]), c("Not available for BCa bootstrap","Not available for BCa bootstrap")) +}) + +test_that("bmdMA function computes BMD (additional) correctly for Decreasing binomial model with multiple curves", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0.LL.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LL.4(), type = "binomial") + object0.LN.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LN.4(), type = "binomial") + object0.W1.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W1.4(), type = "binomial") + object0.W2.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object0.LL.4, object0.LN.4, object0.W1.4, object0.W2.4) + + set.seed(1) + invisible(capture.output({ + resultKang <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "additional", backgType = "modelBased", type = "Kang", display = FALSE)) + resultBuckland <- suppressWarnings(bmdMA(modelList0, modelWeights = "AIC", bmr = 0.1, def = "additional", backgType = "modelBased", type = "Buckland", display = FALSE)) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "additional", backgType = "modelBased", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE)) + resultCurve <- suppressWarnings(bmdMA(modelList0, modelWeights = "BIC", bmr = 0.1, def = "additional", backgType = "modelBased", type = "curve", R = 50, progressInfo = FALSE, display = FALSE)) + })) + + # Expected results based on manual calculation (checked in v2.6.7) + # resultKang + expect_true(all(!is.na(resultKang$Results[, "BMD_MA"]))) + expect_equal(unname(resultKang$Results[, "BMD_MA"]), c(12.0475135843298, 24.2168984689448)) + expect_equal(resultKang$Boot.samples.used, NA) + expect_equal(unname(resultKang$interval[,"BMDL_MA"]), c(0.273646037712913,14.129549861443)) + expect_equal(unname(resultKang$interval[,"BMDU_MA"]), c(23.8213811309467,34.3042470764466)) + # resultBuckland + expect_true(all(!is.na(resultBuckland$Results[, "BMD_MA"]))) + expect_equal(unname(resultBuckland$Results[, "BMD_MA"]), c(12.0475135843298, 24.2168984689448)) + expect_equal(resultBuckland$Boot.samples.used, NA) + expect_equal(unname(resultBuckland$interval[,"BMDL_MA"]), c(0.164984994060264,13.9222959869599)) + expect_equal(unname(resultBuckland$interval[,"BMDU_MA"]), c(23.9300421745994,34.5115009509297)) + # resultBoot + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(unname(resultBoot$Results[, "BMD_MA"]), c(12.0475135843298, 24.2168984689448)) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(unname(resultBoot$interval[,"BMDL_MA"]), c(0.160028906689239,7.38437587559939)) + expect_equal(unname(resultBoot$interval[,"BMDU_MA"]), c(25.2916075533545,33.2573011197188)) + # resultCurve + expect_true(all(!is.na(resultCurve$Results[, "BMD_MA"]))) + expect_equal(unname(resultCurve$Results[, "BMD_MA"]), c(12.2047330511244, 24.4616008187769)) + expect_equal(resultCurve$Boot.samples.used, 48) + expect_equal(unname(resultCurve$interval[,"BMDL_MA"]), c(0.641340012245435,18.4858704146623)) + expect_equal(unname(resultCurve$interval[,"BMDU_MA"]), c(19.5768964306862,34.7795760773764)) +}) + + +test_that("bmdMA function computes BMD (point with stacking weights) correctly for decreasing binomial model with multiple curves", { + data0 <- data.frame( + conc = c(0, rep(c(20, 40, 80, 160, 320), 2)), + total = c(50, rep(20, 5*2)), + alive = c(47, 14, 11, 6, 9, 6, 19, 11, 8, 5, 3), + treat = c("Control", rep(c("Treat1", "Treat2"), each = 5)) + ) + + object0.LL.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LL.4(), type = "binomial") + object0.LN.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = LN.4(), type = "binomial") + object0.W1.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W1.4(), type = "binomial") + object0.W2.4 <- drm(alive/total ~ conc, weights = total, curveid = treat, + pmodels = list(~ treat - 1, ~ treat - 1, + ~ 1, ~ treat -1), + data = data0, fct = W2.4(), type = "binomial") + modelList0 <- list(object0.LL.4, object0.LN.4, object0.W1.4, object0.W2.4) + + set.seed(1) + invisible(capture.output({ + resultKang <- suppressWarnings(bmdMA(modelList0, modelWeights = "Stacking", bmr = 0.77, def = "point", backgType = "modelBased", type = "Kang", stackingSeed = 1, stackingSplits = 3, display = FALSE)) + resultBoot <- suppressWarnings(bmdMA(modelList0, modelWeights = "Stacking", bmr = 0.77, def = "point", backgType = "modelBased", type = "bootstrap", R = 50, stackingSeed = 1, stackingSplits = 3, display = FALSE)) + })) + + # Expected results based on manual calculation (checked in v2.6.7) + # resultKang + expect_true(all(!is.na(resultKang$Results[, "BMD_MA"]))) + expect_equal(unname(resultKang$Results[, "BMD_MA"]), c(16.6498456454902, 30.3165644996408)) + expect_equal(resultKang$Boot.samples.used, NA) + expect_equal(unname(resultKang$interval[,"BMDL_MA"]), c(6.06814221070238,21.8988805204411)) + expect_equal(unname(resultKang$interval[,"BMDU_MA"]), c(27.231549080278,38.7342484788404)) + # resultBoot + expect_true(all(!is.na(resultBoot$Results[, "BMD_MA"]))) + expect_equal(unname(resultBoot$Results[, "BMD_MA"]), c(16.6498456454902, 30.3165644996408)) + expect_equal(resultBoot$Boot.samples.used, 50) + expect_equal(unname(resultBoot$interval[,"BMDL_MA"]), c(2.12333205792999,25.08635184492)) + expect_equal(unname(resultBoot$interval[,"BMDU_MA"]), c(27.8840479507664,38.6902619548875)) +}) diff --git a/tests/testthat/test-bmdOrdinal.R b/tests/testthat/test-bmdOrdinal.R new file mode 100644 index 0000000..fc39f47 --- /dev/null +++ b/tests/testthat/test-bmdOrdinal.R @@ -0,0 +1,83 @@ +# Tests for drmOrdinal function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - guthionS model +# - correct bmd estimate (all definitions) +# - delta and bootstrap intervals + + + + +# Arguments and structure ------------------------------------------------- + +## TO BE ADDED + + + + +# guthionS model ---------------------------------------------------------- + +test_that("bmdOrdinal computes correct bmd estimates (def = point) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + result <- bmdOrdinal(guthionS.LL, bmr = 0.2, backgType = "modelBased", def = "point", display = FALSE) + + # checks + expect_true(all(!is.na(result$Results[,1]))) + expect_equal(result$Results[,1], c("moribund+dead" = 24.6851764586311, "dead" = 25.5366473289933)) + expect_equal(result$Results[,2], c("moribund+dead" = 21.6860301841392, "dead" = 22.153171404582)) + expect_equal(result$interval[,2], c("moribund+dead" = 27.684322733123, "dead" = 28.9201232534045)) +}) + +test_that("bmdOrdinal computes correct bmd estimates (def = excess) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + result <- bmdOrdinal(guthionS.LL, bmr = 0.1, backgType = "modelBased", def = "excess", display = FALSE) + + # checks + expect_true(all(!is.na(result$Results[,1]))) + expect_equal(result$Results[,1], c("moribund+dead" = 20.501035524755, "dead" = 20.5924938340352)) + expect_equal(result$Results[,2], c("moribund+dead" = 17.1148425800741, "dead" = 16.6957341161554)) + expect_equal(result$interval[,2], c("moribund+dead" = 23.887228469436, "dead" = 24.4892535519151)) +}) + +test_that("bmdOrdinal computes correct bmd estimates (def = additional) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + result <- bmdOrdinal(guthionS.LL, bmr = 0.1, backgType = "modelBased", def = "additional", display = FALSE) + + # checks + expect_true(all(!is.na(result$Results[,1]))) + expect_equal(result$Results[,1], c("moribund+dead" = 20.501035524755, "dead" = 20.5924938340352)) + expect_equal(result$Results[,2], c("moribund+dead" = 17.1148425800741, "dead" = 16.6957341161554)) + expect_equal(result$interval[,2], c("moribund+dead" = 23.887228469436, "dead" = 24.4892535519151)) +}) + +test_that("bmdOrdinal computes correct confidence intervals for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + result.delta <- bmdOrdinal(guthionS.LL, bmr = 0.1, backgType = "modelBased", def = "excess", display = FALSE) + result.sandwich <- bmdOrdinal(guthionS.LL, bmr = 0.1, backgType = "modelBased", def = "excess", interval = "sandwich", display = FALSE) + set.seed(1) + result.boot <- bmdOrdinal(guthionS.LL, bmr = 0.1, backgType = "modelBased", def = "excess", interval = "bootstrap", R = 50, display = FALSE, progressInfo = FALSE) + + # checks + expect_true(all(!is.na(result.delta$Results[,1]))) + expect_equal(result.delta$Results[,1], c("moribund+dead" = 20.501035524755, "dead" = 20.5924938340352)) + expect_equal(result.sandwich$Results[,1], c("moribund+dead" = 20.501035524755, "dead" = 20.5924938340352)) + expect_equal(result.boot$Results[,1], c("moribund+dead" = 20.501035524755, "dead" = 20.5924938340352)) + + expect_equal(result.delta$interval[,1], c("moribund+dead" = 17.1148425800741, "dead" = 16.6957341161554)) + expect_equal(result.delta$interval[,2], c("moribund+dead" = 23.887228469436, "dead" = 24.4892535519151)) + + expect_equal(result.sandwich$interval[,1], c("moribund+dead" = 17.712364940837, "dead" = 19.5497322478028)) + expect_equal(result.sandwich$interval[,2], c("moribund+dead" = 23.289706108673, "dead" = 21.6352554202677)) + + expect_equal(result.boot$interval[,1], c("moribund+dead" = 17.7581615954546, "dead" = 16.8551004638107)) + expect_equal(result.boot$interval[,2], c("moribund+dead" = 24.1801039423246, "dead" = 24.3514247473655)) +}) diff --git a/tests/testthat/test-bmdOrdinalMA.R b/tests/testthat/test-bmdOrdinalMA.R new file mode 100644 index 0000000..140d744 --- /dev/null +++ b/tests/testthat/test-bmdOrdinalMA.R @@ -0,0 +1,107 @@ +# Tests for bmdOrdinalMA function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - guthionS model +# - correct bmd estimate (all definitions) +# - delta and bootstrap intervals + + + + +# Arguments and structure ------------------------------------------------- + +## TO BE ADDED + + + + +# guthionS model ---------------------------------------------------------- + +test_that("bmdOrdinalMA computes correct bmd estimates (def = point) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + guthionS.W1 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W1.2()) + guthionS.W2 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W2.2()) + modelList0 <- list(guthionS.LL, guthionS.W1, guthionS.W2) + manWeights0 <- c(0.3, 0.6, 0.1) + resultKangAIC <- bmdOrdinalMA(modelList0, modelWeights = "AIC", bmr = 0.2, backgType = "modelBased", def = "point", type = "Kang", display = FALSE) + resultKangBIC <- bmdOrdinalMA(modelList0, modelWeights = "BIC", bmr = 0.2, backgType = "modelBased", def = "point", type = "Kang", display = FALSE) + resultKangManWeights <- bmdOrdinalMA(modelList0, modelWeights = manWeights0, bmr = 0.2, backgType = "modelBased", def = "point", type = "Kang", display = FALSE) + set.seed(1) + resultBootAIC <- bmdOrdinalMA(modelList0, modelWeights = "AIC", bmr = 0.2, backgType = "modelBased", def = "point", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE) + resultBootBIC <- bmdOrdinalMA(modelList0, modelWeights = "BIC", bmr = 0.2, backgType = "modelBased", def = "point", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE) + resultBootManWeights <- bmdOrdinalMA(modelList0, modelWeights = manWeights0, bmr = 0.2, backgType = "modelBased", def = "point", type = "bootstrap", R = 50, progressInfo = FALSE, display = FALSE) + + # checks + # resultKangAIC + expect_true(all(!is.na(resultKangAIC$Results[,1]))) + expect_equal(resultKangAIC$Results[,1], c("moribund+dead" = 23.2544468633164, "dead" = 24.3204043959293)) + expect_equal(resultKangAIC$Results[,2], c("moribund+dead" = 20.9889153780884, "dead" = 21.6671551612867)) + expect_equal(resultKangAIC$interval[,2], c("moribund+dead" = 25.5199783485443, "dead" = 26.9736536305719)) + expect_true(is.na(resultKangAIC$Boot.samples.used)) + # resultKangBIC + expect_true(all(!is.na(resultKangBIC$Results[,1]))) + expect_equal(resultKangBIC$Results[,1], c("moribund+dead" = 23.2544468633164, "dead" = 24.3204043959293)) + expect_equal(resultKangBIC$Results[,2], c("moribund+dead" = 20.9889153780884, "dead" = 21.6671551612867)) + expect_equal(resultKangBIC$interval[,2], c("moribund+dead" = 25.5199783485443, "dead" = 26.9736536305719)) + expect_true(is.na(resultKangBIC$Boot.samples.used)) + # resultKangManWeights + expect_true(all(!is.na(resultKangManWeights$Results[,1]))) + expect_equal(resultKangManWeights$Results[,1], c("moribund+dead" = 23.7749220575841, "dead" = 24.7506554039273)) + expect_equal(resultKangManWeights$Results[,2], c("moribund+dead" = 21.2467089545517, "dead" = 21.830241980314)) + expect_equal(resultKangManWeights$interval[,2], c("moribund+dead" = 26.3031351606164, "dead" = 27.6710688275405)) + expect_true(is.na(resultKangManWeights$Boot.samples.used)) + # resultBootAIC + expect_equal(resultBootAIC$Results[,1], c("moribund+dead" = 23.2544468633164, "dead" = 24.3204043959293)) + expect_equal(resultBootAIC$Results[,2], c("moribund+dead" = 22.25059194107, "dead" = 22.8512766871584)) + expect_equal(resultBootAIC$interval[,2], c("moribund+dead" = 28.6789792473312, "dead" = 29.1978148632589)) + expect_equal(resultBootAIC$Boot.samples.used, 50) + # resultBootBIC + expect_equal(resultBootBIC$Results[,1], c("moribund+dead" = 23.2544468633164, "dead" = 24.3204043959293)) + expect_equal(resultBootBIC$Results[,2], c("moribund+dead" = 21.3030492748921, "dead" = 22.8711536934761)) + expect_equal(resultBootBIC$interval[,2], c("moribund+dead" = 28.2940621821775, "dead" = 29.467583602007)) + expect_equal(resultBootBIC$Boot.samples.used, 50) + # resultBootManWeights + expect_equal(resultBootManWeights$Results[,1], c("moribund+dead" = 23.7749220575841, "dead" = 24.7506554039273)) + expect_equal(resultBootManWeights$Results[,2], c("moribund+dead" = 21.9772468661395, "dead" = 21.8972828765798)) + expect_equal(resultBootManWeights$interval[,2], c("moribund+dead" = 26.1263977743362, "dead" = 27.4023387249217)) + expect_equal(resultBootManWeights$Boot.samples.used, 50) +}) + +test_that("bmdOrdinal computes correct bmd estimates (def = excess) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + guthionS.W1 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W1.2()) + guthionS.W2 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W2.2()) + modelList0 <- list(guthionS.LL, guthionS.W1, guthionS.W2) + + result <- bmdOrdinalMA(modelList0, modelWeights = "AIC", bmr = 0.1, backgType = "modelBased", def = "excess", type = "Kang", display = FALSE) + + # checks + expect_true(all(!is.na(result$Results[,1]))) + expect_equal(result$Results[,1], c("moribund+dead" = 20.0639900692681, "dead" = 20.4469882115098)) + expect_equal(result$Results[,2], c("moribund+dead" = 17.6456398082174, "dead" = 17.5754769224672)) + expect_equal(result$interval[,2], c("moribund+dead" = 22.4823403303188, "dead" = 23.3184995005524)) +}) + +test_that("bmdOrdinal computes correct bmd estimates (def = additional) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + guthionS.W1 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W1.2()) + guthionS.W2 <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = W2.2()) + modelList0 <- list(guthionS.LL, guthionS.W1, guthionS.W2) + + result <- bmdOrdinalMA(modelList0, modelWeights = "AIC", bmr = 0.1, backgType = "modelBased", def = "additional", type = "Kang", display = FALSE) + + # checks + expect_true(all(!is.na(result$Results[,1]))) + expect_equal(result$Results[,1], c("moribund+dead" = 20.0639900692681, "dead" = 20.4469882115098)) + expect_equal(result$Results[,2], c("moribund+dead" = 17.6456398082174, "dead" = 17.5754769224672)) + expect_equal(result$interval[,2], c("moribund+dead" = 22.4823403303188, "dead" = 23.3184995005524)) +}) + + diff --git a/tests/testthat/test-drmHetVar.R b/tests/testthat/test-drmHetVar.R new file mode 100644 index 0000000..65f6467 --- /dev/null +++ b/tests/testthat/test-drmHetVar.R @@ -0,0 +1,84 @@ +# Tests for drmHetVar function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - Ryegrass model +# - correct values of sigmaFun +# - correct formula +# - correct coefficients of sigmaMod +# - GiantKelp model +# - correct values of sigmaFun +# - correct formula +# - correct coefficients of sigmaMod + + + + +# Arguments and structure ------------------------------------------------- + +test_that("drmHetVar handles missing required arguments", { + lm_object <- lm(y ~ x, + data = data.frame(x = 0:4, + y = 1:5 + c(-0.4, 0, 0.2, -0.1, 0.13))) + drm_ryegrass <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + drm_S.alba <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + + expect_error(drmHetVar(lm_object), 'object must be a dose-response model of class "drc"') + expect_error(drmHetVar(drm_S.alba), 'dose-response models with multiple curves not supported for heteroscedasticity analysis') + expect_error(drmHetVar(drm_ryegrass), 'argument "var.formula" is missing, with no default') + expect_error(drmHetVar(drm_ryegrass, "~ fitted"), 'argument "formula" must be of class "formula"') +}) + + + + + +# Ryegrass model ---------------------------------------------------------- + +test_that("drmHetVar on Ryegrass model", { + ryegrass.W2.4 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = W2.4()) + var.formula0 <- ~ fitted + I(fitted^2) + ryegrass.W2.4.hetVar <- drmHetVar(ryegrass.W2.4, var.formula0) + + expect_equal(unname(ryegrass.W2.4.hetVar$sigmaFun(0:30)), + c(0.40511221475221, 0.40968626192675, 0.706103004999106, 0.792892779243004, 0.670380066035056, + 0.538422954006715, 0.436184506516667, 0.361508041361228, 0.307007516705357, 0.266619836548278, + 0.236108689714632, 0.212610588112651, 0.194185769216453, 0.179501681344542, 0.167626441952835, + 0.157896177513736, 0.14982937328875, 0.143070832121776, 0.137354400911807, 0.132477749754008, + 0.128285014290574, 0.124654653614345, 0.121490824831162, 0.118717166664911, 0.116272258432784, + 0.11410626087336, 0.112178401926649, 0.110455074239762, 0.108908380793708, 0.107515012445684, + 0.106255373873181), tolerance = 1e-8) + expect_equal(ryegrass.W2.4.hetVar$var.formula, var.formula0) + expect_equal(ryegrass.W2.4.hetVar$sigmaMod$coefficients, + c('(Intercept)' = -0.0262169518584718, + 'fitted' = 0.364206633951366, + 'I(fitted^2)' = -0.0399131012240055)) +}) + + + +# GiantKelp model --------------------------------------------------------- + +test_that("drmHetVar on GiantKelp model", { + GiantKelp.LL.4 <- drm(tubeLength ~ dose, data = drcData::GiantKelp, fct = LL.4()) + var.formula0 <- ~ log(dose+1) + I(log(dose+1)^2) + GiantKelp.LL.4.hetVar <- drmHetVar(GiantKelp.LL.4, var.formula0) + + expect_equal(unname(GiantKelp.LL.4.hetVar$sigmaFun(0:30)), + c(1.04778617981885, 1.52105761523325, 1.71774043309804, 1.82140390270584, + 1.88129829696735, 1.91693199359302, 1.93772576623764, 1.94882504223662, + 1.9532883624276, 1.95304997306311, 1.9493924059426, 1.94319840614618, + 1.93509414356216, 1.92553493643006, 1.91485878842791, 1.90332103382559, + 1.89111744462622, 1.87840004800314, 1.8652882012118, 1.85187650121705, + 1.83824053362485, 1.82444111690957, 1.8105274798966, 1.79653967075753, + 1.78251040430148, 1.76846649326726, 1.75442996780752, 1.74041895868067, + 1.72644839956268, 1.71253058960424, 1.69867564707763), tolerance = 1e-8) + expect_equal(GiantKelp.LL.4.hetVar$var.formula, var.formula0) + expect_equal(GiantKelp.LL.4.hetVar$sigmaMod$coefficients, + c('(Intercept)' = 1.04778617981885, + 'log(dose + 1)' = 0.807525479557079, + 'I(log(dose + 1)^2)' = -0.179960519480946)) +}) + + + diff --git a/tests/testthat/test-drmOrdinal.R b/tests/testthat/test-drmOrdinal.R new file mode 100644 index 0000000..009f24e --- /dev/null +++ b/tests/testthat/test-drmOrdinal.R @@ -0,0 +1,48 @@ +# Tests for bmdOrdinal function +# - Arguments and structure +# - Missing arguments +# - Correct backgType and def accepted +# - guthionS model +# - correct bmd estimate (all definitions) +# - delta and bootstrap intervals + + + + +# Arguments and structure ------------------------------------------------- + +test_that("bmdOrdinal handles missing required arguments",{ + guthionS <- subset(drcData::guthion, trt == "S") + + expect_error(drmOrdinal(weights = "total", dose = "dose", data = guthionS, fct = LL.2()), 'argument "levels" is missing, with no default') + expect_error(drmOrdinal(levels = c("alive", "moribund", "dead"), dose = "dose", data = guthionS, fct = LL.2()), 'argument "weights" is missing, with no default') + expect_error(drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose",fct = LL.2()), 'argument "data" is missing, with no default') + expect_error(drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS), 'argument "fct" is missing, with no default') +}) + + + + +# guthionS model ---------------------------------------------------------- + +test_that("bmdOrdinal computes correct bmd estimates (def = point) for gutionS model", { + guthionS <- subset(drcData::guthion, trt == "S") + + guthionS.LL <- drmOrdinal(levels = c("alive", "moribund", "dead"), weights = "total", dose = "dose", data = guthionS, fct = LL.2()) + + # checks + expect_equal(guthionS.LL$levels, c("alive", "moribund", "dead")) + expect_equal(guthionS.LL$levelsMerged, list("moribund+dead", "dead")) + expect_equal(guthionS.LL$dose, "dose") + expect_equal(guthionS.LL$weights, "total") + expect_null(guthionS.LL$blocks) + + expect_equal(guthionS.LL$pFun(0), c("alive" = 1, "moribund" = 0, "dead" = 0)) + expect_equal(guthionS.LL$pFun(10), c("alive" = 0.995187445898751, "moribund" = 0, "dead" = 0.00725091623314945)) + expect_equal(guthionS.LL$pFun(20), c("alive" = 0.909311643501763, "moribund" = 0.000163464702208557, "dead" = 0.0905248917960284)) + expect_equal(guthionS.LL$pFun(30), c("alive" = 0.630625814086567, "moribund" = 0.0548943439739693, "dead" = 0.314479841939464)) + expect_equal(guthionS.LL$pFun(40), c("alive" = 0.327132011789939, "moribund" = 0.0972367191475815, "dead" = 0.57563126906248)) + expect_equal(guthionS.LL$pFun(45), c("alive" = 0.225228290238974, "moribund" = 0.0958704725326432, "dead" = 0.678901237228382)) + + expect_equal(AIC(guthionS.LL), 222.869282843461) +}) diff --git a/tests/testthat/test-monotonicityTest.R b/tests/testthat/test-monotonicityTest.R new file mode 100644 index 0000000..563124a --- /dev/null +++ b/tests/testthat/test-monotonicityTest.R @@ -0,0 +1,109 @@ +# Tests for monotonicityTest function +# - Arguments and structure +# - Missing arguments +# - Simple data +# - correct monotonicity test results for all types +# - Ryegrass data +# - correct monotonicity test results for all types + + + + +# Arguments and structure ------------------------------------------------- + +test_that("monotonicityTest function handles missing required arguments", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + + expect_error(monotonicityTest(x = "x", data = data), 'argument "y" is missing, with no default') + expect_error(monotonicityTest(y = "y", data = data), 'argument "x" is missing, with no default') + expect_error(monotonicityTest(x = "x", y = "y", data = data, test = "unknown_test"), "'arg' should be one of \"jonckheere\", \"bartholomew\"") +}) + + + +# Simple data ------------------------------------------------------------- + +test_that("monotonicityTest (test = 'bartholomew') on simple data set with trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + result <- monotonicityTest("x", "y", data = data, test = "bartholomew") + + expect_equal(result$p.value, 0) + expect_true(result$acceptMonotonicity) +}) + +test_that("monotonicityTest (test = 'jonckheere') on simple data set with trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + result <- monotonicityTest("x", "y", data = data, test = "jonckheere") + + expect_equal(result$p.value, 6.21236026663824e-07) + expect_true(result$acceptMonotonicity) +}) + +test_that("monotonicityTest (test = 'bartholomew') on simple data set with mixed trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(5, 5, 7, 5, 4), 4) + rnorm(20, sd = 1.1)) + result <- monotonicityTest("x", "y", data = data, test = "bartholomew") + + expect_equal(result$p.value, 0.089) + expect_true(!result$acceptMonotonicity) +}) + +test_that("monotonicityTest (test = 'jonckheere') on simple data set with mixed trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(5, 5, 7, 5, 4), 4) + rnorm(20, sd = 0.5)) + result <- monotonicityTest("x", "y", data = data, test = "jonckheere") + + expect_equal(result$p.value, 0.232501894630627) + expect_true(!result$acceptMonotonicity) +}) + + +test_that("monotonicityTest (test = 'bartholomew') on simple data set without trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(5, 20) + rnorm(20, sd = 0.5)) + result <- monotonicityTest("x", "y", data = data, test = "bartholomew") + + expect_equal(result$p.value, 0.565) + expect_true(!result$acceptMonotonicity) +}) + +test_that("monotonicityTest (test = 'jonckheere') on simple data set without trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(5, 20) + rnorm(20, sd = 0.5)) + result <- monotonicityTest("x", "y", data = data, test = "jonckheere") + + expect_equal(result$p.value, 0.129415387402834) + expect_true(!result$acceptMonotonicity) +}) + + + + + +# Ryegrass ---------------------------------------------------------------- + +test_that("monotonicityTest (test = 'bartholomew') on Ryegrass data set", { + result <- monotonicityTest("conc", "rootl", data = drcData::ryegrass, test = "bartholomew") + + expect_equal(result$p.value, 0) + expect_true(result$acceptMonotonicity) +}) + + +test_that("monotonicityTest (test = 'jonckheere') on Ryegrass data set", { + result <- monotonicityTest("conc", "rootl", data = drcData::ryegrass, test = "jonckheere") + + expect_equal(result$p.value, 7.16211783824569e-09) + expect_true(result$acceptMonotonicity) +}) + diff --git a/tests/testthat/test-qplotBmd.R b/tests/testthat/test-qplotBmd.R new file mode 100644 index 0000000..82f5f64 --- /dev/null +++ b/tests/testthat/test-qplotBmd.R @@ -0,0 +1,64 @@ +# Tests for qplotBmd function +# TCDD model +# S.alba model + + +# Arguments and structure ------------------------------------------------- + +test_that("qplotBmd handles wrong objects and arguments", { + object0 <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LL.4()) + object0.LN <- drm(rootl ~ conc, data = drcData::ryegrass, fct = LN.4()) + resultMA <- bmdMA(list(object0, object0.LN), modelWeights = "AIC", bmr = 3.2, def = "point", backgType = "modelBased", type = "Kang", display = FALSE) + + expect_error(qplotBmd(object0), 'qplotBmd only works for plotting objects of type "bmd"') + expect_error(qplotBmd(resultMA), 'qplotBmd does not for for model-averaged BMD') +}) + + +# TCDD model -------------------------------------------------------------- +test_that("qplotBmd returns a ggplot object", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + bmd.TCDD <- bmd(object.TCDD, bmr = 0.05, def = "excess", backgType = "modelBased", display = FALSE) + + p <- qplotBmd(bmd.TCDD) + expect_s3_class(p, "ggplot") +}) + + +test_that("qplotBmd: add argument works", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + bmd.TCDD <- bmd(object.TCDD, bmr = 0.05, def = "excess", backgType = "modelBased", sandwich.vcov = TRUE, display = FALSE) + + p <- qplotDrc(object.TCDD) + + qplotDrc(object.TCDD, type = "confidence", add = TRUE)$confBandLayer + + qplotBmd(bmd.TCDD, add = TRUE) + expect_s3_class(p, "ggplot") +}) + + + + +# S.alba model ------------------------------------------------------------ + +test_that("qplotBmd handles different plot types", { + object.S.alba <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + bmd.S.alba <- bmd(object.S.alba, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + + types <- c("average", "all", "bars", "none", "obs", "confidence") + for (t in types) { + p <- qplotDrc(object.S.alba, type = t) + qplotBmd(bmd.S.alba, add = TRUE) + expect_s3_class(p, "ggplot") + } +}) + + +test_that("qplotBmd handles colours", { + object.S.alba <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + bmd.S.alba <- bmd(object.S.alba, bmr = 0.1, def = "hybridExc", backgType = "hybridSD", backg = 2, display = FALSE) + + p <- qplotBmd(bmd.S.alba, col = TRUE) + expect_s3_class(p, "ggplot") +}) + + + diff --git a/tests/testthat/test-qplotDrc.R b/tests/testthat/test-qplotDrc.R new file mode 100644 index 0000000..d368c3a --- /dev/null +++ b/tests/testthat/test-qplotDrc.R @@ -0,0 +1,61 @@ +# Tests for qplotDrc function +# TCDD model +# S.alba model + + +# TCDD model -------------------------------------------------------------- +test_that("qplotDrc returns a ggplot object", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + p <- qplotDrc(object.TCDD) + expect_s3_class(p, "ggplot") +}) + +test_that("qplotDrc handles log transformation", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + p <- qplotDrc(object.TCDD, xtrans = "log") + expect_s3_class(p, "ggplot") +}) + +test_that("qplotDrc handles pseudo_log transformation", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + p <- qplotDrc(object.TCDD, xtrans = "pseudo_log") + expect_s3_class(p, "ggplot") +}) + + + +test_that("qplotDrc fails when level is out of range", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + expect_error(qplotDrc(object.TCDD, level = "invalid_level"), "Nothing to plot") +}) + +test_that("qplotDrc: add argument works", { + object.TCDD <- drm(incidence/total ~ conc, weights = total, fct = LL.4(), data = drcData::TCDD, type = "binomial") + p <- qplotDrc(object.TCDD) + + qplotDrc(object.TCDD, type = "confidence", add = TRUE)$confBandLayer + expect_s3_class(p, "ggplot") +}) + + + + +# S.alba model ------------------------------------------------------------ + +test_that("qplotDrc handles different plot types", { + object.S.alba <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + types <- c("average", "all", "bars", "none", "obs", "confidence") + for (t in types) { + p <- qplotDrc(object.S.alba, type = t) + expect_s3_class(p, "ggplot") + } +}) + + +test_that("qplotDrc handles colours", { + object.S.alba <- drm(DryMatter ~ Dose, curveid = Herbicide, data = drcData::S.alba, fct = LL.4()) + p <- qplotDrc(object.S.alba, col = TRUE) + expect_s3_class(p, "ggplot") +}) + + + diff --git a/tests/testthat/test-trendTest.R b/tests/testthat/test-trendTest.R new file mode 100644 index 0000000..cc2ab3e --- /dev/null +++ b/tests/testthat/test-trendTest.R @@ -0,0 +1,162 @@ +# Tests for trendTest function +# - Arguments and structure +# - Missing arguments +# - Simple data +# - correct trend test results for all types +# - Ryegrass data +# - correct trend test results for all types + + + + +# Arguments and structure ------------------------------------------------- + +test_that("trendTest function handles missing required arguments", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + + expect_error(trendTest(x = "x", data = data), 'argument "y" is missing, with no default') + expect_error(trendTest(y = "y", data = data), 'argument "x" is missing, with no default') + expect_error(trendTest(x = "x", y = "y", data = data, test = "unknown_test"), "'arg' should be one of \"william\", \"shirley\", \"tukey\"") +}) + + + +# Simple data ------------------------------------------------------------- + +test_that("trendTest (test = 'william') on simple data set with trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "william") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(rep("accept", 4), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'william') on simple data set without trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(5, 5, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "william") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(rep("reject", 4), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(!result$acceptTrend) +}) + +test_that("trendTest (test = 'william') on simple data set with mixed trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 12, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "william") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(c("reject", "accept", "accept", "accept"), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'shirley') on simple data set with trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "shirley") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(c("reject", "accept", "accept", "accept"), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'shirley') on simple data set without trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(5, 5, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "shirley") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(rep("reject", 4), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(!result$acceptTrend) +}) + +test_that("trendTest (test = 'shirley') on simple data set with mixed trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 12, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "shirley") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(c("reject", "accept", "accept", "accept"), nrow = 4, dimnames = list(c("mu1", "mu2", "mu3", "mu4"), "ctr"))) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'tukey') on simple data set with trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 10, 5, 4, 4), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "tukey") + + expect_equal(result$p.values, c("xari: xari" = 0, "xord: xord" = 0, "xarilog: xarilog" = 0)) + expect_equal(result$decisions, c("xari: xari" = "accept", "xord: xord" = "accept", "xarilog: xarilog" = "accept")) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'tukey') on simple data set without trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(5, 5, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "tukey") + + expect_equal(result$p.values, c("xari: xari" = 0.634501907632532, "xord: xord" = 0.634521888020178, "xarilog: xarilog" = 0.656543069891262)) + expect_equal(result$decisions, c("xari: xari" = "reject", "xord: xord" = "reject", "xarilog: xarilog" = "reject")) + expect_true(!result$acceptTrend) +}) + +test_that("trendTest (test = 'tukey') on simple data set with mixed trend", { + set.seed(1) + data <- data.frame(x = rep(1:5, 4), + y = rep(c(12, 12, 5, 5, 5), 4) + rnorm(20, sd = 0.1)) + result <- trendTest("x", "y", data = data, test = "tukey") + + expect_equal(result$p.values, c("xari: xari" = 3.67372798848464e-13, "xord: xord" = 3.96238597488718e-13, "xarilog: xarilog" = 1.59872115546023e-14)) + expect_equal(result$decisions, c("xari: xari" = "accept", "xord: xord" = "accept", "xarilog: xarilog" = "accept")) + expect_true(result$acceptTrend) +}) + + + + + + + +# Ryegrass ---------------------------------------------------------------- + +test_that("trendTest (test = 'william') on Ryegrass data set", { + result <- trendTest("conc", "rootl", data = drcData::ryegrass, test = "william") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(c("reject", "accept", "accept", "accept", "accept", "accept"), + nrow = 6, dimnames = list(c("mu1", "mu2", "mu3", "mu4", "mu5", "mu6"), "ctr"))) + expect_true(result$acceptTrend) +}) + + +test_that("trendTest (test = 'shirley') on Ryegrass data set", { + result <- trendTest("conc", "rootl", data = drcData::ryegrass, test = "shirley") + + expect_null(result$p.values) + expect_equal(result$decisions, matrix(c("reject", "accept", "accept", "accept", "accept", "accept"), + nrow = 6, dimnames = list(c("mu1", "mu2", "mu3", "mu4", "mu5", "mu6"), "ctr"))) + expect_true(result$acceptTrend) +}) + +test_that("trendTest (test = 'tukey') on Ryegrass data set", { + result <- trendTest("conc", "rootl", data = drcData::ryegrass, test = "tukey") + + expect_equal(result$p.values, c("xari: xari" = 2.36404196218842e-09, "xord: xord" = 0, "xarilog: xarilog" = 0)) + expect_equal(result$decisions, c("xari: xari" = "accept", "xord: xord" = "accept", "xarilog: xarilog" = "accept")) + expect_true(result$acceptTrend) +}) + +