diff --git a/DESCRIPTION b/DESCRIPTION index d4ead43..4e4d6be 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,8 +8,8 @@ Description: Tool-set to support Bayesian evidence synthesis. This for details on applying this package while Neuenschwander et al. (2010) and Schmidli et al. (2014) explain details on the methodology. -Version: 1.7-4 -Date: 2024-11-21 +Version: 1.8-0 +Date: 2025-01-08 Authors@R: c(person("Novartis", "Pharma AG", role = "cph") ,person("Sebastian", "Weber", email="sebastian.weber@novartis.com", role=c("aut", "cre")) ,person("Beat", "Neuenschwander", email="beat.neuenschwander@novartis.com", role="ctb") diff --git a/Makefile b/Makefile index ce32c5c..cb0a980 100644 --- a/Makefile +++ b/Makefile @@ -49,12 +49,12 @@ all : $(TARGET) cd $(@D); echo running $(RCMD) -e "rmarkdown::render('$( $@ 2>&1 @printf "Test summary for $( $@ 2>&1 @printf "Test summary for $(= Ninit) - - assert_logical(constrain_gt1, any.missing=FALSE, len=1) - - ## check data for 0 and 1 values which are problematic, but may be - ## valid, depending on a and b. Moving these to eps or 1-eps - ## ensures proper handling during fit. - x0 <- x==0 - if(any(x0)) { - message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") - x[x0] <- .Machine$double.eps +EM_bmm_ab <- function(x, Nc, mix_init, Ninit = 50, verbose = FALSE, Niter.max = 500, tol, Neps, eps = c(w = 0.005, a = 0.005, b = 0.005), constrain_gt1 = TRUE) { + N <- length(x) + assert_that(N + Nc >= Ninit) + + assert_logical(constrain_gt1, any.missing = FALSE, len = 1) + + ## check data for 0 and 1 values which are problematic, but may be + ## valid, depending on a and b. Moving these to eps or 1-eps + ## ensures proper handling during fit. + x0 <- x == 0 + if (any(x0)) { + message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") + x[x0] <- .Machine$double.eps + } + x1 <- x == 1 + if (any(x1)) { + message("Detected ", sum(x1), " value(s) which are exactly 1.\nTo avoid numerical issues during EM such values are moved to one minus smallest eps on machine.") + x[x1] <- 1 - .Machine$double.eps + } + + ## temporaries needed during EM + Lx <- matrix(log(x), ncol = Nc, nrow = N) + LxC <- matrix(log1p(-x), ncol = Nc, nrow = N) + + xRep <- rep(x, each = Nc) + + ## initialize randomly using KNN + if (missing(mix_init)) { + ## abmEst <- matrix(1+rlnorm(Nc*3, 0, log(5)/1.96), nrow=Nc) + ## abmEst[,1] <- 1/Nc + ## assume that the sample is ordered randomly + ind <- seq(1, N - Nc, length = Ninit) + knnInit <- list(mu = matrix(0, nrow = Nc, ncol = 1), p = rep(1 / Nc, times = Nc)) + for (k in seq(Nc)) { + knnInit$mu[k, 1] <- mean(x[ind + k - 1]) } - x1 <- x==1 - if(any(x1)) { - message("Detected ", sum(x1), " value(s) which are exactly 1.\nTo avoid numerical issues during EM such values are moved to one minus smallest eps on machine.") - x[x1] <- 1-.Machine$double.eps + KNN <- suppressWarnings(knn(x, K = Nc, init = knnInit, Niter.max = 50)) + muInit <- rep(mean(x), times = Nc) + varInit <- rep(1.5 * var(x), times = Nc) + for (k in 1:Nc) { + kind <- KNN$cluster == k + if (sum(kind) > 10) { + muInit[k] <- KNN$center[k] + varInit[k] <- var(x[kind]) + } } - - ## temporaries needed during EM - Lx <- matrix(log(x), ncol=Nc, nrow=N) - LxC <- matrix(log1p(-x), ncol=Nc, nrow=N) - - xRep <- rep(x, each=Nc) - - ## initialize randomly using KNN - if(missing(mix_init)) { - ##abmEst <- matrix(1+rlnorm(Nc*3, 0, log(5)/1.96), nrow=Nc) - ##abmEst[,1] <- 1/Nc - ## assume that the sample is ordered randomly - ind <- seq(1,N-Nc,length=Ninit) - knnInit <- list(mu=matrix(0,nrow=Nc,ncol=1), p=rep(1/Nc, times=Nc)) - for(k in seq(Nc)) - knnInit$mu[k,1] <- mean(x[ind+k-1]) - KNN <- suppressWarnings(knn(x, K=Nc, init=knnInit, Niter.max=50)) - muInit <- rep(mean(x), times=Nc) - varInit <- rep(1.5*var(x), times=Nc) - for(k in 1:Nc) { - kind <- KNN$cluster == k - if(sum(kind) > 10) { - muInit[k] <- KNN$center[k] - varInit[k] <- var(x[kind]) - } - } - nInit <- pmax(muInit*(1-muInit)/varInit - 1, 1, na.rm=TRUE) - ## place the component which recieved the least weight at the - ## data center with roughly the variance of the sample - cmin <- which.min(KNN$p) - muInit[cmin] <- sum(KNN$p * KNN$center) - ## muInit[cmin] <- mean(x) ## could be considered here - nInit[cmin] <- pmax(muInit[cmin]*(1-muInit[cmin])/var(x) - 1, 1, na.rm=TRUE) - ##Nmax <- max(2, max(nInit)) - ## ensure n is positive for each cluster; if this is not the - ## case, sample uniformly from the range of n we have - ##Nneg <- nInit <= .Machine$double.eps - ##Nsmall <- nInit <= 0.5 - ##if(any(Nsmall)) - ## nInit[Nsmall] <- runif(sum(Nsmall), 0.5, Nmax) - ##nInitR <- 0.5 + rlnorm(Nc, log(nInit), log(5)/1.96) - mixEst <- rbind(KNN$p, nInit*muInit, nInit*(1-muInit)) - dlink(mixEst) <- identity_dlink - rownames(mixEst) <- c("w", "a", "b") - } else { - mixEst <- mix_init + nInit <- pmax(muInit * (1 - muInit) / varInit - 1, 1, na.rm = TRUE) + ## place the component which recieved the least weight at the + ## data center with roughly the variance of the sample + cmin <- which.min(KNN$p) + muInit[cmin] <- sum(KNN$p * KNN$center) + ## muInit[cmin] <- mean(x) ## could be considered here + nInit[cmin] <- pmax(muInit[cmin] * (1 - muInit[cmin]) / var(x) - 1, 1, na.rm = TRUE) + ## Nmax <- max(2, max(nInit)) + ## ensure n is positive for each cluster; if this is not the + ## case, sample uniformly from the range of n we have + ## Nneg <- nInit <= .Machine$double.eps + ## Nsmall <- nInit <= 0.5 + ## if(any(Nsmall)) + ## nInit[Nsmall] <- runif(sum(Nsmall), 0.5, Nmax) + ## nInitR <- 0.5 + rlnorm(Nc, log(nInit), log(5)/1.96) + mixEst <- rbind(KNN$p, nInit * muInit, nInit * (1 - muInit)) + dlink(mixEst) <- identity_dlink + rownames(mixEst) <- c("w", "a", "b") + } else { + mixEst <- mix_init + } + + ## mixEst parametrization during fitting + mixEstPar <- mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + mixEstPar[2, ] <- log(mixEst[2, ]) + mixEstPar[3, ] <- log(mixEst[3, ]) + rownames(mixEstPar) <- c("w", "la", "lb") + + ## constrain to a>=1 & b>=1 if requested... thus we subtract 1 + if (constrain_gt1) { + mixEstPar[2, ] <- log(pmax(mixEst[2, ] - 1, rep(1E-8, times = Nc))) + mixEstPar[3, ] <- log(pmax(mixEst[3, ] - 1, rep(1E-8, times = Nc))) + + mixEst[2, ] <- 1 + exp(mixEstPar[2, ]) + mixEst[3, ] <- 1 + exp(mixEstPar[3, ]) + } + + if (verbose) { + message("EM for beta mixture model.\n") + message("Initial estimates:\n") + print(mixEst) + } + + ## in case tolerance is not specified, then this criteria is + ## ignored + if (missing(tol)) { + checkTol <- FALSE + tol <- -1 + } else { + checkTol <- TRUE + } + + if (missing(Neps)) { + ## in case tolerance has been declared, but Neps not, we flag + ## to disable checking of running mean convergence check + checkEps <- FALSE + Neps <- 5 + } else { + checkEps <- TRUE + } + + ## if nothing is specified, we declare convergence based on a + ## running mean of differences in parameter estimates + if (!checkTol & !checkEps) { + checkEps <- TRUE + } + + assert_that(Neps > 1) + assert_that(ceiling(Neps) == floor(Neps)) + + ## eps can also be given as a single integer which is interpreted + ## as number of digits + if (length(eps) == 1) eps <- rep(10^(-eps), 3) + + iter <- 0 + logN <- log(N) + traceMix <- list() + traceLli <- c() + Dlli <- Inf + runMixPar <- array(-Inf, dim = c(Neps, 3, Nc), dimnames = list(NULL, rownames(mixEstPar), NULL)) + runOrder <- 0:(Neps - 1) + Npar <- Nc + 2 * Nc + if (Nc == 1) Npar <- Npar - 1 + + ## find alpha and beta for a given component in log-space + bmm_ml <- function(c1, c2) { + function(par) { + ab <- exp(par) + if (constrain_gt1) { + ab <- 1 + ab + } + s <- digamma(sum(ab)) + eq1 <- digamma(ab[1]) - s + eq2 <- digamma(ab[2]) - s + (eq1 - c1)^2 + (eq2 - c2)^2 } - - ## mixEst parametrization during fitting - mixEstPar <- mixEst - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - mixEstPar[2,] <- log(mixEst[2,]) - mixEstPar[3,] <- log(mixEst[3,]) - rownames(mixEstPar) <- c("w", "la", "lb") - - ## constrain to a>=1 & b>=1 if requested... thus we subtract 1 - if(constrain_gt1) { - mixEstPar[2,] <- log(pmax(mixEst[2,] - 1, rep(1E-8, times=Nc))) - mixEstPar[3,] <- log(pmax(mixEst[3,] - 1, rep(1E-8, times=Nc))) - - mixEst[2,] <- 1 + exp(mixEstPar[2,]) - mixEst[3,] <- 1 + exp(mixEstPar[3,]) + } + + bmm_ml_grad <- function(c1, c2) { + function(par) { + ab <- exp(par) + if (constrain_gt1) { + ab <- 1 + ab + } + n <- sum(ab) + s <- digamma(n) + eq1 <- digamma(ab[1]) - s + eq2 <- digamma(ab[2]) - s + sqTerm1 <- (eq1 - c1) + sqTerm2 <- (eq2 - c2) + + trig_n <- trigamma(n) + + grad1 <- 2 * sqTerm1 * (trigamma(ab[1]) * ab[1] - trig_n * ab[1]) - + 2 * sqTerm2 * (trig_n * ab[1]) + + grad2 <- -2 * sqTerm1 * (trig_n * ab[2]) + + 2 * sqTerm2 * (trigamma(ab[2]) * ab[2] - trig_n * ab[2]) + + c(grad1, grad2) } - - if(verbose) { - message("EM for beta mixture model.\n") - message("Initial estimates:\n") - print(mixEst) + } + + while (iter < Niter.max) { + ## calculate responsabilities from the likelihood terms; + ## calculations are done in log-space to avoid numerical + ## difficulties if some points are far away from some + ## component and hence recieve very low density + ## lli <- t(matrix(log(mixEst[1,]) + dbeta(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) + + ## Beta: Gamma(a + b) / (Gamma(a) * Gamma(b)) * x^(a-1) * (1-x)^(b-1) + w <- mixEst[1, ] + a <- mixEst[2, ] + b <- mixEst[3, ] + ## lli <- sweep( sweep(Lx, 2, a - 1, "*", check.margin=FALSE) + sweep(LxC, 2, b - 1, "*", check.margin=FALSE), 2, log(w) + lgamma(a + b) - lgamma(a) - lgamma(b), "+", check.margin=FALSE) + lli <- sweep(sweep(Lx, 2, a - 1, "*", check.margin = FALSE) + sweep(LxC, 2, b - 1, "*", check.margin = FALSE), 2, log(w) - lbeta(a, b), "+", check.margin = FALSE) + ## lli <- t(matrix(log(mixEst[1,]) + dbeta(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) + + ## ensure that the log-likelihood does not go out of numerical + ## reasonable bounds + lli <- apply(lli, 2, pmax, -30) + + ## lnresp <- apply(lli, 1, log_sum_exp) + lnresp <- matrixStats::rowLogSumExps(lli) + ## the log-likelihood is then given by the sum of lresp norms + lliCur <- sum(lnresp) + ## record current state + traceMix <- c(traceMix, list(mixEst)) + traceLli <- c(traceLli, lliCur) + if (iter > 1) { + ## Dlli is the slope of the log-likelihood evaulated with + ## a second order method + Dlli <- (traceLli[iter + 1] - traceLli[iter - 1]) / 2 } - - ## in case tolerance is not specified, then this criteria is - ## ignored - if(missing(tol)) { - checkTol <- FALSE - tol <- -1 - } else - checkTol <- TRUE - - if(missing(Neps)) { - ## in case tolerance has been declared, but Neps not, we flag - ## to disable checking of running mean convergence check - checkEps <- FALSE - Neps <- 5 - } else - checkEps <- TRUE - - ## if nothing is specified, we declare convergence based on a - ## running mean of differences in parameter estimates - if(!checkTol & !checkEps) { - checkEps <- TRUE + if (Nc > 1) { + smean <- apply(runMixPar[order(runOrder), , , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) + } else { + smean <- apply(runMixPar[order(runOrder), -1, , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) } - - assert_that(Neps > 1) - assert_that(ceiling(Neps) == floor(Neps)) - - ## eps can also be given as a single integer which is interpreted - ## as number of digits - if(length(eps) == 1) eps <- rep(10^(-eps), 3) - - iter <- 0 - logN <- log(N) - traceMix <- list() - traceLli <- c() - Dlli <- Inf - runMixPar <- array(-Inf, dim=c(Neps,3,Nc), dimnames=list(NULL, rownames(mixEstPar), NULL )) - runOrder <- 0:(Neps-1) - Npar <- Nc + 2*Nc - if(Nc == 1) Npar <- Npar - 1 - - ## find alpha and beta for a given component in log-space - bmm_ml <- function(c1,c2) { - function(par) { - ab <- exp(par) - if(constrain_gt1) - ab <- 1 + ab - s <- digamma(sum(ab)) - eq1 <- digamma(ab[1]) - s - eq2 <- digamma(ab[2]) - s - (eq1 - c1)^2 + (eq2 - c2)^2 - } + if (is.na(eps.converged)) eps.converged <- 0 + if (verbose) { + message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep = "") } - - bmm_ml_grad <- function(c1,c2) { - function(par) { - ab <- exp(par) - if(constrain_gt1) - ab <- 1 + ab - n <- sum(ab) - s <- digamma(n) - eq1 <- digamma(ab[1]) - s - eq2 <- digamma(ab[2]) - s - sqTerm1 <- (eq1 - c1) - sqTerm2 <- (eq2 - c2) - - trig_n <- trigamma(n) - - grad1 <- 2 * sqTerm1 * (trigamma(ab[1]) * ab[1] - trig_n * ab[1] ) - - 2 * sqTerm2 * (trig_n * ab[1]) - - grad2 <- -2 * sqTerm1 * (trig_n * ab[2]) + - 2 * sqTerm2 * (trigamma(ab[2]) * ab[2] - trig_n * ab[2]) - - c(grad1, grad2) - } + if (checkTol & Dlli < tol) { + break } - - while(iter < Niter.max) { - ## calculate responsabilities from the likelihood terms; - ## calculations are done in log-space to avoid numerical - ## difficulties if some points are far away from some - ## component and hence recieve very low density - ##lli <- t(matrix(log(mixEst[1,]) + dbeta(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) - - ## Beta: Gamma(a + b) / (Gamma(a) * Gamma(b)) * x^(a-1) * (1-x)^(b-1) - w <- mixEst[1,] - a <- mixEst[2,] - b <- mixEst[3,] - ##lli <- sweep( sweep(Lx, 2, a - 1, "*", check.margin=FALSE) + sweep(LxC, 2, b - 1, "*", check.margin=FALSE), 2, log(w) + lgamma(a + b) - lgamma(a) - lgamma(b), "+", check.margin=FALSE) - lli <- sweep( sweep(Lx, 2, a - 1, "*", check.margin=FALSE) + sweep(LxC, 2, b - 1, "*", check.margin=FALSE), 2, log(w) - lbeta(a, b), "+", check.margin=FALSE) - ##lli <- t(matrix(log(mixEst[1,]) + dbeta(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) - - ## ensure that the log-likelihood does not go out of numerical - ## reasonable bounds - lli <- apply(lli, 2, pmax, -30) - - ##lnresp <- apply(lli, 1, log_sum_exp) - lnresp <- matrixStats::rowLogSumExps(lli) - ## the log-likelihood is then given by the sum of lresp norms - lliCur <- sum(lnresp) - ## record current state - traceMix <- c(traceMix, list(mixEst)) - traceLli <- c(traceLli, lliCur) - if(iter > 1) { - ## Dlli is the slope of the log-likelihood evaulated with - ## a second order method - Dlli <- (traceLli[iter+1] - traceLli[iter - 1])/2 - } - if(Nc > 1) { - smean <- apply(runMixPar[order(runOrder),,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) - } else { - smean <- apply(runMixPar[order(runOrder),-1,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) - } - if(is.na(eps.converged)) eps.converged <- 0 - if(verbose) { - message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep="") - } - if(checkTol & Dlli < tol) { - break - } - if(iter >= Neps & checkEps & eps.converged == Npar) { - break - } - - ## ... and the (log) responseability matrix follows from this by - ## appropiate normalization. - lresp <- sweep(lli, 1, lnresp, "-", FALSE) - ##resp <- exp(lresp) - - ## mean probability to be in a specific mixture component -> updates - ## abmEst first colum - ##lzSum <- apply(lresp, 2, log_sum_exp) - lzSum <- matrixStats::colLogSumExps(lresp) - ##zSum <- exp(lzSum) - mixEst[1,] <- exp(lzSum - logN) - - ##c1 <- colSums(Lx * resp)/zSum - ##c2 <- colSums(LxC * resp)/zSum - - resp_zscaled <- exp(sweep(lresp, 2, lzSum, "-", FALSE)) - c1 <- matrixStats::colSums2(Lx * resp_zscaled) - c2 <- matrixStats::colSums2(LxC * resp_zscaled) - - ## now solve for new alpha and beta estimates jointly for each - ## component - for(i in 1:Nc) { - if(constrain_gt1) { - theta <- c(log(mixEst[2:3,i] - 1)) - } else { - theta <- c(log(mixEst[2:3,i])) - } - ##Lest <- optim(theta, bmm_ml(c1[i], c2[i]), gr=bmm_ml_grad(c1[i], c2[i]), method="BFGS", control=list(maxit=500)) - ## Default would be Nelder-Mead - Lest <- optim(theta, bmm_ml(c1[i], c2[i])) - if(Lest$convergence != 0 & Lest$value > 1E-4) { - warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") - } - if(constrain_gt1) { - mixEst[2:3,i] <- 1+pmax(exp(Lest$par), c(1E-8, 1E-8)) - } else { - mixEst[2:3,i] <- exp(Lest$par) - } - } - - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - ind <- 1 + iter %% Neps - runMixPar[ind,,] <- mixEstPar - runOrder[ind] <- iter - - iter <- iter + 1 + if (iter >= Neps & checkEps & eps.converged == Npar) { + break } - if(iter == Niter.max) - warning("Maximum number of iterations reached.") - mixEst <- mixEst[,order(mixEst[1,], decreasing=TRUE),drop=FALSE] - colnames(mixEst) <- paste("comp", seq(Nc), sep="") - likelihood(mixEst) <- "binomial" - dlink(mixEst) <- identity_dlink - class(mixEst) <- c("EM", "EMbmm", "betaMix", "mix") - - ## give further details - attr(mixEst, "df") <- Nc-1 + 2*Nc - attr(mixEst, "nobs") <- N - attr(mixEst, "lli") <- lliCur - - attr(mixEst, "Nc") <- Nc - - attr(mixEst, "tol") <- tol - attr(mixEst, "traceLli") <- traceLli - attr(mixEst, "traceMix") <- lapply(traceMix, function(x) {class(x) <- c("betaMix", "mix"); x}) - attr(mixEst, "x") <- x + ## ... and the (log) responseability matrix follows from this by + ## appropiate normalization. + lresp <- sweep(lli, 1, lnresp, "-", FALSE) + ## resp <- exp(lresp) + + ## mean probability to be in a specific mixture component -> updates + ## abmEst first colum + ## lzSum <- apply(lresp, 2, log_sum_exp) + lzSum <- matrixStats::colLogSumExps(lresp) + ## zSum <- exp(lzSum) + mixEst[1, ] <- exp(lzSum - logN) + + ## c1 <- colSums(Lx * resp)/zSum + ## c2 <- colSums(LxC * resp)/zSum + + resp_zscaled <- exp(sweep(lresp, 2, lzSum, "-", FALSE)) + c1 <- matrixStats::colSums2(Lx * resp_zscaled) + c2 <- matrixStats::colSums2(LxC * resp_zscaled) + + ## now solve for new alpha and beta estimates jointly for each + ## component + for (i in 1:Nc) { + if (constrain_gt1) { + theta <- c(log(mixEst[2:3, i] - 1)) + } else { + theta <- c(log(mixEst[2:3, i])) + } + ## Lest <- optim(theta, bmm_ml(c1[i], c2[i]), gr=bmm_ml_grad(c1[i], c2[i]), method="BFGS", control=list(maxit=500)) + ## Default would be Nelder-Mead + Lest <- optim(theta, bmm_ml(c1[i], c2[i])) + if (Lest$convergence != 0 & Lest$value > 1E-4) { + warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") + } + if (constrain_gt1) { + mixEst[2:3, i] <- 1 + pmax(exp(Lest$par), c(1E-8, 1E-8)) + } else { + mixEst[2:3, i] <- exp(Lest$par) + } + } - mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + ind <- 1 + iter %% Neps + runMixPar[ind, , ] <- mixEstPar + runOrder[ind] <- iter + + iter <- iter + 1 + } + if (iter == Niter.max) { + warning("Maximum number of iterations reached.") + } + + mixEst <- mixEst[, order(mixEst[1, ], decreasing = TRUE), drop = FALSE] + colnames(mixEst) <- paste("comp", seq(Nc), sep = "") + likelihood(mixEst) <- "binomial" + dlink(mixEst) <- identity_dlink + class(mixEst) <- c("EM", "EMbmm", "betaMix", "mix") + + ## give further details + attr(mixEst, "df") <- Nc - 1 + 2 * Nc + attr(mixEst, "nobs") <- N + attr(mixEst, "lli") <- lliCur + + attr(mixEst, "Nc") <- Nc + + attr(mixEst, "tol") <- tol + attr(mixEst, "traceLli") <- traceLli + attr(mixEst, "traceMix") <- lapply(traceMix, function(x) { + class(x) <- c("betaMix", "mix") + x + }) + attr(mixEst, "x") <- x + + mixEst } #' @export print.EMbmm <- function(x, ...) { - cat("EM for Beta Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n",sep="") - NextMethod() + cat("EM for Beta Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n", sep = "") + NextMethod() } - diff --git a/R/EM_bmm_mun.R b/R/EM_bmm_mun.R index 776230d..e1f4843 100644 --- a/R/EM_bmm_mun.R +++ b/R/EM_bmm_mun.R @@ -1,237 +1,240 @@ - ## EM for Beta Mixture Models (BMM) with Nc components -EM_bmm_mun <- function(x, Nc, mix_init, Ninit=50, verbose=FALSE, Niter.max=500, tol, Neps, eps=c(w=0.005,m=0.005,N=0.005)) -{ - N <- length(x) - assert_that(N+Nc >= Ninit) - - ## check data for 0 and 1 values which are problematic, but may be - ## valid, depending on a and b. Moving these to eps or 1-eps - ## ensures proper handling during fit. - x0 <- x==0 - if(any(x0)) { - message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") - x[x0] <- .Machine$double.eps +EM_bmm_mun <- function(x, Nc, mix_init, Ninit = 50, verbose = FALSE, Niter.max = 500, tol, Neps, eps = c(w = 0.005, m = 0.005, N = 0.005)) { + N <- length(x) + assert_that(N + Nc >= Ninit) + + ## check data for 0 and 1 values which are problematic, but may be + ## valid, depending on a and b. Moving these to eps or 1-eps + ## ensures proper handling during fit. + x0 <- x == 0 + if (any(x0)) { + message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") + x[x0] <- .Machine$double.eps + } + x1 <- x == 1 + if (any(x1)) { + message("Detected ", sum(x1), " value(s) which are exactly 1.\nTo avoid numerical issues during EM such values are moved to one minus smallest eps on machine.") + x[x1] <- 1 - .Machine$double.eps + } + + ## temporaries needed during EM + LxO <- matrix(logit(x), ncol = Nc, nrow = N) + LxC <- matrix(log1p(-x), ncol = Nc, nrow = N) + sLxO <- colSums(LxO) + sLxC <- colSums(LxC) + + xRep <- rep(x, each = Nc) + + ## initialize randomly using KNN + if (missing(mix_init)) { + ## assume that the sample is ordered randomly + ind <- seq(1, N - Nc, length = Ninit) + knnInit <- list(mu = matrix(0, nrow = Nc, ncol = 1), p = rep(1 / Nc, times = Nc)) + for (k in seq(Nc)) { + knnInit$mu[k, 1] <- mean(x[ind + k - 1]) } - x1 <- x==1 - if(any(x1)) { - message("Detected ", sum(x1), " value(s) which are exactly 1.\nTo avoid numerical issues during EM such values are moved to one minus smallest eps on machine.") - x[x1] <- 1-.Machine$double.eps + KNN <- suppressWarnings(knn(x, K = Nc, init = knnInit, Niter.max = 50)) + muInit <- rep(mean(x), times = Nc) + varInit <- rep(1.5 * var(x), times = Nc) + for (k in 1:Nc) { + kind <- KNN$cluster == k + if (sum(kind) > 10) { + muInit[k] <- KNN$center[k] + varInit[k] <- var(x[kind]) + } } - - ## temporaries needed during EM - LxO <- matrix(logit(x), ncol=Nc, nrow=N) - LxC <- matrix(log1p(-x), ncol=Nc, nrow=N) - sLxO <- colSums(LxO) - sLxC <- colSums(LxC) - - xRep <- rep(x, each=Nc) - - ## initialize randomly using KNN - if(missing(mix_init)) { - ## assume that the sample is ordered randomly - ind <- seq(1,N-Nc,length=Ninit) - knnInit <- list(mu=matrix(0,nrow=Nc,ncol=1), p=rep(1/Nc, times=Nc)) - for(k in seq(Nc)) - knnInit$mu[k,1] <- mean(x[ind+k-1]) - KNN <- suppressWarnings(knn(x, K=Nc, init=knnInit, Niter.max=50)) - muInit <- rep(mean(x), times=Nc) - varInit <- rep(1.5*var(x), times=Nc) - for(k in 1:Nc) { - kind <- KNN$cluster == k - if(sum(kind) > 10) { - muInit[k] <- KNN$center[k] - varInit[k] <- var(x[kind]) - } - } - nInit <- pmax(muInit*(1-muInit)/varInit - 1, 1, na.rm=TRUE) - ## place the component which recieved the least weight at the - ## data center with roughly the variance of the sample - cmin <- which.min(KNN$p) - muInit[cmin] <- sum(KNN$p * KNN$center) - ## muInit[cmin] <- mean(x) ## could be considered here - nInit[cmin] <- pmax(muInit[cmin]*(1-muInit[cmin])/var(x) - 1, 1, na.rm=TRUE) - ##Nmax <- max(2, max(nInit)) - ## ensure n is positive for each cluster; if this is not the - ## case, sample uniformly from the range of n we have - ##Nneg <- nInit <= .Machine$double.eps - ##Nsmall <- nInit <= 0.5 - ##if(any(Nsmall)) - ## nInit[Nsmall] <- runif(sum(Nsmall), 0.5, Nmax) - ##nInitR <- 0.5 + rlnorm(Nc, log(nInit), log(5)/1.96) - ##mixEst <- rbind(KNN$p, nInitR*muInit, nInitR*(1-muInit)) - mixEst <- rbind(KNN$p, nInit*muInit, nInit*(1-muInit)) - dlink(mixEst) <- identity_dlink - rownames(mixEst) <- c("w", "a", "b") + nInit <- pmax(muInit * (1 - muInit) / varInit - 1, 1, na.rm = TRUE) + ## place the component which recieved the least weight at the + ## data center with roughly the variance of the sample + cmin <- which.min(KNN$p) + muInit[cmin] <- sum(KNN$p * KNN$center) + ## muInit[cmin] <- mean(x) ## could be considered here + nInit[cmin] <- pmax(muInit[cmin] * (1 - muInit[cmin]) / var(x) - 1, 1, na.rm = TRUE) + ## Nmax <- max(2, max(nInit)) + ## ensure n is positive for each cluster; if this is not the + ## case, sample uniformly from the range of n we have + ## Nneg <- nInit <= .Machine$double.eps + ## Nsmall <- nInit <= 0.5 + ## if(any(Nsmall)) + ## nInit[Nsmall] <- runif(sum(Nsmall), 0.5, Nmax) + ## nInitR <- 0.5 + rlnorm(Nc, log(nInit), log(5)/1.96) + ## mixEst <- rbind(KNN$p, nInitR*muInit, nInitR*(1-muInit)) + mixEst <- rbind(KNN$p, nInit * muInit, nInit * (1 - muInit)) + dlink(mixEst) <- identity_dlink + rownames(mixEst) <- c("w", "a", "b") + } else { + mixEst <- mix_init + } + + if (verbose) { + message("EM for beta mixture model.\n") + message("Initial estimates:\n") + print(mixEst) + } + + ## mixEst parametrization during fitting + mixEstPar <- mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + mixEstPar[2, ] <- logit(mixEst[2, ] / (mixEst[2, ] + mixEst[3, ])) + mixEstPar[3, ] <- log(mixEst[2, ] + mixEst[3, ]) + rownames(mixEstPar) <- c("w", "Lm", "lN") + + ## in case tolerance is not specified, then this criteria is + ## ignored + if (missing(tol)) { + checkTol <- FALSE + tol <- -1 + } else { + checkTol <- TRUE + } + + if (missing(Neps)) { + ## in case tolerance has been declared, but Neps not, we flag + ## to disable checking of running mean convergence check + checkEps <- FALSE + Neps <- 5 + } else { + checkEps <- TRUE + } + + ## if nothing is specified, we declare convergence based on a + ## running mean of differences in parameter estimates + if (!checkTol & !checkEps) { + checkEps <- TRUE + } + + assert_that(Neps > 1) + assert_that(ceiling(Neps) == floor(Neps)) + + ## eps can also be given as a single integer which is interpreted + ## as number of digits + if (length(eps) == 1) eps <- rep(10^(-eps), 3) + + iter <- 0 + logN <- log(N) + traceMix <- list() + traceLli <- c() + Dlli <- Inf + runMixPar <- array(-Inf, dim = c(Neps, 3, Nc), dimnames = list(NULL, rownames(mixEstPar), NULL)) + runOrder <- 0:(Neps - 1) + Npar <- Nc + 2 * Nc + if (Nc == 1) Npar <- Npar - 1 + + ## find alpha and beta for a given component in log-space + bmm_mun_ml <- function(c1, c2) { + function(par) { + mu <- inv_logit(par[1]) + nmu <- inv_logit(-par[1]) ## 1-mu + n <- exp(par[2]) + ab <- c(mu * n, nmu * n) + di <- digamma(ab[2]) + eq1 <- digamma(ab[1]) - di + eq2 <- di - digamma(n) + (eq1 - c1)^2 + (eq2 - c2)^2 + } + } + + while (iter < Niter.max) { + ## calculate responsabilities from the likelihood terms; + ## calculations are done in log-space to avoid numerical + ## difficulties if some points are far away from some + ## component and hence recieve very low density + lli <- t(matrix(log(mixEst[1, ]) + dbeta(xRep, mixEst[2, ], mixEst[3, ], log = TRUE), nrow = Nc)) + lnresp <- matrixStats::rowLogSumExps(lli) + ## ensure that the log-likelihood does not go out of numerical + ## reasonable bounds + lli <- apply(lli, 2, pmax, -30) + ## the log-likelihood is then given by the sum of lresp norms + lliCur <- sum(lnresp) + ## record current state + traceMix <- c(traceMix, list(mixEst)) + traceLli <- c(traceLli, lliCur) + if (iter > 1) { + ## Dlli is the slope of the log-likelihood evaulated with + ## a second order method + Dlli <- (traceLli[iter + 1] - traceLli[iter - 1]) / 2 + } + if (Nc > 1) { + smean <- apply(runMixPar[order(runOrder), , , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) } else { - mixEst <- mix_init + smean <- apply(runMixPar[order(runOrder), -1, , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) } - - if(verbose) { - message("EM for beta mixture model.\n") - message("Initial estimates:\n") - print(mixEst) + if (is.na(eps.converged)) eps.converged <- 0 + if (verbose) { + message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep = "") } - - ## mixEst parametrization during fitting - mixEstPar <- mixEst - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - mixEstPar[2,] <- logit(mixEst[2,] / (mixEst[2,] + mixEst[3,])) - mixEstPar[3,] <- log(mixEst[2,] + mixEst[3,]) - rownames(mixEstPar) <- c("w", "Lm", "lN") - - ## in case tolerance is not specified, then this criteria is - ## ignored - if(missing(tol)) { - checkTol <- FALSE - tol <- -1 - } else - checkTol <- TRUE - - if(missing(Neps)) { - ## in case tolerance has been declared, but Neps not, we flag - ## to disable checking of running mean convergence check - checkEps <- FALSE - Neps <- 5 - } else - checkEps <- TRUE - - ## if nothing is specified, we declare convergence based on a - ## running mean of differences in parameter estimates - if(!checkTol & !checkEps) { - checkEps <- TRUE + if (checkTol & Dlli < tol) { + break } - - assert_that(Neps > 1) - assert_that(ceiling(Neps) == floor(Neps)) - - ## eps can also be given as a single integer which is interpreted - ## as number of digits - if(length(eps) == 1) eps <- rep(10^(-eps), 3) - - iter <- 0 - logN <- log(N) - traceMix <- list() - traceLli <- c() - Dlli <- Inf - runMixPar <- array(-Inf, dim=c(Neps,3,Nc), dimnames=list(NULL, rownames(mixEstPar), NULL )) - runOrder <- 0:(Neps-1) - Npar <- Nc + 2*Nc - if(Nc == 1) Npar <- Npar - 1 - - ## find alpha and beta for a given component in log-space - bmm_mun_ml <- function(c1,c2) { - function(par) { - mu <- inv_logit(par[1]) - nmu <- inv_logit(-par[1]) ## 1-mu - n <- exp(par[2]) - ab <- c(mu * n, nmu * n) - di <- digamma(ab[2]) - eq1 <- digamma(ab[1]) - di - eq2 <- di - digamma(n) - (eq1 - c1)^2 + (eq2 - c2)^2 - } + if (iter >= Neps & checkEps & eps.converged == Npar) { + break } - - while(iter < Niter.max) { - ## calculate responsabilities from the likelihood terms; - ## calculations are done in log-space to avoid numerical - ## difficulties if some points are far away from some - ## component and hence recieve very low density - lli <- t(matrix(log(mixEst[1,]) + dbeta(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) - lnresp <- matrixStats::rowLogSumExps(lli) - ## ensure that the log-likelihood does not go out of numerical - ## reasonable bounds - lli <- apply(lli, 2, pmax, -30) - ## the log-likelihood is then given by the sum of lresp norms - lliCur <- sum(lnresp) - ## record current state - traceMix <- c(traceMix, list(mixEst)) - traceLli <- c(traceLli, lliCur) - if(iter > 1) { - ## Dlli is the slope of the log-likelihood evaulated with - ## a second order method - Dlli <- (traceLli[iter+1] - traceLli[iter - 1])/2 - } - if(Nc > 1) { - smean <- apply(runMixPar[order(runOrder),,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) - } else { - smean <- apply(runMixPar[order(runOrder),-1,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) - } - if(is.na(eps.converged)) eps.converged <- 0 - if(verbose) { - message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep="") - } - if(checkTol & Dlli < tol) { - break - } - if(iter >= Neps & checkEps & eps.converged == Npar) { - break - } - ## ... and the (log) responseability matrix follows from this by - ## appropiate normalization. - lresp <- sweep(lli, 1, lnresp, "-") - resp <- exp(lresp) - - ## mean probability to be in a specific mixture component -> updates - ## mixEst first row - lzSum <- matrixStats::colLogSumExps(lresp) - zSum <- exp(lzSum) - mixEst[1,] <- exp(lzSum - logN) - - ## make sure it scales exactly to 1 which may not happen due - ## to small rounding issues - mixEst[1,] <- mixEst[1,] / sum(mixEst[1,]) - - c1 <- colSums(LxO * resp)/zSum - c2 <- colSums(LxC * resp)/zSum - - ## now solve for new alpha and beta estimates jointly for each - ## component - for(i in 1:Nc) { - Lest <- optim(mixEstPar[c(2,3),i], bmm_mun_ml(c1[i], c2[i])) - if(Lest$convergence != 0) { - warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") - } - mixEstPar[c(2,3),i] <- Lest$par - mui <- inv_logit( Lest$par[1]) - nmui <- inv_logit(-Lest$par[1]) - ni <- exp(Lest$par[2]) - mixEst[2,i] <- mui * ni - mixEst[3,i] <- nmui * ni - } - - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - ind <- 1 + iter %% Neps - runMixPar[ind,,] <- mixEstPar - runOrder[ind] <- iter - - iter <- iter + 1 + ## ... and the (log) responseability matrix follows from this by + ## appropiate normalization. + lresp <- sweep(lli, 1, lnresp, "-") + resp <- exp(lresp) + + ## mean probability to be in a specific mixture component -> updates + ## mixEst first row + lzSum <- matrixStats::colLogSumExps(lresp) + zSum <- exp(lzSum) + mixEst[1, ] <- exp(lzSum - logN) + + ## make sure it scales exactly to 1 which may not happen due + ## to small rounding issues + mixEst[1, ] <- mixEst[1, ] / sum(mixEst[1, ]) + + c1 <- colSums(LxO * resp) / zSum + c2 <- colSums(LxC * resp) / zSum + + ## now solve for new alpha and beta estimates jointly for each + ## component + for (i in 1:Nc) { + Lest <- optim(mixEstPar[c(2, 3), i], bmm_mun_ml(c1[i], c2[i])) + if (Lest$convergence != 0) { + warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") + } + mixEstPar[c(2, 3), i] <- Lest$par + mui <- inv_logit(Lest$par[1]) + nmui <- inv_logit(-Lest$par[1]) + ni <- exp(Lest$par[2]) + mixEst[2, i] <- mui * ni + mixEst[3, i] <- nmui * ni } - if(iter == Niter.max) - warning("Maximum number of iterations reached.") - - mixEst <- mixEst[,order(mixEst[1,], decreasing=TRUE),drop=FALSE] - colnames(mixEst) <- paste("comp", seq(Nc), sep="") - dlink(mixEst) <- identity_dlink - class(mixEst) <- c("EM", "EMbmm", "betaMix", "mix") - - ## give further details - attr(mixEst, "df") <- Nc-1 + 2*Nc - attr(mixEst, "nobs") <- N - attr(mixEst, "lli") <- lliCur - - attr(mixEst, "Nc") <- Nc - - attr(mixEst, "tol") <- tol - attr(mixEst, "traceLli") <- traceLli - attr(mixEst, "traceMix") <- lapply(traceMix, function(x) { - class(x) <- c("betaMix", "mix") - x}) - attr(mixEst, "x") <- x - mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + ind <- 1 + iter %% Neps + runMixPar[ind, , ] <- mixEstPar + runOrder[ind] <- iter + + iter <- iter + 1 + } + if (iter == Niter.max) { + warning("Maximum number of iterations reached.") + } + + mixEst <- mixEst[, order(mixEst[1, ], decreasing = TRUE), drop = FALSE] + colnames(mixEst) <- paste("comp", seq(Nc), sep = "") + dlink(mixEst) <- identity_dlink + class(mixEst) <- c("EM", "EMbmm", "betaMix", "mix") + + ## give further details + attr(mixEst, "df") <- Nc - 1 + 2 * Nc + attr(mixEst, "nobs") <- N + attr(mixEst, "lli") <- lliCur + + attr(mixEst, "Nc") <- Nc + + attr(mixEst, "tol") <- tol + attr(mixEst, "traceLli") <- traceLli + attr(mixEst, "traceMix") <- lapply(traceMix, function(x) { + class(x) <- c("betaMix", "mix") + x + }) + attr(mixEst, "x") <- x + + mixEst } diff --git a/R/EM_gmm.R b/R/EM_gmm.R index 0473a55..317fa01 100644 --- a/R/EM_gmm.R +++ b/R/EM_gmm.R @@ -1,242 +1,248 @@ ## EM for GMM with Nc components -EM_gmm <- function(x, Nc, mix_init, Ninit=50, verbose=FALSE, Niter.max=500, tol, Neps, eps=c(weight=0.005,alpha=0.005,beta=0.005)) { - N <- length(x) - assert_that(N+Nc >= Ninit) - - ## check data for 0 values which are problematic, but may be - ## valid. Moving these to eps ensures proper handling during fit. - x0 <- x==0 - if(any(x0)) { - message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") - x[x0] <- .Machine$double.eps +EM_gmm <- function(x, Nc, mix_init, Ninit = 50, verbose = FALSE, Niter.max = 500, tol, Neps, eps = c(weight = 0.005, alpha = 0.005, beta = 0.005)) { + N <- length(x) + assert_that(N + Nc >= Ninit) + + ## check data for 0 values which are problematic, but may be + ## valid. Moving these to eps ensures proper handling during fit. + x0 <- x == 0 + if (any(x0)) { + message("Detected ", sum(x0), " value(s) which are exactly 0.\nTo avoid numerical issues during EM such values are moved to smallest eps on machine.") + x[x0] <- .Machine$double.eps + } + + ## temporaries needed during EM + Lx <- matrix(log(x), ncol = Nc, nrow = N) + + xRep <- matrix(x, ncol = Nc, nrow = N) + + ## initialize randomly using KNN + if (missing(mix_init)) { + ## assume that the sample is ordered randomly + ind <- seq(1, N - Nc, length = Ninit) + knnInit <- list(mu = matrix(0, nrow = Nc, ncol = 1), p = rep(1 / Nc, times = Nc)) + for (k in seq(Nc)) { + knnInit$mu[k, 1] <- mean(x[ind + k - 1]) } - - ## temporaries needed during EM - Lx <- matrix(log(x), ncol=Nc, nrow=N) - - xRep <- matrix(x, ncol=Nc, nrow=N) - - ## initialize randomly using KNN - if(missing(mix_init)) { - ## assume that the sample is ordered randomly - ind <- seq(1,N-Nc,length=Ninit) - knnInit <- list(mu=matrix(0,nrow=Nc,ncol=1), p=rep(1/Nc, times=Nc)) - for(k in seq(Nc)) - knnInit$mu[k,1] <- mean(x[ind+k-1]) - KNN <- suppressWarnings(knn(x, K=Nc, init=knnInit, Niter.max=50)) - muInit <- rep(mean(x), times=Nc) - varInit <- rep(1.5*var(x), times=Nc) - for(k in 1:Nc) { - kind <- KNN$cluster == k - if(sum(kind) > 10) { - muInit[k] <- KNN$center[k] - varInit[k] <- var(x[kind]) - } - } - ## relocate the component with the least weight in the center - ## and assign the sample variance to it; the idea is that we - ## expect an informative component and a heavy tailed - ## background which is best "absorbed" if a wide component is - ## place initially at the center of the data - cmin <- which.min(KNN$p) - varInit[cmin] <- var(x) - muInit[cmin] <- sum(KNN$center * KNN$p) - ##varInit <- rlnorm(Nc, log(varInit), log(2.5)/1.96) - bInit <- muInit / varInit - aInit <- muInit * bInit - mixEst <- rbind(KNN$p, aInit, bInit) - dlink(mixEst) <- identity_dlink - rownames(mixEst) <- c("w", "a", "b") - } else { - mixEst <- mix_init + KNN <- suppressWarnings(knn(x, K = Nc, init = knnInit, Niter.max = 50)) + muInit <- rep(mean(x), times = Nc) + varInit <- rep(1.5 * var(x), times = Nc) + for (k in 1:Nc) { + kind <- KNN$cluster == k + if (sum(kind) > 10) { + muInit[k] <- KNN$center[k] + varInit[k] <- var(x[kind]) + } } - - if(verbose) { - message("EM for gamma mixture model.\n") - message("Initial estimates:\n") - print(mixEst) + ## relocate the component with the least weight in the center + ## and assign the sample variance to it; the idea is that we + ## expect an informative component and a heavy tailed + ## background which is best "absorbed" if a wide component is + ## place initially at the center of the data + cmin <- which.min(KNN$p) + varInit[cmin] <- var(x) + muInit[cmin] <- sum(KNN$center * KNN$p) + ## varInit <- rlnorm(Nc, log(varInit), log(2.5)/1.96) + bInit <- muInit / varInit + aInit <- muInit * bInit + mixEst <- rbind(KNN$p, aInit, bInit) + dlink(mixEst) <- identity_dlink + rownames(mixEst) <- c("w", "a", "b") + } else { + mixEst <- mix_init + } + + if (verbose) { + message("EM for gamma mixture model.\n") + message("Initial estimates:\n") + print(mixEst) + } + + ## mixEst parametrization during fitting + mixEstPar <- mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + mixEstPar[2, ] <- log(mixEst[2, ]) + mixEstPar[3, ] <- log(mixEst[3, ]) + rownames(mixEstPar) <- c("w", "la", "lb") + + ## the optimizer needs a fixed range where search log-alpha + MLrange <- c(min(mixEstPar[2, ]) - log(1e4), max(mixEstPar[2, ]) + log(1e4)) + + ## in case tolerance is not specified, then this criteria is + ## ignored + if (missing(tol)) { + checkTol <- FALSE + tol <- -1 + } else { + checkTol <- TRUE + } + + if (missing(Neps)) { + ## in case tolerance has been declared, but Neps not, we flag + ## to disable checking of running mean convergence check + checkEps <- FALSE + Neps <- 5 + } else { + checkEps <- TRUE + } + + ## if nothing is specified, we declare convergence based on a + ## running mean of differences in parameter estimates + if (!checkTol & !checkEps) { + checkEps <- TRUE + } + + assert_that(Neps > 1) + assert_that(ceiling(Neps) == floor(Neps)) + + + ## eps can also be given as a single integer which is interpreted + ## as number of digits + if (length(eps) == 1) eps <- rep(10^(-eps), 3) + + iter <- 0 + logN <- log(N) + traceMix <- list() + traceLli <- c() + Dlli <- Inf + runMixPar <- array(-Inf, dim = c(Neps, 3, Nc), dimnames = list(NULL, rownames(mixEstPar), NULL)) + runOrder <- 0:(Neps - 1) + Npar <- Nc + 2 * Nc + if (Nc == 1) Npar <- Npar - 1 + + ## find alpha and beta for a given component in log-space + gmm_ml <- function(c1) { + function(la) { + (c1 - digamma(exp(la)) + la)^2 } - - ## mixEst parametrization during fitting - mixEstPar <- mixEst - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - mixEstPar[2,] <- log(mixEst[2,]) - mixEstPar[3,] <- log(mixEst[3,]) - rownames(mixEstPar) <- c("w", "la", "lb") - - ## the optimizer needs a fixed range where search log-alpha - MLrange <- c(min(mixEstPar[2,]) - log(1e4), max(mixEstPar[2,]) + log(1e4)) - - ## in case tolerance is not specified, then this criteria is - ## ignored - if(missing(tol)) { - checkTol <- FALSE - tol <- -1 - } else - checkTol <- TRUE - - if(missing(Neps)) { - ## in case tolerance has been declared, but Neps not, we flag - ## to disable checking of running mean convergence check - checkEps <- FALSE - Neps <- 5 - } else - checkEps <- TRUE - - ## if nothing is specified, we declare convergence based on a - ## running mean of differences in parameter estimates - if(!checkTol & !checkEps) { - checkEps <- TRUE + } + + gmm_ml_grad <- function(c1) { + function(la) { + a <- exp(la) + val <- (c1 - digamma(a) + la) + grad <- 2 * val * (1 - trigamma(a) * a) + grad } - - assert_that(Neps > 1) - assert_that(ceiling(Neps) == floor(Neps)) - - - ## eps can also be given as a single integer which is interpreted - ## as number of digits - if(length(eps) == 1) eps <- rep(10^(-eps), 3) - - iter <- 0 - logN <- log(N) - traceMix <- list() - traceLli <- c() - Dlli <- Inf - runMixPar <- array(-Inf, dim=c(Neps,3,Nc), dimnames=list(NULL, rownames(mixEstPar), NULL )) - runOrder <- 0:(Neps-1) - Npar <- Nc + 2*Nc - if(Nc == 1) Npar <- Npar - 1 - - ## find alpha and beta for a given component in log-space - gmm_ml <- function(c1) { - function(la) { - (c1 - digamma(exp(la)) + la)^2 - } + } + + while (iter < Niter.max) { + ## calculate responsabilities from the likelihood terms; + ## calculations are done in log-space to avoid numerical difficulties if some points are far away from some component and hence recieve very low density + ## li <- t(matrix(abmEst[,1] * dgamma(xRep, abmEst[,2], abmEst[,3]), nrow=Nc)) + + ## lli <- t(matrix(log(mixEst[1,]) + dgamma(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) + w <- mixEst[1, ] + a <- mixEst[2, ] + b <- mixEst[3, ] + ## Gamma density: x^(a-1) * exp(-b * x) * b^a / Gamma(a) + lli <- sweep(sweep(Lx, 2, a - 1, "*") - sweep(xRep, 2, b, "*"), 2, a * log(b) - lgamma(a) + log(w), "+") + + ## ensure that the log-likelihood does not go out of numerical + ## reasonable bounds + lli <- apply(lli, 2, pmax, -30) + + ## lnresp <- apply(lli, 1, log_sum_exp) + lnresp <- matrixStats::rowLogSumExps(lli) + ## the log-likelihood is then given by the sum of lresp norms + lliCur <- sum(lnresp) + ## record current state + traceMix <- c(traceMix, list(mixEst)) + traceLli <- c(traceLli, lliCur) + if (iter > 1) { + ## Dlli is the slope of the log-likelihood evaulated with + ## a second order method + Dlli <- (traceLli[iter + 1] - traceLli[iter - 1]) / 2 } - - gmm_ml_grad <- function(c1) { - function(la) { - a <- exp(la) - val <- (c1 - digamma(a) + la) - grad <- 2 * val * (1 - trigamma(a) * a) - grad - } + if (Nc > 1) { + smean <- apply(runMixPar[order(runOrder), , , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) + } else { + smean <- apply(runMixPar[order(runOrder), -1, , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) } - - while(iter < Niter.max) { - ## calculate responsabilities from the likelihood terms; - ## calculations are done in log-space to avoid numerical difficulties if some points are far away from some component and hence recieve very low density - ##li <- t(matrix(abmEst[,1] * dgamma(xRep, abmEst[,2], abmEst[,3]), nrow=Nc)) - - ##lli <- t(matrix(log(mixEst[1,]) + dgamma(xRep, mixEst[2,], mixEst[3,], log=TRUE), nrow=Nc)) - w <- mixEst[1,] - a <- mixEst[2,] - b <- mixEst[3,] - ## Gamma density: x^(a-1) * exp(-b * x) * b^a / Gamma(a) - lli <- sweep(sweep(Lx, 2, a-1, "*") - sweep(xRep, 2, b, "*"), 2, a * log(b) - lgamma(a) + log(w), "+") - - ## ensure that the log-likelihood does not go out of numerical - ## reasonable bounds - lli <- apply(lli, 2, pmax, -30) - - ##lnresp <- apply(lli, 1, log_sum_exp) - lnresp <- matrixStats::rowLogSumExps(lli) - ## the log-likelihood is then given by the sum of lresp norms - lliCur <- sum(lnresp) - ## record current state - traceMix <- c(traceMix, list(mixEst)) - traceLli <- c(traceLli, lliCur) - if(iter > 1) { - ## Dlli is the slope of the log-likelihood evaulated with - ## a second order method - Dlli <- (traceLli[iter+1] - traceLli[iter - 1])/2 - } - if(Nc > 1) { - smean <- apply(runMixPar[order(runOrder),,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) - } else { - smean <- apply(runMixPar[order(runOrder),-1,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) - } - if(is.na(eps.converged)) eps.converged <- 0 - if(verbose) { - message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep="") - } - if(checkTol & Dlli < tol) { - break - } - if(iter >= Neps & checkEps & eps.converged == Npar) { - break - } - ## ... and the (log) responseability matrix follows from this by - ## appropiate normalization. - lresp <- sweep(lli, 1, lnresp, "-") - resp <- exp(lresp) - - ## mean probability to be in a specific mixture component -> updates - ## mixEst first row - ##lzSum <- apply(lresp, 2, log_sum_exp) - lzSum <- colLogSumExps(lresp) - zSum <- exp(lzSum) - mixEst[1,] <- exp(lzSum - logN) - - ## make sure it is scale to exactly 1 which may not happen due - ## to small rounding issues - mixEst[1,] <- mixEst[1,] / sum(mixEst[1,]) - - ##lrx <- apply(Lx + lresp, 2, log_sum_exp) - lrx <- colLogSumExps(Lx + lresp) - resp_zscaled <- exp(sweep(lresp, 2, lzSum, "-")) - c1 <- colSums(Lx * resp_zscaled) + lzSum - lrx - c2 <- lzSum - lrx - - ## now solve for new alpha and beta estimates - for(i in 1:Nc) { - Lest <- optimize(gmm_ml(c1[i]), MLrange) - ##theta <- c(log(mixEst[2,i])) - ##Lest <- optim(theta, gmm_ml(c1[i]), gr=gmm_ml_grad(c1[i]), method="BFGS", control=list(maxit=500)) - if(abs(Lest$objective) > 1E-4) { - warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") - } - mixEstPar[2,i] <- Lest$minimum - mixEstPar[3,i] <- Lest$minimum + c2[i] - mixEst[c(2,3),i] <- exp(mixEstPar[c(2,3),i]) - } - - mixEstPar[1,] <- logit(mixEst[1,,drop=FALSE]) - ind <- 1 + iter %% Neps - runMixPar[ind,,] <- mixEstPar - runOrder[ind] <- iter - - iter <- iter + 1 + if (is.na(eps.converged)) eps.converged <- 0 + if (verbose) { + message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep = "") + } + if (checkTol & Dlli < tol) { + break + } + if (iter >= Neps & checkEps & eps.converged == Npar) { + break + } + ## ... and the (log) responseability matrix follows from this by + ## appropiate normalization. + lresp <- sweep(lli, 1, lnresp, "-") + resp <- exp(lresp) + + ## mean probability to be in a specific mixture component -> updates + ## mixEst first row + ## lzSum <- apply(lresp, 2, log_sum_exp) + lzSum <- colLogSumExps(lresp) + zSum <- exp(lzSum) + mixEst[1, ] <- exp(lzSum - logN) + + ## make sure it is scale to exactly 1 which may not happen due + ## to small rounding issues + mixEst[1, ] <- mixEst[1, ] / sum(mixEst[1, ]) + + ## lrx <- apply(Lx + lresp, 2, log_sum_exp) + lrx <- colLogSumExps(Lx + lresp) + resp_zscaled <- exp(sweep(lresp, 2, lzSum, "-")) + c1 <- colSums(Lx * resp_zscaled) + lzSum - lrx + c2 <- lzSum - lrx + + ## now solve for new alpha and beta estimates + for (i in 1:Nc) { + Lest <- optimize(gmm_ml(c1[i]), MLrange) + ## theta <- c(log(mixEst[2,i])) + ## Lest <- optim(theta, gmm_ml(c1[i]), gr=gmm_ml_grad(c1[i]), method="BFGS", control=list(maxit=500)) + if (abs(Lest$objective) > 1E-4) { + warning("Warning: Component", i, "in iteration", iter, "had convergence problems!") + } + mixEstPar[2, i] <- Lest$minimum + mixEstPar[3, i] <- Lest$minimum + c2[i] + mixEst[c(2, 3), i] <- exp(mixEstPar[c(2, 3), i]) } - if(iter == Niter.max) - warning("Maximum number of iterations reached.") - - mixEst <- mixEst[,order(mixEst[1,], decreasing=TRUE),drop=FALSE] - colnames(mixEst) <- paste("comp", seq(Nc), sep="") - dlink(mixEst) <- identity_dlink - class(mixEst) <- c("EM", "EMgmm", "gammaMix", "mix") - - ## give further details - attr(mixEst, "df") <- Nc-1 + 2*Nc - attr(mixEst, "nobs") <- N - attr(mixEst, "lli") <- lliCur - - attr(mixEst, "Nc") <- Nc - - attr(mixEst, "tol") <- tol - attr(mixEst, "traceLli") <- traceLli - attr(mixEst, "traceMix") <- lapply(traceMix, function(x) {class(x) <- c("gammaMix", "mix"); x}) - attr(mixEst, "x") <- x - mixEst + mixEstPar[1, ] <- logit(mixEst[1, , drop = FALSE]) + ind <- 1 + iter %% Neps + runMixPar[ind, , ] <- mixEstPar + runOrder[ind] <- iter + + iter <- iter + 1 + } + if (iter == Niter.max) { + warning("Maximum number of iterations reached.") + } + + mixEst <- mixEst[, order(mixEst[1, ], decreasing = TRUE), drop = FALSE] + colnames(mixEst) <- paste("comp", seq(Nc), sep = "") + dlink(mixEst) <- identity_dlink + class(mixEst) <- c("EM", "EMgmm", "gammaMix", "mix") + + ## give further details + attr(mixEst, "df") <- Nc - 1 + 2 * Nc + attr(mixEst, "nobs") <- N + attr(mixEst, "lli") <- lliCur + + attr(mixEst, "Nc") <- Nc + + attr(mixEst, "tol") <- tol + attr(mixEst, "traceLli") <- traceLli + attr(mixEst, "traceMix") <- lapply(traceMix, function(x) { + class(x) <- c("gammaMix", "mix") + x + }) + attr(mixEst, "x") <- x + + mixEst } #' @export print.EMgmm <- function(x, ...) { - cat("EM for Gamma Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n",sep="") - NextMethod() + cat("EM for Gamma Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n", sep = "") + NextMethod() } - diff --git a/R/EM_logLik.R b/R/EM_logLik.R index 8287858..bf34b9b 100644 --- a/R/EM_logLik.R +++ b/R/EM_logLik.R @@ -1,12 +1,12 @@ #' Extract log likelihood from fitted EM objects #' #' @keywords internal -#' +#' #' @export logLik.EM <- function(object, ...) { - val <- attr(object, "lli") - attr(val, "df") <- attr(object, "df") - attr(val, "nobs") <- attr(object, "nobs") - class(val) <- "logLik" - val + val <- attr(object, "lli") + attr(val, "df") <- attr(object, "df") + attr(val, "nobs") <- attr(object, "nobs") + class(val) <- "logLik" + val } diff --git a/R/EM_mnmm.R b/R/EM_mnmm.R index 8f34391..0bd0cfa 100644 --- a/R/EM_mnmm.R +++ b/R/EM_mnmm.R @@ -1,266 +1,275 @@ - ## EM for MNMM (Multi-variate Normal Mixture Model) with Nc components ## if init is not speciefied, then knn is used to initialize means, ## cluster weights and covariance matrices (taken from the knn ## determined clusters) -EM_mnmm <- function(X, Nc, mix_init, Ninit=50, verbose=FALSE, Niter.max=500, tol, Neps, eps=c(w=0.005,m=0.005,s=0.005)) { - ## in case X is no matrix, interpret it as uni-variate case - if(!is.matrix(X)) - X <- matrix(X,ncol=1) - - N <- dim(X)[1] - Nd <- dim(X)[2] - assert_that(N+Nc >= Ninit) - - ## initialize normal EM using a Student-t EM which is very robust - ## against outliers - if(missing(mix_init)) { - mix_init <- EM_msmm(X, Nc, Ninit=Ninit, verbose=verbose, Niter.max=round(Niter.max/2), tol=0.1) +EM_mnmm <- function(X, Nc, mix_init, Ninit = 50, verbose = FALSE, Niter.max = 500, tol, Neps, eps = c(w = 0.005, m = 0.005, s = 0.005)) { + ## in case X is no matrix, interpret it as uni-variate case + if (!is.matrix(X)) { + X <- matrix(X, ncol = 1) + } + + N <- dim(X)[1] + Nd <- dim(X)[2] + assert_that(N + Nc >= Ninit) + + ## initialize normal EM using a Student-t EM which is very robust + ## against outliers + if (missing(mix_init)) { + mix_init <- EM_msmm(X, Nc, Ninit = Ninit, verbose = verbose, Niter.max = round(Niter.max / 2), tol = 0.1) + } + pEst <- mix_init$p + muEst <- mix_init$center + covEst <- mix_init$cov + + ## take current estimates and transform to scale on which + ## convergence is assessed + est2par <- function(p, mu, cov) { + est <- rbind(logit(p), matrix(sapply(1:Nc, function(i) mv2vec(mu[i, ], cov[i, , ])), ncol = Nc)) + est[(1 + Nd + 1):(1 + 2 * Nd), ] <- log(est[(1 + Nd + 1):(1 + 2 * Nd), ]) + est + } + ## in case tolerance is not specified, then this criteria is + ## ignored + if (missing(tol)) { + checkTol <- FALSE + tol <- -1 + } else { + checkTol <- TRUE + } + + if (missing(Neps)) { + ## in case tolerance has been declared, but Neps not, we flag + ## to disable checking of running mean convergence check + checkEps <- FALSE + Neps <- 5 + } else { + checkEps <- TRUE + } + + ## if nothing is specified, we declare convergence based on a + ## running mean of differences in parameter estimates + if (!checkTol & !checkEps) { + checkEps <- TRUE + } + + assert_that(Neps > 1) + assert_that(ceiling(Neps) == floor(Neps)) + + ## eps can also be given as a single integer which is interpreted + ## as number of digits + if (length(eps) == 1) eps <- rep(10^(-eps), 3) + + ## degrees of freedom + ## covariance matrix df per component + cov.df <- (Nd - 1) * Nd / 2 + Nd + df <- Nc * (Nd + cov.df) + Nc - 1 + df.comp <- cov.df + Nd + 1 + + ## expand eps according to the dimensionality + eps <- c(eps[1], rep(eps[2], Nd), rep(eps[3], Nd), rep(eps[2], (Nd - 1) * Nd / 2)) + + iter <- 0 + logN <- log(N) + traceMix <- list() + traceLli <- c() + Dlli <- Inf + runMixPar <- array(-Inf, dim = c(Neps, df.comp, Nc)) + runOrder <- 0:(Neps - 1) + if (Nc == 1) Npar <- df else Npar <- df + 1 + + ## initialize component and element wise log-likelihood matrix + lli <- array(-20, dim = c(N, Nc)) + + if (verbose) { + message("EM multi-variate normal with Nc =", Nc, ":\n") + } + + while (iter < Niter.max) { + ## calculate responsabilities from the likelihood terms; + ## calculations are done in log-space to avoid numerical + ## difficulties if some points are far away from some + ## component and hence recieve very low density + for (i in seq(Nc)) { + lli[, i] <- log(pEst[i]) + dmvnorm(X, muEst[i, ], as.matrix(covEst[i, , ]), log = TRUE, checkSymmetry = FALSE) + } + ## ensure that the log-likelihood does not go out of numerical + ## reasonable bounds + lli <- apply(lli, 2, pmax, -30) + ## lnresp <- apply(lli, 1, log_sum_exp) + lnresp <- matrixStats::rowLogSumExps(lli) + ## the log-likelihood is then given by the sum of lresp + lliCur <- sum(lnresp) + ## record current state + traceMix <- c(traceMix, list(list(p = pEst, mean = muEst, sigma = covEst))) + traceLli <- c(traceLli, lliCur) + if (iter > 1) { + ## Dlli is the slope of the log-likelihood evaulated with + ## a second order method + Dlli <- (traceLli[iter + 1] - traceLli[iter - 1]) / 2 + } + if (Nc > 1) { + smean <- apply(runMixPar[order(runOrder), , , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) + } else { + smean <- apply(runMixPar[order(runOrder), -1, , drop = FALSE], c(2, 3), function(x) mean(abs(diff(x)))) + eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) + } + if (is.na(eps.converged)) eps.converged <- 0 + if (verbose) { + message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep = "") + } + if (checkTol & Dlli < tol) { + break } - pEst <- mix_init$p - muEst <- mix_init$center - covEst <- mix_init$cov - - ## take current estimates and transform to scale on which - ## convergence is assessed - est2par <- function(p, mu, cov) { - est <- rbind(logit(p), matrix(sapply(1:Nc, function(i) mv2vec(mu[i,], cov[i,,])), ncol=Nc)) - est[(1+Nd+1):(1+2*Nd),] <- log(est[(1+Nd+1):(1+2*Nd),]) - est + if (iter >= Neps & checkEps & eps.converged == Npar) { + break } - ## in case tolerance is not specified, then this criteria is - ## ignored - if(missing(tol)) { - checkTol <- FALSE - tol <- -1 - } else - checkTol <- TRUE - - if(missing(Neps)) { - ## in case tolerance has been declared, but Neps not, we flag - ## to disable checking of running mean convergence check - checkEps <- FALSE - Neps <- 5 - } else - checkEps <- TRUE - - ## if nothing is specified, we declare convergence based on a - ## running mean of differences in parameter estimates - if(!checkTol & !checkEps) { - checkEps <- TRUE + ## ... and the responseability matrix follows from this by + ## appropiate normalization. + lresp <- sweep(lli, 1, lnresp, "-") + ## resp <- exp(lresp) + + ## mean probability to be in a specific mixture component -> updates + ## pEst + ## lzSum <- apply(lresp, 2, log_sum_exp) + lzSum <- colLogSumExps(lresp) + ## zSum <- exp(lzSum) + pEst <- exp(lzSum - logN) + + ## make sure it is scale to exactly 1 which may not happen due + ## to small rounding issues + pEst <- pEst / sum(pEst) + + ## now obtain new estimates for each component of the mixtures + ## of their mu vector and covariance matrices + for (i in seq(Nc)) { + upd <- cov.wt(X, exp(lresp[, i] - lzSum[i]), method = "ML") + ## upd <- cov.wt(X, resp[,i]/zSum[i], method="ML") + muEst[i, ] <- upd$center + covEst[i, , ] <- upd$cov + ## ensure that diagonal stays non-zero + for (j in 1:Nd) { + covEst[i, j, j] <- max(covEst[i, j, j], .Machine$double.eps) + } } - assert_that(Neps > 1) - assert_that(ceiling(Neps) == floor(Neps)) + ind <- 1 + iter %% Neps + runMixPar[ind, , ] <- est2par(pEst, muEst, covEst) + runOrder[ind] <- iter - ## eps can also be given as a single integer which is interpreted - ## as number of digits - if(length(eps) == 1) eps <- rep(10^(-eps), 3) + iter <- iter + 1 + } + if (iter + 1 == Niter.max) { + warning("Maximum number of iterations reached.") + } - ## degrees of freedom - ## covariance matrix df per component - cov.df <- (Nd-1)*Nd/2 + Nd - df <- Nc * (Nd + cov.df) + Nc-1 - df.comp <- cov.df + Nd + 1 + ## sort by largest weight + o <- order(pEst, decreasing = TRUE) + pEst <- pEst[o] + muEst <- muEst[o, , drop = FALSE] + covEst <- covEst[o, , , drop = FALSE] - ## expand eps according to the dimensionality - eps <- c(eps[1], rep(eps[2], Nd), rep(eps[3], Nd), rep(eps[2], (Nd-1)*Nd/2)) + ## if(Nd != 1) { + ## rhoEst <- array(apply(covEst, 1, cov2cor), c(Nd,Nd,Nc)) + ## rhoEst <- apply(rhoEst, 3, function(x) x[lower.tri(x)]) + ## tauEst <- sqrt(t(apply(covEst, 1, diag))) + ## } else { + ## rhoEst <- NULL + ## tauEst <- sqrt(as.vector(covEst)) + ## } - iter <- 0 - logN <- log(N) - traceMix <- list() - traceLli <- c() - Dlli <- Inf - runMixPar <- array(-Inf, dim=c(Neps,df.comp,Nc)) - runOrder <- 0:(Neps-1) - if(Nc == 1) Npar <- df else Npar <- df + 1 + ## mixEst <- list(p=pEst, mean=muEst, sigma=covEst) - ## initialize component and element wise log-likelihood matrix - lli <- array(-20, dim=c(N,Nc)) + mixEst <- do.call(mixmvnorm, lapply(1:Nc, function(i) c(pEst[i], muEst[i, , drop = TRUE], matrix(covEst[i, , ], Nd, Nd)))) - if(verbose) { - message("EM multi-variate normal with Nc =", Nc, ":\n") - } + ## give further details + attr(mixEst, "df") <- df + attr(mixEst, "nobs") <- N + attr(mixEst, "lli") <- lliCur - while(iter < Niter.max) { - ## calculate responsabilities from the likelihood terms; - ## calculations are done in log-space to avoid numerical - ## difficulties if some points are far away from some - ## component and hence recieve very low density - for(i in seq(Nc)) { - lli[,i] <- log(pEst[i]) + dmvnorm(X, muEst[i,], as.matrix(covEst[i,,]), log=TRUE, checkSymmetry=FALSE) - } - ## ensure that the log-likelihood does not go out of numerical - ## reasonable bounds - lli <- apply(lli, 2, pmax, -30) - ##lnresp <- apply(lli, 1, log_sum_exp) - lnresp <- matrixStats::rowLogSumExps(lli) - ## the log-likelihood is then given by the sum of lresp - lliCur <- sum(lnresp) - ## record current state - traceMix <- c(traceMix, list(list(p=pEst, mean=muEst, sigma=covEst))) - traceLli <- c(traceLli, lliCur) - if(iter > 1) { - ## Dlli is the slope of the log-likelihood evaulated with - ## a second order method - Dlli <- (traceLli[iter+1] - traceLli[iter - 1])/2 - } - if(Nc > 1) { - smean <- apply(runMixPar[order(runOrder),,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps, "-") < 0) - } else { - smean <- apply(runMixPar[order(runOrder),-1,,drop=FALSE], c(2,3), function(x) mean(abs(diff(x)))) - eps.converged <- sum(sweep(smean, 1, eps[-1], "-") < 0) - } - if(is.na(eps.converged)) eps.converged <- 0 - if(verbose) - message("Iteration ", iter, ": log-likelihood = ", lliCur, "; Dlli = ", Dlli, "; converged = ", eps.converged, " / ", Npar, "\n", sep="") - if(checkTol & Dlli < tol) { - break - } - if(iter >= Neps & checkEps & eps.converged == Npar) { - break - } - ## ... and the responseability matrix follows from this by - ## appropiate normalization. - lresp <- sweep(lli, 1, lnresp, "-") - ##resp <- exp(lresp) - - ## mean probability to be in a specific mixture component -> updates - ## pEst - ##lzSum <- apply(lresp, 2, log_sum_exp) - lzSum <- colLogSumExps(lresp) - ##zSum <- exp(lzSum) - pEst <- exp(lzSum - logN) - - ## make sure it is scale to exactly 1 which may not happen due - ## to small rounding issues - pEst <- pEst / sum(pEst) - - ## now obtain new estimates for each component of the mixtures - ## of their mu vector and covariance matrices - for(i in seq(Nc)) { - upd <- cov.wt(X, exp(lresp[,i] - lzSum[i]), method="ML") - ##upd <- cov.wt(X, resp[,i]/zSum[i], method="ML") - muEst[i,] <- upd$center - covEst[i,,] <- upd$cov - ## ensure that diagonal stays non-zero - for(j in 1:Nd) - covEst[i,j,j] <- max(covEst[i,j,j], .Machine$double.eps) - } - - ind <- 1 + iter %% Neps - runMixPar[ind,,] <- est2par(pEst, muEst, covEst) - runOrder[ind] <- iter - - iter <- iter + 1 - } - if(iter+1 == Niter.max) - warning("Maximum number of iterations reached.") - - ## sort by largest weight - o <- order(pEst, decreasing=TRUE) - pEst <- pEst[o] - muEst <- muEst[o,,drop=FALSE] - covEst <- covEst[o,,,drop=FALSE] - - ##if(Nd != 1) { - ## rhoEst <- array(apply(covEst, 1, cov2cor), c(Nd,Nd,Nc)) - ## rhoEst <- apply(rhoEst, 3, function(x) x[lower.tri(x)]) - ## tauEst <- sqrt(t(apply(covEst, 1, diag))) - ##} else { - ## rhoEst <- NULL - ## tauEst <- sqrt(as.vector(covEst)) - ##} - - ##mixEst <- list(p=pEst, mean=muEst, sigma=covEst) - - mixEst <- do.call(mixmvnorm, lapply(1:Nc, function(i) c(pEst[i], muEst[i,,drop=TRUE], matrix(covEst[i,,], Nd, Nd)))) - - ## give further details - attr(mixEst, "df") <- df - attr(mixEst, "nobs") <- N - attr(mixEst, "lli") <- lliCur - - attr(mixEst, "Nc") <- Nc - - convert <- function(est) suppressWarnings(do.call(mixmvnorm, lapply(1:Nc, function(i) c(est$p[i], est$mean[i,,drop=FALSE], matrix(est$sigma[i,,], Nd, Nd))))) - - attr(mixEst, "tol") <- tol - attr(mixEst, "traceLli") <- traceLli - attr(mixEst, "traceMix") <- lapply(traceMix, convert) - attr(mixEst, "x") <- X - - class(mixEst) <- c("EM", "EMmvnmm", "mvnormMix", "mix") - - mixEst + attr(mixEst, "Nc") <- Nc + + convert <- function(est) suppressWarnings(do.call(mixmvnorm, lapply(1:Nc, function(i) c(est$p[i], est$mean[i, , drop = FALSE], matrix(est$sigma[i, , ], Nd, Nd))))) + + attr(mixEst, "tol") <- tol + attr(mixEst, "traceLli") <- traceLli + attr(mixEst, "traceMix") <- lapply(traceMix, convert) + attr(mixEst, "x") <- X + + class(mixEst) <- c("EM", "EMmvnmm", "mvnormMix", "mix") + + mixEst } ## uni-variate case -EM_nmm <- function(X, Nc, mix_init, verbose=FALSE, Niter.max=500, tol, Neps, eps=c(w=0.005,m=0.005,s=0.005)) { - if(is.matrix(X)) { - assert_matrix(X, any.missing=FALSE, ncols=1) +EM_nmm <- function(X, Nc, mix_init, verbose = FALSE, Niter.max = 500, tol, Neps, eps = c(w = 0.005, m = 0.005, s = 0.005)) { + if (is.matrix(X)) { + assert_matrix(X, any.missing = FALSE, ncols = 1) + } + mixEst <- EM_mnmm(X = X, Nc = Nc, mix_init = mix_init, verbose = verbose, Niter.max = Niter.max, tol = tol, Neps = Neps, eps = eps) + rownames(mixEst) <- c("w", "m", "s") + class(mixEst) <- c("EM", "EMnmm", "normMix", "mix") + attr(mixEst, "traceMix") <- lapply( + attr(mixEst, "traceMix"), + function(x) { + class(x) <- class(mixEst) + rownames(x) <- rownames(mixEst) + x } - mixEst <- EM_mnmm(X=X, Nc=Nc, mix_init=mix_init, verbose=verbose, Niter.max=Niter.max, tol=tol, Neps=Neps, eps=eps) - rownames(mixEst) <- c("w", "m", "s") - class(mixEst) <- c("EM", "EMnmm", "normMix", "mix") - attr(mixEst, "traceMix") <- lapply(attr(mixEst, "traceMix"), - function(x) { - class(x) <- class(mixEst) - rownames(x) <- rownames(mixEst) - x - }) - likelihood(mixEst) <- "normal" - mixEst + ) + likelihood(mixEst) <- "normal" + mixEst } #' @export print.EMnmm <- function(x, ...) { - cat("EM for Normal Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n",sep="") - NextMethod() + cat("EM for Normal Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n", sep = "") + NextMethod() } #' @export print.EMmvnmm <- function(x, ...) { - cat("EM for Multivariate Normal Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n",sep="") - NextMethod() + cat("EM for Multivariate Normal Mixture Model\nLog-Likelihood = ", logLik(x), "\n\n", sep = "") + NextMethod() } ## given a vector of means and a covariance matrix for a multi-variate ## normal (and optionally a vector of df), return a vector of ## coefficients with a deterministic mapping -mv2vec <- function(mean, sigma, df, label=TRUE) { - Nd <- length(mean) - if(Nd != 1) { - rho <- cov2cor(sigma)[lower.tri(sigma)] - tau <- sqrt(diag(sigma)) +mv2vec <- function(mean, sigma, df, label = TRUE) { + Nd <- length(mean) + if (Nd != 1) { + rho <- cov2cor(sigma)[lower.tri(sigma)] + tau <- sqrt(diag(sigma)) + } else { + rho <- NULL + tau <- sqrt(sigma) + } + if (missing(df)) df <- NULL + res <- c(mean, tau, rho, df) + if (label) { + tauN <- paste("sd", 1:Nd, sep = "") + cols <- names(mean) + if (is.null(cols)) { + cols <- paste("mu", 1:Nd, sep = "") + } + if (Nd == 1) { + corNames <- NULL + } else if (length(cols) == 2) { + corNames <- "cor" } else { - rho <- NULL - tau <- sqrt(sigma) + corNames <- outer(cols, cols, paste, sep = "_") + corNames <- paste("cor", corNames[lower.tri(corNames)], sep = ".") } - if(missing(df)) df <- NULL - res <- c(mean, tau, rho, df) - if(label) { - tauN <- paste("sd", 1:Nd, sep="") - cols <- names(mean) - if(is.null(cols)) - cols <- paste("mu", 1:Nd, sep="") - if(Nd == 1) - corNames <- NULL - else if(length(cols) == 2) - corNames <- "cor" - else { - corNames <- outer(cols, cols, paste, sep="_") - corNames <- paste("cor", corNames[lower.tri(corNames)], sep=".") - } - if(!is.null(df)) - dfNames <- paste("df", 1:Nd, sep="") - else - dfNames <- NULL - names(res) <- c(cols, tauN, corNames, dfNames) + if (!is.null(df)) { + dfNames <- paste("df", 1:Nd, sep = "") + } else { + dfNames <- NULL } - return(res) + names(res) <- c(cols, tauN, corNames, dfNames) + } + return(res) } ## vec2mv <- function(vec) { diff --git a/R/EM_msmm.R b/R/EM_msmm.R index 5fd29f3..c5c6fce 100644 --- a/R/EM_msmm.R +++ b/R/EM_msmm.R @@ -1,4 +1,3 @@ - ## EM for MSMM (Multi-variate Student t Mixture Model) with Nc components ## if init is not specified, then knn is used to initialize means, ## cluster weights and covariance matrices (taken from the knn @@ -8,212 +7,217 @@ ## modelling using the t distribution". D. Peel and G.J. McLachlan, ## Statistics and Computing (2000), 10, 339-348, -EM_msmm <- function(X, Nc, init, Ninit=50, verbose=TRUE, Niter.max=500, tol=1e-1) { - ## in case X is no matrix, interpret it as uni-variate case - if(!is.matrix(X)) - X <- matrix(X,ncol=1) - - N <- dim(X)[1] - Nd <- dim(X)[2] - - ## initialize randomly - if(missing(init)) { - ## assume that the sample is ordered randomly - ind <- seq(1,N-Nc,length=Ninit) - knnInit <- list(mu=matrix(0,nrow=Nc,ncol=Nd), p=(1/seq(1,Nc))/sum(seq(1,Nc))) - for(k in seq(Nc)) - knnInit$mu[k,] <- colMeans(X[ind+k-1,,drop=FALSE]) - ## use k means clustering with K=Nc as init; ignore warnings - ## as we may hit the maximal number of iterations - suppressWarnings(KNN <- knn(X, K=Nc, init=knnInit, verbose=verbose, Niter.max=50)) - pEst <- KNN$p - cmin <- which.min(pEst) - muEst <- KNN$center - ##nuEst <- rlnorm(Nc, log(20), log(5)/1.96) ## avoid randomness during initialization - nuEst <- rep(12, times=Nc) - covEst <- array(0, dim=c(Nc, Nd, Nd)) - Xtau <- sqrt(colVars(X)) - for(i in seq(Nc)) { - if(i == cmin) next - ind <- KNN$cluster==i - if(sum(ind) > 10) { - covKNN <- as.matrix(cov(X[ind,,drop=FALSE])) - R <- cov2cor(covKNN) - tau <- sqrt(diag(covKNN)) - ## set variances below or equal to 0 to the sample variance - tau[tau <= 0] <- Xtau[tau <= 0] - } else { - R <- diag(Nd) - tau <- Xtau - } - ##tauR <- rlnorm(Nd, log(tau), log(3)/1.96) - ##covEst[i,,] <- diag(tauR, Nd, Nd) %*% R %*% diag(tauR, Nd, Nd) - ## ensure that the smallest variance is not less than the global - ## variance divided by 100... which is to stabilize things - tau <- pmax(tau, Xtau / 100) - covEst[i,,] <- diag(tau, Nd, Nd) %*% R %*% diag(tau, Nd, Nd) - } - ##tauR <- rlnorm(Nd, log(Xtau), log(3)/1.96) - ##covEst[cmin,,] <- diag(tauR, Nd, Nd) %*% diag(Nd) %*% diag(tauR, Nd, Nd) - covEst[cmin,,] <- diag(Xtau, Nd, Nd) %*% diag(Nd) %*% diag(Xtau, Nd, Nd) - muEst[cmin] <- sum(pEst * muEst) - } else { - pEst <- init$p - muEst <- init$center - nuEst <- init$nu - covEst <- init$cov +EM_msmm <- function(X, Nc, init, Ninit = 50, verbose = TRUE, Niter.max = 500, tol = 1e-1) { + ## in case X is no matrix, interpret it as uni-variate case + if (!is.matrix(X)) { + X <- matrix(X, ncol = 1) + } + + N <- dim(X)[1] + Nd <- dim(X)[2] + + ## initialize randomly + if (missing(init)) { + ## assume that the sample is ordered randomly + ind <- seq(1, N - Nc, length = Ninit) + knnInit <- list(mu = matrix(0, nrow = Nc, ncol = Nd), p = (1 / seq(1, Nc)) / sum(seq(1, Nc))) + for (k in seq(Nc)) { + knnInit$mu[k, ] <- colMeans(X[ind + k - 1, , drop = FALSE]) } - - iter <- 0 - logN <- log(N) - traceLli <- c() - Dlli <- Inf - - ## initialize component and element wise log-likelihood matrix - lli <- array(-20, dim=c(N,Nc)) - - ## and the log(U) matrix which is the inverse mahalanobis distances - ## decorated with nuEst - lU <- array(0, dim=c(N,Nc)) - - if(verbose) { - message("EM multi-variate student t with Nc =", Nc, ":\n") + ## use k means clustering with K=Nc as init; ignore warnings + ## as we may hit the maximal number of iterations + suppressWarnings(KNN <- knn(X, K = Nc, init = knnInit, verbose = verbose, Niter.max = 50)) + pEst <- KNN$p + cmin <- which.min(pEst) + muEst <- KNN$center + ## nuEst <- rlnorm(Nc, log(20), log(5)/1.96) ## avoid randomness during initialization + nuEst <- rep(12, times = Nc) + covEst <- array(0, dim = c(Nc, Nd, Nd)) + Xtau <- sqrt(colVars(X)) + for (i in seq(Nc)) { + if (i == cmin) next + ind <- KNN$cluster == i + if (sum(ind) > 10) { + covKNN <- as.matrix(cov(X[ind, , drop = FALSE])) + R <- cov2cor(covKNN) + tau <- sqrt(diag(covKNN)) + ## set variances below or equal to 0 to the sample variance + tau[tau <= 0] <- Xtau[tau <= 0] + } else { + R <- diag(Nd) + tau <- Xtau + } + ## tauR <- rlnorm(Nd, log(tau), log(3)/1.96) + ## covEst[i,,] <- diag(tauR, Nd, Nd) %*% R %*% diag(tauR, Nd, Nd) + ## ensure that the smallest variance is not less than the global + ## variance divided by 100... which is to stabilize things + tau <- pmax(tau, Xtau / 100) + covEst[i, , ] <- diag(tau, Nd, Nd) %*% R %*% diag(tau, Nd, Nd) } - - nu_ml <- function(c1) { - function(nu) { - (log(nu/2) - digamma(nu/2) + c1 + digamma((nu+Nd)/2) - log((nu+Nd)/2))^2 - } + ## tauR <- rlnorm(Nd, log(Xtau), log(3)/1.96) + ## covEst[cmin,,] <- diag(tauR, Nd, Nd) %*% diag(Nd) %*% diag(tauR, Nd, Nd) + covEst[cmin, , ] <- diag(Xtau, Nd, Nd) %*% diag(Nd) %*% diag(Xtau, Nd, Nd) + muEst[cmin] <- sum(pEst * muEst) + } else { + pEst <- init$p + muEst <- init$center + nuEst <- init$nu + covEst <- init$cov + } + + iter <- 0 + logN <- log(N) + traceLli <- c() + Dlli <- Inf + + ## initialize component and element wise log-likelihood matrix + lli <- array(-20, dim = c(N, Nc)) + + ## and the log(U) matrix which is the inverse mahalanobis distances + ## decorated with nuEst + lU <- array(0, dim = c(N, Nc)) + + if (verbose) { + message("EM multi-variate student t with Nc =", Nc, ":\n") + } + + nu_ml <- function(c1) { + function(nu) { + (log(nu / 2) - digamma(nu / 2) + c1 + digamma((nu + Nd) / 2) - log((nu + Nd) / 2))^2 } - - while(iter < Niter.max) { - ## calculate responsabilities from the likelihood terms; - ## calculations are done in log-space to avoid numerical - ## difficulties if some points are far away from some - ## component and hence recieve very low density - for(i in seq(Nc)) { - lli[,i] <- log(pEst[i]) + mvtnorm::dmvt(X, muEst[i,], as.matrix(covEst[i,,]), nuEst[i], log=TRUE) - } - ## ensure that the log-likelihood does not go out of numerical - ## reasonable bounds - lli <- apply(lli, 2, pmax, -30) - ##lnresp <- apply(lli, 1, log_sum_exp) - lnresp <- matrixStats::rowLogSumExps(lli) - ## the log-likelihood is then given by the sum of lresp - lliCur <- sum(lnresp) - traceLli <- c(traceLli, lliCur) - if(iter > 1) { - ## Dlli is the slope of the log-likelihood evaulated with - ## a second order method - Dlli <- (traceLli[iter+1] - traceLli[iter - 1])/2 - } - if(verbose) - message("Iteration", iter, ": log-likelihood", lliCur, "; Dlli =", Dlli, "\n") - if(Dlli < tol) { - break - } - ## ... and the responisbility matrix follows from this by - ## appropiate normalization. - lresp <- sweep(lli, 1, lnresp, "-") ## Eq. 16 - resp <- exp(lresp) - - ## calculate additional weights of the U matrix aka latent - ## tail mass of a point - for(i in seq(Nc)) { - Xc_i <- sweep(X, 2L, muEst[i,]) - Sigma_i <- as.matrix(covEst[i,,]) - ## in rare cases the covariance matrix becomes (almost) - ## singular in which case the alternative cholesky - ## factorization gives more stable results - maha_dist <- tryCatch( - mahalanobis(Xc_i, FALSE, Sigma_i), - error = function(e) { - ## see https://stats.stackexchange.com/questions/147210/efficient-fast-mahalanobis-distance-computation - ## also adding eps to the diagonal to further stabilize the computation - L_i <- t(chol(Sigma_i + diag(5 * .Machine$double.eps, Nd, Nd))) - y_i <- forwardsolve(L_i, t(Xc_i)) - colSums(y_i^2) - } - ) - lU[,i] <- log(nuEst[i] + Nd) - log(nuEst[i] + maha_dist) ## Eq. 20 - } - - ## mean probability to be in a specific mixture component -> - ## updates pEst - ##lzSum <- apply(lresp, 2, log_sum_exp) - lzSum <- colLogSumExps(lresp) - zSum <- exp(lzSum) - ##zSum <- colSums(resp) - ##pEst <- zSum/N ## Eq. 29 - pEst <- exp(lzSum - logN) - - ## make sure it is scale to exactly 1 which may not happen due - ## to small rounding issues - pEst <- pEst/sum(pEst) - - ## product of u weight and responsabilities - lW <- lresp + lU ## intermediate formed, i.e. tau_ij * u_ij - ##wSum <- exp(apply(lW, 2, log_sum_exp)) - wSum <- exp(colLogSumExps(lW)) - ##wSum <- colSums(W) - - ## now obtain new estimates for each component of the mixtures - ## of their mu vector and covariance matrices - for(i in seq(Nc)) { - ##xc <- sqrt(W[,i]) * sweep(X, 2, muEst[i,], check.margin = FALSE) - ##covEst[i,,] <- crossprod(xc) / zSum[i] ## Eq. 31 - ##muEst[i,] <- colSums(W[,i] * X) / wSum[i] ## Eq. 30 - ##xc <- exp(0.5 * lW[,i]) * sweep(X, 2, muEst[i,], check.margin = FALSE) - ##covEst[i,,] <- crossprod(xc) / zSum[i] ## Eq. 31 - xc <- exp(0.5 * (lW[,i] - lzSum[i])) * sweep(X, 2, muEst[i,], check.margin = FALSE) - covEst[i,,] <- crossprod(xc) ## Eq. 31 (divisor moved to xc) - muEst[i,] <- colSums(exp(lW[,i]) * X) / wSum[i] ## Eq. 30 - ## ensure that diagonal stays non-zero - for(j in 1:Nd) - covEst[i,j,j] <- max(covEst[i,j,j], .Machine$double.eps) - } - - ## finally get the new nu estimates via numerical solution - ## first calculate necessary constants which don't involve v_i - ##c1 <- 1 + colSums(resp * (log(U) - U)) / zSum - c1 <- 1 + colSums(resp * (lU - exp(lU))) / zSum - for(i in seq(Nc)) { - nuEstML <- optimize(nu_ml(c1[i]), c(0,150)) # Eq. 32 - if(is.na(nuEstML$objective)) { - warning("Component ", i, " in iteration ", iter, " failed convergence.") - } else if(nuEstML$objective > 1e-3 & nuEstML$minimum < 50) { - ## only warn if we had trouble finding the minimum - ## when below 50, larger values are anyway normals - warning("Component ", i, " in iteration ", iter, " had convergence problems.\nObjective function = ",nuEstML$objective,"\n") - } - nuEst[i] <- nuEstML$minimum + } + + while (iter < Niter.max) { + ## calculate responsabilities from the likelihood terms; + ## calculations are done in log-space to avoid numerical + ## difficulties if some points are far away from some + ## component and hence recieve very low density + for (i in seq(Nc)) { + lli[, i] <- log(pEst[i]) + mvtnorm::dmvt(X, muEst[i, ], as.matrix(covEst[i, , ]), nuEst[i], log = TRUE) + } + ## ensure that the log-likelihood does not go out of numerical + ## reasonable bounds + lli <- apply(lli, 2, pmax, -30) + ## lnresp <- apply(lli, 1, log_sum_exp) + lnresp <- matrixStats::rowLogSumExps(lli) + ## the log-likelihood is then given by the sum of lresp + lliCur <- sum(lnresp) + traceLli <- c(traceLli, lliCur) + if (iter > 1) { + ## Dlli is the slope of the log-likelihood evaulated with + ## a second order method + Dlli <- (traceLli[iter + 1] - traceLli[iter - 1]) / 2 + } + if (verbose) { + message("Iteration", iter, ": log-likelihood", lliCur, "; Dlli =", Dlli, "\n") + } + if (Dlli < tol) { + break + } + ## ... and the responisbility matrix follows from this by + ## appropiate normalization. + lresp <- sweep(lli, 1, lnresp, "-") ## Eq. 16 + resp <- exp(lresp) + + ## calculate additional weights of the U matrix aka latent + ## tail mass of a point + for (i in seq(Nc)) { + Xc_i <- sweep(X, 2L, muEst[i, ]) + Sigma_i <- as.matrix(covEst[i, , ]) + ## in rare cases the covariance matrix becomes (almost) + ## singular in which case the alternative cholesky + ## factorization gives more stable results + maha_dist <- tryCatch( + mahalanobis(Xc_i, FALSE, Sigma_i), + error = function(e) { + ## see https://stats.stackexchange.com/questions/147210/efficient-fast-mahalanobis-distance-computation + ## also adding eps to the diagonal to further stabilize the computation + L_i <- t(chol(Sigma_i + diag(5 * .Machine$double.eps, Nd, Nd))) + y_i <- forwardsolve(L_i, t(Xc_i)) + colSums(y_i^2) } + ) + lU[, i] <- log(nuEst[i] + Nd) - log(nuEst[i] + maha_dist) ## Eq. 20 + } - iter <- iter + 1 + ## mean probability to be in a specific mixture component -> + ## updates pEst + ## lzSum <- apply(lresp, 2, log_sum_exp) + lzSum <- colLogSumExps(lresp) + zSum <- exp(lzSum) + ## zSum <- colSums(resp) + ## pEst <- zSum/N ## Eq. 29 + pEst <- exp(lzSum - logN) + + ## make sure it is scale to exactly 1 which may not happen due + ## to small rounding issues + pEst <- pEst / sum(pEst) + + ## product of u weight and responsabilities + lW <- lresp + lU ## intermediate formed, i.e. tau_ij * u_ij + ## wSum <- exp(apply(lW, 2, log_sum_exp)) + wSum <- exp(colLogSumExps(lW)) + ## wSum <- colSums(W) + + ## now obtain new estimates for each component of the mixtures + ## of their mu vector and covariance matrices + for (i in seq(Nc)) { + ## xc <- sqrt(W[,i]) * sweep(X, 2, muEst[i,], check.margin = FALSE) + ## covEst[i,,] <- crossprod(xc) / zSum[i] ## Eq. 31 + ## muEst[i,] <- colSums(W[,i] * X) / wSum[i] ## Eq. 30 + ## xc <- exp(0.5 * lW[,i]) * sweep(X, 2, muEst[i,], check.margin = FALSE) + ## covEst[i,,] <- crossprod(xc) / zSum[i] ## Eq. 31 + xc <- exp(0.5 * (lW[, i] - lzSum[i])) * sweep(X, 2, muEst[i, ], check.margin = FALSE) + covEst[i, , ] <- crossprod(xc) ## Eq. 31 (divisor moved to xc) + muEst[i, ] <- colSums(exp(lW[, i]) * X) / wSum[i] ## Eq. 30 + ## ensure that diagonal stays non-zero + for (j in 1:Nd) { + covEst[i, j, j] <- max(covEst[i, j, j], .Machine$double.eps) + } } - if(iter == Niter.max) - warning("Maximum number of iterations reached.") - - ## degrees of freedom - ## covariance matrix df per component - cov.df <- (Nd-1)*Nd/2 + Nd - df <- Nc * (Nd + cov.df) + Nc + Nc-1 - - ## sort by largest weight - o <- order(pEst, decreasing=TRUE) - pEst <- pEst[o] - muEst <- muEst[o,,drop=FALSE] - covEst <- covEst[o,,,drop=FALSE] - nuEst <- nuEst[o,drop=FALSE] - - if(Nd != 1) { - rhoEst <- array(apply(covEst, 1, cov2cor), c(Nd,Nd,Nc)) - rhoEst <- apply(rhoEst, 3, function(x) x[lower.tri(x)]) - tauEst <- sqrt(t(apply(covEst, 1, diag))) - } else { - rhoEst <- NULL - tauEst <- sqrt(as.vector(covEst)) + + ## finally get the new nu estimates via numerical solution + ## first calculate necessary constants which don't involve v_i + ## c1 <- 1 + colSums(resp * (log(U) - U)) / zSum + c1 <- 1 + colSums(resp * (lU - exp(lU))) / zSum + for (i in seq(Nc)) { + nuEstML <- optimize(nu_ml(c1[i]), c(0, 150)) # Eq. 32 + if (is.na(nuEstML$objective)) { + warning("Component ", i, " in iteration ", iter, " failed convergence.") + } else if (nuEstML$objective > 1e-3 & nuEstML$minimum < 50) { + ## only warn if we had trouble finding the minimum + ## when below 50, larger values are anyway normals + warning("Component ", i, " in iteration ", iter, " had convergence problems.\nObjective function = ", nuEstML$objective, "\n") + } + nuEst[i] <- nuEstML$minimum } - invisible(list(cov=covEst, center=muEst, nu=nuEst, p=pEst, rho=rhoEst, tau=tauEst, lli=lliCur, df=df, Dlli=Dlli, niter=iter)) + iter <- iter + 1 + } + if (iter == Niter.max) { + warning("Maximum number of iterations reached.") + } + + ## degrees of freedom + ## covariance matrix df per component + cov.df <- (Nd - 1) * Nd / 2 + Nd + df <- Nc * (Nd + cov.df) + Nc + Nc - 1 + + ## sort by largest weight + o <- order(pEst, decreasing = TRUE) + pEst <- pEst[o] + muEst <- muEst[o, , drop = FALSE] + covEst <- covEst[o, , , drop = FALSE] + nuEst <- nuEst[o, drop = FALSE] + + if (Nd != 1) { + rhoEst <- array(apply(covEst, 1, cov2cor), c(Nd, Nd, Nc)) + rhoEst <- apply(rhoEst, 3, function(x) x[lower.tri(x)]) + tauEst <- sqrt(t(apply(covEst, 1, diag))) + } else { + rhoEst <- NULL + tauEst <- sqrt(as.vector(covEst)) + } + + invisible(list(cov = covEst, center = muEst, nu = nuEst, p = pEst, rho = rhoEst, tau = tauEst, lli = lliCur, df = df, Dlli = Dlli, niter = iter)) } diff --git a/R/EM_plot.R b/R/EM_plot.R index 3919ca7..2e8c1cd 100644 --- a/R/EM_plot.R +++ b/R/EM_plot.R @@ -28,9 +28,9 @@ #' #' @examples #' -#' bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) +#' bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) #' bsamp <- rmix(bmix, 1000) -#' bfit <- mixfit(bsamp, type="beta", Nc=2) +#' bfit <- mixfit(bsamp, type = "beta", Nc = 2) #' pl <- plot(bfit) #' #' print(pl$mixdens) @@ -38,7 +38,7 @@ #' #' \donttest{ #' # a number of additional plots are generated in verbose mode -#' .user_option <- options(RBesT.verbose=TRUE) +#' .user_option <- options(RBesT.verbose = TRUE) #' pl_all <- plot(bfit) #' #' # recover previous user options @@ -50,149 +50,171 @@ #' #' @method plot EM #' @export -plot.EM <- function(x, size=1.25, link=c("identity", "logit", "log"), ...) { - pl <- list() - if(!is_mixmv(x)) - pl$mixdist <- plot.mix(x, size=size, ...) - ## in verbose mode we output EM fit diagnostics - if(getOption("RBesT.verbose", FALSE)) { - ## these NULL assignments make R check happy - a <- b <- w <- s <- comp <- iteration <- NULL - Nc <- ncol(x) - pseq <- lapply(attr(x, "traceMix"), - function(m) { - class(m) <- "matrix" - m <- as.data.frame(t(m)) - m$comp <- 1:Nc - m - }) - names(pseq) <- 1:length(pseq) - 1 - Mw <- dplyr::bind_rows(pseq, .id="iteration") - Mw <- Mw[c(1,5,2,3,4)] - Mw$iteration <- as.numeric(Mw$iteration) - if("EMbmm" %in% class(x)) { - Mw <- within(Mw, { - m <- a/(a+b) - N <- a+b - Lm <- logit(m) - lN <- log(N) - }) - if(Nc != 1) - Mw <- within(Mw, { Lw=logit(w) }) - } - if("EMnmm" %in% class(x)) { - Mw <- within(Mw, { ls=log(s) } ) - if(Nc != 1) - Mw <- within(Mw, { Lw=logit(w) }) - } - if("EMgmm" %in% class(x)) { - Mw <- within(Mw, { - la <- log(a) - lb <- log(b) - }) - if(Nc != 1) - Mw <- within(Mw, { Lw=logit(w) }) - } - pars <- names(Mw)[-c(1,2)] - Mw <- within(Mw, { Comp=factor(comp) } ) - LL <- data.frame(iteration=0:max(Mw$iteration), lli=attr(x, "traceLli")) - basePl <- ggplot(Mw, aes(x=.data$iteration, colour=.data$Comp)) + geom_line(size=size) - for(p in pars) { - pl[[p]] <- basePl + aes(y=.data$p) - } - pl$lli <- ggplot(subset(LL, iteration>0), aes(x=.data$iteration, y=.data$lli)) + geom_line(size=size) + ylab("log-likelihood") +plot.EM <- function(x, size = 1.25, link = c("identity", "logit", "log"), ...) { + pl <- list() + if (!is_mixmv(x)) { + pl$mixdist <- plot.mix(x, size = size, ...) + } + ## in verbose mode we output EM fit diagnostics + if (getOption("RBesT.verbose", FALSE)) { + ## these NULL assignments make R check happy + a <- b <- w <- s <- comp <- iteration <- NULL + Nc <- ncol(x) + pseq <- lapply( + attr(x, "traceMix"), + function(m) { + class(m) <- "matrix" + m <- as.data.frame(t(m)) + m$comp <- 1:Nc + m + } + ) + names(pseq) <- 1:length(pseq) - 1 + Mw <- dplyr::bind_rows(pseq, .id = "iteration") + Mw <- Mw[c(1, 5, 2, 3, 4)] + Mw$iteration <- as.numeric(Mw$iteration) + if ("EMbmm" %in% class(x)) { + Mw <- within(Mw, { + m <- a / (a + b) + N <- a + b + Lm <- logit(m) + lN <- log(N) + }) + if (Nc != 1) { + Mw <- within(Mw, { + Lw <- logit(w) + }) + } } - ##pl$mix <- plot.mix(x, comp=TRUE, samp=attr(x, "x"), ...) - link <- match.arg(link) - dlink(x) <- link_map[[link]] + if ("EMnmm" %in% class(x)) { + Mw <- within(Mw, { + ls <- log(s) + }) + if (Nc != 1) { + Mw <- within(Mw, { + Lw <- logit(w) + }) + } + } + if ("EMgmm" %in% class(x)) { + Mw <- within(Mw, { + la <- log(a) + lb <- log(b) + }) + if (Nc != 1) { + Mw <- within(Mw, { + Lw <- logit(w) + }) + } + } + pars <- names(Mw)[-c(1, 2)] + Mw <- within(Mw, { + Comp <- factor(comp) + }) + LL <- data.frame(iteration = 0:max(Mw$iteration), lli = attr(x, "traceLli")) + basePl <- ggplot(Mw, aes(x = .data$iteration, colour = .data$Comp)) + + geom_line(size = size) + for (p in pars) { + pl[[p]] <- basePl + aes(y = .data$p) + } + pl$lli <- ggplot(subset(LL, iteration > 0), aes(x = .data$iteration, y = .data$lli)) + + geom_line(size = size) + + ylab("log-likelihood") + } + ## pl$mix <- plot.mix(x, comp=TRUE, samp=attr(x, "x"), ...) + link <- match.arg(link) + dlink(x) <- link_map[[link]] - cols <- bayesplot::color_scheme_get(i=1:6) + cols <- bayesplot::color_scheme_get(i = 1:6) - if(!is_mixmv(x)) { - ## univariate case - samp <- data.frame(Sample=mixlink(x, as.vector(attr(x, "x")))) - ## workaround a weird bug in ggplot which enlarges the interval - interval <- quantile(samp$Sample, c(0.025, 0.975)) - n_fun <- 501 - max_span <- diff(range(samp)) - interval_span <- diff(interval) - n_fun <- min(5E3, round(n_fun * max_span/interval_span)) - - if(!is.dlink_identity(dlink(x))) - subtitle <- paste("Link:", dlink(x)$name) - else - subtitle <- NULL - - pl$mixdens <- bayesplot::mcmc_dens(samp) + bayesplot::facet_text(FALSE) + - stat_function(inherit.aes=FALSE, fun=dmix, args=list(mix=x), size=size, n=n_fun) + - ggtitle("Parametric Mixture (black line) and Kernel Estimate of Sample Density", subtitle=subtitle) + - bayesplot::xaxis_title(FALSE) - - pl$mixecdf <- ggplot(samp, aes(x=.data$Sample)) + - stat_ecdf(geom="area", size=0, fill=cols$light) + - stat_ecdf(geom="step", size=size, colour=cols$mid) + - stat_function(fun=pmix, args=list(mix=x), size=size, n=n_fun) + - ggtitle("Estimated Cumulative Density from Parametric Mixture (black line) and Sample", subtitle=subtitle) + - bayesplot::bayesplot_theme_get() + - bayesplot::yaxis_title(FALSE) + - bayesplot::xaxis_title(FALSE) + - bayesplot::facet_text(FALSE) - - pl$mix <- bayesplot::mcmc_hist(samp, binwidth=diff(interval)/50, freq=FALSE) + bayesplot::facet_text(FALSE) + - stat_function(inherit.aes=FALSE, fun=dmix, args=list(mix=x), size=size, n=n_fun) + - ggtitle("Parametric Mixture Density (black line) and Histogram of Sample", subtitle=subtitle) + - bayesplot::xaxis_title(FALSE) - } else if(inherits(x, "mvnormMix")) { - var1 <- var2 <- NULL - ## multivariate case: only support mvnorm for now (the only - ## one supported as of Aug 2023). Plot the pair-wise marginal - ## densities, which are the pair-wise marginal mixtures. - message("Diagnostic plots for mixture multivariate normal densities are experimental.\nPlease note that these are subject to changes in future releases.") - samp <- attr(x, "x") - p <- ncol(samp) - dim_labels <- mvnorm_dim_labels(x[-1,1]) - if(is.null(dim_labels)) - dim_labels <- paste0("Dimension ", 1:p) - breaks <- 60 - nbins <- 20 - pairs <- subset(expand.grid(var1=1:p, var2=1:p), var1 >= var2) - layout <- matrix(NA, nrow=p, ncol=p) - pl_pairs <- list() - pl_pairs_compact <- list() - for(i in seq_len(nrow(pairs))) { - v1 <- pairs$var1[i] - v2 <- pairs$var2[i] - label <- paste0("mixpair[", v2, ",", v1, "]") - mix_sub <- mvnorm_extract_dim(x, unique(c(v2, v1))) - layout[v1,v2] <- i - if (v1 == v2) { - interval <- quantile(samp[,v1], c(0.025, 0.975)) - pl_pairs[[label]] <- bayesplot::mcmc_hist(samp[,v1, drop=FALSE], binwidth=diff(interval)/50, freq=FALSE) + - bayesplot::facet_text(FALSE) + - stat_function(inherit.aes=FALSE, fun=function(mix, x) dmix(mix, matrix(x, nrow=length(x))), args=list(mix=mix_sub)) + - ylab(dim_labels[v2]) + - xlab(dim_labels[v2]) - } else { - data_ranges <- apply(samp[,c(v2, v1), drop=FALSE], 2, range) - colnames(data_ranges) <- c("x", "y") - data_grid <- expand.grid(apply(data_ranges, 2, function(r) seq(r[1], r[2], length=breaks), simplify=FALSE)) - data_grid$z <- dmix(mix_sub, as.matrix(data_grid), log=TRUE) - pl_pairs[[label]] <- bayesplot::mcmc_scatter(samp[,c(v2, v1), drop=FALSE], alpha=0.1) + - bayesplot::facet_text(FALSE) + - geom_contour(aes(z=.data$z), data=data_grid, bins=nbins, colour="black") + - xlab(dim_labels[v2]) + - ylab(dim_labels[v1]) - } - pl_pairs_compact[[label]] <- pl_pairs[[label]] - if(v1 != p) - pl_pairs_compact[[label]] <- pl_pairs_compact[[label]] + bayesplot::xaxis_title(FALSE) + bayesplot::xaxis_ticks(FALSE) + bayesplot::xaxis_text(FALSE) - if(v2 != 1) - pl_pairs_compact[[label]] <- pl_pairs_compact[[label]] + bayesplot::yaxis_title(FALSE) + bayesplot::yaxis_ticks(FALSE) + bayesplot::yaxis_text(FALSE) - } - pl$mixpairs <- bayesplot::bayesplot_grid(plots=pl_pairs_compact, grid_args=list(nrow=p, ncol=p, layout_matrix=layout)) - pl$mixpairs$bayesplots <- pl_pairs + if (!is_mixmv(x)) { + ## univariate case + samp <- data.frame(Sample = mixlink(x, as.vector(attr(x, "x")))) + ## workaround a weird bug in ggplot which enlarges the interval + interval <- quantile(samp$Sample, c(0.025, 0.975)) + n_fun <- 501 + max_span <- diff(range(samp)) + interval_span <- diff(interval) + n_fun <- min(5E3, round(n_fun * max_span / interval_span)) + + if (!is.dlink_identity(dlink(x))) { + subtitle <- paste("Link:", dlink(x)$name) + } else { + subtitle <- NULL } - pl -} + pl$mixdens <- bayesplot::mcmc_dens(samp) + bayesplot::facet_text(FALSE) + + stat_function(inherit.aes = FALSE, fun = dmix, args = list(mix = x), size = size, n = n_fun) + + ggtitle("Parametric Mixture (black line) and Kernel Estimate of Sample Density", subtitle = subtitle) + + bayesplot::xaxis_title(FALSE) + pl$mixecdf <- ggplot(samp, aes(x = .data$Sample)) + + stat_ecdf(geom = "area", size = 0, fill = cols$light) + + stat_ecdf(geom = "step", size = size, colour = cols$mid) + + stat_function(fun = pmix, args = list(mix = x), size = size, n = n_fun) + + ggtitle("Estimated Cumulative Density from Parametric Mixture (black line) and Sample", subtitle = subtitle) + + bayesplot::bayesplot_theme_get() + + bayesplot::yaxis_title(FALSE) + + bayesplot::xaxis_title(FALSE) + + bayesplot::facet_text(FALSE) + + pl$mix <- bayesplot::mcmc_hist(samp, binwidth = diff(interval) / 50, freq = FALSE) + bayesplot::facet_text(FALSE) + + stat_function(inherit.aes = FALSE, fun = dmix, args = list(mix = x), size = size, n = n_fun) + + ggtitle("Parametric Mixture Density (black line) and Histogram of Sample", subtitle = subtitle) + + bayesplot::xaxis_title(FALSE) + } else if (inherits(x, "mvnormMix")) { + var1 <- var2 <- NULL + ## multivariate case: only support mvnorm for now (the only + ## one supported as of Aug 2023). Plot the pair-wise marginal + ## densities, which are the pair-wise marginal mixtures. + message("Diagnostic plots for mixture multivariate normal densities are experimental.\nPlease note that these are subject to changes in future releases.") + samp <- attr(x, "x") + p <- ncol(samp) + dim_labels <- mvnorm_dim_labels(x[-1, 1]) + if (is.null(dim_labels)) { + dim_labels <- paste0("Dimension ", 1:p) + } + breaks <- 60 + nbins <- 20 + pairs <- subset(expand.grid(var1 = 1:p, var2 = 1:p), var1 >= var2) + layout <- matrix(NA, nrow = p, ncol = p) + pl_pairs <- list() + pl_pairs_compact <- list() + for (i in seq_len(nrow(pairs))) { + v1 <- pairs$var1[i] + v2 <- pairs$var2[i] + label <- paste0("mixpair[", v2, ",", v1, "]") + mix_sub <- mvnorm_extract_dim(x, unique(c(v2, v1))) + layout[v1, v2] <- i + if (v1 == v2) { + interval <- quantile(samp[, v1], c(0.025, 0.975)) + pl_pairs[[label]] <- bayesplot::mcmc_hist(samp[, v1, drop = FALSE], binwidth = diff(interval) / 50, freq = FALSE) + + bayesplot::facet_text(FALSE) + + stat_function(inherit.aes = FALSE, fun = function(mix, x) dmix(mix, matrix(x, nrow = length(x))), args = list(mix = mix_sub)) + + ylab(dim_labels[v2]) + + xlab(dim_labels[v2]) + } else { + data_ranges <- apply(samp[, c(v2, v1), drop = FALSE], 2, range) + colnames(data_ranges) <- c("x", "y") + data_grid <- expand.grid(apply(data_ranges, 2, function(r) seq(r[1], r[2], length = breaks), simplify = FALSE)) + data_grid$z <- dmix(mix_sub, as.matrix(data_grid), log = TRUE) + pl_pairs[[label]] <- bayesplot::mcmc_scatter(samp[, c(v2, v1), drop = FALSE], alpha = 0.1) + + bayesplot::facet_text(FALSE) + + geom_contour(aes(z = .data$z), data = data_grid, bins = nbins, colour = "black") + + xlab(dim_labels[v2]) + + ylab(dim_labels[v1]) + } + pl_pairs_compact[[label]] <- pl_pairs[[label]] + if (v1 != p) { + pl_pairs_compact[[label]] <- pl_pairs_compact[[label]] + bayesplot::xaxis_title(FALSE) + bayesplot::xaxis_ticks(FALSE) + bayesplot::xaxis_text(FALSE) + } + if (v2 != 1) { + pl_pairs_compact[[label]] <- pl_pairs_compact[[label]] + bayesplot::yaxis_title(FALSE) + bayesplot::yaxis_ticks(FALSE) + bayesplot::yaxis_text(FALSE) + } + } + pl$mixpairs <- bayesplot::bayesplot_grid(plots = pl_pairs_compact, grid_args = list(nrow = p, ncol = p, layout_matrix = layout)) + pl$mixpairs$bayesplots <- pl_pairs + } + + pl +} diff --git a/R/KLdivmix.R b/R/KLdivmix.R index ed4a3db..a16d627 100644 --- a/R/KLdivmix.R +++ b/R/KLdivmix.R @@ -1,9 +1,12 @@ ## Kullback-Leibler distance between mixtures KLdivmix <- function(mixRef, mixTest) { - interval <- support(mixRef) - if(!all(interval == support(mixRef))) - warning("Support of mixRef and mixTest do not match.") - ## note: setting stop.on.error to FALSE manages to avoid boundary - ## value issues - integrate(function(x) { dmix(mixRef, x) * (dmix(mixRef,x,log=TRUE) - dmix(mixTest,x,log=TRUE)) }, interval[1], interval[2], stop.on.error=FALSE )$value + interval <- support(mixRef) + if (!all(interval == support(mixRef))) { + warning("Support of mixRef and mixTest do not match.") + } + ## note: setting stop.on.error to FALSE manages to avoid boundary + ## value issues + integrate(function(x) { + dmix(mixRef, x) * (dmix(mixRef, x, log = TRUE) - dmix(mixTest, x, log = TRUE)) + }, interval[1], interval[2], stop.on.error = FALSE)$value } diff --git a/R/RBesT-package.R b/R/RBesT-package.R index 14cc304..007405e 100644 --- a/R/RBesT-package.R +++ b/R/RBesT-package.R @@ -49,7 +49,7 @@ #' Stan Development Team (2020). RStan: the R interface to Stan. R package version 2.19.3. https://mc-stan.org #' #' @useDynLib RBesT, .registration = TRUE -#' +#' # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! ## usethis namespace: start diff --git a/R/SimSum.R b/R/SimSum.R index feba1d7..5757fa4 100644 --- a/R/SimSum.R +++ b/R/SimSum.R @@ -20,25 +20,25 @@ #' @keywords internal #' `SimSum` <- -function( x, min.max=FALSE, n.sim=FALSE, probs=c(0.025,0.5,0.975), margin=ifelse(is.null(dim(x) | length(dim(x)) == 1), 2, length(dim(x))) ) -{ - # Version 1.1, 16-Oct-2014 - if(is.null(dim(x)) | length(dim(x)) == 1) - x <- matrix(x, ncol=1) + function(x, min.max = FALSE, n.sim = FALSE, probs = c(0.025, 0.5, 0.975), margin = ifelse(is.null(dim(x) | length(dim(x)) == 1), 2, length(dim(x)))) { + # Version 1.1, 16-Oct-2014 + if (is.null(dim(x)) | length(dim(x)) == 1) { + x <- matrix(x, ncol = 1) + } sfun <- function(r) { - ex <- if(min.max) c(min=min(r), max=max(r)) else NULL - N <- if(n.sim) c(nsim=length(r)) else NULL - c( mean=mean(r), sd=sd(r), quantile(r,probs), ex, N ) + ex <- if (min.max) c(min = min(r), max = max(r)) else NULL + N <- if (n.sim) c(nsim = length(r)) else NULL + c(mean = mean(r), sd = sd(r), quantile(r, probs), ex, N) } sim.out <- apply(x, margin, sfun) ## to ensure compatibility with old versions of the function, a ## transpose is needed for the standard case of margin being 2 - if(is.matrix(x) && margin == 2) - sim.out <- t(sim.out) + if (is.matrix(x) && margin == 2) { + sim.out <- t(sim.out) + } return(sim.out) -} - + } diff --git a/R/automixfit.R b/R/automixfit.R index a84b814..eb3a776 100644 --- a/R/automixfit.R +++ b/R/automixfit.R @@ -38,51 +38,52 @@ #' #' @examples #' # random sample of size 1000 from a mixture of 2 beta components -#' bm <- mixbeta(beta1=c(0.4, 20, 90), beta2=c(0.6, 35, 65)) +#' bm <- mixbeta(beta1 = c(0.4, 20, 90), beta2 = c(0.6, 35, 65)) #' bmSamp <- rmix(bm, 1000) #' #' # fit with EM mixture models with up to 10 components and stop if #' # AIC increases -#' bmFit <- automixfit(bmSamp, Nc=1:10, thresh=0, type="beta") +#' bmFit <- automixfit(bmSamp, Nc = 1:10, thresh = 0, type = "beta") #' bmFit #' #' # advanced usage: find out about all discarded models #' bmFitAll <- attr(bmFit, "models") #' -#' sapply(bmFitAll, AIC, k=6) -#' +#' sapply(bmFitAll, AIC, k = 6) #' #' @export -automixfit <- function(sample, Nc=seq(1, 4), k=6, thresh=-Inf, verbose=FALSE, ...) { - if("gMAPpred" %in% class(sample)) { - stop("Not yet supported.") +automixfit <- function(sample, Nc = seq(1, 4), k = 6, thresh = -Inf, verbose = FALSE, ...) { + if ("gMAPpred" %in% class(sample)) { + stop("Not yet supported.") + } + assert_that(all(diff(Nc) >= 1)) + models <- list() + ic <- Inf + aic <- c() + for (i in seq_along(Nc)) { + curNc <- Nc[i] + icLast <- ic + if (!verbose) { + suppressMessages(run <- mixfit(sample, Nc = curNc, verbose = verbose, ...)) + } else { + run <- mixfit(sample, Nc = curNc, verbose = verbose, ...) + } + ic <- AIC(run, k = k) + aic <- c(aic, ic) + delta <- icLast - ic + if (verbose) { + message("Components", curNc, ": AIC", ic, "; deltaAIC =", delta, "\n") } - assert_that(all(diff(Nc) >=1 )) - models <- list() - ic <- Inf - aic <- c() - for(i in seq_along(Nc)) { - curNc <- Nc[i] - icLast <- ic - if(!verbose) - suppressMessages(run <- mixfit(sample, Nc=curNc, verbose=verbose, ...)) - else - run <- mixfit(sample, Nc=curNc, verbose=verbose, ...) - ic <- AIC(run, k=k) - aic <- c(aic, ic) - delta <- icLast - ic - if(verbose) - message("Components", curNc, ": AIC", ic, "; deltaAIC =", delta, "\n") - models <- c(models, list(run)) - if(delta < thresh) - break + models <- c(models, list(run)) + if (delta < thresh) { + break } - names(models) <- Nc[1:i] - o <- order(aic) - models <- models[o] - models - bestfit <- models[[1]] - attr(bestfit, "models") <- models - bestfit + } + names(models) <- Nc[1:i] + o <- order(aic) + models <- models[o] + models + bestfit <- models[[1]] + attr(bestfit, "models") <- models + bestfit } - diff --git a/R/chains2sample.R b/R/chains2sample.R index 9a044cc..35cb9be 100644 --- a/R/chains2sample.R +++ b/R/chains2sample.R @@ -2,10 +2,11 @@ #' sample. It is advisable to set order once per mcmc run, otherwise #' correlations in the mcmc sample will be lost. #' @keywords internal -chains2sample <- function(chains, order, drop=TRUE) { - d <- dim(chains) - N <- prod(d[2:3]) - if(missing(order)) - order <- sample.int(N) - matrix(chains, nrow=d[1], ncol=N)[,order,drop=drop] +chains2sample <- function(chains, order, drop = TRUE) { + d <- dim(chains) + N <- prod(d[2:3]) + if (missing(order)) { + order <- sample.int(N) + } + matrix(chains, nrow = d[1], ncol = N)[, order, drop = drop] } diff --git a/R/colVars.R b/R/colVars.R index c0491eb..20b852a 100644 --- a/R/colVars.R +++ b/R/colVars.R @@ -1,8 +1,7 @@ #' Fast column-wise calculation of unbiased variances #' @keywords internal colVars <- function(a) { - n <- dim(a)[[1]] - c <- dim(a)[[2]] - return(.colMeans(((a - matrix(.colMeans(a, n, c), nrow = n, ncol = c, byrow = TRUE)) ^ 2), n, c) * n / (n - 1)) + n <- dim(a)[[1]] + c <- dim(a)[[2]] + return(.colMeans(((a - matrix(.colMeans(a, n, c), nrow = n, ncol = c, byrow = TRUE))^2), n, c) * n / (n - 1)) } - diff --git a/R/crohn.R b/R/crohn.R index 8adf30f..c723bb2 100644 --- a/R/crohn.R +++ b/R/crohn.R @@ -19,10 +19,11 @@ #' @examples #' set.seed(546346) #' map_crohn <- gMAP(cbind(y, y.se) ~ 1 | study, -#' family=gaussian, -#' data=transform(crohn, y.se=88/sqrt(n)), -#' weights=n, -#' tau.dist="HalfNormal", tau.prior=44, -#' beta.prior=cbind(0,88)) +#' family = gaussian, +#' data = transform(crohn, y.se = 88 / sqrt(n)), +#' weights = n, +#' tau.dist = "HalfNormal", tau.prior = 44, +#' beta.prior = cbind(0, 88) +#' ) #' @template example-stop "crohn" diff --git a/R/dBetaBinomial.R b/R/dBetaBinomial.R index fa89711..0676886 100644 --- a/R/dBetaBinomial.R +++ b/R/dBetaBinomial.R @@ -8,16 +8,17 @@ #' #' @keywords internal #' -dBetaBinomial <- function(r, n, a, b, log=FALSE) { - assert_integerish(n, lower=0L, any.missing=FALSE) - assert_integerish(r, lower=0L, upper=max(n), any.missing=FALSE) - p <- lgamma(n+1)-lgamma(r+1)-lgamma(n-r+1)+lgamma(a+b)-lgamma(a)-lgamma(b)+lgamma(a+r)+lgamma(b+n-r)-lgamma(a+b+n); - if(log) - return(p) - exp(p); +dBetaBinomial <- function(r, n, a, b, log = FALSE) { + assert_integerish(n, lower = 0L, any.missing = FALSE) + assert_integerish(r, lower = 0L, upper = max(n), any.missing = FALSE) + p <- lgamma(n + 1) - lgamma(r + 1) - lgamma(n - r + 1) + lgamma(a + b) - lgamma(a) - lgamma(b) + lgamma(a + r) + lgamma(b + n - r) - lgamma(a + b + n) + if (log) { + return(p) + } + exp(p) } -##pBetaBinomial <- function(r, n, a, b, lower.tail=TRUE, log.p=FALSE) { +## pBetaBinomial <- function(r, n, a, b, lower.tail=TRUE, log.p=FALSE) { ## return(.pBetaBinomial(r, n, a, b, lower.tail, log.p)) -##} +## } diff --git a/R/decision1S.R b/R/decision1S.R index 6470d71..54cd34d 100644 --- a/R/decision1S.R +++ b/R/decision1S.R @@ -61,18 +61,18 @@ #' theta_ni <- 0.4 #' theta_a <- 0 #' alpha <- 0.05 -#' beta <- 0.2 -#' za <- qnorm(1-alpha) -#' zb <- qnorm(1-beta) -#' n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) # n for which design was intended +#' beta <- 0.2 +#' za <- qnorm(1 - alpha) +#' zb <- qnorm(1 - beta) +#' n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) # n for which design was intended #' nL <- 233 #' c1 <- theta_ni - za * s / sqrt(n1) #' #' # flat prior -#' flat_prior <- mixnorm(c(1,0,100), sigma=s) +#' flat_prior <- mixnorm(c(1, 0, 100), sigma = s) #' #' # standard NI design -#' decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) +#' decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) #' #' # for double criterion with indecision point (mean estimate must be #' # lower than this) @@ -80,13 +80,13 @@ #' #' # double criterion design #' # statistical significance (like NI design) -#' dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +#' dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) #' # require mean to be at least as good as theta_c -#' dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +#' dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) #' # combination -#' decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +#' decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) #' -#' theta_eval <- c(theta_a, theta_c, theta_ni) +#' theta_eval <- c(theta_a, theta_c, theta_ni) #' #' # we can display the decision function definition #' decComb @@ -97,44 +97,44 @@ #' decComb(flat_prior) #' # or for a possible outcome of the trial #' # here with HR of 0.8 for 40 events -#' decComb(postmix(flat_prior, m=log(0.8), n=40)) -#' +#' decComb(postmix(flat_prior, m = log(0.8), n = 40)) #' #' @export -decision1S <- function(pc=0.975, qc=0, lower.tail=TRUE) { - assert_that(length(pc) == length(qc)) - lpc <- log(pc) - fun <- function(mix, dist=FALSE) { - test <- pmix(mix, qc, lower.tail=lower.tail, log.p=TRUE) - lpc - if(dist) - return(test) - as.numeric(all(test > 0)) +decision1S <- function(pc = 0.975, qc = 0, lower.tail = TRUE) { + assert_that(length(pc) == length(qc)) + lpc <- log(pc) + fun <- function(mix, dist = FALSE) { + test <- pmix(mix, qc, lower.tail = lower.tail, log.p = TRUE) - lpc + if (dist) { + return(test) } - attr(fun, "pc") <- pc - attr(fun, "qc") <- qc - attr(fun, "lower.tail") <- lower.tail - class(fun) <- c("decision1S", "function") - fun + as.numeric(all(test > 0)) + } + attr(fun, "pc") <- pc + attr(fun, "qc") <- qc + attr(fun, "lower.tail") <- lower.tail + class(fun) <- c("decision1S", "function") + fun } #' @export print.decision1S <- function(x, ...) { - cat("1 sample decision function\n") - cat("Conditions for acceptance:\n") - qc <- attr(x, "qc") - pc <- attr(x, "pc") - low <- attr(x, "lower.tail") - cmp <- ifelse(low, "<=", ">") - for(i in seq_along(qc)) { - cat(paste0("P(theta ", cmp, " ", qc[i], ") > ", pc[i], "\n")) - } - invisible(x) + cat("1 sample decision function\n") + cat("Conditions for acceptance:\n") + qc <- attr(x, "qc") + pc <- attr(x, "pc") + low <- attr(x, "lower.tail") + cmp <- ifelse(low, "<=", ">") + for (i in seq_along(qc)) { + cat(paste0("P(theta ", cmp, " ", qc[i], ") > ", pc[i], "\n")) + } + invisible(x) } #' @describeIn decision1S Deprecated old function name. Please use #' \code{decision1S} instead. #' @export -oc1Sdecision <- function(pc=0.975, qc=0, lower.tail=TRUE) { - deprecated("oc1Sdecision", "decision1S") - return(decision1S(pc, qc, lower.tail)) +oc1Sdecision <- function(pc = 0.975, qc = 0, lower.tail = TRUE) { + deprecated("oc1Sdecision", "decision1S") + return(decision1S(pc, qc, lower.tail)) } diff --git a/R/decision1S_boundary.R b/R/decision1S_boundary.R index ef7426f..86abf77 100644 --- a/R/decision1S_boundary.R +++ b/R/decision1S_boundary.R @@ -3,13 +3,13 @@ #' Calculates the decision boundary for a 1 sample design. This is the #' critical value at which the decision function will change from 0 #' (failure) to 1 (success). -#' +#' #' @template args-boundary1S -#' +#' #' @details The specification of the 1 sample design (prior, sample #' size and decision function, \eqn{D(y)}), uniquely defines the #' decision boundary -#' +#' #' \deqn{y_c = \max_y\{D(y) = 1\},}{y_c = max_{y}{D(y) = 1},} #' #' which is the maximal value of \eqn{y} whenever the decision \eqn{D(y)} @@ -21,7 +21,7 @@ #' \eqn{y} is defined for binary and Poisson endpoints as the sufficient #' statistic \eqn{y = \sum_{i=1}^{n} y_i} and for the normal #' case as the mean \eqn{\bar{y} = 1/n \sum_{i=1}^n y_i}. -#' +#' #' The convention for the critical value \eqn{y_c} depends on whether #' a left (\code{lower.tail=TRUE}) or right-sided decision function #' (\code{lower.tail=FALSE}) is used. For \code{lower.tail=TRUE} the @@ -30,35 +30,35 @@ #' \code{lower.tail=FALSE} then \eqn{D(y > y_c) = 1} holds. This is #' aligned with the cumulative density function definition within R #' (see for example \code{\link{pbinom}}). -#' +#' #' @return Returns the critical value \eqn{y_c}. -#' +#' #' @family design1S -#' +#' #' @examples #' #' # non-inferiority example using normal approximation of log-hazard #' # ratio, see ?decision1S for all details #' s <- 2 -#' flat_prior <- mixnorm(c(1,0,100), sigma=s) +#' flat_prior <- mixnorm(c(1, 0, 100), sigma = s) #' nL <- 233 #' theta_ni <- 0.4 #' theta_a <- 0 #' alpha <- 0.05 -#' beta <- 0.2 -#' za <- qnorm(1-alpha) -#' zb <- qnorm(1-beta) -#' n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +#' beta <- 0.2 +#' za <- qnorm(1 - alpha) +#' zb <- qnorm(1 - beta) +#' n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) #' theta_c <- theta_ni - za * s / sqrt(n1) -#' +#' #' # double criterion design #' # statistical significance (like NI design) -#' dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +#' dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) #' # require mean to be at least as good as theta_c -#' dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +#' dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) #' # combination -#' decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) -#' +#' decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) +#' #' # critical value of double criterion design #' decision1S_boundary(flat_prior, nL, decComb) #' @@ -77,31 +77,33 @@ decision1S_boundary.default <- function(prior, n, decision, ...) "Unknown densit #' @template design1S-binomial #' @export decision1S_boundary.betaMix <- function(prior, n, decision, ...) { - - VdecisionLazy <- Vectorize(function(r) { decision(postmix(prior, r=r, n=n)) - 0.25 } ) - - ## find decision boundary - bounds <- VdecisionLazy(c(0,n)) - lower.tail <- attr(decision, "lower.tail") - if(prod(bounds) > 0) { - ## decision is always the same - if(lower.tail) { - crit <- ifelse(bounds[1] < 0, 0, n+1) - } else { - crit <- ifelse(bounds[1] < 0, n, -1) - } - } else { - crit <- uniroot_int(VdecisionLazy, c(0,n), - f.lower=bounds[1], f.upper=bounds[2]) + VdecisionLazy <- Vectorize(function(r) { + decision(postmix(prior, r = r, n = n)) - 0.25 + }) + + ## find decision boundary + bounds <- VdecisionLazy(c(0, n)) + lower.tail <- attr(decision, "lower.tail") + if (prod(bounds) > 0) { + ## decision is always the same + if (lower.tail) { + crit <- ifelse(bounds[1] < 0, 0, n + 1) + } else { + crit <- ifelse(bounds[1] < 0, n, -1) } - - ## crit is always pointing to the 0 just before the decision which - ## is why we need a discrimination here - if(lower.tail) { - crit <- crit - 1 - } - - crit + } else { + crit <- uniroot_int(VdecisionLazy, c(0, n), + f.lower = bounds[1], f.upper = bounds[2] + ) + } + + ## crit is always pointing to the 0 just before the decision which + ## is why we need a discrimination here + if (lower.tail) { + crit <- crit - 1 + } + + crit } @@ -110,119 +112,120 @@ decision1S_boundary.betaMix <- function(prior, n, decision, ...) { ## roots of the decision function and returns an interpolation ## function object solve_boundary1S_normMix <- function(decision, mix, n, lim) { + sigma <- sigma(mix) - sigma <- sigma(mix) - - cond_decisionStep <- function() { - fn <- function(m) { - decision(postmix(mix, m=m, se=sigma/sqrt(n))) - 0.75 - } - Vectorize(fn) + cond_decisionStep <- function() { + fn <- function(m) { + decision(postmix(mix, m = m, se = sigma / sqrt(n))) - 0.75 } - - ## ensure that at the limiting boundaries the decision function - ## has a different sign (which must be true) - ind_fun <- cond_decisionStep() + Vectorize(fn) + } + + ## ensure that at the limiting boundaries the decision function + ## has a different sign (which must be true) + ind_fun <- cond_decisionStep() + dec_bounds <- ind_fun(lim) + while (prod(dec_bounds) > 0) { + w <- diff(lim) + lim <- c(lim[1] - w / 2, lim[2] + w / 2) dec_bounds <- ind_fun(lim) - while(prod(dec_bounds) > 0) { - w <- diff(lim) - lim <- c(lim[1] - w/2, lim[2] + w/2) - dec_bounds <- ind_fun(lim) - } + } - uniroot(ind_fun, interval=lim, - f.lower=dec_bounds[1], f.upper=dec_bounds[2])$root + uniroot(ind_fun, + interval = lim, + f.lower = dec_bounds[1], f.upper = dec_bounds[2] + )$root } #' @templateVar fun decision1S_boundary #' @template design1S-normal #' @export -decision1S_boundary.normMix <- function(prior, n, decision, sigma, eps=1e-6, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - if(missing(sigma)) { - sigma <- RBesT::sigma(prior) - message("Using default prior reference scale ", sigma) - } - assert_number(sigma, lower=0) - - sd_samp <- sigma / sqrt(n) +decision1S_boundary.normMix <- function(prior, n, decision, sigma, eps = 1e-6, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + if (missing(sigma)) { + sigma <- RBesT::sigma(prior) + message("Using default prior reference scale ", sigma) + } + assert_number(sigma, lower = 0) + + sd_samp <- sigma / sqrt(n) + + sigma(prior) <- sigma - sigma(prior) <- sigma + ## change the reference scale of the prior such that the prior + ## represents the distribution of the respective means + ## mean_prior <- prior + ## sigma(mean_prior) <- sd_samp - ## change the reference scale of the prior such that the prior - ## represents the distribution of the respective means - ##mean_prior <- prior - ##sigma(mean_prior) <- sd_samp + m <- summary(prior, probs = c())["mean"] - m <- summary(prior, probs=c())["mean"] - - lim <- qnorm(p=c(eps/2, 1-eps/2), mean=m, sd=sd_samp) + lim <- qnorm(p = c(eps / 2, 1 - eps / 2), mean = m, sd = sd_samp) - ## find the boundary of the decision function within the domain we integrate - crit <- solve_boundary1S_normMix(decision, prior, n, lim) - - crit + ## find the boundary of the decision function within the domain we integrate + crit <- solve_boundary1S_normMix(decision, prior, n, lim) + + crit } #' @templateVar fun decision1S_boundary #' @template design1S-poisson #' @export -decision1S_boundary.gammaMix <- function(prior, n, decision, eps=1e-6, ...) { - assert_that(likelihood(prior) == "poisson") - - cond_decisionStep <- function() { - fn <- function(m) { - decision(postmix(prior, n=n, m=m/n)) - 0.25 - } - Vectorize(fn) - } +decision1S_boundary.gammaMix <- function(prior, n, decision, eps = 1e-6, ...) { + assert_that(likelihood(prior) == "poisson") - Vdecision <- cond_decisionStep() - - m <- summary(prior, probs=c())["mean"] - - lambda_prior <- m * n - - lim <- qpois(p=c(eps/2, 1-eps/2), lambda=lambda_prior) - lim[1] <- 0 - - bounds <- Vdecision(lim) - ## make sure there is a decision somewhere - while(prod(bounds) > 0) { - lim[2] <- round(lim[2]*2) - bounds[2] <- Vdecision(lim[2]) - if(diff(lim) > 1e9) - break; - } - - lower.tail <- attr(decision, "lower.tail") - - ## check if the decision is constantly 1 or 0 - if(prod(bounds) > 0) { - ## decision is always the same - if(lower.tail) { - crit <- ifelse(bounds[1] < 0, 0, Inf) - } else { - crit <- ifelse(bounds[1] < 0, Inf, -1) - } - } else { - ## find decision boundary - crit <- uniroot_int(Vdecision, - c(lim[1],lim[2]), - f.lower=bounds[1], - f.upper=bounds[2]) + cond_decisionStep <- function() { + fn <- function(m) { + decision(postmix(prior, n = n, m = m / n)) - 0.25 } + Vectorize(fn) + } - ## crit is always pointing to the 0 just before the decision which - ## is why we need a discrimination here - if(lower.tail) { - crit <- crit - 1 - } + Vdecision <- cond_decisionStep() - crit -} + m <- summary(prior, probs = c())["mean"] + lambda_prior <- m * n + lim <- qpois(p = c(eps / 2, 1 - eps / 2), lambda = lambda_prior) + lim[1] <- 0 + + bounds <- Vdecision(lim) + ## make sure there is a decision somewhere + while (prod(bounds) > 0) { + lim[2] <- round(lim[2] * 2) + bounds[2] <- Vdecision(lim[2]) + if (diff(lim) > 1e9) { + break + } + } + + lower.tail <- attr(decision, "lower.tail") + + ## check if the decision is constantly 1 or 0 + if (prod(bounds) > 0) { + ## decision is always the same + if (lower.tail) { + crit <- ifelse(bounds[1] < 0, 0, Inf) + } else { + crit <- ifelse(bounds[1] < 0, Inf, -1) + } + } else { + ## find decision boundary + crit <- uniroot_int(Vdecision, + c(lim[1], lim[2]), + f.lower = bounds[1], + f.upper = bounds[2] + ) + } + + ## crit is always pointing to the 0 just before the decision which + ## is why we need a discrimination here + if (lower.tail) { + crit <- crit - 1 + } + + crit +} diff --git a/R/decision2S.R b/R/decision2S.R index ff6db19..1e6137e 100644 --- a/R/decision2S.R +++ b/R/decision2S.R @@ -65,32 +65,32 @@ #' @examples #' #' # see Gsponer et al., 2010 -#' priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -#' priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +#' priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +#' priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") #' # the success criteria is for delta which are larger than some #' # threshold value which is why we set lower.tail=FALSE -#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) #' # the futility criterion acts in the opposite direction -#' futilityCrit <- decision2S(c(0.90) , c(40), TRUE) +#' futilityCrit <- decision2S(c(0.90), c(40), TRUE) #' #' print(successCrit) #' print(futilityCrit) #' #' # consider decision for specific outcomes -#' postP_interim <- postmix(priorP, n=10, m=-50) -#' postT_interim <- postmix(priorT, n=20, m=-80) -#' futilityCrit( postP_interim, postT_interim ) -#' successCrit( postP_interim, postT_interim ) +#' postP_interim <- postmix(priorP, n = 10, m = -50) +#' postT_interim <- postmix(priorT, n = 20, m = -80) +#' futilityCrit(postP_interim, postT_interim) +#' successCrit(postP_interim, postT_interim) #' #' # Binary endpoint with double criterion decision on log-odds scale #' # 95% certain positive difference and an odds ratio of 2 at least -#' decL2 <- decision2S(c(0.95, 0.5), c(0, log(2)), lower.tail=FALSE, link="logit") +#' decL2 <- decision2S(c(0.95, 0.5), c(0, log(2)), lower.tail = FALSE, link = "logit") #' # 95% certain positive difference and an odds ratio of 3 at least -#' decL3 <- decision2S(c(0.95, 0.5), c(0, log(3)), lower.tail=FALSE, link="logit") +#' decL3 <- decision2S(c(0.95, 0.5), c(0, log(3)), lower.tail = FALSE, link = "logit") #' #' # data scenario -#' post1 <- postmix(mixbeta(c(1, 1, 1)), n=40, r=10) -#' post2 <- postmix(mixbeta(c(1, 1, 1)), n=40, r=18) +#' post1 <- postmix(mixbeta(c(1, 1, 1)), n = 40, r = 10) +#' post2 <- postmix(mixbeta(c(1, 1, 1)), n = 40, r = 18) #' #' # positive outcome and a median odds ratio of at least 2 ... #' decL2(post2, post1) @@ -98,53 +98,55 @@ #' decL3(post2, post1) #' #' @export -decision2S <- function(pc=0.975, qc=0, lower.tail=TRUE, link=c("identity", "logit", "log")) { - assert_that(length(pc) == length(qc)) - lpc <- log(pc) - link <- match.arg(link) - dlink_obj <- link_map[[link]] - fun <- function(mix1, mix2, dist=FALSE) { - dlink(mix1) <- dlink_obj - dlink(mix2) <- dlink_obj - ## Note that for normal mixture densities we can expedite the - ## calculation of the convolution dramatically, i.e. the - ## convolution is done analytically exact - test <- if(inherits(mix1, "normMix")) - pmix(mixnormdiff(mix1, mix2), qc, lower.tail=lower.tail, log.p=TRUE) - lpc - else - log(pmax(pmixdiff(mix1, mix2, qc, lower.tail=lower.tail), .Machine$double.eps) ) - lpc - if(dist) - return(test) - as.numeric(all(test>0)) +decision2S <- function(pc = 0.975, qc = 0, lower.tail = TRUE, link = c("identity", "logit", "log")) { + assert_that(length(pc) == length(qc)) + lpc <- log(pc) + link <- match.arg(link) + dlink_obj <- link_map[[link]] + fun <- function(mix1, mix2, dist = FALSE) { + dlink(mix1) <- dlink_obj + dlink(mix2) <- dlink_obj + ## Note that for normal mixture densities we can expedite the + ## calculation of the convolution dramatically, i.e. the + ## convolution is done analytically exact + test <- if (inherits(mix1, "normMix")) { + pmix(mixnormdiff(mix1, mix2), qc, lower.tail = lower.tail, log.p = TRUE) - lpc + } else { + log(pmax(pmixdiff(mix1, mix2, qc, lower.tail = lower.tail), .Machine$double.eps)) - lpc } - attr(fun, "pc") <- pc - attr(fun, "qc") <- qc - attr(fun, "link") <- link - attr(fun, "lower.tail") <- lower.tail - class(fun) <- c("decision2S", "function") - fun + if (dist) { + return(test) + } + as.numeric(all(test > 0)) + } + attr(fun, "pc") <- pc + attr(fun, "qc") <- qc + attr(fun, "link") <- link + attr(fun, "lower.tail") <- lower.tail + class(fun) <- c("decision2S", "function") + fun } #' @export print.decision2S <- function(x, ...) { - cat("2 sample decision function\n") - cat("Conditions for acceptance:\n") - link <- attr(x, "link") - qc <- attr(x, "qc") - pc <- attr(x, "pc") - low <- attr(x, "lower.tail") - cmp <- ifelse(low, "<=", ">") - for(i in seq_along(qc)) { - cat(paste0("P(theta1 - theta2 ", cmp, " ", qc[i], ") > ", pc[i], "\n")) - } - cat("Link:", link, "\n") - invisible(x) + cat("2 sample decision function\n") + cat("Conditions for acceptance:\n") + link <- attr(x, "link") + qc <- attr(x, "qc") + pc <- attr(x, "pc") + low <- attr(x, "lower.tail") + cmp <- ifelse(low, "<=", ">") + for (i in seq_along(qc)) { + cat(paste0("P(theta1 - theta2 ", cmp, " ", qc[i], ") > ", pc[i], "\n")) + } + cat("Link:", link, "\n") + invisible(x) } #' @describeIn decision2S Deprecated old function name. Please use #' \code{decision2S} instead. #' @export -oc2Sdecision <- function(pc=0.975, qc=0, lower.tail=TRUE, link=c("identity", "logit", "log")) { - deprecated("oc2Sdecision", "decision2S") - return(decision2S(pc, qc, lower.tail, link)) +oc2Sdecision <- function(pc = 0.975, qc = 0, lower.tail = TRUE, link = c("identity", "logit", "log")) { + deprecated("oc2Sdecision", "decision2S") + return(decision2S(pc, qc, lower.tail, link)) } diff --git a/R/decision2S_boundary.R b/R/decision2S_boundary.R index 2d02429..6bd782b 100644 --- a/R/decision2S_boundary.R +++ b/R/decision2S_boundary.R @@ -39,13 +39,13 @@ #' @examples #' #' # see ?decision2S for details of example -#' priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -#' priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +#' priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +#' priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") #' # the success criteria is for delta which are larger than some #' # threshold value which is why we set lower.tail=FALSE -#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) #' # the futility criterion acts in the opposite direction -#' futilityCrit <- decision2S(c(0.90) , c(40), TRUE) +#' futilityCrit <- decision2S(c(0.90), c(40), TRUE) #' #' # success criterion boundary #' successBoundary <- decision2S_boundary(priorP, priorT, 10, 20, successCrit) @@ -53,15 +53,15 @@ #' # futility criterion boundary #' futilityBoundary <- decision2S_boundary(priorP, priorT, 10, 20, futilityCrit) #' -#' curve(successBoundary(x), -25:25 - 49, xlab="y2", ylab="critical y1") -#' curve(futilityBoundary(x), lty=2, add=TRUE) +#' curve(successBoundary(x), -25:25 - 49, xlab = "y2", ylab = "critical y1") +#' curve(futilityBoundary(x), lty = 2, add = TRUE) #' #' # hence, for mean in sample 2 of 10, the critical value for y1 is #' y1c <- futilityBoundary(-10) #' #' # around the critical value the decision for futility changes -#' futilityCrit(postmix(priorP, m=y1c+1E-3, n=10), postmix(priorT, m=-10, n=20)) -#' futilityCrit(postmix(priorP, m=y1c-1E-3, n=10), postmix(priorT, m=-10, n=20)) +#' futilityCrit(postmix(priorP, m = y1c + 1E-3, n = 10), postmix(priorT, m = -10, n = 20)) +#' futilityCrit(postmix(priorP, m = y1c - 1E-3, n = 10), postmix(priorT, m = -10, n = 20)) #' #' @export decision2S_boundary <- function(prior1, prior2, n1, n2, decision, ...) UseMethod("decision2S_boundary") @@ -75,133 +75,137 @@ decision2S_boundary.default <- function(prior1, prior2, n1, n2, decision, ...) " # argument to limit the search for the critical value. #' @export decision2S_boundary.betaMix <- function(prior1, prior2, n1, n2, decision, eps, ...) { - ## only n2=0 is supported - assert_number(n1, lower=1, finite=TRUE) - assert_number(n2, lower=0, finite=TRUE) - - if(!missing(eps)) - assert_number(eps, lower=0, upper=0.1, finite=TRUE) - - cond_decisionDist <- function(post2cond) { - fn <- function(m1) { - ## Note: Subtracting from the decision 0.25 leads to - ## negative decisions being at -0.25 while positives are - ## at 0.75; since uniroot_int *always* returns the x which - ## has lowest absolute value we are guaranteed that y2crit - ## is just before the jump - ##decision(post1cond, post2[[m2+1]]) - 0.25 - decision(postmix(prior1, r=m1, n=n1), post2cond) - 0.25 - ##decision(postmix(prior2, r=m2, n=n2), post1cond) - 0.25 - } - Vectorize(fn) + ## only n2=0 is supported + assert_number(n1, lower = 1, finite = TRUE) + assert_number(n2, lower = 0, finite = TRUE) + + if (!missing(eps)) { + assert_number(eps, lower = 0, upper = 0.1, finite = TRUE) + } + + cond_decisionDist <- function(post2cond) { + fn <- function(m1) { + ## Note: Subtracting from the decision 0.25 leads to + ## negative decisions being at -0.25 while positives are + ## at 0.75; since uniroot_int *always* returns the x which + ## has lowest absolute value we are guaranteed that y2crit + ## is just before the jump + ## decision(post1cond, post2[[m2+1]]) - 0.25 + decision(postmix(prior1, r = m1, n = n1), post2cond) - 0.25 + ## decision(postmix(prior2, r=m2, n=n2), post1cond) - 0.25 } - - ## saves the decision boundary conditional on the outcome of the - ## second variable - clim1 <- c(Inf, -Inf) - clim2 <- c(Inf, -Inf) - boundary <- c() - full_boundary <- missing(eps) - - lower.tail <- attr(decision, "lower.tail") - - update_boundary <- function(lim1, lim2) { - boundary <<- rep(NA, diff(lim2) + 1) - clim2 <<- lim2 - clim1 <<- lim1 - for(y2 in lim2[1]:lim2[2]) { - ## find decision point - if(n2 == 0) { - decFun <- cond_decisionDist(prior2) - } else { - decFun <- cond_decisionDist(postmix(prior2, r=y2, n=n2)) - } - ind_llim <- decFun(lim1[1]) - ind_ulim <- decFun(lim1[2]) - y2ind <- y2 - lim2[1] + 1 - if(ind_llim < 0 & ind_ulim < 0) { - ## then the decision is never 1 - boundary[y2ind] <<- -1 - next - } - if(ind_llim > 0 & ind_ulim > 0) { - ## then the decision is always 1 - boundary[y2ind] <<- n1+1 - next - } - ## find boundary - boundary[y2ind] <<- uniroot_int(decFun, lim1, - f.lower=ind_llim, - f.upper=ind_ulim) - } - if(lower.tail) { - ## if lower.tail==TRUE, then the condition becomes true when - ## going from large to small values, hence we need to integrate from - ## 0 to boundary - boundary <<- pmax(boundary - 1, -1) - } - return() + Vectorize(fn) + } + + ## saves the decision boundary conditional on the outcome of the + ## second variable + clim1 <- c(Inf, -Inf) + clim2 <- c(Inf, -Inf) + boundary <- c() + full_boundary <- missing(eps) + + lower.tail <- attr(decision, "lower.tail") + + update_boundary <- function(lim1, lim2) { + boundary <<- rep(NA, diff(lim2) + 1) + clim2 <<- lim2 + clim1 <<- lim1 + for (y2 in lim2[1]:lim2[2]) { + ## find decision point + if (n2 == 0) { + decFun <- cond_decisionDist(prior2) + } else { + decFun <- cond_decisionDist(postmix(prior2, r = y2, n = n2)) + } + ind_llim <- decFun(lim1[1]) + ind_ulim <- decFun(lim1[2]) + y2ind <- y2 - lim2[1] + 1 + if (ind_llim < 0 & ind_ulim < 0) { + ## then the decision is never 1 + boundary[y2ind] <<- -1 + next + } + if (ind_llim > 0 & ind_ulim > 0) { + ## then the decision is always 1 + boundary[y2ind] <<- n1 + 1 + next + } + ## find boundary + boundary[y2ind] <<- uniroot_int(decFun, lim1, + f.lower = ind_llim, + f.upper = ind_ulim + ) + } + if (lower.tail) { + ## if lower.tail==TRUE, then the condition becomes true when + ## going from large to small values, hence we need to integrate from + ## 0 to boundary + boundary <<- pmax(boundary - 1, -1) + } + return() + } + + if (full_boundary) { + update_boundary(c(0, n1), c(0, n2)) + } + + decision_boundary <- function(y2, lim1) { + ## check if we need to recalculate the decision grid for the + ## case of enabled approximate method + assert_integerish(y2, lower = 0, upper = n2, any.missing = FALSE) + + if (!full_boundary) { + if (missing(lim1)) { + ## if not hint is given we search the full sample + ## space which should be OK, as the complexity is + ## log(N) + lim1 <- c(0, n1) + } else { + assert_integerish(lim1, lower = 0, upper = n1, any.missing = FALSE) + } + lim2 <- c(min(y2), max(y2)) + ## check if the decision grid needs to be recomputed + if (lim1[1] < clim1[1] | lim1[2] > clim1[2] | + lim2[1] < clim2[1] | lim2[2] > clim2[2]) { + ## ensure that lim1 never shrinks + lim1[1] <- min(lim1[1], clim1[1]) + lim1[2] <- max(lim1[2], clim1[2]) + update_boundary(lim1, lim2) + } } - if(full_boundary) - update_boundary(c(0, n1), c(0, n2)) - - decision_boundary <- function(y2, lim1) { - ## check if we need to recalculate the decision grid for the - ## case of enabled approximate method - assert_integerish(y2, lower=0, upper=n2, any.missing=FALSE) - - if(!full_boundary) { - if(missing(lim1)) { - ## if not hint is given we search the full sample - ## space which should be OK, as the complexity is - ## log(N) - lim1 <- c(0, n1) - } else { - assert_integerish(lim1, lower=0, upper=n1, any.missing=FALSE) - } - lim2 <- c(min(y2), max(y2)) - ## check if the decision grid needs to be recomputed - if(lim1[1] < clim1[1] | lim1[2] > clim1[2] | - lim2[1] < clim2[1] | lim2[2] > clim2[2]) { - ## ensure that lim1 never shrinks - lim1[1] <- min(lim1[1], clim1[1]) - lim1[2] <- max(lim1[2], clim1[2]) - update_boundary(lim1, lim2) - } - } - - ## make sure y2 is an integer which is the value of - ## the second read-out for which we return the decision - ## boundary - ## TODO: handle case with eps with care - crit <- boundary[(y2 - clim2[1]) + 1] - if(!full_boundary) { - ## in case the lower boundary of the searched grid is not - ## zero, then we cannot say anything about cases when the - ## decision is always negative - if(!lower.tail) { - ## in this case the decision changes from negative to - ## positive when going from small to large - ## values. Hence, if the decision is always negative, - ## then we can be sure of that we can never be sure, - ## but should the decision be negative at all values, - ## it can change at larger values. - crit[crit==n1+1] <- NA - } else { - ## now the decision changes from positive to negative - ## when going from small to large => should the - ## decision not change in the clim1 domain then we do - ## not know if it happens later - if(clim1[1] > 0) - crit[crit==-1] <- NA - ## however, if crit==Inf then we can be sure that the - ## decision is indeed always positive - } + ## make sure y2 is an integer which is the value of + ## the second read-out for which we return the decision + ## boundary + ## TODO: handle case with eps with care + crit <- boundary[(y2 - clim2[1]) + 1] + if (!full_boundary) { + ## in case the lower boundary of the searched grid is not + ## zero, then we cannot say anything about cases when the + ## decision is always negative + if (!lower.tail) { + ## in this case the decision changes from negative to + ## positive when going from small to large + ## values. Hence, if the decision is always negative, + ## then we can be sure of that we can never be sure, + ## but should the decision be negative at all values, + ## it can change at larger values. + crit[crit == n1 + 1] <- NA + } else { + ## now the decision changes from positive to negative + ## when going from small to large => should the + ## decision not change in the clim1 domain then we do + ## not know if it happens later + if (clim1[1] > 0) { + crit[crit == -1] <- NA } - return(crit) + ## however, if crit==Inf then we can be sure that the + ## decision is indeed always positive + } } - decision_boundary + return(crit) + } + decision_boundary } @@ -210,276 +214,278 @@ decision2S_boundary.betaMix <- function(prior1, prior2, n1, n2, decision, eps, . ## roots of the decision function and returns an interpolation ## function object solve_boundary2S_normMix <- function(decision, mix1, mix2, n1, n2, lim1, lim2, delta2) { - grid <- seq(lim2[1], lim2[2], length=diff(lim2)/delta2) + grid <- seq(lim2[1], lim2[2], length = diff(lim2) / delta2) - sigma1 <- sigma(mix1) - sigma2 <- sigma(mix2) + sigma1 <- sigma(mix1) + sigma2 <- sigma(mix2) - sem1 <- sigma1/sqrt(n1) - scale1 <- sigma1/(n1^0.25) + sem1 <- sigma1 / sqrt(n1) + scale1 <- sigma1 / (n1^0.25) - cond_decisionStep <- function(post2) { - fn <- function(m1) { - decision(postmix(mix1, m=m1, se=sem1), post2) - 0.75 - } - Vectorize(fn) + cond_decisionStep <- function(post2) { + fn <- function(m1) { + decision(postmix(mix1, m = m1, se = sem1), post2) - 0.75 } - - Neval <- length(grid) - #cat("Calculating boundary from", lim2[1], "to", lim2[2], "with", Neval, "points\n") - tol <- min(delta2/100, .Machine$double.eps^0.25) - ##cat("Using tolerance", tol, "\n") - crit <- rep(NA, times=Neval) - for(i in 1:Neval) { - if(n2 == 0) { - post2 <- mix2 - } else { - post2 <- postmix(mix2, m=grid[i], se=sigma2/sqrt(n2)) - } - ind_fun <- cond_decisionStep(post2) - dec_bounds <- ind_fun(lim1) - ## if decision function is not different at boundaries, lim1 - ## is too narrow and we then enlarge - while(prod(dec_bounds) > 0) { - w <- diff(lim1) - lim1 <- c(lim1[1] - w/2, lim1[2] + w/2) - dec_bounds <- ind_fun(lim1) - } - y1c <- uniroot(ind_fun, lim1, - f.lower=dec_bounds[1], f.upper=dec_bounds[2], tol=tol)$root - crit[i] <- y1c - ## set lim1 tightly around the current critical value and use the - ## last boundary limits to not shrink too fast - lim1 <- c(mean(lim1[1], y1c - 2*scale1), mean(y1c + 2*scale1, lim1[2])) + Vectorize(fn) + } + + Neval <- length(grid) + # cat("Calculating boundary from", lim2[1], "to", lim2[2], "with", Neval, "points\n") + tol <- min(delta2 / 100, .Machine$double.eps^0.25) + ## cat("Using tolerance", tol, "\n") + crit <- rep(NA, times = Neval) + for (i in 1:Neval) { + if (n2 == 0) { + post2 <- mix2 + } else { + post2 <- postmix(mix2, m = grid[i], se = sigma2 / sqrt(n2)) } - - cbind(grid, crit) + ind_fun <- cond_decisionStep(post2) + dec_bounds <- ind_fun(lim1) + ## if decision function is not different at boundaries, lim1 + ## is too narrow and we then enlarge + while (prod(dec_bounds) > 0) { + w <- diff(lim1) + lim1 <- c(lim1[1] - w / 2, lim1[2] + w / 2) + dec_bounds <- ind_fun(lim1) + } + y1c <- uniroot(ind_fun, lim1, + f.lower = dec_bounds[1], f.upper = dec_bounds[2], tol = tol + )$root + crit[i] <- y1c + ## set lim1 tightly around the current critical value and use the + ## last boundary limits to not shrink too fast + lim1 <- c(mean(lim1[1], y1c - 2 * scale1), mean(y1c + 2 * scale1, lim1[2])) + } + + cbind(grid, crit) } #' @templateVar fun decision2S_boundary #' @template design2S-normal #' @export -decision2S_boundary.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps=1e-6, Ngrid=10, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - if(missing(sigma1)) { - sigma1 <- RBesT::sigma(prior1) - message("Using default prior 1 reference scale ", sigma1) - } - if(missing(sigma2)) { - sigma2 <- RBesT::sigma(prior2) - message("Using default prior 2 reference scale ", sigma2) - } - assert_number(sigma1, lower=0) - assert_number(sigma2, lower=0) - - sem1 <- sigma1 / sqrt(n1) - sem2 <- sigma2 / sqrt(n2) - - sigma(prior1) <- sigma1 - sigma(prior2) <- sigma2 - - ## only n2 can be zero - assert_that(n1 > 0) - assert_that(n2 >= 0) - - if(n2 == 0) sem2 <- sigma(prior2) / sqrt(1E-1) - - ## change the reference scale of the prior such that the prior - ## represents the distribution of the respective means - mean_prior1 <- prior1 - sigma(mean_prior1) <- sem1 - ##mean_prior2 <- prior2 - ##sigma(mean_prior2) <- sem2 - - ## discretization step-size - delta2 <- sem2/Ngrid - - ## for the case of mix1 and mix2 having just 1 component, then one - ## can prove that the decision boundary is a linear function. - ## Hence we only calculate a very rough grid and apply linear - ## interpolation. - - linear_boundary <- FALSE - if(ncol(prior1) == 1 && ncol(prior2) == 1) { - linear_boundary <- TRUE - ## we could relax this even further - delta2 <- sigma2/Ngrid - } - - ## the boundary function depends only on the samples sizes n1, n2, - ## the priors and the decision, but not the assumed truths - - clim2 <- c(Inf, -Inf) - - ## the boundary function which gives conditional on the second - ## variable the critical value where the decision changes - boundary <- NA - boundary_discrete <- matrix(NA, nrow=0, ncol=2) - - ## check where the decision is 1, i.e. left or right - lower.tail <- attr(decision, "lower.tail") - - decision_boundary <- function(y2, lim1) { - - lim2 <- range(y2) - - ## check if boundary function must be recomputed - if(lim2[1] < clim2[1] | lim2[2] > clim2[2]) { - new_lim2 <- clim2 - ## note: the <<- assignment is needed to set the variable in the enclosure - if(missing(lim1)) - lim1 <- qmix(mean_prior1, c(eps/2, 1-eps/2)) - if(nrow(boundary_discrete) == 0) { - ## boundary hasn't been calculated before, do it all - boundary_discrete <<- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, lim2, delta2) - new_lim2 <- lim2 - } else { - if(lim2[1] < clim2[1]) { - ## the lower bound is not low enough... only add the region which is missing - new_left_lim2 <- min(lim2[1], clim2[1]-2*delta2) - boundary_extra <- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, c(new_left_lim2, clim2[1]-delta2), delta2) - new_lim2[1] <- new_left_lim2 - boundary_discrete <<- rbind(boundary_extra, boundary_discrete) - } - if(lim2[2] > clim2[2]) { - ## the upper bound is not large enough.. again only add whats missing - new_right_lim2 <- max(lim2[2], clim2[2]+2*delta2) - boundary_extra <- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, c(clim2[2]+delta2, new_right_lim2), delta2) - new_lim2[2] <- new_right_lim2 - boundary_discrete <<- rbind(boundary_discrete, boundary_extra) - } - } - ## only for debugging - ##assert_that(all(order(boundary_discrete[,1]) == 1:nrow(boundary_discrete)), msg="x grid must stay ordered!") - if(linear_boundary) { - boundary <<- approxfun(boundary_discrete[,1], boundary_discrete[,2], rule=2) - } else { - boundary <<- splinefun(boundary_discrete[,1], boundary_discrete[,2]) - } - clim2 <<- new_lim2 +decision2S_boundary.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps = 1e-6, Ngrid = 10, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + if (missing(sigma1)) { + sigma1 <- RBesT::sigma(prior1) + message("Using default prior 1 reference scale ", sigma1) + } + if (missing(sigma2)) { + sigma2 <- RBesT::sigma(prior2) + message("Using default prior 2 reference scale ", sigma2) + } + assert_number(sigma1, lower = 0) + assert_number(sigma2, lower = 0) + + sem1 <- sigma1 / sqrt(n1) + sem2 <- sigma2 / sqrt(n2) + + sigma(prior1) <- sigma1 + sigma(prior2) <- sigma2 + + ## only n2 can be zero + assert_that(n1 > 0) + assert_that(n2 >= 0) + + if (n2 == 0) sem2 <- sigma(prior2) / sqrt(1E-1) + + ## change the reference scale of the prior such that the prior + ## represents the distribution of the respective means + mean_prior1 <- prior1 + sigma(mean_prior1) <- sem1 + ## mean_prior2 <- prior2 + ## sigma(mean_prior2) <- sem2 + + ## discretization step-size + delta2 <- sem2 / Ngrid + + ## for the case of mix1 and mix2 having just 1 component, then one + ## can prove that the decision boundary is a linear function. + ## Hence we only calculate a very rough grid and apply linear + ## interpolation. + + linear_boundary <- FALSE + if (ncol(prior1) == 1 && ncol(prior2) == 1) { + linear_boundary <- TRUE + ## we could relax this even further + delta2 <- sigma2 / Ngrid + } + + ## the boundary function depends only on the samples sizes n1, n2, + ## the priors and the decision, but not the assumed truths + + clim2 <- c(Inf, -Inf) + + ## the boundary function which gives conditional on the second + ## variable the critical value where the decision changes + boundary <- NA + boundary_discrete <- matrix(NA, nrow = 0, ncol = 2) + + ## check where the decision is 1, i.e. left or right + lower.tail <- attr(decision, "lower.tail") + + decision_boundary <- function(y2, lim1) { + lim2 <- range(y2) + + ## check if boundary function must be recomputed + if (lim2[1] < clim2[1] | lim2[2] > clim2[2]) { + new_lim2 <- clim2 + ## note: the <<- assignment is needed to set the variable in the enclosure + if (missing(lim1)) { + lim1 <- qmix(mean_prior1, c(eps / 2, 1 - eps / 2)) + } + if (nrow(boundary_discrete) == 0) { + ## boundary hasn't been calculated before, do it all + boundary_discrete <<- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, lim2, delta2) + new_lim2 <- lim2 + } else { + if (lim2[1] < clim2[1]) { + ## the lower bound is not low enough... only add the region which is missing + new_left_lim2 <- min(lim2[1], clim2[1] - 2 * delta2) + boundary_extra <- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, c(new_left_lim2, clim2[1] - delta2), delta2) + new_lim2[1] <- new_left_lim2 + boundary_discrete <<- rbind(boundary_extra, boundary_discrete) } - - return(boundary(y2)) + if (lim2[2] > clim2[2]) { + ## the upper bound is not large enough.. again only add whats missing + new_right_lim2 <- max(lim2[2], clim2[2] + 2 * delta2) + boundary_extra <- solve_boundary2S_normMix(decision, prior1, prior2, n1, n2, lim1, c(clim2[2] + delta2, new_right_lim2), delta2) + new_lim2[2] <- new_right_lim2 + boundary_discrete <<- rbind(boundary_discrete, boundary_extra) + } + } + ## only for debugging + ## assert_that(all(order(boundary_discrete[,1]) == 1:nrow(boundary_discrete)), msg="x grid must stay ordered!") + if (linear_boundary) { + boundary <<- approxfun(boundary_discrete[, 1], boundary_discrete[, 2], rule = 2) + } else { + boundary <<- splinefun(boundary_discrete[, 1], boundary_discrete[, 2]) + } + clim2 <<- new_lim2 } - decision_boundary + return(boundary(y2)) + } + + decision_boundary } #' @templateVar fun decision2S_boundary #' @template design2S-poisson #' @export -decision2S_boundary.gammaMix <- function(prior1, prior2, n1, n2, decision, eps=1e-6, ...) { - assert_that(likelihood(prior1) == "poisson") - assert_that(likelihood(prior2) == "poisson") +decision2S_boundary.gammaMix <- function(prior1, prior2, n1, n2, decision, eps = 1e-6, ...) { + assert_that(likelihood(prior1) == "poisson") + assert_that(likelihood(prior2) == "poisson") - # only the second n2 argument may be 0 - assert_that(n1 > 0) - assert_that(n2 >= 0) + # only the second n2 argument may be 0 + assert_that(n1 > 0) + assert_that(n2 >= 0) - cond_decisionStep <- function(post2) { - fn <- function(m1) { - decision(postmix(prior1, n=n1, m=m1/n1), post2) - 0.25 - } - Vectorize(fn) + cond_decisionStep <- function(post2) { + fn <- function(m1) { + decision(postmix(prior1, n = n1, m = m1 / n1), post2) - 0.25 + } + Vectorize(fn) + } + + clim1 <- c(Inf, -Inf) + clim2 <- c(Inf, -Inf) + boundary <- NA + grid <- NA + lower.tail <- attr(decision, "lower.tail") + + decision_boundary <- function(y2, lim1) { + if (missing(lim1)) { + lambda1 <- summary(prior1, probs = c())["mean"] * n1 + lim1 <- qpois(c(eps / 2, 1 - eps / 2), lambda1) } - clim1 <- c(Inf, -Inf) - clim2 <- c(Inf, -Inf) - boundary <- NA - grid <- NA - lower.tail <- attr(decision, "lower.tail") - - decision_boundary <- function(y2, lim1) { - - if(missing(lim1)) { - lambda1 <- summary(prior1, probs=c())["mean"] * n1 - lim1 <- qpois(c(eps/2, 1-eps/2), lambda1) + lim2 <- range(y2) + + assert_number(lim1[1], lower = 0, finite = TRUE) + assert_number(lim1[2], lower = 0, finite = TRUE) + assert_number(lim2[1], lower = 0, finite = TRUE) + assert_number(lim2[2], lower = 0, finite = TRUE) + + ## check if the boundary needs to be recomputed + if (lim1[1] < clim1[1] | lim1[2] > clim1[2] | + lim2[1] < clim2[1] | lim2[2] > clim2[2]) { + ## ensure that lim1 never shrinks in size + lim1[1] <- min(lim1[1], clim1[1]) + lim1[2] <- max(lim1[2], clim1[2]) + grid <<- lim2[1]:lim2[2] + Neval <- length(grid) + boundary <<- rep(NA, Neval) + for (i in 1:Neval) { + if (n2 == 0) { + cond_dec <- cond_decisionStep(prior2) + } else { + cond_dec <- cond_decisionStep(postmix(prior2, n = n2, m = grid[i] / n2)) } - - lim2 <- range(y2) - - assert_number(lim1[1], lower=0, finite=TRUE) - assert_number(lim1[2], lower=0, finite=TRUE) - assert_number(lim2[1], lower=0, finite=TRUE) - assert_number(lim2[2], lower=0, finite=TRUE) - - ## check if the boundary needs to be recomputed - if(lim1[1] < clim1[1] | lim1[2] > clim1[2] | - lim2[1] < clim2[1] | lim2[2] > clim2[2]) { - ## ensure that lim1 never shrinks in size - lim1[1] <- min(lim1[1], clim1[1]) - lim1[2] <- max(lim1[2], clim1[2]) - grid <<- lim2[1]:lim2[2] - Neval <- length(grid) - boundary <<- rep(NA, Neval) - for(i in 1:Neval) { - if(n2 == 0) { - cond_dec <- cond_decisionStep(prior2) - } else { - cond_dec <- cond_decisionStep(postmix(prior2, n=n2, m=grid[i]/n2)) - } - low <- cond_dec(lim1[1]) - high <- cond_dec(lim1[2]) - if(low < 0 & high < 0) { - boundary[i] <<- -1 - next; - } - if(low > 0 & high > 0) { - boundary[i] <<- Inf - next; - } - boundary[i] <<- uniroot_int(cond_dec, lim1, - f.lower=low, - f.upper=high) - } - - if(lower.tail) { - ## if lower.tail==TRUE, then the condition becomes - ## true when going from large to small values, hence - ## we need to integrate from 0 to the boundary - boundary <<- pmax(boundary - 1, -1) - } - - ## save limits of new grid - clim1 <<- lim1 - clim2 <<- lim2 + low <- cond_dec(lim1[1]) + high <- cond_dec(lim1[2]) + if (low < 0 & high < 0) { + boundary[i] <<- -1 + next } - - assert_numeric(y2, lower=0, finite=TRUE, any.missing=FALSE) - crit <- boundary[y2 - clim2[1] + 1] - ## in case the lower boundary of the searched grid is not - ## zero, then we cannot say anything about cases when the - ## decision is always negative - if(!lower.tail) { - ## in this case the decision changes from negative to - ## positive when going from small to large values. Hence, - ## if the decision is always negative, then we can be sure - ## that the decision changes past lim1[2]. We set the - ## boundary to lim1[2]+1 if lim1 has been given; otherwise - ## to NA. - ## Should the decision be negative at all values, - ## it can change at larger values. - if(missing(lim1)) { - crit[crit==-1] <- NA - crit[crit==Inf] <- NA - } else { - crit[crit==-1] <- lim1[2]+1 - crit[crit==Inf] <- lim1[1]-1 - } - } else { - ## now the decision changes from positive to negative - ## when going from small to large => should the - ## decision not change in the clim1 domain then we do - ## not know if it happens later - if(clim1[1] > 0) - crit[crit==-1] <- NA - ## however, if crit==Inf then we can be sure that the - ## decision is indeed always positive + if (low > 0 & high > 0) { + boundary[i] <<- Inf + next } - return(crit) + boundary[i] <<- uniroot_int(cond_dec, lim1, + f.lower = low, + f.upper = high + ) + } + + if (lower.tail) { + ## if lower.tail==TRUE, then the condition becomes + ## true when going from large to small values, hence + ## we need to integrate from 0 to the boundary + boundary <<- pmax(boundary - 1, -1) + } + + ## save limits of new grid + clim1 <<- lim1 + clim2 <<- lim2 + } + + assert_numeric(y2, lower = 0, finite = TRUE, any.missing = FALSE) + crit <- boundary[y2 - clim2[1] + 1] + ## in case the lower boundary of the searched grid is not + ## zero, then we cannot say anything about cases when the + ## decision is always negative + if (!lower.tail) { + ## in this case the decision changes from negative to + ## positive when going from small to large values. Hence, + ## if the decision is always negative, then we can be sure + ## that the decision changes past lim1[2]. We set the + ## boundary to lim1[2]+1 if lim1 has been given; otherwise + ## to NA. + ## Should the decision be negative at all values, + ## it can change at larger values. + if (missing(lim1)) { + crit[crit == -1] <- NA + crit[crit == Inf] <- NA + } else { + crit[crit == -1] <- lim1[2] + 1 + crit[crit == Inf] <- lim1[1] - 1 + } + } else { + ## now the decision changes from positive to negative + ## when going from small to large => should the + ## decision not change in the clim1 domain then we do + ## not know if it happens later + if (clim1[1] > 0) { + crit[crit == -1] <- NA + } + ## however, if crit==Inf then we can be sure that the + ## decision is indeed always positive } - decision_boundary + return(crit) + } + decision_boundary } diff --git a/R/deprecation_message.R b/R/deprecation_message.R index 38513ad..20b2ff0 100644 --- a/R/deprecation_message.R +++ b/R/deprecation_message.R @@ -1,5 +1,6 @@ deprecated <- function(what, replaced) { - message(what, " is deprecated and will be removed in a future release.") - if(!missing(replaced)) - message("Please use instead ", replaced, ".") + message(what, " is deprecated and will be removed in a future release.") + if (!missing(replaced)) { + message("Please use instead ", replaced, ".") + } } diff --git a/R/dlink.R b/R/dlink.R index 7f1aac4..e6665f7 100644 --- a/R/dlink.R +++ b/R/dlink.R @@ -9,69 +9,84 @@ #' x_1 < x_2 holds, then link(x_1) < link(x_2). #' #' @keywords internal -'dlink<-' <- function(object, value) { - if(is.dlink(value)) - trans <- value - else { - trans <- match.fun(value)() - } - assert_that(is.dlink(trans)) - attr(object, "link") <- trans - object +"dlink<-" <- function(object, value) { + if (is.dlink(value)) { + trans <- value + } else { + trans <- match.fun(value)() + } + assert_that(is.dlink(trans)) + attr(object, "link") <- trans + object } dlink <- function(object) { - attr(object, "link") + attr(object, "link") } dlink_new <- function(name, link, inv, Jinv_orig, lJinv_orig, lJinv_link) { - if (is.character(link)) - link <- match.fun(link) - if (is.character(inv)) - inv <- match.fun(inv) - if (is.character(Jinv_orig)) - Jinv_orig <- match.fun(Jinv_orig) - if (is.character(lJinv_orig)) - lJinv_orig <- match.fun(lJinv_orig) - if (is.character(lJinv_link)) - lJinv_link <- match.fun(lJinv_link) + if (is.character(link)) { + link <- match.fun(link) + } + if (is.character(inv)) { + inv <- match.fun(inv) + } + if (is.character(Jinv_orig)) { + Jinv_orig <- match.fun(Jinv_orig) + } + if (is.character(lJinv_orig)) { + lJinv_orig <- match.fun(lJinv_orig) + } + if (is.character(lJinv_link)) { + lJinv_link <- match.fun(lJinv_link) + } - structure(list(name=name, link=link, invlink=inv, - Jinv_orig=Jinv_orig, - lJinv_orig=lJinv_orig, - lJinv_link=lJinv_link), class="dlink") + structure(list( + name = name, link = link, invlink = inv, + Jinv_orig = Jinv_orig, + lJinv_orig = lJinv_orig, + lJinv_link = lJinv_link + ), class = "dlink") } -identity_dlink <- dlink_new("identity", - identity, identity, - Curry(fill, value=1), Curry(fill, value=0), Curry(fill, value=0)) +identity_dlink <- dlink_new( + "identity", + identity, identity, + Curry(fill, value = 1), Curry(fill, value = 0), Curry(fill, value = 0) +) -logit_Jinverse_orig <- function(mu) mu * (1-mu) +logit_Jinverse_orig <- function(mu) mu * (1 - mu) logit_lJinverse_orig <- function(mu) log(mu) + log1p(-mu) logit_lJinverse_link <- function(l) log_inv_logit(l) + log_inv_logit(-l) -logit_dlink <- dlink_new("logit", - binomial()$linkfun, binomial()$linkinv, - logit_Jinverse_orig, logit_lJinverse_orig, logit_lJinverse_link) +logit_dlink <- dlink_new( + "logit", + binomial()$linkfun, binomial()$linkinv, + logit_Jinverse_orig, logit_lJinverse_orig, logit_lJinverse_link +) -log_dlink <- dlink_new("log", - log, exp, - identity, log, identity) +log_dlink <- dlink_new( + "log", + log, exp, + identity, log, identity +) -link_map <- list(identity=identity_dlink, - logit=logit_dlink, - log=log_dlink) +link_map <- list( + identity = identity_dlink, + logit = logit_dlink, + log = log_dlink +) canonical_dlink <- function(mix) { - if(inherits(mix, "betaMix")) { - dlink(mix) <- logit_dlink - return(mix) - } - if(inherits(mix, "gammaMix")) { - dlink(mix) <- log_dlink - return(mix) - } + if (inherits(mix, "betaMix")) { + dlink(mix) <- logit_dlink return(mix) + } + if (inherits(mix, "gammaMix")) { + dlink(mix) <- log_dlink + return(mix) + } + return(mix) } #' Fill numeric objects @@ -84,19 +99,22 @@ canonical_dlink <- function(mix) { #' #' @keywords internal fill <- function(x, value) { - cl <- class(x) - ax <- array(value, dim(as.array(x))) - class(ax) <- class(x) - attributes(ax) <- attributes(x) - ax + cl <- class(x) + ax <- array(value, dim(as.array(x))) + class(ax) <- class(x) + attributes(ax) <- attributes(x) + ax } -is.dlink <- function(x) - inherits(x, "dlink") +is.dlink <- function(x) { + inherits(x, "dlink") +} -is.dlink_identity <- function(x) - is.dlink(x) & x$name == "identity" +is.dlink_identity <- function(x) { + is.dlink(x) & x$name == "identity" +} #' @export -print.dlink <- function(x, ...) - cat("Link:", x$name, "\n") +print.dlink <- function(x, ...) { + cat("Link:", x$name, "\n") +} diff --git a/R/forest_plot.R b/R/forest_plot.R index 0347cc7..ec82dce 100644 --- a/R/forest_plot.R +++ b/R/forest_plot.R @@ -35,7 +35,7 @@ #' forest_plot(map_AS) #' #' # standard forest plot (only stratified estimate and Mean) -#' forest_plot(map_AS, est=c("Mean"), model="stratified") +#' forest_plot(map_AS, est = c("Mean"), model = "stratified") #' #' # to further customize these plots, first load bayesplot and ggplot2 #' library(bayesplot) @@ -44,89 +44,95 @@ #' # to make plots with red colors, big fonts for presentations, suppress #' # the x axis label and add another title (with a subtitle) #' color_scheme_set("red") -#' theme_set(theme_default(base_size=16)) -#' forest_plot(map_AS, size=2) + -#' yaxis_title(FALSE) + -#' ggtitle("Ankylosing Spondylitis Forest Plot", -#' subtitle="Control Group Response Rate") +#' theme_set(theme_default(base_size = 16)) +#' forest_plot(map_AS, size = 2) + +#' yaxis_title(FALSE) + +#' ggtitle("Ankylosing Spondylitis Forest Plot", +#' subtitle = "Control Group Response Rate" +#' ) #' #' # the defaults are set with #' color_scheme_set("blue") -#' theme_set(theme_default(base_size=12)) +#' theme_set(theme_default(base_size = 12)) #' #' @export forest_plot <- function(x, - prob=0.95, + prob = 0.95, est = c("both", "MAP", "Mean", "none"), model = c("stratified", "both", "meta"), point_est = c("median", "mean"), - size=1.25, - alpha=0.5) { + size = 1.25, + alpha = 0.5) { + assert_number(prob, lower = 0, upper = 1) + assert_that(inherits(x, "gMAP")) + assert_that(x$has_intercept) + est <- match.arg(est) + low <- (1 - prob) / 2 + up <- 1 - low + strat <- as.data.frame(x$est_strat(1 - prob)) + strat <- cbind(strat[1:2], median = strat$mean, strat[3:4]) + names(strat)[3:4] <- c("low", "up") + fit <- as.data.frame(fitted(x, type = "response", probs = c(0.5, low, up))) - assert_number(prob, lower=0, upper=1) - assert_that(inherits(x, "gMAP")) - assert_that(x$has_intercept) - est <- match.arg(est) - low <- (1-prob)/2 - up <- 1-low - strat <- as.data.frame(x$est_strat(1-prob)) - strat <- cbind(strat[1:2], median=strat$mean, strat[3:4]) - names(strat)[3:4] <- c("low", "up") - fit <- as.data.frame(fitted(x, type="response", probs=c(0.5, low, up))) + est <- match.arg(est) + model <- match.arg(model) + point_est <- match.arg(point_est) - est <- match.arg(est) - model <- match.arg(model) - point_est <- match.arg(point_est) + if (est == "both") est <- c("MAP", "Mean") + if (model == "both") model <- c("stratified", "meta") - if(est == "both") est <- c("MAP", "Mean") - if(model == "both") model <- c("stratified", "meta") + pred_est <- as.data.frame(do.call(rbind, summary(x, probs = c(0.5, low, up), type = "response")[c("theta.pred", "theta")])) + pred_est <- transform(pred_est, study = c("MAP", "Mean"), model = "meta") + pred_est <- pred_est[c("MAP", "Mean") %in% est, ] - pred_est <- as.data.frame(do.call(rbind, summary(x, probs=c(0.5, low, up), type="response")[c("theta.pred", "theta")])) - pred_est <- transform(pred_est, study=c("MAP", "Mean") , model="meta") - pred_est <- pred_est[c("MAP", "Mean") %in% est,] + names(pred_est)[1:5] <- names(strat) <- names(fit) <- c("mean", "sem", "median", "low", "up") + comb <- rbind( + if ("stratified" %in% model) transform(strat, study = rownames(strat), model = "stratified"), + if ("meta" %in% model) transform(fit, study = rownames(strat), model = "meta"), + pred_est + ) + comb <- within(comb, { + model <- factor(model, levels = c("meta", "stratified")) + study <- factor(study, levels = rev(c(rownames(strat), "Mean", "MAP"))) + }) - names(pred_est)[1:5] <- names(strat) <- names(fit) <- c("mean", "sem", "median", "low", "up") - comb <- rbind(if("stratified" %in% model) transform(strat, study=rownames(strat), model="stratified"), - if("meta" %in% model) transform(fit, study=rownames(strat), model="meta"), - pred_est - ) - comb <- within(comb, { - model <- factor(model, levels=c("meta", "stratified")) - study <- factor(study, levels=rev(c(rownames(strat), "Mean", "MAP"))) - }) + opts <- list(position = position_dodge(width = 0.3), size = size) - opts <- list(position=position_dodge(width=0.3), size=size) + xlab_str <- switch(x$family$family, + gaussian = "Response", + binomial = "Response Rate", + poisson = "Counting Rate" + ) - xlab_str <- switch(x$family$family, - gaussian="Response", - binomial="Response Rate", - poisson="Counting Rate") - - graph <- ggplot(comb, aes(x=.data$study, y=.data[[point_est]], ymin=.data$low, ymax=.data$up, linetype=.data$model, color=.data$model)) + graph <- ggplot(comb, aes(x = .data$study, y = .data[[point_est]], ymin = .data$low, ymax = .data$up, linetype = .data$model, color = .data$model)) - if(any(c("MAP", "Mean") %in% est)) { - ref_line <- est[est %in% c("Mean", "MAP")][1] - ref_data <- subset(pred_est, study == ref_line) - no_ref <- sum(est %in% c("Mean", "MAP")) - graph <- graph + geom_rect(ymin=-Inf, ymax=Inf, xmin=0, xmax=no_ref + 0.5, - fill=get_color("l"), - color=get_color("l"), show.legend=FALSE) + - geom_hline(yintercept=ref_data[1,point_est], - color=get_color("mh"), - alpha=alpha, - size=size) - } + if (any(c("MAP", "Mean") %in% est)) { + ref_line <- est[est %in% c("Mean", "MAP")][1] + ref_data <- subset(pred_est, study == ref_line) + no_ref <- sum(est %in% c("Mean", "MAP")) + graph <- graph + geom_rect( + ymin = -Inf, ymax = Inf, xmin = 0, xmax = no_ref + 0.5, + fill = get_color("l"), + color = get_color("l"), show.legend = FALSE + ) + + geom_hline( + yintercept = ref_data[1, point_est], + color = get_color("mh"), + alpha = alpha, + size = size + ) + } - graph <- graph + - scale_color_manual("Model", values=get_color(c("mh", "m"))) + - do.call(geom_pointrange, opts) + - ylab(xlab_str) + - scale_linetype_discrete("Model") + - theme(axis.line.y=element_blank(), axis.ticks.y=element_blank()) + - bayesplot::bayesplot_theme_get() + - bayesplot::xaxis_title(FALSE) + - coord_flip() + - bayesplot::legend_none() + graph <- graph + + scale_color_manual("Model", values = get_color(c("mh", "m"))) + + do.call(geom_pointrange, opts) + + ylab(xlab_str) + + scale_linetype_discrete("Model") + + theme(axis.line.y = element_blank(), axis.ticks.y = element_blank()) + + bayesplot::bayesplot_theme_get() + + bayesplot::xaxis_title(FALSE) + + coord_flip() + + bayesplot::legend_none() - graph + graph } diff --git a/R/gMAP.R b/R/gMAP.R index c1180e8..315776b 100644 --- a/R/gMAP.R +++ b/R/gMAP.R @@ -6,38 +6,46 @@ #' \code{\link[stats:glm]{glm}} conventions. #' #' @param formula the model formula describing the linear predictor -#' and encoding the grouping; see details -#' @param family the family of distributions defining the statistical -#' model (\code{binomial}, \code{gaussian}, or \code{poisson}) +#' and encoding the grouping; see details +#' @param family defines data likelihood and link function +#' (\code{binomial}, \code{gaussian}, or \code{poisson}) #' @param data optional data frame containing the variables of the -#' model. If not found in \code{data}, the variables are taken from -#' \code{environment(formula)}. +#' model. If not found in \code{data}, the variables are taken +#' from \code{environment(formula)}. #' @param weights optional weight vector; see details below. #' @param offset offset term in statistical model used for Poisson -#' data +#' data #' @param tau.strata sets the exchangability stratum per study. That -#' is, it is expected that each study belongs to a single -#' stratum. Default is to assign all studies to stratum 1. See section -#' differential heterogeniety below. -#' @param tau.strata.pred the index for the prediction stratum; default is 1. +#' is, it is expected that each study belongs to a single +#' stratum. Default is to assign all studies to stratum 1. See +#' section differential heterogeniety below. +#' @param tau.strata.pred the index for the prediction stratum; +#' default is 1. #' @param tau.dist type of prior distribution for \code{tau}; -#' supported priors are \code{HalfNormal} (default), -#' \code{TruncNormal}, \code{Uniform}, \code{Gamma}, \code{InvGamma}, -#' \code{LogNormal}, \code{TruncCauchy}, \code{Exp} and \code{Fixed}. +#' supported priors are \code{HalfNormal} (default), +#' \code{TruncNormal}, \code{Uniform}, \code{Gamma}, +#' \code{InvGamma}, \code{LogNormal}, \code{TruncCauchy}, +#' \code{Exp} and \code{Fixed}. #' @param tau.prior parameters of prior distribution for \code{tau}; -#' see section prior specification below. +#' see section prior specification below. #' @param beta.prior mean and standard deviation for normal priors of -#' regression coefficients, see section prior specification below. -#' @param prior_PD logical to indicate if the prior predictive distribution should be sampled (no conditioning on the data). Defaults to \code{FALSE}. -#' @param REdist type of random effects distribution. \code{Normal} (default) or \code{t}. -#' @param t.df degrees of freedom if random-effects distribution is \code{t}. +#' regression coefficients, see section prior specification below. +#' @param prior_PD logical to indicate if the prior predictive +#' distribution should be sampled (no conditioning on the +#' data). Defaults to \code{FALSE}. +#' @param REdist type of random effects distribution. \code{Normal} +#' (default) or \code{t}. +#' @param t.df degrees of freedom if random-effects distribution is +#' \code{t}. #' @param contrasts an optional list; See \code{contrasts.arg} from -#' \code{\link[stats:model.matrix.default]{model.matrix.default}}. +#' \code{\link[stats:model.matrix.default]{model.matrix.default}}. #' @template args-sampling #' @param digits number of displayed significant digits. #' @param probs defines quantiles to be reported. -#' @param type sets reported scale (\code{response} (default) or \code{link}). -#' @param x,object \code{gMAP} analysis object created by \code{gMAP} function +#' @param type sets reported scale (\code{response} (default) or +#' \code{link}). +#' @param x,object \code{gMAP} analysis object created by \code{gMAP} +#' function #' @param ... optional arguments are ignored #' #' @details @@ -276,11 +284,12 @@ #' # illustrated below. #' # for exact reproducible results, the seed must be set #' set.seed(34563) -#' map_AS <- gMAP(cbind(r, n-r) ~ 1 | study, -#' family=binomial, -#' data=AS, -#' tau.dist="HalfNormal", tau.prior=1, -#' beta.prior=2) +#' map_AS <- gMAP(cbind(r, n - r) ~ 1 | study, +#' family = binomial, +#' data = AS, +#' tau.dist = "HalfNormal", tau.prior = 1, +#' beta.prior = 2 +#' ) #' print(map_AS) #' #' # obtain numerical summaries @@ -308,7 +317,7 @@ #' coef(map_AS) #' #' # finally fit MAP prior with parametric mixture -#' map_mix <- mixfit(map_AS, Nc=2) +#' map_mix <- mixfit(map_AS, Nc = 2) #' plot(map_mix)$mix #' #' \donttest{ @@ -325,25 +334,27 @@ #' # n_infinity concept as discussed in Neuenschwander et al., 2010. #' # This assumes a normal approximation which applies for the colitis #' # data set as: -#' p_bar <- mean(with(colitis, r/n)) -#' s <- round(1/sqrt(p_bar * (1-p_bar)), 1) +#' p_bar <- mean(with(colitis, r / n)) +#' s <- round(1 / sqrt(p_bar * (1 - p_bar)), 1) #' # s is the approximate sampling standard deviation and a #' # conservative prior is tau ~ HalfNormal(0,s/2) -#' tau_prior_sd <- s/2 +#' tau_prior_sd <- s / 2 #' #' # Evaluate HalfNormal prior for tau -#' tau_cat <- c(pooling=0 -#' ,small=0.0625 -#' ,moderate=0.125 -#' ,substantial=0.25 -#' ,large=0.5 -#' ,veryLarge=1 -#' ,stratified=Inf) +#' tau_cat <- c( +#' pooling = 0, +#' small = 0.0625, +#' moderate = 0.125, +#' substantial = 0.25, +#' large = 0.5, +#' veryLarge = 1, +#' stratified = Inf +#' ) #' # Interval probabilites (basically saying we are assuming #' # heterogeniety to be smaller than very large) -#' diff(2*pnorm(tau_cat * s, 0, tau_prior_sd)) +#' diff(2 * pnorm(tau_cat * s, 0, tau_prior_sd)) #' # Cumulative probabilities as 1-F -#' 1 - 2*(pnorm(tau_cat * s, 0, tau_prior_sd) - 0.5) +#' 1 - 2 * (pnorm(tau_cat * s, 0, tau_prior_sd) - 0.5) #' #' @template example-stop #' @export @@ -353,595 +364,624 @@ gMAP <- function(formula, weights, offset, tau.strata, - tau.dist=c("HalfNormal","TruncNormal","Uniform","Gamma","InvGamma","LogNormal","TruncCauchy","Exp", "Fixed"), - tau.prior, - tau.strata.pred=1, + tau.dist = c("HalfNormal", "TruncNormal", "Uniform", "Gamma", "InvGamma", "LogNormal", "TruncCauchy", "Exp", "Fixed"), + tau.prior, + tau.strata.pred = 1, beta.prior, - prior_PD=FALSE, - REdist=c("normal","t"), - t.df=5, - contrasts=NULL, - iter=getOption("RBesT.MC.iter" , 6000), - warmup=getOption("RBesT.MC.warmup", 2000), - thin=getOption("RBesT.MC.thin", 4), - init=getOption("RBesT.MC.init", 1), - chains=getOption("RBesT.MC.chains", 4), - cores=getOption("mc.cores", 1L) - ) { - call <- match.call() - - if (is.character(family)) - family <- get(family, mode = "function", envir = parent.frame()) - if (is.function(family)) - family <- family() - if (is.null(family$family)) { - print(family) - stop("'family' not recognized") + prior_PD = FALSE, + REdist = c("normal", "t"), + t.df = 5, + contrasts = NULL, + iter = getOption("RBesT.MC.iter", 6000), + warmup = getOption("RBesT.MC.warmup", 2000), + thin = getOption("RBesT.MC.thin", 4), + init = getOption("RBesT.MC.init", 1), + chains = getOption("RBesT.MC.chains", 4), + cores = getOption("mc.cores", 1L)) { + call <- match.call() + + if (is.character(family)) { + family <- get(family, mode = "function", envir = parent.frame()) + } + if (is.function(family)) { + family <- family() + } + if (is.null(family$family)) { + print(family) + stop("'family' not recognized") + } + + if (missing(data)) { + data <- environment(formula) + } + + mf <- match.call(expand.dots = FALSE) + m <- match(c("formula", "data", "subset", "offset", "weights", "tau.strata", "na.action"), names(mf), 0) + mf <- mf[c(1, m)] + + f <- Formula::Formula(formula) + mf[[1]] <- as.name("model.frame") + mf$formula <- f + ## mf$weights <- weights + mf <- eval(mf, parent.frame()) + mt <- terms(f, rhs = 1) + + ## we only support a single LHS + assert_that(length(f)[1] == 1) + ## check that we have an overall intercept, otherwise the + ## RBesT approach is not straightforward + ## assert_that(attr(terms(mf, rhs=1), "intercept") == 1) + has_intercept <- attr(terms(f, rhs = 1), "intercept") == 1 + + ## if the model response is a matrix, then the first column is + ## interpreted as y and the second as n + y <- model.response(mf) + if (is.matrix(y)) { + ## if y is a matrix, then we expect it to have 2 columns + assert_that(ncol(y) == 2) + ## y.aux is the standard deviation for the case of a normal + ## y.aux is the number of non-responders for the binary case + y.aux <- array(y[, 2]) + y <- array(y[, 1]) + } else { + y <- array(y) + y.aux <- NULL + } + + weights <- model.weights(mf) + H <- NROW(y) + + ## todo: offset right now only taken care of for poisson + ## regression, should be handled for all cases + if (missing(offset)) { + log_offset <- model.offset(model.part(f, data = mf, rhs = 1, terms = TRUE)) + } else { + log_offset <- model.offset(mf) + } + if (is.null(log_offset)) log_offset <- rep(0, H) + log_offset <- array(log_offset) + + ## first define dummy data for all cases, which get overwritten for + ## the case calculated below + + y_se <- array(rep(0, H)) + + r <- array(rep(0, H)) + r_n <- array(rep(1, H)) + + count <- array(rep(0, H)) + + if (length(f)[2] == 1) { + ## no grouping has been given, then treat each data row as + ## individual study + group.factor <- 1:H + } else { + group.factor <- model.part(f, data = mf, rhs = 2) + if (ncol(group.factor) != 1) { + stop("Grouping factor must be a single term (study).") } - - if (missing(data)) - data <- environment(formula) - - mf <- match.call(expand.dots = FALSE) - m <- match(c("formula", "data", "subset", "offset", "weights", "tau.strata", "na.action"), names(mf), 0) - mf <- mf[c(1, m)] - - f <- Formula::Formula(formula) - mf[[1]] <- as.name("model.frame") - mf$formula <- f - ##mf$weights <- weights - mf <- eval(mf, parent.frame()) - mt <- terms(f, rhs=1) - - ## we only support a single LHS - assert_that(length(f)[1] == 1) - ## check that we have an overall intercept, otherwise the - ## RBesT approach is not straightforward - ##assert_that(attr(terms(mf, rhs=1), "intercept") == 1) - has_intercept <- attr(terms(f, rhs=1), "intercept") == 1 - - ## if the model response is a matrix, then the first column is - ## interpreted as y and the second as n - y <- model.response(mf) - if(is.matrix(y)) { - ## if y is a matrix, then we expect it to have 2 columns - assert_that(ncol(y) == 2) - ## y.aux is the standard deviation for the case of a normal - ## y.aux is the number of non-responders for the binary case - y.aux <- array(y[,2]) - y <- array(y[,1]) - } else { - y <- array(y) - y.aux <- NULL + group.factor <- group.factor[, 1] + } + if (!is.factor(group.factor)) { + group.factor <- factor(group.factor) + } + labels <- as.character(group.factor) + group.index <- array(as.integer(group.factor)) + + ## nubmer of groups coded by the factor + n.groups <- nlevels(group.factor) + ## number of groups actually observed in the data + n.groups.obs <- length(unique(group.index)) + + ## estimate of the reference scale, used in the normal case + sigma_ref <- 0 + + ## guess of the sd on the link scale, used to scale variables + sigma_guess <- 1 + + ## guessed tau + tau_guess <- 1 + + ## from here on everything should be defined which is needed for + ## the given cases. Hence check if all inputs are given for the + ## particular cases. + if (family$family == "gaussian") { + assert_that(family$link == "identity") + if (is.null(y.aux)) { + message("No standard error specified for normal data. Assuming standard error of 1 for all data items.") + y.aux <- rep(1, H) } - - weights <- model.weights(mf) - H <- NROW(y) - - ## todo: offset right now only taken care of for poisson - ## regression, should be handled for all cases - if(missing(offset)) - log_offset <- model.offset(model.part(f, data = mf, rhs = 1, terms = TRUE)) - else - log_offset <- model.offset(mf) - if(is.null(log_offset)) log_offset <- rep(0, H) - log_offset <- array(log_offset) - - ## first define dummy data for all cases, which get overwritten for - ## the case calculated below - - y_se <- array(rep(0,H)) - - r <- array(rep(0,H)) - r_n <- array(rep(1,H)) - - count <- array(rep(0, H)) - - if(length(f)[2] == 1) { - ## no grouping has been given, then treat each data row as - ## individual study - group.factor <- 1:H + y_se <- y.aux + y_n <- weights + ## reference scale is the pooled variance estimate scaled by + ## the total sample size + if (!is.null(y_se) & !is.null(y_n)) { + sigma_ref <- sqrt(sum(y_n) * 1 / sum(1 / y_se^2)) + sigma_guess <- sigma_ref } else { - group.factor <- model.part(f, data = mf, rhs = 2) - if(ncol(group.factor) != 1) - stop("Grouping factor must be a single term (study).") - group.factor <- group.factor[,1] + sigma_ref <- NULL + sigma_guess <- tau_guess } - if (!is.factor(group.factor)) { - group.factor <- factor(group.factor) + if (n.groups.obs > 1) { + tau_guess <- max(sigma_guess / 10, sd(tapply(y, group.index, mean))) } - labels <- as.character(group.factor) - group.index <- array(as.integer(group.factor)) - - ## nubmer of groups coded by the factor - n.groups <- nlevels(group.factor) - ## number of groups actually observed in the data - n.groups.obs <- length(unique(group.index)) - - ## estimate of the reference scale, used in the normal case - sigma_ref <- 0 - - ## guess of the sd on the link scale, used to scale variables - sigma_guess <- 1 - - ## guessed tau - tau_guess <- 1 - - ## from here on everything should be defined which is needed for - ## the given cases. Hence check if all inputs are given for the - ## particular cases. - if(family$family == "gaussian") { - assert_that(family$link == "identity") - if(is.null(y.aux)) { - message("No standard error specified for normal data. Assuming standard error of 1 for all data items.") - y.aux <- rep(1, H) - } - y_se <- y.aux - y_n <- weights - ## reference scale is the pooled variance estimate scaled by - ## the total sample size - if(!is.null(y_se) & !is.null(y_n)) { - sigma_ref <- sqrt( sum(y_n) * 1/sum(1/y_se^2) ) - sigma_guess <- sigma_ref - } else { - sigma_ref <- NULL - sigma_guess <- tau_guess - } - if(n.groups.obs > 1) { - tau_guess <- max(sigma_guess/10, sd( tapply(y, group.index, mean) ) ) - } + } + if (family$family == "binomial") { + assert_that(family$link == "logit") + r <- y + nr <- y.aux + r_n <- y + y.aux + lodds <- log((y + 0.5) / (nr + 0.5)) + ## p_bar would be 1 of r=n + ## p_bar <- (sum(r) + 0.5)/ (sum(r_n) + 0.5) + p_bar <- mean(inv_logit(lodds)) + sigma_guess <- 1 / sqrt(p_bar * (1 - p_bar)) + if (n.groups.obs > 1) { + tau_guess <- max(sigma_guess / 10, sd(tapply(lodds, group.index, mean))) } - if(family$family == "binomial") { - assert_that(family$link == "logit") - r <- y - nr <- y.aux - r_n <- y + y.aux - lodds <- log((y + 0.5)/(nr + 0.5)) - ## p_bar would be 1 of r=n - ##p_bar <- (sum(r) + 0.5)/ (sum(r_n) + 0.5) - p_bar <- mean(inv_logit(lodds)) - sigma_guess <- 1/sqrt(p_bar * (1-p_bar)) - if(n.groups.obs > 1) { - tau_guess <- max(sigma_guess/10, sd( tapply(lodds, group.index, mean) ) ) - } - } - if(family$family == "poisson") { - assert_that(family$link == "log") - count <- y - sigma_guess <- 1/exp(mean(log(y + 0.5) - log_offset)) - if(n.groups.obs > 1) { - tau_guess <- max(sigma_guess/10, sd( tapply(log(y + 0.5) - log_offset, group.index, mean) ) ) - } else { - tau_guess <- sigma_guess - } - } - - ## create a unique label vector - ulabels <- labels - if(length(unique(ulabels)) != length(ulabels)) { - group_column <- names(model.part(f, data = mf, rhs = 2))[1] - data_factors <- setdiff(names(.getXlevels(mt, mf)), group_column) - if(!is.null(model.extract(mf, "tau.strata"))) { - group_column <- c(group_column, "(tau.strata)") - } - label_columns <- c(group_column, data_factors) - if(length(label_columns) > 1) - ulabels <- do.call(paste, c(mf[,label_columns], list(sep="/"))) - ## if now labels are still not unique, we label them sequentially - if(length(unique(ulabels)) != length(ulabels)) { - for(l in unique(labels)) { - ind <- labels == l - if(sum(ind) > 1) { - ulabels[ind] <- paste(ulabels[ind], seq(1,sum(ind)), sep="/") - } - } - } - } - - ## per group we must have an assignment to a tau stratum - tau.strata.factor <- model.extract(mf, "tau.strata") - if(is.null(tau.strata.factor)) { - tau.strata.factor <- rep(1, H) + } + if (family$family == "poisson") { + assert_that(family$link == "log") + count <- y + sigma_guess <- 1 / exp(mean(log(y + 0.5) - log_offset)) + if (n.groups.obs > 1) { + tau_guess <- max(sigma_guess / 10, sd(tapply(log(y + 0.5) - log_offset, group.index, mean))) } else { - ## check that per group the tau stratum is unique - for(g in levels(group.factor)) { - gind <- group.factor == g - if(length(unique(tau.strata.factor[gind])) != 1) - stop("Found multiple tau strata defined for group", g, "!\nEach tau stratum must correspond to a unique group.") - } + tau_guess <- sigma_guess } - if(!is.factor(tau.strata.factor)) - tau.strata.factor <- factor(tau.strata.factor) - tau.strata.index <- as.integer(tau.strata.factor) - n.tau.strata <- max(nlevels(tau.strata.factor), tau.strata.pred) - tau.strata.index <- array(as.integer(tau.strata.factor)) - - ## setup design matrix - X <- model.matrix(f, mf, rhs=1, contrasts.arg=contrasts) - - ## stratified estimates - est_strat <- function(alpha) { - z <- qnorm(1-alpha/2) - theta_resp.strat <- switch(family$family, - gaussian = cbind(y, y_se ,y - z * y_se,y + z * y_se), - binomial = cbind(r/r_n, sqrt(r/(r_n) * (1-r/r_n) / r_n), BinaryExactCI(r, r_n, alpha, drop=FALSE) ), - poisson = cbind(count/exp(log_offset), sqrt(count/exp(2*log_offset)), do.call(cbind, lapply(c(low=alpha/2, high=1-alpha/2), qgamma, shape=count + 0.5 * (count == 0), rate=exp(log_offset)))) - ) - dimnames(theta_resp.strat) <- list(ulabels,c("mean","se",paste0(c(100 * alpha/2, 100 *(1-alpha/2)), "%" ))) - theta_resp.strat + } + + ## create a unique label vector + ulabels <- labels + if (length(unique(ulabels)) != length(ulabels)) { + group_column <- names(model.part(f, data = mf, rhs = 2))[1] + data_factors <- setdiff(names(.getXlevels(mt, mf)), group_column) + if (!is.null(model.extract(mf, "tau.strata"))) { + group_column <- c(group_column, "(tau.strata)") } - theta_resp.strat <- est_strat(0.05) - theta.strat <- family$linkfun(theta_resp.strat) - - ## pooled estimates via glm fit - fit.pooled <- if(family$family == "gaussian") { - glm.fit(X, y, weights=as.vector(1/y_se^2), offset=log_offset, family=family) - } else { - glm.fit(X, model.response(mf), weights=as.vector(weights), offset=as.vector(log_offset), family=family) + label_columns <- c(group_column, data_factors) + if (length(label_columns) > 1) { + ulabels <- do.call(paste, c(mf[, label_columns], list(sep = "/"))) } - theta.pooled <- fit.pooled$fitted.values - theta_resp.pooled <- family$linkinv(fit.pooled$fitted.values) - - ## pooled fit should be replaced in the future with call to Stan - ## optimizer: - ##dataFixedL <- modifyList(dataL, list(tau_prior_dist=-1, tau_prior=matrix(1e-5, nrow=n.tau.strata, ncol=2))) - ##fit_pooled <- optimizing(gMAP_model@stanmodel, data=dataFixedL) - - mX <- NCOL(X) - - if (missing(beta.prior)) { - if(family$family == "gaussian") { - beta.prior <- c(1e2*tau_guess) - } - if(family$family == "poisson") { - beta.prior <- log(1e2) + tau_guess + ## if now labels are still not unique, we label them sequentially + if (length(unique(ulabels)) != length(ulabels)) { + for (l in unique(labels)) { + ind <- labels == l + if (sum(ind) > 1) { + ulabels[ind] <- paste(ulabels[ind], seq(1, sum(ind)), sep = "/") } - if(family$family == "binomial") { - beta.prior <- c(2) - } - message(paste("Assuming default prior dispersion for beta:", paste(beta.prior, collapse=", "))) + } } - if(NCOL(beta.prior) == 1) { - if(length(beta.prior) != 1) { - assert_that(length(beta.prior) == mX) - } else { - beta.prior <- rep(beta.prior, mX) - } - beta.prior.location <- rep(0, mX) - message("Assuming default prior location for beta: ", paste(beta.prior.location, collapse=", ")) - if(mX > 1) - warning("Check default prior location for intercept and regression coefficients!") - beta.prior <- cbind(mean=beta.prior.location, sd=beta.prior) + } + + ## per group we must have an assignment to a tau stratum + tau.strata.factor <- model.extract(mf, "tau.strata") + if (is.null(tau.strata.factor)) { + tau.strata.factor <- rep(1, H) + } else { + ## check that per group the tau stratum is unique + for (g in levels(group.factor)) { + gind <- group.factor == g + if (length(unique(tau.strata.factor[gind])) != 1) { + stop("Found multiple tau strata defined for group", g, "!\nEach tau stratum must correspond to a unique group.") + } } - if(!is.matrix(beta.prior)) - beta.prior <- matrix(beta.prior, mX, 2, byrow=TRUE, list(NULL, c("mean", "sd"))) - - tau.dist <- match.arg(tau.dist) - - if(missing(tau.prior)) { - ## abort execution if tau.prior not given - stop("tau.prior must be set. This parameter is problem specific. Please consult documentation for details.") - tau.prior <- switch(tau.dist, - Fixed = c(1, 0), - HalfNormal = c(0, 1), - TruncNormal = c(0, 1), - Uniform = c(0, 1), - Gamma = c(1, 1), - InvGamma = c(2, 1), - LogNormal = c(0, 1), - TruncCauchy = c(0, 1), - Exp = c(1, 0)) - tau.prior <- matrix(tau.prior, nrow=1, ncol=2) + } + if (!is.factor(tau.strata.factor)) { + tau.strata.factor <- factor(tau.strata.factor) + } + tau.strata.index <- as.integer(tau.strata.factor) + n.tau.strata <- max(nlevels(tau.strata.factor), tau.strata.pred) + tau.strata.index <- array(as.integer(tau.strata.factor)) + + ## setup design matrix + X <- model.matrix(f, mf, rhs = 1, contrasts.arg = contrasts) + + ## stratified estimates + est_strat <- function(alpha) { + z <- qnorm(1 - alpha / 2) + theta_resp.strat <- switch(family$family, + gaussian = cbind(y, y_se, y - z * y_se, y + z * y_se), + binomial = cbind(r / r_n, sqrt(r / (r_n) * (1 - r / r_n) / r_n), BinaryExactCI(r, r_n, alpha, drop = FALSE)), + poisson = cbind(count / exp(log_offset), sqrt(count / exp(2 * log_offset)), do.call(cbind, lapply(c(low = alpha / 2, high = 1 - alpha / 2), qgamma, shape = count + 0.5 * (count == 0), rate = exp(log_offset)))) + ) + dimnames(theta_resp.strat) <- list(ulabels, c("mean", "se", paste0(c(100 * alpha / 2, 100 * (1 - alpha / 2)), "%"))) + theta_resp.strat + } + theta_resp.strat <- est_strat(0.05) + theta.strat <- family$linkfun(theta_resp.strat) + + ## pooled estimates via glm fit + fit.pooled <- if (family$family == "gaussian") { + glm.fit(X, y, weights = as.vector(1 / y_se^2), offset = log_offset, family = family) + } else { + glm.fit(X, model.response(mf), weights = as.vector(weights), offset = as.vector(log_offset), family = family) + } + theta.pooled <- fit.pooled$fitted.values + theta_resp.pooled <- family$linkinv(fit.pooled$fitted.values) + + ## pooled fit should be replaced in the future with call to Stan + ## optimizer: + ## dataFixedL <- modifyList(dataL, list(tau_prior_dist=-1, tau_prior=matrix(1e-5, nrow=n.tau.strata, ncol=2))) + ## fit_pooled <- optimizing(gMAP_model@stanmodel, data=dataFixedL) + + mX <- NCOL(X) + + if (missing(beta.prior)) { + if (family$family == "gaussian") { + beta.prior <- c(1e2 * tau_guess) } - - assert_that(is.numeric(tau.prior)) - - ## in case the user did not provide a matrix as prior.tau, try to - ## guess if possible - if(NCOL(tau.prior) == 1) { - if(n.tau.strata == 1 & length(tau.prior) == 2) - tau.prior <- matrix(tau.prior, nrow=1, ncol=2) - if(n.tau.strata > 1 & !is.matrix(tau.prior) & tau.dist %in% c("LogNormal", "Gamma", "InvGamma")) { - stop("Random effects dispersion distribution LogNormal, Gamma and InvGamma require matrix for tau.prior.") - } - if(!is.matrix(tau.prior)) { - if(tau.dist %in% c("Fixed", "Exp")) { - tau.prior <- cbind(tau.prior, 0) - } else { - tau.prior <- cbind(0, tau.prior) - } - } + if (family$family == "poisson") { + beta.prior <- log(1e2) + tau_guess } - - if(NROW(tau.prior) < n.tau.strata) { - stop("Multiple tau.strata defined, but tau.prior parameter not set for all strata.") + if (family$family == "binomial") { + beta.prior <- c(2) } - if(NROW(tau.prior) > n.tau.strata) { - stop("More tau priors defined than tau.strata defined.") + message(paste("Assuming default prior dispersion for beta:", paste(beta.prior, collapse = ", "))) + } + if (NCOL(beta.prior) == 1) { + if (length(beta.prior) != 1) { + assert_that(length(beta.prior) == mX) + } else { + beta.prior <- rep(beta.prior, mX) } - - ## code prior distribution - tau_prior_dist <- switch(tau.dist - ,Fixed=-1 - ,HalfNormal=0 - ,TruncNormal=1 - ,Uniform=2 - ,Gamma=3 - ,InvGamma=4 - ,LogNormal=5 - ,TruncCauchy=6 - ,Exp=7 - ) - - if(tau.dist == "HalfNormal") - assert_that(all(tau.prior[,1] == 0)) - - REdist <- match.arg(REdist) - - re_dist <- ifelse(REdist == "normal", 0, 1) - re_dist_t_df <- t.df - - link <- switch(family$family, - gaussian = 1, - binomial = 2, - poisson = 3 - ) - - ## Model parametrization - ## 0 = Use CP - ## 1 = Use NCP - ## 2 = Automatically detect which param to take - ncp <- getOption("RBesT.MC.ncp", 1) - - assert_number(ncp, lower=0, upper=2) - - ## automatically detect if we have a sparse or rich data situation - ## (very experimental detection, default is to use NCP) - if(ncp == 2) { - ncp <- 1 - ## we only have a tau_guess for H>1, then we set the CP - ## parametrization whenever on average of the standard error is - ## much smaller than the guessed tau in which case each group - ## is estimated with high precision from the data in - ## comparison to the between-group variation - if( H>1 & sqrt(tau_guess^2 / max(theta_resp.strat[,"se"]^2)) > 20) - ncp <- 0 + beta.prior.location <- rep(0, mX) + message("Assuming default prior location for beta: ", paste(beta.prior.location, collapse = ", ")) + if (mX > 1) { + warning("Check default prior location for intercept and regression coefficients!") } - - ## calculate very roughly the scale of tau and mu; tau is - ## calculated on the log-scale - - ## approximate maximal sample size we may get - nInf <- 0.9 * (sigma_guess / tau_guess)^2 - - ## consider here that the ss is chisq distributed; however, we - ## need the square root transformed distribution; now this - ## estimate will be over-confident since the between-group - ## variation decreases the information we have. Hence we inflate - ## the resulting sd according to the ratio of - ## n_inf/n_(n.groups-1)/2 (eq. 11, Neuenschwander 2010) - if(n.groups > 1) { - ms <- square_root_gamma_stats((n.groups-1)/2, 2 * tau_guess^2 /(n.groups-1)) - ms[2] <- sqrt(1 + 2/(n.groups-1)) * ms[2] - tau_raw_guess <- c(log(ms[1]) - log( sqrt( (1 + ms[2]^2/ms[1]^2) ) ), - sqrt(log(1 + ms[2]^2/ms[1]^2))) - } else { - tau_raw_guess <- c(log(tau_guess), 1) + beta.prior <- cbind(mean = beta.prior.location, sd = beta.prior) + } + if (!is.matrix(beta.prior)) { + beta.prior <- matrix(beta.prior, mX, 2, byrow = TRUE, list(NULL, c("mean", "sd"))) + } + + tau.dist <- match.arg(tau.dist) + + if (missing(tau.prior)) { + ## abort execution if tau.prior not given + stop("tau.prior must be set. This parameter is problem specific. Please consult documentation for details.") + tau.prior <- switch(tau.dist, + Fixed = c(1, 0), + HalfNormal = c(0, 1), + TruncNormal = c(0, 1), + Uniform = c(0, 1), + Gamma = c(1, 1), + InvGamma = c(2, 1), + LogNormal = c(0, 1), + TruncCauchy = c(0, 1), + Exp = c(1, 0) + ) + tau.prior <- matrix(tau.prior, nrow = 1, ncol = 2) + } + + assert_that(is.numeric(tau.prior)) + + ## in case the user did not provide a matrix as prior.tau, try to + ## guess if possible + if (NCOL(tau.prior) == 1) { + if (n.tau.strata == 1 & length(tau.prior) == 2) { + tau.prior <- matrix(tau.prior, nrow = 1, ncol = 2) } - - beta_raw_guess <- rbind(mean=fit.pooled$coefficients, - sd=rep(sigma_guess/sqrt(nInf), mX)) - - assert_logical(prior_PD, FALSE, len=1) - - fitData <- list("H", "X", "mX", "link", - "y", "y_se", - "r", "r_n", - "count", "log_offset", - "tau_prior_dist", - "re_dist", "re_dist_t_df", - "group.index", "n.groups", - "tau.strata.index", "n.tau.strata", "tau.strata.pred", - "beta.prior", "tau.prior", - "ncp", "tau_raw_guess", "beta_raw_guess", - "prior_PD") - - ## MODEL SETUP - - ##para <- c("beta", "tau", "theta", "theta_pred", "theta_resp_pred", "beta_raw", "tau_raw", "lp__") - - ## place data in a named list for safer passing it around in R - dataL <- mget(unlist(fitData), envir=as.environment(-1)) - - ## convert to Stan's 0/1 convention - dataL$prior_PD <- as.integer(dataL$prior_PD) - - ## change variable naming conventions, replace forbidden "." to - ## "_" - names(dataL) <- gsub("\\.", "_", names(dataL)) - - ## run model with Stan - - rescale <- getOption("RBesT.MC.rescale", TRUE) - control_user <- getOption("RBesT.MC.control", list()) - control <- modifyList(list(adapt_delta=0.99, stepsize=0.01, max_treedepth=20), control_user) - verbose <- getOption("RBesT.verbose", FALSE) - - assert_flag(rescale) - assert_number(init, lower=0, finite=TRUE) - - if(!rescale) { - dataL$tau_raw_guess[2] <- 1 - dataL$beta_raw_guess[2,] <- 1 + if (n.tau.strata > 1 & !is.matrix(tau.prior) & tau.dist %in% c("LogNormal", "Gamma", "InvGamma")) { + stop("Random effects dispersion distribution LogNormal, Gamma and InvGamma require matrix for tau.prior.") } - - exclude_pars <- c("beta_raw", "tau_raw", "xi_eta") - ## in absence of an overall intercept we drop the MAP posterior - if(!has_intercept) - exclude_pars <- c(exclude_pars, "theta_pred", "theta_resp_pred") - - if(verbose) - exclude_pars <- c() - - ## MODEL RUN - stan_msg <- capture.output(fit <- rstan::sampling(stanmodels$gMAP, - data=dataL, - ##pars=para, - warmup=warmup, - iter=iter, - chains=chains, - cores=cores, - thin=thin, - init=init, - refresh=0, - control=control, - algorithm = "NUTS", - open_progress=FALSE, - pars=exclude_pars, - include=FALSE, - save_warmup=TRUE - )) - - if(attributes(fit)$mode != 0) - stop("Stan sampler did not run successfully!") - - ## only display Stan messages in verbose mode - if(verbose) { - cat(paste(c(stan_msg, ""), collapse="\n")) + if (!is.matrix(tau.prior)) { + if (tau.dist %in% c("Fixed", "Exp")) { + tau.prior <- cbind(tau.prior, 0) + } else { + tau.prior <- cbind(0, tau.prior) + } } - - ## MODEL FINISHED - fit_sum <- rstan::summary(fit)$summary - - vars <- rownames(fit_sum) - - beta_ind <- grep("^beta\\[", vars) - tau_ind <- grep("^tau\\[", vars) - lp_ind <- grep("^lp__", vars) - - beta <- fit_sum[beta_ind, "mean"] - tau <- fit_sum[tau_ind , "mean"] - - names(beta) <- colnames(X) - names(tau) <- paste0("tau", seq(n.tau.strata)) - - Rhat.max <- max(fit_sum[,"Rhat"], na.rm=TRUE) - - if(Rhat.max > 1.1) - warning("Maximal Rhat > 1.1. Consider increasing RBesT.MC.warmup MCMC parameter.") - - Neff.min <- min(fit_sum[c(beta_ind, tau_ind, lp_ind),"n_eff"], na.rm=TRUE) - - if(Neff.min < 1e3) - message("Final MCMC sample equivalent to less than 1000 independent draws.\nPlease consider increasing the MCMC simulation size.") - - ## set internal RBesT thinning to 1 - thin <- 1 - - ## finally include a check if the Stan NuTS sample had any - ## divergence in the sampling phase, these are not supposed to - ## happen and can often be avoided by increasing adapt_delta - sampler_params <- get_sampler_params(fit, inc_warmup=FALSE) - n_divergent <- sum(sapply(sampler_params, function(x) sum(x[,'divergent__'])) ) - if(n_divergent > 0) { - warning(paste("In total", n_divergent, "divergent transitions occured during the sampling phase.\nPlease consider increasing adapt_delta closer to 1 with the following command prior to gMAP:\noptions(RBesT.MC.control=list(adapt_delta=0.999))")) + } + + if (NROW(tau.prior) < n.tau.strata) { + stop("Multiple tau.strata defined, but tau.prior parameter not set for all strata.") + } + if (NROW(tau.prior) > n.tau.strata) { + stop("More tau priors defined than tau.strata defined.") + } + + ## code prior distribution + tau_prior_dist <- switch(tau.dist, + Fixed = -1, + HalfNormal = 0, + TruncNormal = 1, + Uniform = 2, + Gamma = 3, + InvGamma = 4, + LogNormal = 5, + TruncCauchy = 6, + Exp = 7 + ) + + if (tau.dist == "HalfNormal") { + assert_that(all(tau.prior[, 1] == 0)) + } + + REdist <- match.arg(REdist) + + re_dist <- ifelse(REdist == "normal", 0, 1) + re_dist_t_df <- t.df + + link <- switch(family$family, + gaussian = 1, + binomial = 2, + poisson = 3 + ) + + ## Model parametrization + ## 0 = Use CP + ## 1 = Use NCP + ## 2 = Automatically detect which param to take + ncp <- getOption("RBesT.MC.ncp", 1) + + assert_number(ncp, lower = 0, upper = 2) + + ## automatically detect if we have a sparse or rich data situation + ## (very experimental detection, default is to use NCP) + if (ncp == 2) { + ncp <- 1 + ## we only have a tau_guess for H>1, then we set the CP + ## parametrization whenever on average of the standard error is + ## much smaller than the guessed tau in which case each group + ## is estimated with high precision from the data in + ## comparison to the between-group variation + if (H > 1 & sqrt(tau_guess^2 / max(theta_resp.strat[, "se"]^2)) > 20) { + ncp <- 0 } - - Out <- list(theta.strat=theta.strat, - theta_resp.strat=theta_resp.strat, - theta.pooled=theta.pooled, - theta_resp.pooled=theta_resp.pooled, - n.tau.strata=n.tau.strata, - sigma_ref=sigma_ref, - tau.strata.pred=tau.strata.pred, - has_intercept=has_intercept, - tau = tau, - beta = beta, - REdist = REdist, - t.df=t.df, - X = X, - Rhat.max = Rhat.max, - thin = thin, - call = call, - family = family, - formula = f, - model = mf, - terms = mt, - xlevels = .getXlevels(mt, mf), - group.factor=group.factor, - tau.strata.factor=tau.strata.factor, - data = data, - log_offset = log_offset, - est_strat=est_strat, - fit=fit, - fit.data=dataL - ) - - structure(Out, class=c("gMAP")) + } + + ## calculate very roughly the scale of tau and mu; tau is + ## calculated on the log-scale + + ## approximate maximal sample size we may get + nInf <- 0.9 * (sigma_guess / tau_guess)^2 + + ## consider here that the ss is chisq distributed; however, we + ## need the square root transformed distribution; now this + ## estimate will be over-confident since the between-group + ## variation decreases the information we have. Hence we inflate + ## the resulting sd according to the ratio of + ## n_inf/n_(n.groups-1)/2 (eq. 11, Neuenschwander 2010) + if (n.groups > 1) { + ms <- square_root_gamma_stats((n.groups - 1) / 2, 2 * tau_guess^2 / (n.groups - 1)) + ms[2] <- sqrt(1 + 2 / (n.groups - 1)) * ms[2] + tau_raw_guess <- c( + log(ms[1]) - log(sqrt((1 + ms[2]^2 / ms[1]^2))), + sqrt(log(1 + ms[2]^2 / ms[1]^2)) + ) + } else { + tau_raw_guess <- c(log(tau_guess), 1) + } + + beta_raw_guess <- rbind( + mean = fit.pooled$coefficients, + sd = rep(sigma_guess / sqrt(nInf), mX) + ) + + assert_logical(prior_PD, FALSE, len = 1) + + fitData <- list( + "H", "X", "mX", "link", + "y", "y_se", + "r", "r_n", + "count", "log_offset", + "tau_prior_dist", + "re_dist", "re_dist_t_df", + "group.index", "n.groups", + "tau.strata.index", "n.tau.strata", "tau.strata.pred", + "beta.prior", "tau.prior", + "ncp", "tau_raw_guess", "beta_raw_guess", + "prior_PD" + ) + + ## MODEL SETUP + + ## para <- c("beta", "tau", "theta", "theta_pred", "theta_resp_pred", "beta_raw", "tau_raw", "lp__") + + ## place data in a named list for safer passing it around in R + dataL <- mget(unlist(fitData), envir = as.environment(-1)) + + ## convert to Stan's 0/1 convention + dataL$prior_PD <- as.integer(dataL$prior_PD) + + ## change variable naming conventions, replace forbidden "." to + ## "_" + names(dataL) <- gsub("\\.", "_", names(dataL)) + + ## run model with Stan + + rescale <- getOption("RBesT.MC.rescale", TRUE) + control_user <- getOption("RBesT.MC.control", list()) + control <- modifyList(list(adapt_delta = 0.99, stepsize = 0.01, max_treedepth = 20), control_user) + verbose <- getOption("RBesT.verbose", FALSE) + + assert_flag(rescale) + assert_number(init, lower = 0, finite = TRUE) + + if (!rescale) { + dataL$tau_raw_guess[2] <- 1 + dataL$beta_raw_guess[2, ] <- 1 + } + + exclude_pars <- c("beta_raw", "tau_raw", "xi_eta") + ## in absence of an overall intercept we drop the MAP posterior + if (!has_intercept) { + exclude_pars <- c(exclude_pars, "theta_pred", "theta_resp_pred") + } + + if (verbose) { + exclude_pars <- c() + } + + ## MODEL RUN + stan_msg <- capture.output(fit <- rstan::sampling(stanmodels$gMAP, + data = dataL, + ## pars=para, + warmup = warmup, + iter = iter, + chains = chains, + cores = cores, + thin = thin, + init = init, + refresh = 0, + control = control, + algorithm = "NUTS", + open_progress = FALSE, + pars = exclude_pars, + include = FALSE, + save_warmup = TRUE + )) + + if (attributes(fit)$mode != 0) { + stop("Stan sampler did not run successfully!") + } + + ## only display Stan messages in verbose mode + if (verbose) { + cat(paste(c(stan_msg, ""), collapse = "\n")) + } + + ## MODEL FINISHED + fit_sum <- rstan::summary(fit)$summary + + vars <- rownames(fit_sum) + + beta_ind <- grep("^beta\\[", vars) + tau_ind <- grep("^tau\\[", vars) + lp_ind <- grep("^lp__", vars) + + beta <- fit_sum[beta_ind, "mean"] + tau <- fit_sum[tau_ind, "mean"] + + names(beta) <- colnames(X) + names(tau) <- paste0("tau", seq(n.tau.strata)) + + Rhat.max <- max(fit_sum[, "Rhat"], na.rm = TRUE) + + if (Rhat.max > 1.1) { + warning("Maximal Rhat > 1.1. Consider increasing RBesT.MC.warmup MCMC parameter.") + } + + Neff.min <- min(fit_sum[c(beta_ind, tau_ind, lp_ind), "n_eff"], na.rm = TRUE) + + if (Neff.min < 1e3) { + message("Final MCMC sample equivalent to less than 1000 independent draws.\nPlease consider increasing the MCMC simulation size.") + } + + ## set internal RBesT thinning to 1 + thin <- 1 + + ## finally include a check if the Stan NuTS sample had any + ## divergence in the sampling phase, these are not supposed to + ## happen and can often be avoided by increasing adapt_delta + sampler_params <- get_sampler_params(fit, inc_warmup = FALSE) + n_divergent <- sum(sapply(sampler_params, function(x) sum(x[, "divergent__"]))) + if (n_divergent > 0) { + warning(paste("In total", n_divergent, "divergent transitions occured during the sampling phase.\nPlease consider increasing adapt_delta closer to 1 with the following command prior to gMAP:\noptions(RBesT.MC.control=list(adapt_delta=0.999))")) + } + + Out <- list( + theta.strat = theta.strat, + theta_resp.strat = theta_resp.strat, + theta.pooled = theta.pooled, + theta_resp.pooled = theta_resp.pooled, + n.tau.strata = n.tau.strata, + sigma_ref = sigma_ref, + tau.strata.pred = tau.strata.pred, + has_intercept = has_intercept, + tau = tau, + beta = beta, + REdist = REdist, + t.df = t.df, + X = X, + Rhat.max = Rhat.max, + thin = thin, + call = call, + family = family, + formula = f, + model = mf, + terms = mt, + xlevels = .getXlevels(mt, mf), + group.factor = group.factor, + tau.strata.factor = tau.strata.factor, + data = data, + log_offset = log_offset, + est_strat = est_strat, + fit = fit, + fit.data = dataL + ) + + structure(Out, class = c("gMAP")) } #' @describeIn gMAP displays a summary of the gMAP analysis. #' @export -print.gMAP <- function(x, digits=3, probs=c(0.025, 0.5, 0.975), ...) { - cat("Generalized Meta Analytic Predictive Prior Analysis\n") - cat("\nCall: ", paste(deparse(x$call), sep = "\n", collapse = "\n"), - "\n\n", sep = "") - cat("Exchangeability tau strata:", x$n.tau.strata,"\n") - cat("Prediction tau stratum :", x$tau.strata.pred,"\n") - cat("Maximal Rhat :", signif(x$Rhat.max, digits=digits),"\n") - - if(x$family$family == "gaussian" & !is.null(x$sigma_ref)) - cat("Estimated reference scale :", signif(x$sigma_ref, digits=digits), "\n") - - csum_tau <- rstan::summary(x$fit, probs=probs, pars=paste0("tau[", x$tau.strata.pred , "]"))$summary - - f <- colnames(csum_tau)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum_tau))] - csum_tau <- csum_tau[,f] - - cat("\nBetween-trial heterogeneity of tau prediction stratum\n") - print(signif(csum_tau, digits=digits)) - - if(x$has_intercept) { - csum_map <- rstan::summary(x$fit, probs=probs, pars="theta_resp_pred")$summary - csum_map <- csum_map[,f] - cat("\nMAP Prior MCMC sample\n") - print(signif(csum_map, digits=digits)) - } - - div_trans <- sum(rstan::get_divergent_iterations(x$fit)) - num_sim <- length(rstan::get_divergent_iterations(x$fit)) - if (div_trans > 0) { - warning( - "The sampler detected ", div_trans, " out of ", num_sim, " transitions ending in a divergence after warmup.\n", - "Increasing 'adapt_delta' closer to 1 may help to avoid these. Use for example: \n", - paste0("options(RBesT.MC.control=list(adapt_delta=0.999))"), - call.=FALSE - ) - } - Rhats <- bayesplot::rhat(x$fit) - if (any(Rhats > 1.1, na.rm = TRUE)) { - warning( - "Parts of the model have not converged (some Rhats are > 1.1).\n", - "Be careful when analysing the results! It is recommend to run\n", - "more iterations and/or setting stronger priors.", call.=FALSE - ) - } - - invisible(x) +print.gMAP <- function(x, digits = 3, probs = c(0.025, 0.5, 0.975), ...) { + cat("Generalized Meta Analytic Predictive Prior Analysis\n") + cat("\nCall: ", paste(deparse(x$call), sep = "\n", collapse = "\n"), + "\n\n", + sep = "" + ) + cat("Exchangeability tau strata:", x$n.tau.strata, "\n") + cat("Prediction tau stratum :", x$tau.strata.pred, "\n") + cat("Maximal Rhat :", signif(x$Rhat.max, digits = digits), "\n") + + if (x$family$family == "gaussian" & !is.null(x$sigma_ref)) { + cat("Estimated reference scale :", signif(x$sigma_ref, digits = digits), "\n") + } + + csum_tau <- rstan::summary(x$fit, probs = probs, pars = paste0("tau[", x$tau.strata.pred, "]"))$summary + + f <- colnames(csum_tau)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum_tau))] + csum_tau <- csum_tau[, f] + + cat("\nBetween-trial heterogeneity of tau prediction stratum\n") + print(signif(csum_tau, digits = digits)) + + if (x$has_intercept) { + csum_map <- rstan::summary(x$fit, probs = probs, pars = "theta_resp_pred")$summary + csum_map <- csum_map[, f] + cat("\nMAP Prior MCMC sample\n") + print(signif(csum_map, digits = digits)) + } + + div_trans <- sum(rstan::get_divergent_iterations(x$fit)) + num_sim <- length(rstan::get_divergent_iterations(x$fit)) + if (div_trans > 0) { + warning( + "The sampler detected ", div_trans, " out of ", num_sim, " transitions ending in a divergence after warmup.\n", + "Increasing 'adapt_delta' closer to 1 may help to avoid these. Use for example: \n", + paste0("options(RBesT.MC.control=list(adapt_delta=0.999))"), + call. = FALSE + ) + } + Rhats <- bayesplot::rhat(x$fit) + if (any(Rhats > 1.1, na.rm = TRUE)) { + warning( + "Parts of the model have not converged (some Rhats are > 1.1).\n", + "Be careful when analysing the results! It is recommend to run\n", + "more iterations and/or setting stronger priors.", + call. = FALSE + ) + } + + invisible(x) } #' @describeIn gMAP returns the quantiles of the posterior shrinkage #' estimates for each data item used during the analysis of the given #' \code{gMAP} object. #' @export -fitted.gMAP <- function(object, type=c("response", "link"), probs = c(0.025, 0.5, 0.975), ...) { - type <- match.arg(type) - trans <- if(type == "response") object$family$linkinv else identity - sim <- rstan::extract(object$fit, pars="theta")$theta - res <- SimSum(trans(sim), probs=probs, margin=2) - dimnames(res) <- list(rownames(object$theta_resp.strat), colnames(res)) - res +fitted.gMAP <- function(object, type = c("response", "link"), probs = c(0.025, 0.5, 0.975), ...) { + type <- match.arg(type) + trans <- if (type == "response") object$family$linkinv else identity + sim <- rstan::extract(object$fit, pars = "theta")$theta + res <- SimSum(trans(sim), probs = probs, margin = 2) + dimnames(res) <- list(rownames(object$theta_resp.strat), colnames(res)) + res } #' @describeIn gMAP returns the quantiles of the predictive @@ -949,24 +989,24 @@ fitted.gMAP <- function(object, type=c("response", "link"), probs = c(0.025, 0.5 #' the response or the link scale. #' @export coef.gMAP <- function(object, probs = c(0.025, 0.5, 0.975), ...) { - csum <- rstan::summary(object$fit, probs=probs, pars="beta")$summary - f <- colnames(csum)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum))] - csum <- subset(csum, select=f) - rownames(csum) <- colnames(object$X) - csum + csum <- rstan::summary(object$fit, probs = probs, pars = "beta")$summary + f <- colnames(csum)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum))] + csum <- subset(csum, select = f) + rownames(csum) <- colnames(object$X) + csum } #' @describeIn gMAP extracts the posterior sample of the model. #' @method as.matrix gMAP #' @export as.matrix.gMAP <- function(x, ...) { - as.matrix(x$fit, pars=c("lp__"), include=FALSE) + as.matrix(x$fit, pars = c("lp__"), include = FALSE) } #' @method model.matrix gMAP #' @export model.matrix.gMAP <- function(object, ...) { - return(model.matrix.default(object, object$data, contrasts.arg=object$contrast)) + return(model.matrix.default(object, object$data, contrasts.arg = object$contrast)) } @@ -980,57 +1020,57 @@ model.matrix.gMAP <- function(object, ...) { #' } #' @method summary gMAP #' @export -summary.gMAP <- function(object, type=c("response", "link"), probs = c(0.025, 0.5, 0.975), ...) { - call <- match.call() - type <- match.arg(type) - csum_beta <- rstan::summary(object$fit, probs=probs, pars=c("beta"))$summary - csum_tau <- rstan::summary(object$fit, probs=probs, pars=c("tau"))$summary - if(object$has_intercept) { - if(type == "response") { - csum_pred <- rstan::summary(object$fit, probs=probs, pars=c("theta_resp_pred"))$summary - csum_mean <- SimSum( object$family$linkinv( rstan::extract(object$fit, pars=c("beta[1]"))[[1]] ), probs=probs ) - rownames(csum_mean) <- "theta_resp" - } else { - csum_pred <- rstan::summary(object$fit, probs=probs, pars=c("theta_pred"))$summary - csum_mean <- rstan::summary(object$fit, probs=probs, pars=c("beta[1]"))$summary - rownames(csum_mean) <- "theta" - } +summary.gMAP <- function(object, type = c("response", "link"), probs = c(0.025, 0.5, 0.975), ...) { + call <- match.call() + type <- match.arg(type) + csum_beta <- rstan::summary(object$fit, probs = probs, pars = c("beta"))$summary + csum_tau <- rstan::summary(object$fit, probs = probs, pars = c("tau"))$summary + if (object$has_intercept) { + if (type == "response") { + csum_pred <- rstan::summary(object$fit, probs = probs, pars = c("theta_resp_pred"))$summary + csum_mean <- SimSum(object$family$linkinv(rstan::extract(object$fit, pars = c("beta[1]"))[[1]]), probs = probs) + rownames(csum_mean) <- "theta_resp" } else { - csum_pred <- NULL - csum_mean <- NULL - } - f <- colnames(csum_beta)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum_beta))] - rownames(csum_beta) <- colnames(object$X) - Out <- list(tau=subset(csum_tau, select=f), beta=subset(csum_beta, select=f)) - if(object$has_intercept) { - Out <- c(Out, list(theta.pred=subset(csum_pred,select=f), theta=subset(csum_mean,select=f))) + csum_pred <- rstan::summary(object$fit, probs = probs, pars = c("theta_pred"))$summary + csum_mean <- rstan::summary(object$fit, probs = probs, pars = c("beta[1]"))$summary + rownames(csum_mean) <- "theta" } - structure(Out, class=c("gMAPsummary"), call=call) + } else { + csum_pred <- NULL + csum_mean <- NULL + } + f <- colnames(csum_beta)[-match(c("se_mean", "n_eff", "Rhat"), colnames(csum_beta))] + rownames(csum_beta) <- colnames(object$X) + Out <- list(tau = subset(csum_tau, select = f), beta = subset(csum_beta, select = f)) + if (object$has_intercept) { + Out <- c(Out, list(theta.pred = subset(csum_pred, select = f), theta = subset(csum_mean, select = f))) + } + structure(Out, class = c("gMAPsummary"), call = call) } #' @export -print.gMAPsummary <- function(x, digits=3, ...) { - cat("Heterogeneity parameter tau per stratum:\n") - print(signif(x$tau, digits=digits)) - cat("\nRegression coefficients:\n") - print(signif(x$beta, digits=digits)) - if("theta" %in% names(x)) { - cat("\nMean estimate MCMC sample:\n") - print(signif(x$theta, digits=digits)) - } - if("theta.pred" %in% names(x)) { - cat("\nMAP Prior MCMC sample:\n") - print(signif(x$theta.pred, digits=digits)) - } - invisible(x) +print.gMAPsummary <- function(x, digits = 3, ...) { + cat("Heterogeneity parameter tau per stratum:\n") + print(signif(x$tau, digits = digits)) + cat("\nRegression coefficients:\n") + print(signif(x$beta, digits = digits)) + if ("theta" %in% names(x)) { + cat("\nMean estimate MCMC sample:\n") + print(signif(x$theta, digits = digits)) + } + if ("theta.pred" %in% names(x)) { + cat("\nMAP Prior MCMC sample:\n") + print(signif(x$theta.pred, digits = digits)) + } + invisible(x) } ## calculate the for a gamma distribution the mean and standard ## deviation of the square root transformed variable ## see square-root-of-gamma mathematica file square_root_gamma_stats <- function(a, b) { - m <- sqrt(b) * exp(lgamma(0.5 + a) - lgamma(a)) - v <- b*a - m^2 - c(mean=m, sd=sqrt(v)) + m <- sqrt(b) * exp(lgamma(0.5 + a) - lgamma(a)) + v <- b * a - m^2 + c(mean = m, sd = sqrt(v)) } diff --git a/R/get_color.R b/R/get_color.R index a8390fc..66a0e5e 100644 --- a/R/get_color.R +++ b/R/get_color.R @@ -1,8 +1,16 @@ # internal utilities to work with bayesplot ------------------------------- #' @keywords internal get_color <- function(levels) { - color_code <- sapply(levels, function(lev) - switch(lev, l=1, lh=2, m=3, mh=4, d=5, dh=6, lev) - ) - unname(unlist(bayesplot::color_scheme_get())[color_code]) + color_code <- sapply(levels, function(lev) { + switch(lev, + l = 1, + lh = 2, + m = 3, + mh = 4, + d = 5, + dh = 6, + lev + ) + }) + unname(unlist(bayesplot::color_scheme_get())[color_code]) } diff --git a/R/integrate_logit_log.R b/R/integrate_logit_log.R index 653ff4f..78631ce 100644 --- a/R/integrate_logit_log.R +++ b/R/integrate_logit_log.R @@ -16,79 +16,84 @@ #' @param Lpupper logit of upper cumulative density #' #' @keywords internal -integrate_density_log <- function(log_integrand, mix, Lplower=-Inf, Lpupper=Inf, eps=getOption("RBesT.integrate_prob_eps", 1E-6)) { - .integrand_comp_logit <- function(mix_comp) { - function(l) { - u <- inv_logit(l) - lp <- log_inv_logit(l) - lnp <- log_inv_logit(-l) - exp(lp + lnp + log_integrand(qmix(mix_comp, u))) - } +integrate_density_log <- function(log_integrand, mix, Lplower = -Inf, Lpupper = Inf, eps = getOption("RBesT.integrate_prob_eps", 1E-6)) { + .integrand_comp_logit <- function(mix_comp) { + function(l) { + u <- inv_logit(l) + lp <- log_inv_logit(l) + lnp <- log_inv_logit(-l) + exp(lp + lnp + log_integrand(qmix(mix_comp, u))) } + } - Nc <- ncol(mix) + Nc <- ncol(mix) - ## integrate by component of mix separatley to increase precision - ## when the density is not 0 at the boundaries integration, then - ## the integration is performed on the natural scale. The check - ## for that is done on the identity scale to avoid numerical - ## issues. - lower <- inv_logit(Lplower) - upper <- inv_logit(Lpupper) - return(sum(vapply(1:Nc, function(comp) { - mix_comp <- mix[[comp, rescale=TRUE]] - fn_integrand_comp_logit <- .integrand_comp_logit(mix_comp) - if (all(!is.na(fn_integrand_comp_logit(c(Lplower, Lpupper))))) { - return(.integrate(fn_integrand_comp_logit, Lplower, Lpupper)) - } - lower_comp <- ifelse(Lplower==-Inf, qmix(mix_comp, eps), qmix(mix_comp, lower)) - upper_comp <- ifelse(Lpupper==Inf, qmix(mix_comp, 1-eps), qmix(mix_comp, upper)) - return(.integrate(function(x) exp(log_integrand(x) + dmix(mix_comp, x, log=TRUE)), lower_comp, upper_comp)) - }, c(0.1)) * mix[1,])) + ## integrate by component of mix separatley to increase precision + ## when the density is not 0 at the boundaries integration, then + ## the integration is performed on the natural scale. The check + ## for that is done on the identity scale to avoid numerical + ## issues. + lower <- inv_logit(Lplower) + upper <- inv_logit(Lpupper) + return(sum(vapply(1:Nc, function(comp) { + mix_comp <- mix[[comp, rescale = TRUE]] + fn_integrand_comp_logit <- .integrand_comp_logit(mix_comp) + if (all(!is.na(fn_integrand_comp_logit(c(Lplower, Lpupper))))) { + return(.integrate(fn_integrand_comp_logit, Lplower, Lpupper)) + } + lower_comp <- ifelse(Lplower == -Inf, qmix(mix_comp, eps), qmix(mix_comp, lower)) + upper_comp <- ifelse(Lpupper == Inf, qmix(mix_comp, 1 - eps), qmix(mix_comp, upper)) + return(.integrate(function(x) exp(log_integrand(x) + dmix(mix_comp, x, log = TRUE)), lower_comp, upper_comp)) + }, c(0.1)) * mix[1, ])) } -integrate_density <- function(integrand, mix, Lplower=-Inf, Lpupper=Inf, eps=getOption("RBesT.integrate_prob_eps", 1E-6)) { - .integrand_comp_logit <- function(mix_comp) { - function(l) { - u <- inv_logit(l) - lp <- log_inv_logit(l) - lnp <- log_inv_logit(-l) - exp(lp + lnp) * integrand(qmix(mix_comp, u)) - } +integrate_density <- function(integrand, mix, Lplower = -Inf, Lpupper = Inf, eps = getOption("RBesT.integrate_prob_eps", 1E-6)) { + .integrand_comp_logit <- function(mix_comp) { + function(l) { + u <- inv_logit(l) + lp <- log_inv_logit(l) + lnp <- log_inv_logit(-l) + exp(lp + lnp) * integrand(qmix(mix_comp, u)) } - Nc <- ncol(mix) + } + Nc <- ncol(mix) + + lower <- inv_logit(Lplower) + upper <- inv_logit(Lpupper) - lower <- inv_logit(Lplower) - upper <- inv_logit(Lpupper) - - return(sum(vapply(1:Nc, function(comp) { - mix_comp <- mix[[comp, rescale=TRUE]] - ## ensure that the integrand is defined at the boundaries... - fn_integrand_comp_logit <- .integrand_comp_logit(mix_comp) - if (all(!is.na(fn_integrand_comp_logit(c(Lplower, Lpupper))))) { - return(.integrate(fn_integrand_comp_logit, Lplower, Lpupper)) - } - ## ... otherwise we avoid the boundaries by eps prob density: - lower_comp <- ifelse(Lplower==-Inf, qmix(mix_comp, eps), qmix(mix_comp, lower)) - upper_comp <- ifelse(Lpupper==Inf, qmix(mix_comp, 1-eps), qmix(mix_comp, upper)) - return(.integrate(function(x) integrand(x) * dmix(mix_comp, x), lower_comp, upper_comp)) - }, c(0.1)) * mix[1,])) + return(sum(vapply(1:Nc, function(comp) { + mix_comp <- mix[[comp, rescale = TRUE]] + ## ensure that the integrand is defined at the boundaries... + fn_integrand_comp_logit <- .integrand_comp_logit(mix_comp) + if (all(!is.na(fn_integrand_comp_logit(c(Lplower, Lpupper))))) { + return(.integrate(fn_integrand_comp_logit, Lplower, Lpupper)) + } + ## ... otherwise we avoid the boundaries by eps prob density: + lower_comp <- ifelse(Lplower == -Inf, qmix(mix_comp, eps), qmix(mix_comp, lower)) + upper_comp <- ifelse(Lpupper == Inf, qmix(mix_comp, 1 - eps), qmix(mix_comp, upper)) + return(.integrate(function(x) integrand(x) * dmix(mix_comp, x), lower_comp, upper_comp)) + }, c(0.1)) * mix[1, ])) } .integrate <- function(integrand, lower, upper) { - integrate_args_user <- getOption("RBesT.integrate_args", list()) - args <- modifyList(list(lower=lower, upper=upper, - rel.tol=.Machine$double.eps^0.25, - abs.tol=.Machine$double.eps^0.25, - subdivisions=1000, - stop.on.error=TRUE), - integrate_args_user) + integrate_args_user <- getOption("RBesT.integrate_args", list()) + args <- modifyList( + list( + lower = lower, upper = upper, + rel.tol = .Machine$double.eps^0.25, + abs.tol = .Machine$double.eps^0.25, + subdivisions = 1000, + stop.on.error = TRUE + ), + integrate_args_user + ) - integrate(integrand, - lower=args$lower, - upper=args$upper, - rel.tol=args$rel.tol, - abs.tol=args$abs.tol, - subdivisions=args$subdivisions, - stop.on.error=args$stop.on.error)$value + integrate(integrand, + lower = args$lower, + upper = args$upper, + rel.tol = args$rel.tol, + abs.tol = args$abs.tol, + subdivisions = args$subdivisions, + stop.on.error = args$stop.on.error + )$value } diff --git a/R/knn.R b/R/knn.R index 08b1373..de1d571 100644 --- a/R/knn.R +++ b/R/knn.R @@ -9,87 +9,92 @@ #' @param Niter.max maximum number of admissible iterations #' #' @keywords internal -knn <- function(X, K=2, init, Ninit=50, verbose=FALSE, tol, Niter.max=500) { - ## in case X is no matrix, interpret it as uni-variate case - if(!is.matrix(X)) - X <- matrix(X,ncol=1) - - if(missing(tol)) { - ## if tol is missing, then set it well below the minimial - ## length-scale in the data set - sdSq <- colVars(X) - ## use k means clustering with K=Nc as init - tol <- min(sdSq)/5 +knn <- function(X, K = 2, init, Ninit = 50, verbose = FALSE, tol, Niter.max = 500) { + ## in case X is no matrix, interpret it as uni-variate case + if (!is.matrix(X)) { + X <- matrix(X, ncol = 1) + } + + if (missing(tol)) { + ## if tol is missing, then set it well below the minimial + ## length-scale in the data set + sdSq <- colVars(X) + ## use k means clustering with K=Nc as init + tol <- min(sdSq) / 5 + } + + N <- dim(X)[1] + Nd <- dim(X)[2] + + if (missing(init)) { + ## initialize randomly + pEst <- runif(K) / K + pEst <- pEst / sum(pEst) + muEst <- matrix(0, K, Nd) + ## sample for each component from the base data + for (i in seq(K)) { + muEst[i, ] <- colMeans(X[sample.int(N, min(Ninit, N), replace = FALSE), , drop = FALSE]) } + } else { + pEst <- init$p + muEst <- init$mu + } - N <- dim(X)[1] - Nd <- dim(X)[2] - - if(missing(init)) { - ## initialize randomly - pEst <- runif(K)/K - pEst <- pEst/sum(pEst) - muEst <- matrix(0, K, Nd) - ## sample for each component from the base data - for(i in seq(K)) - muEst[i,] <- colMeans(X[sample.int(N,min(Ninit, N),replace=FALSE),,drop=FALSE]) - } else { - pEst <- init$p - muEst <- init$mu - } + ## init 1-of-K coding matrix indicating cluster membership + Kresp <- matrix(1:K, nrow = N, ncol = K, byrow = TRUE) + + ## distance matrix which gets updated in each iteration + DM <- matrix(0, N, K) + + iter <- 1 + J <- Inf - ## init 1-of-K coding matrix indicating cluster membership - Kresp <- matrix(1:K,nrow=N,ncol=K,byrow=TRUE) + if (verbose) { + message("K nearest neighbors clustering with K =", K, ":\n") + } - ## distance matrix which gets updated in each iteration - DM <- matrix(0, N, K) + while (iter < Niter.max) { + Jprev <- J - iter <- 1 - J <- Inf + ## "E" step, i.e. find for each data point the cluster with the + ## smallest euclidean distance - if(verbose) { - message("K nearest neighbors clustering with K =", K, ":\n") + for (i in seq(K)) { + DM[, i] <- rowSums(scale(X, muEst[i, ], FALSE)^2) } - while(iter < Niter.max) { - Jprev <- J - - ## "E" step, i.e. find for each data point the cluster with the - ## smallest euclidean distance - - for(i in seq(K)) - DM[,i] <- rowSums(scale(X, muEst[i,], FALSE)^2) - - ##resp <- 1*(Kresp == apply(DM, 1, which.min)) - resp <- 1*(1 == matrixStats::rowRanks(DM, ties.method="first")) - respM <- matrixStats::colSums2(resp) - if(any(respM == 0)) { - warning("Some components are assigned the empty set! Try reducing K.") - respM[respM==0] <- 1 - } - - ## "M" step, i.e. given cluster membership, calculate new means - ##muEst <- sweep(t(resp) %*% X, 1, respM, "/") - muEst <- sweep(crossprod(resp, X), 1, respM, "/", FALSE) - - ## functional to be minimized - J <- sum( (X - resp %*% muEst)^2 ) - delta <- Jprev - J - - if(verbose) - message("Iteration", iter, ": J =", J, "; delta =", delta, "\n") - if(delta < tol) { - break - } - iter <- iter + 1 + ## resp <- 1*(Kresp == apply(DM, 1, which.min)) + resp <- 1 * (1 == matrixStats::rowRanks(DM, ties.method = "first")) + respM <- matrixStats::colSums2(resp) + if (any(respM == 0)) { + warning("Some components are assigned the empty set! Try reducing K.") + respM[respM == 0] <- 1 } - if(iter == Niter.max) - warning("Maximum number of iterations reached.") - res <- list(center=muEst, p=colMeans(resp), J=J, delta=delta, niter=iter) - ##res$cluster <- apply(resp==1, 1, which) - ## 10x faster - res$cluster <- ((which(t(resp==1)) - 1) %% K) + 1 + ## "M" step, i.e. given cluster membership, calculate new means + ## muEst <- sweep(t(resp) %*% X, 1, respM, "/") + muEst <- sweep(crossprod(resp, X), 1, respM, "/", FALSE) - invisible(res) + ## functional to be minimized + J <- sum((X - resp %*% muEst)^2) + delta <- Jprev - J + + if (verbose) { + message("Iteration", iter, ": J =", J, "; delta =", delta, "\n") + } + if (delta < tol) { + break + } + iter <- iter + 1 + } + if (iter == Niter.max) { + warning("Maximum number of iterations reached.") + } + + res <- list(center = muEst, p = colMeans(resp), J = J, delta = delta, niter = iter) + ## res$cluster <- apply(resp==1, 1, which) + ## 10x faster + res$cluster <- ((which(t(resp == 1)) - 1) %% K) + 1 + + invisible(res) } diff --git a/R/likelihood.R b/R/likelihood.R index e29b37d..1f16677 100644 --- a/R/likelihood.R +++ b/R/likelihood.R @@ -34,15 +34,15 @@ NULL #' @rdname likelihood #' @export likelihood <- function(mix) { - likelihood <- attr(mix, "likelihood") - check_choice(likelihood, c("poisson", "exp", "normal", "binomial")) - likelihood + likelihood <- attr(mix, "likelihood") + check_choice(likelihood, c("poisson", "exp", "normal", "binomial")) + likelihood } #' @rdname likelihood #' @export -'likelihood<-' <- function(mix, value) { - check_choice(value, c("poisson", "exp", "normal", "binomial")) - attr(mix, "likelihood") <- value - mix +"likelihood<-" <- function(mix, value) { + check_choice(value, c("poisson", "exp", "normal", "binomial")) + attr(mix, "likelihood") <- value + mix } diff --git a/R/lodds.R b/R/lodds.R index e703974..45adbf2 100644 --- a/R/lodds.R +++ b/R/lodds.R @@ -1,6 +1,6 @@ #' @rdname lodds #' @name lodds -#' +#' #' @title Logit (log-odds) and inverse-logit function. #' #' @description @@ -13,18 +13,18 @@ #' #' @details Values of mu equal to 0 or 1 will return -Inf or Inf #' respectively. -#' +#' #' @return A numeric object of the same type as mu and eta containing #' the logits or inverse logit of the input values. The logit and #' inverse transformation equates to -#' +#' #' \deqn{\mbox{logit}(\mu) = \log(\mu/(1-\mu))}{logit(\mu) = log(\mu/(1-\mu))} #' \deqn{\mbox{logit}^{-1}(\eta)= \exp(\eta)/(1 + \exp(\eta)).}{logit^-1(\eta) = exp(\eta)/(1 + exp(\eta)).} -#' +#' #' @examples #' logit(0.2) #' inv_logit(-1.386) -#' +#' NULL bin <- binomial() diff --git a/R/log_inv_logit.R b/R/log_inv_logit.R index 1c99fc9..fa2c8c4 100644 --- a/R/log_inv_logit.R +++ b/R/log_inv_logit.R @@ -1,10 +1,10 @@ #' Numerically stable log of the inv_logit function #' @keywords internal log_inv_logit <- function(mat) { - ##- ifelse(is.finite(mat) & (mat < 0), log1p(exp(mat)) - mat, log1p(exp(-mat))) - ##idx <- is.finite(mat) & (mat < 0) - idx <- mat < 0 - mat[idx] <- mat[idx] - log1p(exp(mat[idx])) - mat[!idx] <- -1*log1p(exp(-mat[!idx])) - mat + ## - ifelse(is.finite(mat) & (mat < 0), log1p(exp(mat)) - mat, log1p(exp(-mat))) + ## idx <- is.finite(mat) & (mat < 0) + idx <- mat < 0 + mat[idx] <- mat[idx] - log1p(exp(mat[idx])) + mat[!idx] <- -1 * log1p(exp(-mat[!idx])) + mat } diff --git a/R/mix.R b/R/mix.R index 5388492..8a7fc3f 100644 --- a/R/mix.R +++ b/R/mix.R @@ -72,189 +72,191 @@ #' #' @examples #' ## a beta mixture -#' bm <- mixbeta(weak=c(0.2, 2, 10), inf=c(0.4, 10, 100), inf2=c(0.4, 30, 80)) +#' bm <- mixbeta(weak = c(0.2, 2, 10), inf = c(0.4, 10, 100), inf2 = c(0.4, 30, 80)) #' #' ## extract the two most informative components -#' bm[[c(2,3)]] +#' bm[[c(2, 3)]] #' ## rescaling needed in order to plot -#' plot(bm[[c(2,3),rescale=TRUE]]) +#' plot(bm[[c(2, 3), rescale = TRUE]]) #' #' summary(bm) #' -#' NULL ### DECLARATION #' @export #' @rdname mix -dmix <- function(mix, x, log=FALSE) UseMethod("dmix") +dmix <- function(mix, x, log = FALSE) UseMethod("dmix") #' @export #' @rdname mix -pmix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) UseMethod("pmix") +pmix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) UseMethod("pmix") #' @export #' @rdname mix -qmix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) UseMethod("qmix") +qmix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) UseMethod("qmix") #' @export #' @rdname mix rmix <- function(mix, n) UseMethod("rmix") #' @export #' @rdname mix -"[[.mix" <- function(mix, ..., rescale=FALSE) { - ## ensure that the resulting object is a mixture object only - cl <- grep("mix$", class(mix), ignore.case=TRUE, value=TRUE) - dl <- dlink(mix) - if(inherits(mix, "normMix")) s <- sigma(mix) - if(inherits(mix, "mvnormMix")) s <- sigma(mix) - mix <- mix[,...,drop=FALSE] - if(rescale) mix[1,] <- mix[1,] / sum(mix[1,]) - class(mix) <- cl - dlink(mix) <- dl - if(inherits(mix, "normMix")) sigma(mix) <- s - if(inherits(mix, "mvnormMix")) sigma(mix) <- s - mix +"[[.mix" <- function(mix, ..., rescale = FALSE) { + ## ensure that the resulting object is a mixture object only + cl <- grep("mix$", class(mix), ignore.case = TRUE, value = TRUE) + dl <- dlink(mix) + if (inherits(mix, "normMix")) s <- sigma(mix) + if (inherits(mix, "mvnormMix")) s <- sigma(mix) + mix <- mix[, ..., drop = FALSE] + if (rescale) mix[1, ] <- mix[1, ] / sum(mix[1, ]) + class(mix) <- cl + dlink(mix) <- dl + if (inherits(mix, "normMix")) sigma(mix) <- s + if (inherits(mix, "mvnormMix")) sigma(mix) <- s + mix } #' @export #' @keywords internal -"[[.betaBinomialMix" <- function(mix, ..., rescale=FALSE) { - ## ensure that the resulting object has still the N attribute - n <- attr(mix, "n") - mix <- NextMethod() - attr(mix, "n") <- n - mix +"[[.betaBinomialMix" <- function(mix, ..., rescale = FALSE) { + ## ensure that the resulting object has still the N attribute + n <- attr(mix, "n") + mix <- NextMethod() + attr(mix, "n") <- n + mix } ## IMPLEMENTATION DETAILS #' @export -dmix.default <- function(mix, x, log=FALSE) stop("Unknown mixture") +dmix.default <- function(mix, x, log = FALSE) stop("Unknown mixture") ## default implementation which only needs the density function; ## assumption is that the first argument of the density corresponds to ## the second entry and the third to the last entry in the mix matrix dmix_impl <- function(dens, mix, x, log) { - Nc <- ncol(mix) - ## logic is to replicate the original data vector such that each - ## item appears nc times which allows easy vectorized calls to - ## dgamma. Then we cast the result into a matrix with as many rows - ## as nc components which we sum together with a fast colSums call. - Nx <- length(x) - if(is.mixidentity_link(mix)) { - log_dens <- matrixStats::colLogSumExps(matrix(log(mix[1,]) + dens(rep(x, each=Nc), rep(mix[2,], times=Nx), rep(mix[3,], times=Nx), log=TRUE), nrow=Nc)) - } else { - ox <- rep(mixinvlink(mix, x), each=Nc) - log_dens <- matrixStats::colLogSumExps(matrix(log(mix[1,]) + rep(mixlJinv_link(mix, x), each=Nc) + dens(ox, rep(mix[2,], times=Nx), rep(mix[3,], times=Nx), log=TRUE), nrow=Nc)) - } - if(!log) - return(exp(log_dens)) - return(log_dens) + Nc <- ncol(mix) + ## logic is to replicate the original data vector such that each + ## item appears nc times which allows easy vectorized calls to + ## dgamma. Then we cast the result into a matrix with as many rows + ## as nc components which we sum together with a fast colSums call. + Nx <- length(x) + if (is.mixidentity_link(mix)) { + log_dens <- matrixStats::colLogSumExps(matrix(log(mix[1, ]) + dens(rep(x, each = Nc), rep(mix[2, ], times = Nx), rep(mix[3, ], times = Nx), log = TRUE), nrow = Nc)) + } else { + ox <- rep(mixinvlink(mix, x), each = Nc) + log_dens <- matrixStats::colLogSumExps(matrix(log(mix[1, ]) + rep(mixlJinv_link(mix, x), each = Nc) + dens(ox, rep(mix[2, ], times = Nx), rep(mix[3, ], times = Nx), log = TRUE), nrow = Nc)) + } + if (!log) { + return(exp(log_dens)) + } + return(log_dens) } #' @export -dmix.gammaMix <- function(mix, x, log=FALSE) dmix_impl(dgamma, mix, x, log) +dmix.gammaMix <- function(mix, x, log = FALSE) dmix_impl(dgamma, mix, x, log) #' @export -dmix.betaMix <- function(mix, x, log=FALSE) dmix_impl(dbeta, mix, x, log) +dmix.betaMix <- function(mix, x, log = FALSE) dmix_impl(dbeta, mix, x, log) #' @export -dmix.normMix <- function(mix, x, log=FALSE) dmix_impl(dnorm, mix, x, log) +dmix.normMix <- function(mix, x, log = FALSE) dmix_impl(dnorm, mix, x, log) #' @export -dmix.betaBinomialMix <- function(mix, x, log=FALSE) dmix_impl(Curry(dBetaBinomial, n=attr(mix, "n")), mix, x, log) +dmix.betaBinomialMix <- function(mix, x, log = FALSE) dmix_impl(Curry(dBetaBinomial, n = attr(mix, "n")), mix, x, log) ## internal redefinition of negative binomial -##.dnbinomAB <- function(x, a, b, n=1, log=FALSE) dnbinom(x, size=a, prob=(b/n)/((b/n)+1), log=log) -.dnbinomAB <- function(x, a, b, n=1, log=FALSE) dnbinom(x, size=a, prob=b/(b+n), log=log) -#' @export -dmix.gammaPoissonMix <- function(mix, x, log=FALSE) dmix_impl(Curry(.dnbinomAB, n=attr(mix, "n")), mix, x, log) - -#' @export -dmix.mvnormMix <- function(mix, x, log=FALSE) { - p <- mvnormdim(mix[-1,1]) - Nc <- ncol(mix) - if(is.matrix(x)) { - Nx <- nrow(x) - assert_matrix(x, any.missing=FALSE, nrows=Nx, ncols=p) - } else if(is.vector(x)) { - Nx <- 1 - assert_vector(x, any.missing=FALSE, len=p) - } else { - stop("x must a vector or a matrix.") - } - assert_that(is.mixidentity_link(mix)) - comp_res <- matrix(NA_real_, nrow=Nx, ncol=Nc) - for(i in 1:Nc) { - S <- mvnormsigma(mix[-1,i]) - comp_res[,i] <- log(mix[1,i]) + mvtnorm::dmvnorm(x, mix[2:(p+1), i], sigma=S, log=TRUE, checkSymmetry=FALSE) - } - res <- matrixStats::rowLogSumExps(comp_res) - if(!log) - res <- exp(res) - return(res) +## .dnbinomAB <- function(x, a, b, n=1, log=FALSE) dnbinom(x, size=a, prob=(b/n)/((b/n)+1), log=log) +.dnbinomAB <- function(x, a, b, n = 1, log = FALSE) dnbinom(x, size = a, prob = b / (b + n), log = log) +#' @export +dmix.gammaPoissonMix <- function(mix, x, log = FALSE) dmix_impl(Curry(.dnbinomAB, n = attr(mix, "n")), mix, x, log) + +#' @export +dmix.mvnormMix <- function(mix, x, log = FALSE) { + p <- mvnormdim(mix[-1, 1]) + Nc <- ncol(mix) + if (is.matrix(x)) { + Nx <- nrow(x) + assert_matrix(x, any.missing = FALSE, nrows = Nx, ncols = p) + } else if (is.vector(x)) { + Nx <- 1 + assert_vector(x, any.missing = FALSE, len = p) + } else { + stop("x must a vector or a matrix.") + } + assert_that(is.mixidentity_link(mix)) + comp_res <- matrix(NA_real_, nrow = Nx, ncol = Nc) + for (i in 1:Nc) { + S <- mvnormsigma(mix[-1, i]) + comp_res[, i] <- log(mix[1, i]) + mvtnorm::dmvnorm(x, mix[2:(p + 1), i], sigma = S, log = TRUE, checkSymmetry = FALSE) + } + res <- matrixStats::rowLogSumExps(comp_res) + if (!log) { + res <- exp(res) + } + return(res) } ## DISTRIBUTION FUNCTIONS #' @export -pmix.default <- function(mix, q, lower.tail = TRUE, log.p=FALSE) stop("Unknown mixture") - -pmix_impl <- function(dist, mix, q, lower.tail = TRUE, log.p=FALSE) { - Nc <- ncol(mix) - ## logic is to replicate the original data vector such that each - ## item appears nc times which allows easy vectorized calls to - ## dgamma. Then we cast the result into a matrix with as many rows - ## as nc components which we sum together with a fast colSums call. - oq <- mixinvlink(mix, q) - Nq <- length(q) - if(!log.p) - return(matrixStats::colSums2(matrix(mix[1,] * dist(rep(oq, each=Nc), rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=FALSE), nrow=Nc))) - ## log version is slower, but numerically more stable - res <- matrixStats::colLogSumExps(matrix(log(mix[1,]) + dist(rep(oq, each=Nc), rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=TRUE), nrow=Nc)) - return(res) +pmix.default <- function(mix, q, lower.tail = TRUE, log.p = FALSE) stop("Unknown mixture") + +pmix_impl <- function(dist, mix, q, lower.tail = TRUE, log.p = FALSE) { + Nc <- ncol(mix) + ## logic is to replicate the original data vector such that each + ## item appears nc times which allows easy vectorized calls to + ## dgamma. Then we cast the result into a matrix with as many rows + ## as nc components which we sum together with a fast colSums call. + oq <- mixinvlink(mix, q) + Nq <- length(q) + if (!log.p) { + return(matrixStats::colSums2(matrix(mix[1, ] * dist(rep(oq, each = Nc), rep(mix[2, ], times = Nq), rep(mix[3, ], times = Nq), lower.tail = lower.tail, log.p = FALSE), nrow = Nc))) + } + ## log version is slower, but numerically more stable + res <- matrixStats::colLogSumExps(matrix(log(mix[1, ]) + dist(rep(oq, each = Nc), rep(mix[2, ], times = Nq), rep(mix[3, ], times = Nq), lower.tail = lower.tail, log.p = TRUE), nrow = Nc)) + return(res) } #' @export -pmix.gammaMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) pmix_impl(pgamma, mix, q, lower.tail, log.p) +pmix.gammaMix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) pmix_impl(pgamma, mix, q, lower.tail, log.p) #' @export -pmix.betaMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) pmix_impl(pbeta, mix, q, lower.tail, log.p) +pmix.betaMix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) pmix_impl(pbeta, mix, q, lower.tail, log.p) #' @export -pmix.normMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) pmix_impl(pnorm, mix, q, lower.tail, log.p) +pmix.normMix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) pmix_impl(pnorm, mix, q, lower.tail, log.p) #' @export ## pmix.betaBinomialMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) pmix_impl(Curry(pBetaBinomial, n=attr(mix, "n")), mix, q, lower.tail, log.p) -pmix.betaBinomialMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) { - assert_that(is.dlink_identity(attr(mix, "link"))) - ## ## the analytic solution needs the generalized hypergeometric - ## ## function which is only available in the hyper-geo package which - ## ## is why a numeric integration is performed here - ## ## treat out-of-bounds quantiles special -## if (requireNamespace("extraDistr", quietly = TRUE)) { -## Nq <- length(q) -## size <- attr(mix, "n") -## if(!log.p) -## return(matrixStats::colSums2(matrix(mix[1,] * extraDistr::pbbinom(rep(q, each=Nc), size, rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=FALSE), nrow=Nc))) - ## log version is slower, but numerically more stable -## res <- matrixStats::colLogSumExps(matrix(log(mix[1,]) + dist(rep(q, each=Nc), rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=TRUE), nrow=Nc)) -## return(res) -## } - - ## default implementation uses brute-force integration - out_low <- q<0 - out_high <- q>attr(mix, "n") - q[out_low | out_high] <- 0 - dist <- cumsum(dmix.betaBinomialMix(mix, seq(0,max(q)))) - dist <- pmin(pmax(dist, 0), 1) ## avoid over and underflows - p <- dist[q+1] - p[out_low] <- 0 - p[out_high] <- 1 - if(!lower.tail) p <- 1-p - if(log.p) p <- log(p) - return(p) +pmix.betaBinomialMix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) { + assert_that(is.dlink_identity(attr(mix, "link"))) + ## ## the analytic solution needs the generalized hypergeometric + ## ## function which is only available in the hyper-geo package which + ## ## is why a numeric integration is performed here + ## ## treat out-of-bounds quantiles special + ## if (requireNamespace("extraDistr", quietly = TRUE)) { + ## Nq <- length(q) + ## size <- attr(mix, "n") + ## if(!log.p) + ## return(matrixStats::colSums2(matrix(mix[1,] * extraDistr::pbbinom(rep(q, each=Nc), size, rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=FALSE), nrow=Nc))) + ## log version is slower, but numerically more stable + ## res <- matrixStats::colLogSumExps(matrix(log(mix[1,]) + dist(rep(q, each=Nc), rep(mix[2,], times=Nq), rep(mix[3,], times=Nq), lower.tail=lower.tail, log.p=TRUE), nrow=Nc)) + ## return(res) + ## } + + ## default implementation uses brute-force integration + out_low <- q < 0 + out_high <- q > attr(mix, "n") + q[out_low | out_high] <- 0 + dist <- cumsum(dmix.betaBinomialMix(mix, seq(0, max(q)))) + dist <- pmin(pmax(dist, 0), 1) ## avoid over and underflows + p <- dist[q + 1] + p[out_low] <- 0 + p[out_high] <- 1 + if (!lower.tail) p <- 1 - p + if (log.p) p <- log(p) + return(p) } ## internal redefinition of negative binomial -##.pnbinomAB <- function(q, a, b, lower.tail = TRUE, log.p = FALSE ) pnbinom(q, size=a, prob=b/(b+1), lower.tail = lower.tail, log.p = log.p ) -.pnbinomAB <- function(q, a, b, n=1, lower.tail = TRUE, log.p = FALSE ) pnbinom(q, size=a, prob=b/(b+n), lower.tail = lower.tail, log.p = log.p ) +## .pnbinomAB <- function(q, a, b, lower.tail = TRUE, log.p = FALSE ) pnbinom(q, size=a, prob=b/(b+1), lower.tail = lower.tail, log.p = log.p ) +.pnbinomAB <- function(q, a, b, n = 1, lower.tail = TRUE, log.p = FALSE) pnbinom(q, size = a, prob = b / (b + n), lower.tail = lower.tail, log.p = log.p) #' @export -pmix.gammaPoissonMix <- function(mix, q, lower.tail = TRUE, log.p=FALSE) pmix_impl(Curry(.pnbinomAB, n=attr(mix, "n")), mix, q, lower.tail, log.p) +pmix.gammaPoissonMix <- function(mix, q, lower.tail = TRUE, log.p = FALSE) pmix_impl(Curry(.pnbinomAB, n = attr(mix, "n")), mix, q, lower.tail, log.p) #' @export pmix.mvnormMix <- function(mix, q, ...) stop("Multivariate normal mixture cumulative density not supported.") @@ -263,92 +265,99 @@ pmix.mvnormMix <- function(mix, q, ...) stop("Multivariate normal mixture cumula ## QUANTILE FUNCTION #' @export -qmix.default <- function(mix, p, lower.tail = TRUE, log.p=FALSE) stop("Unknown mixture") - -qmix_impl <- function(quant, mix, p, lower.tail = TRUE, log.p=FALSE) { - Nc <- ncol(mix) - if(log.p) - assert_that(all(p <= 0)) - else - assert_that(all(p >= 0 & p <= 1)) - ## in the simple case of a single component, use R's functions - if(Nc == 1) - return(mixlink(mix, quant(p, mix[2,1], mix[3,1], lower.tail=lower.tail, log.p=log.p))) - assert_that(abs(sum(mix["w",])-1) < sqrt(.Machine$double.eps)) - ## first get the support of the mixture, i.e. the 99.9% CI of each - ## mixture or lower, if the requested quantile is more in the - ## tails - eps <- 1E-1 - plow <- if(log.p) min(c(eps, exp(p), (1-exp(p)))) / 2 else min(c(eps, p, (1-p))) / 2 - phigh <- 1-plow - qlow <- mixlink(mix, min(quant(rep.int(plow, Nc), mix[2,], mix[3,]))) - qhigh <- mixlink(mix, max(quant(rep.int(phigh, Nc), mix[2,], mix[3,]))) - if(is.infinite(qlow )) qlow <- -sqrt(.Machine$double.xmax) - if(is.infinite(qhigh)) qhigh <- sqrt(.Machine$double.xmax) - res <- rep.int(NA, length(p)) - pboundary <- pmix(mix, c(qlow, qhigh), lower.tail=lower.tail, log.p=log.p) - for(i in seq_along(p)) { - ## take advantage of the monotonicity of the CDF function such - ## that we can use a gradient based method to find the root - ## 13th Aug 2019: disabled for now; unreliable in rare cases - ##o <- optimise(function(x) { (pmix(mix,x,lower.tail=lower.tail,log.p=log.p) - p[i])^2 }, c(qlow, qhigh)) - ##res[i] <- o$minimum - ##if(o$objective > 1E-3) { - u <- uniroot(function(x) { pmix(mix,x,lower.tail=lower.tail,log.p=log.p) - p[i] }, - c(qlow, qhigh), - f.lower=pboundary[1] - p[i], - f.upper=pboundary[2] - p[i], - extendInt="upX") - res[i] <- u$root - if(u$estim.prec > 1E-3) - warning("Quantile ", p[i], " possibly imprecise.\nEstimated precision= ", u$estim.prec, ".\nRange = ", qlow, " to ", qhigh, "\n") - ##} +qmix.default <- function(mix, p, lower.tail = TRUE, log.p = FALSE) stop("Unknown mixture") + +qmix_impl <- function(quant, mix, p, lower.tail = TRUE, log.p = FALSE) { + Nc <- ncol(mix) + if (log.p) { + assert_that(all(p <= 0)) + } else { + assert_that(all(p >= 0 & p <= 1)) + } + ## in the simple case of a single component, use R's functions + if (Nc == 1) { + return(mixlink(mix, quant(p, mix[2, 1], mix[3, 1], lower.tail = lower.tail, log.p = log.p))) + } + assert_that(abs(sum(mix["w", ]) - 1) < sqrt(.Machine$double.eps)) + ## first get the support of the mixture, i.e. the 99.9% CI of each + ## mixture or lower, if the requested quantile is more in the + ## tails + eps <- 1E-1 + plow <- if (log.p) min(c(eps, exp(p), (1 - exp(p)))) / 2 else min(c(eps, p, (1 - p))) / 2 + phigh <- 1 - plow + qlow <- mixlink(mix, min(quant(rep.int(plow, Nc), mix[2, ], mix[3, ]))) + qhigh <- mixlink(mix, max(quant(rep.int(phigh, Nc), mix[2, ], mix[3, ]))) + if (is.infinite(qlow)) qlow <- -sqrt(.Machine$double.xmax) + if (is.infinite(qhigh)) qhigh <- sqrt(.Machine$double.xmax) + res <- rep.int(NA, length(p)) + pboundary <- pmix(mix, c(qlow, qhigh), lower.tail = lower.tail, log.p = log.p) + for (i in seq_along(p)) { + ## take advantage of the monotonicity of the CDF function such + ## that we can use a gradient based method to find the root + ## 13th Aug 2019: disabled for now; unreliable in rare cases + ## o <- optimise(function(x) { (pmix(mix,x,lower.tail=lower.tail,log.p=log.p) - p[i])^2 }, c(qlow, qhigh)) + ## res[i] <- o$minimum + ## if(o$objective > 1E-3) { + u <- uniroot( + function(x) { + pmix(mix, x, lower.tail = lower.tail, log.p = log.p) - p[i] + }, + c(qlow, qhigh), + f.lower = pboundary[1] - p[i], + f.upper = pboundary[2] - p[i], + extendInt = "upX" + ) + res[i] <- u$root + if (u$estim.prec > 1E-3) { + warning("Quantile ", p[i], " possibly imprecise.\nEstimated precision= ", u$estim.prec, ".\nRange = ", qlow, " to ", qhigh, "\n") } - res + ## } + } + res } #' @export -qmix.gammaMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) qmix_impl(qgamma, mix, p, lower.tail, log.p) +qmix.gammaMix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) qmix_impl(qgamma, mix, p, lower.tail, log.p) #' @export -qmix.betaMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) qmix_impl(qbeta, mix, p, lower.tail, log.p) +qmix.betaMix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) qmix_impl(qbeta, mix, p, lower.tail, log.p) #' @export -qmix.normMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) qmix_impl(qnorm, mix, p, lower.tail, log.p) +qmix.normMix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) qmix_impl(qnorm, mix, p, lower.tail, log.p) #' @export -qmix.betaBinomialMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) { - assert_that(is.dlink_identity(attr(mix, "link"))) - ## numerical evaluation - n <- attr(mix, "n") - dist <- pmix.betaBinomialMix(mix, seq(0,n-1)) - if(log.p) p <- exp(p) - ind <- findInterval(p, dist) - if(!lower.tail) ind <- n - ind - ind +qmix.betaBinomialMix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) { + assert_that(is.dlink_identity(attr(mix, "link"))) + ## numerical evaluation + n <- attr(mix, "n") + dist <- pmix.betaBinomialMix(mix, seq(0, n - 1)) + if (log.p) p <- exp(p) + ind <- findInterval(p, dist) + if (!lower.tail) ind <- n - ind + ind } ## internal redefinition of negative binomial -##.qnbinomAB <- function(p, a, b, lower.tail = TRUE, log.p = FALSE ) qnbinom(p, size=a, prob=b/(b+1), lower.tail = lower.tail, log.p = log.p ) -.qnbinomAB <- function(p, a, b, n=1, lower.tail = TRUE, log.p = FALSE ) qnbinom(p, size=a, prob=b/(b+n), lower.tail = lower.tail, log.p = log.p ) -##qmix.gammaPoissonMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) qmix_impl(Curry(.qnbinomAB, n=attr(mix, "n")), mix, p, lower.tail, log.p, discrete=TRUE) +## .qnbinomAB <- function(p, a, b, lower.tail = TRUE, log.p = FALSE ) qnbinom(p, size=a, prob=b/(b+1), lower.tail = lower.tail, log.p = log.p ) +.qnbinomAB <- function(p, a, b, n = 1, lower.tail = TRUE, log.p = FALSE) qnbinom(p, size = a, prob = b / (b + n), lower.tail = lower.tail, log.p = log.p) +## qmix.gammaPoissonMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) qmix_impl(Curry(.qnbinomAB, n=attr(mix, "n")), mix, p, lower.tail, log.p, discrete=TRUE) ## switched to numeric implementation as discretization seems to cause ## some trouble in the above definitions #' @export -qmix.gammaPoissonMix <- function(mix, p, lower.tail = TRUE, log.p=FALSE) { - assert_that(is.dlink_identity(attr(mix, "link"))) - ## numerical evaulation - n <- attr(mix, "n") - eps <- 1e-6 - plow <- if(log.p) min(c(eps, exp(p), (1-exp(p)))) / 2 else min(c(eps, p, (1-p))) / 2 - phigh <- 1-plow - Nc <- ncol(mix) - qhigh <- max(.qnbinomAB(rep.int(phigh, Nc), mix[2,], mix[3,], n=n)) - - dist <- pmix.gammaPoissonMix(mix, seq(0,qhigh-1)) - if(log.p) p <- exp(p) - ind <- findInterval(p, dist) - if(!lower.tail) ind <- qhigh - ind - ind +qmix.gammaPoissonMix <- function(mix, p, lower.tail = TRUE, log.p = FALSE) { + assert_that(is.dlink_identity(attr(mix, "link"))) + ## numerical evaulation + n <- attr(mix, "n") + eps <- 1e-6 + plow <- if (log.p) min(c(eps, exp(p), (1 - exp(p)))) / 2 else min(c(eps, p, (1 - p))) / 2 + phigh <- 1 - plow + Nc <- ncol(mix) + qhigh <- max(.qnbinomAB(rep.int(phigh, Nc), mix[2, ], mix[3, ], n = n)) + + dist <- pmix.gammaPoissonMix(mix, seq(0, qhigh - 1)) + if (log.p) p <- exp(p) + ind <- findInterval(p, dist) + if (!lower.tail) ind <- qhigh - ind + ind } #' @export @@ -360,86 +369,96 @@ qmix.mvnormMix <- function(mix, p, ...) stop("Multivariate normal mixture quanti rmix.default <- function(mix, n) stop("Unknown mixture") rmix_impl <- function(rng, mix, n) { - ind <- sample.int(ncol(mix), n, replace = TRUE, prob = mix[1,]) - samp <- rng(n, mix[2,ind], mix[3,ind]) - attr(samp, "ind") <- ind - mixlink(mix, samp) + ind <- sample.int(ncol(mix), n, replace = TRUE, prob = mix[1, ]) + samp <- rng(n, mix[2, ind], mix[3, ind]) + attr(samp, "ind") <- ind + mixlink(mix, samp) } #' @export rmix.gammaMix <- function(mix, n) rmix_impl(rgamma, mix, n) #' @export -rmix.betaMix <- function(mix, n) rmix_impl(rbeta, mix, n) +rmix.betaMix <- function(mix, n) rmix_impl(rbeta, mix, n) #' @export -rmix.normMix <- function(mix, n) rmix_impl(rnorm, mix, n) +rmix.normMix <- function(mix, n) rmix_impl(rnorm, mix, n) #' @export -rmix.betaBinomialMix <- function(mix, n) { - assert_that(is.dlink_identity(attr(mix, "link"))) - p <- rmix_impl(rbeta, mix, n) - samp <- rbinom(n, attr(mix, "n"), p) - attr(samp, "ind") <- attr(samp, "ind") - samp +rmix.betaBinomialMix <- function(mix, n) { + assert_that(is.dlink_identity(attr(mix, "link"))) + p <- rmix_impl(rbeta, mix, n) + samp <- rbinom(n, attr(mix, "n"), p) + attr(samp, "ind") <- attr(samp, "ind") + samp } ## internal redefinition of negative binomial -##.rnbinomAB <- function(n, a, b) rnbinom(n, size=a, prob=b/(b+1)) -.rnbinomAB <- function(N, a, b, n=1) rnbinom(N, size=a, prob=b/(b+n)) +## .rnbinomAB <- function(n, a, b) rnbinom(n, size=a, prob=b/(b+1)) +.rnbinomAB <- function(N, a, b, n = 1) rnbinom(N, size = a, prob = b / (b + n)) #' @export -rmix.gammaPoissonMix <- function(mix, n) rmix_impl(Curry(.rnbinomAB, n=attr(mix, "n")), mix, n) +rmix.gammaPoissonMix <- function(mix, n) rmix_impl(Curry(.rnbinomAB, n = attr(mix, "n")), mix, n) #' @export rmix.mvnormMix <- function(mix, n) { - ## sample the mixture components - ind <- sample.int(ncol(mix), n, replace = TRUE, prob = mix["w",]) - ## sort these - sidx <- order(ind) - ## ensure we can sort into the original random order - oidx <- seq(1, n)[sidx] - sind <- ind[sidx] - ## now sind[oidx] == ind - ## count how many times we need to sample which component - r <- rle(sind) - p <- mvnormdim(mix[-1,1]) - samp <- do.call(rbind, - mapply(function(comp, cn) { - m <- mix[2:(p+1),comp] - S <- mvnormsigma(mix[-1,comp]) - rmvnorm(cn, m, S, checkSymmetry=FALSE) - }, - r$values, r$lengths, SIMPLIFY=FALSE))[oidx,,drop=FALSE] - colnames(samp) <- mvnorm_dim_labels(mix[-1,1]) - attr(samp, "ind") <- ind - samp + ## sample the mixture components + ind <- sample.int(ncol(mix), n, replace = TRUE, prob = mix["w", ]) + ## sort these + sidx <- order(ind) + ## ensure we can sort into the original random order + oidx <- seq(1, n)[sidx] + sind <- ind[sidx] + ## now sind[oidx] == ind + ## count how many times we need to sample which component + r <- rle(sind) + p <- mvnormdim(mix[-1, 1]) + samp <- do.call( + rbind, + mapply( + function(comp, cn) { + m <- mix[2:(p + 1), comp] + S <- mvnormsigma(mix[-1, comp]) + rmvnorm(cn, m, S, checkSymmetry = FALSE) + }, + r$values, r$lengths, + SIMPLIFY = FALSE + ) + )[oidx, , drop = FALSE] + colnames(samp) <- mvnorm_dim_labels(mix[-1, 1]) + attr(samp, "ind") <- ind + samp } #' @export print.mix <- function(x, digits, ...) { - tr <- attr(x, "link") - if(tr$name != "identity") print(tr) - cat("Mixture Components:\n") - if(missing(digits)) digits <- NULL - print.default(format(x, digits=digits), quote=FALSE) + tr <- attr(x, "link") + if (tr$name != "identity") print(tr) + cat("Mixture Components:\n") + if (missing(digits)) digits <- NULL + print.default(format(x, digits = digits), quote = FALSE) } #' takes x and transforms it according to the defined link function of #' the mixture #' @keywords internal -mixlink <- function(mix, x) - attr(mix, "link")$link(x) - -mixinvlink <- function(mix, x) - attr(mix, "link")$invlink(x) +mixlink <- function(mix, x) { + attr(mix, "link")$link(x) +} -mixJinv_orig <- function(mix, x) - attr(mix, "link")$Jinv_orig(x) +mixinvlink <- function(mix, x) { + attr(mix, "link")$invlink(x) +} -mixlJinv_orig <- function(mix, x) - attr(mix, "link")$lJinv_orig(x) +mixJinv_orig <- function(mix, x) { + attr(mix, "link")$Jinv_orig(x) +} -mixlJinv_link <- function(mix, l) - attr(mix, "link")$lJinv_link(l) +mixlJinv_orig <- function(mix, x) { + attr(mix, "link")$lJinv_orig(x) +} -is.mixidentity_link <- function(mix, l) - is.dlink_identity(attr(mix, "link")) +mixlJinv_link <- function(mix, l) { + attr(mix, "link")$lJinv_link(l) +} +is.mixidentity_link <- function(mix, l) { + is.dlink_identity(attr(mix, "link")) +} diff --git a/R/mixbeta.R b/R/mixbeta.R index b7ffd9f..4b552f0 100644 --- a/R/mixbeta.R +++ b/R/mixbeta.R @@ -35,16 +35,16 @@ #' #' @examples #' ## a beta mixture -#' bm <- mixbeta(rob=c(0.2, 2, 10), inf=c(0.4, 10, 100), inf2=c(0.4, 30, 80)) +#' bm <- mixbeta(rob = c(0.2, 2, 10), inf = c(0.4, 10, 100), inf2 = c(0.4, 30, 80)) #' #' # mean/standard deviation parametrization -#' bm2 <- mixbeta(rob=c(0.2, 0.3, 0.2), inf=c(0.8, 0.4, 0.01), param="ms") +#' bm2 <- mixbeta(rob = c(0.2, 0.3, 0.2), inf = c(0.8, 0.4, 0.01), param = "ms") #' #' # mean/observations parametrization -#' bm3 <- mixbeta(rob=c(0.2, 0.3, 5), inf=c(0.8, 0.4, 30), param="mn") +#' bm3 <- mixbeta(rob = c(0.2, 0.3, 5), inf = c(0.8, 0.4, 30), param = "mn") #' #' # even mixed is possible -#' bm4 <- mixbeta(rob=c(0.2, mn2beta(0.3, 5)), inf=c(0.8, ms2beta(0.4, 0.1))) +#' bm4 <- mixbeta(rob = c(0.2, mn2beta(0.3, 5)), inf = c(0.8, ms2beta(0.4, 0.1))) #' #' # print methods are defined #' bm4 @@ -54,39 +54,40 @@ NULL #' @rdname mixbeta #' @export -mixbeta <- function(..., param=c("ab", "ms", "mn")) { - mix <- mixdist3(...) - assert_matrix(mix, nrows=3, any.missing=FALSE) - param <- match.arg(param) - mix[c(2,3),] <- switch(param, - ab=mix[c(2,3),], - ms=t(ms2beta(mix[2,], mix[3,], FALSE)), - mn=t(mn2beta(mix[2,], mix[3,], FALSE))) - rownames(mix) <- c("w", "a", "b") - assert_that(all(mix["a",]>=0)) - assert_that(all(mix["b",]>=0)) - class(mix) <- c("betaMix", "mix") - likelihood(mix) <- "binomial" - mix +mixbeta <- function(..., param = c("ab", "ms", "mn")) { + mix <- mixdist3(...) + assert_matrix(mix, nrows = 3, any.missing = FALSE) + param <- match.arg(param) + mix[c(2, 3), ] <- switch(param, + ab = mix[c(2, 3), ], + ms = t(ms2beta(mix[2, ], mix[3, ], FALSE)), + mn = t(mn2beta(mix[2, ], mix[3, ], FALSE)) + ) + rownames(mix) <- c("w", "a", "b") + assert_that(all(mix["a", ] >= 0)) + assert_that(all(mix["b", ] >= 0)) + class(mix) <- c("betaMix", "mix") + likelihood(mix) <- "binomial" + mix } #' @rdname mixbeta #' @export -ms2beta <- function(m, s, drop=TRUE) { - n <- m*(1-m)/s^2 - 1 - assert_that(all(n>=0)) - ab <- cbind(a=n*m, b=n*(1-m)) - if(drop) ab <- drop(ab) - ab +ms2beta <- function(m, s, drop = TRUE) { + n <- m * (1 - m) / s^2 - 1 + assert_that(all(n >= 0)) + ab <- cbind(a = n * m, b = n * (1 - m)) + if (drop) ab <- drop(ab) + ab } #' @rdname mixbeta #' @export -mn2beta <- function(m, n, drop=TRUE) { - assert_that(all(n>=0)) - ab <- cbind(a=n*m, b=n*(1-m)) - if(drop) ab <- drop(ab) - ab +mn2beta <- function(m, n, drop = TRUE) { + assert_that(all(n >= 0)) + ab <- cbind(a = n * m, b = n * (1 - m)) + if (drop) ab <- drop(ab) + ab } #' @rdname mixbeta @@ -94,8 +95,8 @@ mn2beta <- function(m, n, drop=TRUE) { #' @param x The mixture to print #' @export print.betaMix <- function(x, ...) { - cat("Univariate beta mixture\n") - NextMethod() + cat("Univariate beta mixture\n") + NextMethod() } #' @rdname mixbeta @@ -103,50 +104,50 @@ print.betaMix <- function(x, ...) { #' @param x The mixture to print #' @export print.betaBinomialMix <- function(x, ...) { - cat("Univariate beta binomial mixture\nn = ", attr(x, "n"),"\n", sep="") - NextMethod() + cat("Univariate beta binomial mixture\nn = ", attr(x, "n"), "\n", sep = "") + NextMethod() } #' @rdname mixbeta #' @method summary betaMix #' @export -summary.betaMix <- function(object, probs=c(0.025,0.5,0.975), ...) { - p <- object[1,] - a <- object[2,] - b <- object[3,] - m <- a/(a+b) - v <- m*(1-m)/(a+b+1) - ## calculate mean of the second moment - m2 <- v + m^2 - ## from this we can get the mean and variance of the mixture - mmix <- sum(p * m) - vmix <- sum(p * (m2 - (mmix)^2) ) - q <- c() - if(length(probs) != 0) { - q <- qmix.betaMix(object, p=probs) - names(q) <- paste(format(probs*100,digits=2), "%", sep="") - } - c(mean=mmix, sd=sqrt(vmix), q) +summary.betaMix <- function(object, probs = c(0.025, 0.5, 0.975), ...) { + p <- object[1, ] + a <- object[2, ] + b <- object[3, ] + m <- a / (a + b) + v <- m * (1 - m) / (a + b + 1) + ## calculate mean of the second moment + m2 <- v + m^2 + ## from this we can get the mean and variance of the mixture + mmix <- sum(p * m) + vmix <- sum(p * (m2 - (mmix)^2)) + q <- c() + if (length(probs) != 0) { + q <- qmix.betaMix(object, p = probs) + names(q) <- paste(format(probs * 100, digits = 2), "%", sep = "") + } + c(mean = mmix, sd = sqrt(vmix), q) } #' @rdname mixbeta #' @method summary betaBinomialMix #' @export -summary.betaBinomialMix <- function(object, probs=c(0.025,0.5,0.975), ...) { - n <- attr(object, "n") - p <- object[1,] - a <- object[2,] - b <- object[3,] - m <- n * a/(a+b) - v <- n*a*b*(a+b+n)/( (a+b)^2 * ( a + b + 1 ) ) - ## calculate mean of the second moment - m2 <- v + m^2 - ## from this we can get the mean and variance of the mixture - mmix <- sum(p * m) - vmix <- sum(p * (m2 - (mmix)^2) ) - q <- qmix.betaBinomialMix(object, p=probs) - if(length(q) != 0) - names(q) <- paste(format(probs*100,digits=2), "%", sep="") - c(mean=mmix, sd=sqrt(vmix), q) +summary.betaBinomialMix <- function(object, probs = c(0.025, 0.5, 0.975), ...) { + n <- attr(object, "n") + p <- object[1, ] + a <- object[2, ] + b <- object[3, ] + m <- n * a / (a + b) + v <- n * a * b * (a + b + n) / ((a + b)^2 * (a + b + 1)) + ## calculate mean of the second moment + m2 <- v + m^2 + ## from this we can get the mean and variance of the mixture + mmix <- sum(p * m) + vmix <- sum(p * (m2 - (mmix)^2)) + q <- qmix.betaBinomialMix(object, p = probs) + if (length(q) != 0) { + names(q) <- paste(format(probs * 100, digits = 2), "%", sep = "") + } + c(mean = mmix, sd = sqrt(vmix), q) } - diff --git a/R/mixcombine.R b/R/mixcombine.R index c1e5310..d65b068 100644 --- a/R/mixcombine.R +++ b/R/mixcombine.R @@ -20,27 +20,28 @@ #' @seealso \code{\link{robustify}} #' #' @example inst/examples/mixcombine.R -#' +#' #' @export -mixcombine <- function(..., weight, rescale=TRUE) { - comp <- list(...) - ## ensure that the resulting object is a mixture object only - cl <- grep("mix$", class(comp[[1]]), ignore.case=TRUE, value=TRUE) - dl <- dlink(comp[[1]]) - lik <- likelihood(comp[[1]]) - assert_that(all(sapply(comp, inherits, "mix")), msg="All components must be mixture objects.") - assert_that(all(sapply(comp, likelihood) == lik), msg="All components must have the same likelihood set.") - mix <- do.call(cbind, comp) - if(!missing(weight)) { - assert_that(length(weight) == length(comp)) - mix[1,] <- mix[1,] * rep(weight, times=sapply(comp, ncol)) - } - if(rescale) - mix[1,] <- mix[1,] / sum(mix[1,]) - class(mix) <- cl - dlink(mix) <- dl - likelihood(mix) <- lik - if("normMix" %in% cl) sigma(mix) <- sigma(comp[[1]]) - if("mvnormMix" %in% cl) sigma(mix) <- sigma(comp[[1]]) - mix +mixcombine <- function(..., weight, rescale = TRUE) { + comp <- list(...) + ## ensure that the resulting object is a mixture object only + cl <- grep("mix$", class(comp[[1]]), ignore.case = TRUE, value = TRUE) + dl <- dlink(comp[[1]]) + lik <- likelihood(comp[[1]]) + assert_that(all(sapply(comp, inherits, "mix")), msg = "All components must be mixture objects.") + assert_that(all(sapply(comp, likelihood) == lik), msg = "All components must have the same likelihood set.") + mix <- do.call(cbind, comp) + if (!missing(weight)) { + assert_that(length(weight) == length(comp)) + mix[1, ] <- mix[1, ] * rep(weight, times = sapply(comp, ncol)) + } + if (rescale) { + mix[1, ] <- mix[1, ] / sum(mix[1, ]) + } + class(mix) <- cl + dlink(mix) <- dl + likelihood(mix) <- lik + if ("normMix" %in% cl) sigma(mix) <- sigma(comp[[1]]) + if ("mvnormMix" %in% cl) sigma(mix) <- sigma(comp[[1]]) + mix } diff --git a/R/mixdiff.R b/R/mixdiff.R index ccdff48..dfcd39b 100644 --- a/R/mixdiff.R +++ b/R/mixdiff.R @@ -46,153 +46,165 @@ #' pmixdiff(mix1, mix2, 0.3) - pmixdiff(mix1, mix2, 0) #' #' # 2. two distributions, one of them a mixture -#' m1 <- mixbeta( c(1,30,50)) -#' m2 <- mixbeta( c(0.75,20,50),c(0.25,1,1)) +#' m1 <- mixbeta(c(1, 30, 50)) +#' m2 <- mixbeta(c(0.75, 20, 50), c(0.25, 1, 1)) #' #' # random sample of difference #' set.seed(23434) #' rM <- rmixdiff(m1, m2, 1E4) #' #' # histogram of random numbers and exact density -#' hist(rM,prob=TRUE,new=TRUE,nclass=40) -#' curve(dmixdiff(m1,m2,x), add=TRUE, n=51) +#' hist(rM, prob = TRUE, new = TRUE, nclass = 40) +#' curve(dmixdiff(m1, m2, x), add = TRUE, n = 51) #' #' # threshold probabilities for difference, at 0 and 0.2 #' pmixdiff(m1, m2, 0) -#' mean(rM<0) -#' pmixdiff(m1,m2,0.2) -#' mean(rM<0.2) +#' mean(rM < 0) +#' pmixdiff(m1, m2, 0.2) +#' mean(rM < 0.2) #' #' # median of difference #' mdn <- qmixdiff(m1, m2, 0.5) -#' mean(rM= 0 & p <= 1)) - assert_that(abs(sum(mix1["w",])-1) < sqrt(.Machine$double.eps)) - assert_that(abs(sum(mix2["w",])-1) < sqrt(.Machine$double.eps)) - ## first get the support of the mixture, i.e. the 99% CI of each - ## mixture or lower, if the requested quantile is more in the - ## tails - plow <- min(c(p, (1-p))) / 2 - ##plow <- if(log.p) min(c(0.01, exp(p), (1-exp(p)))) / 2 else min(c(0.01, p, (1-p))) / 2 - phigh <- 1-plow - qlow <- qmix(mix1, plow) - qmix(mix2, phigh) - qhigh <- qmix(mix1, phigh) - qmix(mix2, plow ) - res <- rep.int(NA, length(p)) - for(i in seq_along(p)) { - ## take advantage of the monotonicity of the CDF function such - ## that we can use a gradient based method to find the root - o <- optimise(function(x) { (pmixdiff(mix1,mix2,x,lower.tail=lower.tail) - p[i])^2 }, c(qlow, qhigh)) - res[i] <- o$minimum - if(o$objective > 1e-3) { - ## in that case fall back to binary search which is more robust - u <- uniroot(function(x) { pmixdiff(mix1,mix2,x,lower.tail=lower.tail) - p[i] }, c(qlow, qhigh)) - res[i] <- u$root - if(u$estim.prec > 1E-3) - warning("Quantile ", p[i], " possibly imprecise.\nEstimated precision= ", u$estim.prec, ".\nRange = ", qlow, " to ", qhigh, "\n") - } + assert_that(!inherits(mix1, "mvnormMix") & !inherits(mix2, "mvnormMix"), msg = "Multivariate normal mixture density not supported.") + if (inherits(mix1, "normMix")) { + return(qmix(mixnormdiff(mix1, mix2), p = p, lower.tail = lower.tail)) + } + interval <- support(mix1) + if (!all(interval == support(mix2))) { + warning("Support of variates mix1 and mix2 do not match.") + } + assert_that(all(p >= 0 & p <= 1)) + assert_that(abs(sum(mix1["w", ]) - 1) < sqrt(.Machine$double.eps)) + assert_that(abs(sum(mix2["w", ]) - 1) < sqrt(.Machine$double.eps)) + ## first get the support of the mixture, i.e. the 99% CI of each + ## mixture or lower, if the requested quantile is more in the + ## tails + plow <- min(c(p, (1 - p))) / 2 + ## plow <- if(log.p) min(c(0.01, exp(p), (1-exp(p)))) / 2 else min(c(0.01, p, (1-p))) / 2 + phigh <- 1 - plow + qlow <- qmix(mix1, plow) - qmix(mix2, phigh) + qhigh <- qmix(mix1, phigh) - qmix(mix2, plow) + res <- rep.int(NA, length(p)) + for (i in seq_along(p)) { + ## take advantage of the monotonicity of the CDF function such + ## that we can use a gradient based method to find the root + o <- optimise(function(x) { + (pmixdiff(mix1, mix2, x, lower.tail = lower.tail) - p[i])^2 + }, c(qlow, qhigh)) + res[i] <- o$minimum + if (o$objective > 1e-3) { + ## in that case fall back to binary search which is more robust + u <- uniroot(function(x) { + pmixdiff(mix1, mix2, x, lower.tail = lower.tail) - p[i] + }, c(qlow, qhigh)) + res[i] <- u$root + if (u$estim.prec > 1E-3) { + warning("Quantile ", p[i], " possibly imprecise.\nEstimated precision= ", u$estim.prec, ".\nRange = ", qlow, " to ", qhigh, "\n") + } } - res + } + res } #' @rdname mixdiff #' @export rmixdiff <- function(mix1, mix2, n) { - rmix(mix1, n) - rmix(mix2, n) + rmix(mix1, n) - rmix(mix2, n) } - diff --git a/R/mixdist3.R b/R/mixdist3.R index dd7cda9..7f8269b 100644 --- a/R/mixdist3.R +++ b/R/mixdist3.R @@ -2,25 +2,28 @@ #' #' @keywords internal mixdist3 <- function(...) { - args <- list(...) - Nc <- length(args) - l <- sapply(args, length) - if(!all(l >= 3) | !all(l == l[1])) - stop("All components must have equal number of parameters.") - res <- do.call(cbind, args) - if(is.null(names(args))) - colnames(res) <- paste("comp", seq(Nc), sep="") - norm <- sum(res[1,]) - if(norm != 1) { - ## only issue a warning if difference appears to be a real - ## user error, otherwise just silently rescale since we are - ## correcting floating point arithmetic unless RBesT is asked - ## to be verbose - if(getOption("RBesT.verbose", FALSE) | abs(norm - 1) > 1E-4) - warning("Weights do not sum to 1. Rescaling accordingly.") - res[1,] <- res[1,]/norm + args <- list(...) + Nc <- length(args) + l <- sapply(args, length) + if (!all(l >= 3) | !all(l == l[1])) { + stop("All components must have equal number of parameters.") + } + res <- do.call(cbind, args) + if (is.null(names(args))) { + colnames(res) <- paste("comp", seq(Nc), sep = "") + } + norm <- sum(res[1, ]) + if (norm != 1) { + ## only issue a warning if difference appears to be a real + ## user error, otherwise just silently rescale since we are + ## correcting floating point arithmetic unless RBesT is asked + ## to be verbose + if (getOption("RBesT.verbose", FALSE) | abs(norm - 1) > 1E-4) { + warning("Weights do not sum to 1. Rescaling accordingly.") } - ## assign the default identity transform - dlink(res) <- identity_dlink - res + res[1, ] <- res[1, ] / norm + } + ## assign the default identity transform + dlink(res) <- identity_dlink + res } diff --git a/R/mixess.R b/R/mixess.R index 03ae16a..78ef8fd 100644 --- a/R/mixess.R +++ b/R/mixess.R @@ -14,22 +14,31 @@ #' of the expected information for the Poisson-Gamma case of #' Morita method (defaults to 1E-4). #' @param sigma reference scale. +#' @param family defines data likelihood and link function +#' (\code{binomial}, \code{gaussian}, or \code{poisson}). #' @param ... Optional arguments applicable to specific methods. #' #' @details The ESS is calculated using either the expected local #' information ratio (elir) \emph{Neuenschwander et -#' al. (submitted)}, the moments approach or the method by +#' al. (2020)}, the moments approach or the method by #' \emph{Morita et al. (2008)}. #' -#' The elir approach is the only ESS which fulfills predictive -#' consistency. The predictive consistency of the ESS requires that -#' the ESS of a prior is the same as averaging the posterior ESS after -#' a fixed amount of events over the prior predictive distribution -#' from which the number of forward simulated events is -#' subtracted. The elir approach results in ESS estimates which are -#' neither conservative nor liberal whereas the moments method yields -#' conservative and the morita method liberal results. See the example -#' section for a demonstration of predictive consistency. +#' The elir approach measures effective sample size in terms of the +#' average curvature of the prior in relation to the Fisher +#' information. Informally this corresponds to the average peakiness +#' of the prior in relation to the information content of a single +#' observation. The elir approach is the only ESS which fulfills +#' predictive consistency. The predictive consistency of the ESS +#' requires that the ESS of a prior is consistent when considering an +#' averaged posterior ESS of additional data distributed according to +#' the predictive distribution of the prior. The expectation of the +#' posterior ESS is taken wrt to the prior predictive distribution and +#' the averaged posterior ESS corresponds to the sum of the prior ESS +#' and the number of forward simulated data items. The elir approach +#' results in ESS estimates which are neither conservative nor liberal +#' whereas the moments method yields conservative and the morita +#' method liberal results. See the example section for a demonstration +#' of predictive consistency. #' #' For the moments method the mean and standard deviation of the #' mixture are calculated and then approximated by the conjugate @@ -45,99 +54,107 @@ #' (2019) which avoids the need for a minimization and does not #' restrict the ESS to be an integer. #' +#' The arguments \code{sigma} and \code{family} are specific for +#' normal mixture densities. These specify the sampling standard +#' deviation for a \code{gaussian} family (the default) while also +#' allowing to consider the ESS of standard one-parameter exponential +#' families, i.e. \code{binomial} or \code{poisson}. The function +#' supports non-gaussian families with unit dispersion only. +#' #' @return Returns the ESS of the prior as floating point number. #' #' @template conjugate_pairs #' -#' @references Morita S, Thall PF, Mueller P. -#' Determining the effective sample size of a parametric prior. -#' \emph{Biometrics} 2008;64(2):595-602. +#' @references Morita S, Thall PF, Mueller P. Determining the +#' effective sample size of a parametric prior. \emph{Biometrics} +#' 2008;64(2):595-602. #' -#' @references Neuenschwander B, Weber S, Schmidli H, O'Hagen A. -#' Predictively Consistent Prior Effective Sample Sizes. -#' \emph{pre-print} 2019; arXiv:1907.04185 +#' @references Neuenschwander B., Weber S., Schmidli H., O’Hagan +#' A. (2020). Predictively consistent prior effective sample +#' sizes. \emph{Biometrics}, 76(2), +#' 578–587. https://doi.org/10.1111/biom.13252 #' #' @example inst/examples/ess.R -#' +#' #' @export -ess <- function(mix, method=c("elir", "moment", "morita"), ...) UseMethod("ess") +ess <- function(mix, method = c("elir", "moment", "morita"), ...) UseMethod("ess") #' @export -ess.default <- function(mix, method=c("elir", "moment", "morita"), ...) stop("Unknown density") +ess.default <- function(mix, method = c("elir", "moment", "morita"), ...) stop("Unknown density") -calc_loc <- function(mix, loc=c("mode", "median", "mean")) { - loc <- match.arg(loc) - if(loc == "mode") { - tol <- .Machine$double.eps^0.25 - locEst <- mixmode(mix) +calc_loc <- function(mix, loc = c("mode", "median", "mean")) { + loc <- match.arg(loc) + if (loc == "mode") { + tol <- .Machine$double.eps^0.25 + locEst <- mixmode(mix) - if(length(attr(locEst, "modes")) > 1) { - warning("Detected multiple modes.\nThe ESS is determined for the largest mode, but ESS concept is ill-defined for multi-modal distributions.") - } else { - attr(locEst, "modes") <- NULL - } - } - if(loc == "median") { - locEst <- qmix(mix, 0.5) - } - if(loc == "mean") { - locEst <- summary(mix, NULL)["mean"] + if (length(attr(locEst, "modes")) > 1) { + warning("Detected multiple modes.\nThe ESS is determined for the largest mode, but ESS concept is ill-defined for multi-modal distributions.") + } else { + attr(locEst, "modes") <- NULL } - names(locEst) <- NULL - - return(unname(locEst)) + } + if (loc == "median") { + locEst <- qmix(mix, 0.5) + } + if (loc == "mean") { + locEst <- summary(mix, NULL)["mean"] + } + names(locEst) <- NULL + + return(unname(locEst)) } ## function to calculate mixture info of arbitrary density; input ## needed is the density function, gradient and hessian of the log ## density with respect to x (data) mixInfo <- function(mix, x, dens, gradl, hessl) { - p <- mix[1,] - a <- mix[2,] - b <- mix[3,] - lp <- log(p) - ldensComp <- dens(x, a, b, log=TRUE) - ldensMix <- matrixStats::logSumExp(lp + ldensComp) - lwdensComp <- lp + ldensComp - ldensMix - dgl <- gradl(x,a,b) - dhl <- (hessl(x,a,b) + dgl^2) - ## attempt numerically more stable log calculations if possible, - ## i.e. if all sings are the same - if(all(!is.na(dgl)) && ( all(dgl < 0) || all(dgl > 0))) { - gsum <- exp(2*matrixStats::logSumExp(lwdensComp + log(abs(dgl)))) - } else { - gsum <- (sum(exp(lwdensComp)*dgl))^2 - } - if(all(!is.na(dhl)) && (all(dhl < 0) || all(dhl > 0))) { - hsum <- sign(dhl[1]) * exp(matrixStats::logSumExp(lwdensComp + log(abs(dhl)))) - } else { - hsum <- (sum(exp(lwdensComp)*dhl)) - } - gsum - hsum + p <- mix[1, ] + a <- mix[2, ] + b <- mix[3, ] + lp <- log(p) + ldensComp <- dens(x, a, b, log = TRUE) + ldensMix <- matrixStats::logSumExp(lp + ldensComp) + lwdensComp <- lp + ldensComp - ldensMix + dgl <- gradl(x, a, b) + dhl <- (hessl(x, a, b) + dgl^2) + ## attempt numerically more stable log calculations if possible, + ## i.e. if all signs are the same + if (all(!is.na(dgl)) && (all(dgl < 0) || all(dgl > 0))) { + gsum <- exp(2 * matrixStats::logSumExp(lwdensComp + log(abs(dgl)))) + } else { + gsum <- (sum(exp(lwdensComp) * dgl))^2 + } + if (all(!is.na(dhl)) && (all(dhl < 0) || all(dhl > 0))) { + hsum <- sign(dhl[1]) * exp(matrixStats::logSumExp(lwdensComp + log(abs(dhl)))) + } else { + hsum <- (sum(exp(lwdensComp) * dhl)) + } + gsum - hsum } ## local information ratio (which we integrate over the prior) lir <- function(mix, info, fisher_inverse) { - fn <- function(x) { - info(mix, x) * fisher_inverse(x) - } - Vectorize(fn) + fn <- function(x) { + info(mix, x) * fisher_inverse(x) + } + Vectorize(fn) } weighted_lir <- function(mix, info, fisher_inverse) { - fn <- function(x) { - dmix(mix, x) * info(mix, x) * fisher_inverse(x) - } - Vectorize(fn) + fn <- function(x) { + dmix(mix, x) * info(mix, x) * fisher_inverse(x) + } + Vectorize(fn) } ## not used ATM as there have been numerical issues weighted_lir_link <- function(mix, info, fisher_inverse, link) { - dlink(mix) <- link_map[[link]] - fn <- function(x) { - x_orig <- mixinvlink(mix, x) - dmix(mix, x) * info(mix, x_orig) * fisher_inverse(x_orig) - } - Vectorize(fn) + dlink(mix) <- link_map[[link]] + fn <- function(x) { + x_orig <- mixinvlink(mix, x) + dmix(mix, x) * info(mix, x_orig) * fisher_inverse(x_orig) + } + Vectorize(fn) } ## function to calculate the gradient of the log mixture @@ -151,292 +168,311 @@ weighted_lir_link <- function(mix, info, fisher_inverse, link) { ## sum(p*densComp*dgl)/densMix ## } - # prior effective sample size ESS for Beta-mixture priors # based on # Morita, Thall, Mueller (MTM) 2008 Biometrics # only difference: evaluated at mode of prior rather than at mean; and the flattened prior are derived with respect to the scale of 1 instead of being relative to the input scale #' @describeIn ess ESS for beta mixtures. #' @export -ess.betaMix <- function(mix, method=c("elir", "moment", "morita"), ..., s=100) { - - method <- match.arg(method) - - if(method == "elir") { - if(!test_numeric(mix[2,], lower=1, finite=TRUE, any.missing=FALSE) || - !test_numeric(mix[3,], lower=1, finite=TRUE, any.missing=FALSE)) { - stop("At least one parameter of the beta mixtures is less than 1.\n", - "This leads to an ill-defined elir ess since the defining integral diverges.\n", - "Consider constraining all parameters to be greater than 1 (use constrain_gt1=TRUE argument for EM fitting functions).") - } - elir <- integrate_density(lir(mix, betaMixInfo, bernoulliFisherInfo_inverse), mix) - return(elir) +ess.betaMix <- function(mix, method = c("elir", "moment", "morita"), ..., s = 100) { + method <- match.arg(method) + + assert_that(!("family" %in% names(match.call())), msg = "Argument family is only supported for normal mixtures.") + + if (method == "elir") { + if (!test_numeric(mix[2, ], lower = 1, finite = TRUE, any.missing = FALSE) || + !test_numeric(mix[3, ], lower = 1, finite = TRUE, any.missing = FALSE)) { + stop( + "At least one parameter of the beta mixtures is less than 1.\n", + "This leads to an ill-defined elir ess since the defining integral diverges.\n", + "Consider constraining all parameters to be greater than 1 (use constrain_gt1=TRUE argument for EM fitting functions)." + ) } - - ## simple and conservative moment matching - if(method == "moment") { - smix <- summary(mix) - res <- sum(ms2beta(smix["mean"], smix["sd"])) - names(res) <- NULL - return( res ) + elir <- integrate_density(lir(mix, betaMixInfo, bernoulliFisherInfo_inverse), mix) + if (elir < 0) { + warning("Negative ESS elir found indicating unstable integration of the elir ratio.\nConsider estimating the ESS elir on the logit scale for the respective transformed density and use the family=binomial argument.") } + return(elir) + } - alphaP <- mix[2,] - betaP <- mix[3,] + ## simple and conservative moment matching + if (method == "moment") { + smix <- summary(mix) + res <- sum(ms2beta(smix["mean"], smix["sd"])) + names(res) <- NULL + return(res) + } - locEst <- calc_loc(mix, "mode") + locEst <- calc_loc(mix, "mode") - deriv2.prior <- betaMixInfo(mix, locEst) + deriv2.prior <- betaMixInfo(mix, locEst) - ESSmax <- ceiling(sum(alphaP+betaP)) * 2 + ## alpha and beta of "flattened" priors + alphaP0 <- locEst / s + betaP0 <- (1 - locEst) / s - ## alpha and beta of "flattened" priors - alphaP0 <- locEst / s - betaP0 <- (1-locEst) / s + info.prior0 <- betaInfo(locEst, alphaP0, betaP0) - info.prior0 <- betaInfo(locEst, alphaP0, betaP0) + ## MTM paper would follow this: + ## priorN <- sum(mix[1,] * (alphaP + betaP)) + ## alphaP0 <- mode * priorN / s + ## betaP0 <- (1-mode) * priorN / s - ## MTM paper would follow this: - ##priorN <- sum(mix[1,] * (alphaP + betaP)) - ##alphaP0 <- mode * priorN / s - ##betaP0 <- (1-mode) * priorN / s - - ## we warn if any of the mixture components has a scale (n) which - ## is less than 10/s such that the - if(any(rowSums(mix[2:3,,drop=FALSE]) < 10/s )) { - warning("Some of the mixture components have a scale which is large compared to the rescaling factor s. Consider increasing s.") - } - - ## expected 2nd derivative at mode - ed2p <- function(m) { - yn <- seq(0,m) - ## negative 2nd log-derivative at mode - info <- betaInfo(locEst, alphaP0 + yn, betaP0 + m - yn) - ## prior predictive - sum(info * dmix(preddist(mix,n=m), yn) ) - } - ## function to search for change of sign - ed2pDiff <- function(m) { - deriv2.prior - ed2p(m) - } + ## we warn if any of the mixture components has a scale (n) which + ## is less than 10/s such that the + if (any(rowSums(mix[2:3, , drop = FALSE]) < 10 / s)) { + warning("Some of the mixture components have a scale which is large compared to the rescaling factor s. Consider increasing s.") + } - pd0 <- dmix(preddist(mix, n=1), 0) - Einfo <- binomialInfo(0,locEst,1) * pd0 + binomialInfo(1,locEst,1) * (1-pd0) + pd0 <- dmix(preddist(mix, n = 1), 0) + Einfo <- binomialInfo(0, locEst, 1) * pd0 + binomialInfo(1, locEst, 1) * (1 - pd0) - ##return(unname(uniroot_int(ed2pDiff, c(0,ESSmax)))) - ## Eq. 9 of Neuenschwander et al. (2019) - return( unname((deriv2.prior - info.prior0) / Einfo ) ) + ## Eq. 9 of Neuenschwander et al. (2019) + return(unname((deriv2.prior - info.prior0) / Einfo)) } ## derivative of a single log-beta -betaLogGrad <- function(x,a,b) { - lxm1 <- log1p(-x) - lx <- log(x) - - (b-1) * exp(- lxm1) + (a-1)*exp(- lx) +betaLogGrad <- function(x, a, b) { + -(b - 1) / (1 - x) + (a - 1) / x } ## second derivative of a single log-beta -betaLogHess <- function(x,a,b) { - lxm1 <- log1p(-x) - lx <- log(x) - - (b-1) * exp(-2 * lxm1) - (a-1)*exp(-2 * lx) +betaLogHess <- function(x, a, b) { + -(b - 1) / (x - 1)^2 - (a - 1) / x^2 } -betaMixInfo <- function(mix,x) { - mixInfo(mix, x, dbeta, betaLogGrad, betaLogHess) +betaMixInfo <- function(mix, x) { + x <- pmin(pmax(x, .Machine$double.eps), 1.0 - .Machine$double.eps) + mixInfo(mix, x, dbeta, betaLogGrad, betaLogHess) } ## info metric for a single beta, i.e. negative second derivative of log beta -betaInfo <- function(x,a,b) { - -betaLogHess(x,a,b) +betaInfo <- function(x, a, b) { + x <- pmin(pmax(x, .Machine$double.eps), 1.0 - .Machine$double.eps) + -betaLogHess(x, a, b) } ## 1/i_F(x): The inverse of the fisher information for a Bernoulli ## experiment (binomial with n=1) bernoulliFisherInfo_inverse <- function(x) { - x - x^2 + x - x^2 } ## info metric for a binomial, second derivative wrt to theta of the ## log binomial -binomialInfo <- function(r,theta,n) { - r / theta^2 + (n-r)/(1-theta)^2 +binomialInfo <- function(r, theta, n) { + r / theta^2 + (n - r) / (1 - theta)^2 } #' @describeIn ess ESS for gamma mixtures. #' @export -ess.gammaMix <- function(mix, method=c("elir", "moment", "morita"), ..., s=100, eps=1E-4) { +ess.gammaMix <- function(mix, method = c("elir", "moment", "morita"), ..., s = 100, eps = 1E-4) { + method <- match.arg(method) - method <- match.arg(method) - lik <- likelihood(mix) + assert_that(!("family" %in% names(match.call())), msg = "Argument family is only supported for normal mixtures.") - if(method == "elir") { - if(lik == "poisson") - return(integrate_density(lir(mix, gammaMixInfo, poissonFisherInfo_inverse), mix)) - if(lik == "exp") - return(integrate_density(lir(mix, gammaMixInfo, expFisherInfo_inverse), mix)) - } + lik <- likelihood(mix) - ## simple and conservative moment matching - if(method == "moment") { - smix <- summary(mix) - coef <- ms2gamma(smix["mean"], smix["sd"]) - names(coef) <- NULL - if(lik == "poisson") - return(unname(coef[2])) - if(lik == "exp") - return(unname(coef[1])) - stop("Unkown likelihood") + if (method == "elir") { + if (lik == "poisson") { + return(integrate_density(lir(mix, gammaMixInfo, poissonFisherInfo_inverse), mix)) } + if (lik == "exp") { + return(integrate_density(lir(mix, gammaMixInfo, expFisherInfo_inverse), mix)) + } + } + + ## simple and conservative moment matching + if (method == "moment") { + smix <- summary(mix) + coef <- ms2gamma(smix["mean"], smix["sd"]) + names(coef) <- NULL + if (lik == "poisson") { + return(unname(coef[2])) + } + if (lik == "exp") { + return(unname(coef[1])) + } + stop("Unkown likelihood") + } - ## Morita method - locEst <- calc_loc(mix, "mode") - - deriv2.prior <- gammaMixInfo(mix, locEst) - - if(lik == "poisson") { - meanPrior <- summary(mix)["mean"] - names(meanPrior) <- NULL - priorN <- mix[3,,drop=FALSE] - - ## function to search for change of sign - ed2pDiff <- function(m) { - deriv2.prior - ( gammaInfo(locEst, locEst/s + m * meanPrior, 1/s)) - } + ## Morita method + locEst <- calc_loc(mix, "mode") - ESSmax <- ceiling(sum(mix[3,])) * 2 + deriv2.prior <- gammaMixInfo(mix, locEst) - info.prior0 <- gammaInfo(locEst, locEst/s, 1/s) + if (lik == "poisson") { + meanPrior <- summary(mix)["mean"] + names(meanPrior) <- NULL + priorN <- mix[3, , drop = FALSE] - ## E_Y1 ( i_F ) using numerical integration - pred_pmf <- preddist(mix, n=1) - lim <- qmix(pred_pmf, c(eps/2, 1-eps/2)) - y1 <- seq(lim[1], lim[2]) - Einfo <- sum(dmix(pred_pmf, y1) * poissonInfo(y1, locEst)) - } + info.prior0 <- gammaInfo(locEst, locEst / s, 1 / s) - if(lik == "exp") { - priorN <- mix[2,,drop=FALSE] - ## function to search for change of sign - ed2pDiff <- function(m) { - deriv2.prior - gammaInfo(locEst, 1/s + m, 1/(s*locEst)) - } + ## E_Y1 ( i_F ) using numerical integration + pred_pmf <- preddist(mix, n = 1) + lim <- qmix(pred_pmf, c(eps / 2, 1 - eps / 2)) + y1 <- seq(lim[1], lim[2]) + Einfo <- sum(dmix(pred_pmf, y1) * poissonInfo(y1, locEst)) + } - ESSmax <- ceiling(sum(mix[2,])) * 2 + if (lik == "exp") { + priorN <- mix[2, , drop = FALSE] - info.prior0 <- gammaInfo(locEst, 1/s, 1/(s*locEst)) + info.prior0 <- gammaInfo(locEst, 1 / s, 1 / (s * locEst)) - ## E_Y1 ( i_F ) (the i_F does not depend on the data) - Einfo <- expInfo(1,locEst) - } + ## E_Y1 ( i_F ) (the i_F does not depend on the data) + Einfo <- expInfo(1, locEst) + } - if(any(priorN < 10/s )) { - warning("Some of the mixture components have a scale which is large compared to the rescaling factor s. Consider increasing s.") - } + if (any(priorN < 10 / s)) { + warning("Some of the mixture components have a scale which is large compared to the rescaling factor s. Consider increasing s.") + } - return(unname( (deriv2.prior - info.prior0)/Einfo ) ) + return(unname((deriv2.prior - info.prior0) / Einfo)) } ## respective functions for the gamma distribution -gammaLogGrad <- function(x,a,b) { - (a-1)/x - b +gammaLogGrad <- function(x, a, b) { + (a - 1) / x - b } -gammaLogHess <- function(x,a,b) { - -(a-1)/x^2 +gammaLogHess <- function(x, a, b) { + -(a - 1) / x^2 } -gammaInfo <- function(x,a,b) { - -gammaLogHess(x,a,b) +gammaInfo <- function(x, a, b) { + -gammaLogHess(x, a, b) } -gammaMixInfo <- function(mix,x) { - mixInfo(mix, x, dgamma, gammaLogGrad, gammaLogHess) +gammaMixInfo <- function(mix, x) { + mixInfo(mix, x, dgamma, gammaLogGrad, gammaLogHess) } poissonFisherInfo_inverse <- function(x) { - x + x } expFisherInfo_inverse <- function(x) { - x^2 + x^2 } -poissonInfo <- function(y,theta) { - y/theta^2 +poissonInfo <- function(y, theta) { + y / theta^2 } -expInfo <- function(y,theta) { - 1/theta^2 +expInfo <- function(y, theta) { + 1 / theta^2 } #' @describeIn ess ESS for normal mixtures. #' @export -ess.normMix <- function(mix, method=c("elir", "moment", "morita"), ..., sigma, s=100) { - - method <- match.arg(method) - - if(missing(sigma)) { - sigma <- RBesT::sigma(mix) - message("Using default prior reference scale ", sigma) +ess.normMix <- function(mix, method = c("elir", "moment", "morita"), ..., family = gaussian, sigma, s = 100) { + method <- match.arg(method) + + if (is.character(family)) { + family <- get(family, mode = "function", envir = parent.frame()) + } + if (is.function(family)) { + family <- family() + } + if (is.null(family$family)) { + print(family) + stop("'family' not recognized") + } + + is_gaussian_family <- family$family == "gaussian" + if (!is_gaussian_family) { + assert_that(family$dispersion == 1, msg = "Only dispersion unity is supported for non-gaussian families.") + } + + normTransformedFisherInfo_inverse <- make_normTransformedFisherInfo_inverse(family) + + if (!is_gaussian_family) { + sigma <- 1 + } else { + if (missing(sigma)) { + sigma <- RBesT::sigma(mix) + message("Using default prior reference scale ", sigma) + } + } + assert_number(sigma, lower = 0) + tauSq <- sigma^2 + + ## note: sigma is reassigned the sd's of each mixture component + mu <- mix[2, ] + sigma <- mix[3, ] + sigmaSq <- sigma^2 + + if (method == "elir") { + elir <- integrate_density(lir(mix, normMixInfo, normTransformedFisherInfo_inverse), mix) + if (is_gaussian_family) { + ## in this case we have to account for the non-unity scale + ## of the Gaussian likelihood + elir <- elir * tauSq } - assert_number(sigma, lower=0) - tauSq <- sigma^2 + return(elir) + } - ## note: sigma is reassigned the sd's of each mixture component - mu <- mix[2,] - sigma <- mix[3,] - sigmaSq <- sigma^2 - if(method == "elir") { - return(tauSq * integrate_density(lir(mix, normMixInfo, normStdFisherInfo_inverse), mix)) + ## simple and conservative moment matching compared to the + ## expected fisher information over the prior parameter space + if (method == "moment") { + smix <- summary(mix) + if (is_gaussian_family && family$link == "identity") { + expected_info <- 1 + } else { + expected_info <- integrate_density(normTransformedFisherInfo_inverse, mix) } - - ## simple and conservative moment matching - if(method == "moment") { - smix <- summary(mix) - res <- tauSq / smix["sd"]^2 - return( unname(res) ) + if (is_gaussian_family) { + expected_info <- tauSq * expected_info } + res <- expected_info / smix["sd"]^2 + return(unname(res)) + } - locEst <- calc_loc(mix, "mode") + locEst <- calc_loc(mix, "mode") - deriv2.prior <- normMixInfo(mix, locEst) + deriv2.prior <- normMixInfo(mix, locEst) - ESSmax <- ceiling(sum( (1-1/s) * tauSq/sigmaSq )) * 2 + ## "flattened" priors + muP0 <- locEst + sigmaP0Sq <- s * max(sigmaSq) - ## "flattened" priors - muP0 <- locEst - sigmaP0Sq <- s * max(sigmaSq) + info.prior0 <- normInfo(locEst, muP0, sqrt(sigmaP0Sq)) - ## difference of info at locEst and the expected 2nd derivative at - ## locEst - ed2pDiff <- function(m) { - deriv2.prior - normInfo(locEst, muP0, sqrt(1/(m/tauSq + 1/sigmaP0Sq))) - } - - info.prior0 <- normInfo(locEst, muP0, sqrt(sigmaP0Sq)) + ## info at mode + mode_info <- 1 / normTransformedFisherInfo_inverse(locEst) - Einfo <- 1/tauSq + if (is_gaussian_family) { + ## in this case we have to account for the non-unity scale + ## of the Gaussian likelihood + mode_info <- mode_info / tauSq + } - return(unname( (deriv2.prior - info.prior0)/Einfo )) + return(unname((deriv2.prior - info.prior0) / mode_info)) } ## derivative of a single log-normal -normLogGrad <- function(x,mu,sigma) { - -1 * (x-mu)/(sigma)^2 +normLogGrad <- function(x, mu, sigma) { + -1 * (x - mu) / (sigma)^2 } ## second derivative of a single log-normal -normLogHess <- function(x,mu,sigma) { - -1/sigma^2 +normLogHess <- function(x, mu, sigma) { + -1 / sigma^2 } -normMixInfo <- function(mix,x) { - mixInfo(mix, x, dnorm, normLogGrad, normLogHess) +normMixInfo <- function(mix, x) { + mixInfo(mix, x, dnorm, normLogGrad, normLogHess) } ## info metric for a single norm, i.e. negative second derivative of log norm -normInfo <- function(x,mean,sigma) { - -normLogHess(x,mean,sigma) +normInfo <- function(x, mean, sigma) { + -normLogHess(x, mean, sigma) } ## Fisher info for normal sampling sd with known unit variance normStdFisherInfo_inverse <- function(x) { - 1.0 + 1.0 +} + +make_normTransformedFisherInfo_inverse <- function(family) { + function(x) { + 1 / family$variance(family$linkinv(x)) + } } diff --git a/R/mixfit.R b/R/mixfit.R index b949b7b..2ce818a 100644 --- a/R/mixfit.R +++ b/R/mixfit.R @@ -57,11 +57,11 @@ #' of the Royal Statistical Society, Series B} 1977; 39 (1): 1-38. #' #' @examples -#' bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) +#' bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) #' #' bsamp <- rmix(bmix, 1000) #' -#' bfit <- mixfit(bsamp, type="beta", Nc=2) +#' bfit <- mixfit(bsamp, type = "beta", Nc = 2) #' #' # diagnostic plots can easily by generated from the EM fit with #' bfit.check <- plot(bfit) @@ -81,20 +81,25 @@ #' #' @export -mixfit <- function(sample, type=c("norm", "beta", "gamma", "mvnorm"), thin, ...) UseMethod("mixfit") +mixfit <- function(sample, type = c("norm", "beta", "gamma", "mvnorm"), thin, ...) UseMethod("mixfit") #' @describeIn mixfit Performs an EM fit for the given #' sample. Thinning is applied only if thin is specified. #' @export -mixfit.default <- function(sample, type=c("norm", "beta", "gamma", "mvnorm"), thin, ...) { - type <- match.arg(type) - assert_that(type %in% c("norm", "beta", "gamma", "mvnorm")) - EM <- switch(type, norm=EM_nmm, beta=EM_bmm_ab, gamma=EM_gmm, mvnorm=EM_mnmm) - if(!missing(thin)) { - assert_that(thin >= 1) - sample <- asub(sample, seq(1,NROW(sample),by=thin), dims=1, drop=FALSE) - } - EM(sample, ...) +mixfit.default <- function(sample, type = c("norm", "beta", "gamma", "mvnorm"), thin, ...) { + type <- match.arg(type) + assert_that(type %in% c("norm", "beta", "gamma", "mvnorm")) + EM <- switch(type, + norm = EM_nmm, + beta = EM_bmm_ab, + gamma = EM_gmm, + mvnorm = EM_mnmm + ) + if (!missing(thin)) { + assert_that(thin >= 1) + sample <- asub(sample, seq(1, NROW(sample), by = thin), dims = 1, drop = FALSE) + } + EM(sample, ...) } #' @describeIn mixfit Fits the default predictive distribution from a @@ -107,45 +112,56 @@ mixfit.default <- function(sample, type=c("norm", "beta", "gamma", "mvnorm"), th #' sigma in \code{\link{gMAP}} call. #' @export mixfit.gMAP <- function(sample, type, thin, ...) { - family <- sample$family$family - ## automatically thin sample as estimated by gMAP function - if(missing(thin)) { - thin <- sample$thin - } - assert_that(thin >= 1) - type <- switch(sample$family$family, binomial = "beta", gaussian = "norm", poisson = "gamma", "unknown") - sim <- rstan::extract(sample$fit, pars="theta_resp_pred", inc_warmup=FALSE, permuted=FALSE) - sim <- as.vector(sim[seq(1,dim(sim)[1],by=thin),,]) - mix <- mixfit.default(sim, type, thin=1, ...) - ## for the case of normal data, read out the estimated reference - ## scale - if(family == "gaussian" & !is.null(sample$sigma_ref)) - sigma(mix) <- sample$sigma_ref - set_likelihood(mix, family) + family <- sample$family$family + ## automatically thin sample as estimated by gMAP function + if (missing(thin)) { + thin <- sample$thin + } + assert_that(thin >= 1) + type <- switch(sample$family$family, + binomial = "beta", + gaussian = "norm", + poisson = "gamma", + "unknown" + ) + sim <- rstan::extract(sample$fit, pars = "theta_resp_pred", inc_warmup = FALSE, permuted = FALSE) + sim <- as.vector(sim[seq(1, dim(sim)[1], by = thin), , ]) + mix <- mixfit.default(sim, type, thin = 1, ...) + ## for the case of normal data, read out the estimated reference + ## scale + if (family == "gaussian" & !is.null(sample$sigma_ref)) { + sigma(mix) <- sample$sigma_ref + } + set_likelihood(mix, family) } #' @describeIn mixfit Fits a mixture density for each prediction from #' the \code{\link{gMAP}} prediction. #' @export mixfit.gMAPpred <- function(sample, type, thin, ...) { - if(attr(sample, "type") == "response") { - type <- switch(attr(sample, "family")$family, binomial = "beta", gaussian = "norm", poisson = "gamma", "unknown") - family <- attr(sample, "family")$family - } else { - type <- "norm" - family <- "gaussian" - } - res <- list() - for(i in 1:dim(sample)[2]) { - ## for the case of normal data, read out the estimated reference - ## scale - ## note: gMAPpred objects are already thinned down - res[[i]] <- set_likelihood(mixfit.default(sample[,i], type=type, thin=1, ...), family) - if(family == "gaussian" & !is.null(attr(sample, "sigma_ref"))) { - sigma(res[[i]]) <- attr(sample, "sigma_ref") - } + if (attr(sample, "type") == "response") { + type <- switch(attr(sample, "family")$family, + binomial = "beta", + gaussian = "norm", + poisson = "gamma", + "unknown" + ) + family <- attr(sample, "family")$family + } else { + type <- "norm" + family <- "gaussian" + } + res <- list() + for (i in 1:dim(sample)[2]) { + ## for the case of normal data, read out the estimated reference + ## scale + ## note: gMAPpred objects are already thinned down + res[[i]] <- set_likelihood(mixfit.default(sample[, i], type = type, thin = 1, ...), family) + if (family == "gaussian" & !is.null(attr(sample, "sigma_ref"))) { + sigma(res[[i]]) <- attr(sample, "sigma_ref") } - res + } + res } #' @describeIn mixfit Fits a mixture density for an MCMC sample. It is #' recommended to provide a thinning argument which roughly yields @@ -155,18 +171,19 @@ mixfit.gMAPpred <- function(sample, type, thin, ...) { #' chains, and draws. #' @export mixfit.array <- function(sample, type, thin, ...) { - if(type != "mvnorm" & dim(sample)[3] != 1) - stop("Only univariate data is supported.") - mixfit.default(sample, type, thin, ...) + if (type != "mvnorm" & dim(sample)[3] != 1) { + stop("Only univariate data is supported.") + } + mixfit.default(sample, type, thin, ...) } set_likelihood <- function(mix, family) { - if(family == "binomial") { - likelihood(mix) <- "binomial" - } else if(family == "gaussian") { - likelihood(mix) <- "normal" - } else if(family == "poisson") { - likelihood(mix) <- "poisson" - } - mix + if (family == "binomial") { + likelihood(mix) <- "binomial" + } else if (family == "gaussian") { + likelihood(mix) <- "normal" + } else if (family == "poisson") { + likelihood(mix) <- "poisson" + } + mix } diff --git a/R/mixgamma.R b/R/mixgamma.R index 750ee8c..32acbb0 100644 --- a/R/mixgamma.R +++ b/R/mixgamma.R @@ -40,7 +40,7 @@ #' #' @examples #' # Gamma mixture with robust and informative component -#' gmix <- mixgamma(rob=c(0.3, 20, 4), inf=c(0.7, 50, 10)) +#' gmix <- mixgamma(rob = c(0.3, 20, 4), inf = c(0.7, 50, 10)) #' #' # objects can be printed #' gmix @@ -57,52 +57,57 @@ #' gmix[["inf"]] #' #' # alternative mean and standard deviation parametrization -#' gmsMix <- mixgamma(rob=c(0.5, 8, 0.5), inf=c(0.5, 9, 2), param="ms") +#' gmsMix <- mixgamma(rob = c(0.5, 8, 0.5), inf = c(0.5, 9, 2), param = "ms") #' #' # or mean and number of observations parametrization -#' gmnMix <- mixgamma(rob=c(0.2, 2, 1), inf=c(0.8, 2, 5), param="mn") +#' gmnMix <- mixgamma(rob = c(0.2, 2, 1), inf = c(0.8, 2, 5), param = "mn") #' #' # and mixed parametrizations are also possible -#' gfmix <- mixgamma(rob1=c(0.15, mn2gamma(2, 1)), rob2=c(0.15, ms2gamma(2, 5)), inf=c(0.7, 50, 10)) +#' gfmix <- mixgamma(rob1 = c(0.15, mn2gamma(2, 1)), +#' rob2 = c(0.15, ms2gamma(2, 5)), +#' inf = c(0.7, 50, 10)) NULL #' @rdname mixgamma #' @export -mixgamma <- function(..., param=c("ab", "ms", "mn"), likelihood=c("poisson", "exp")) { - mix <- mixdist3(...) - assert_matrix(mix, nrows=3, any.missing=FALSE) - param <- match.arg(param) - likelihood <- match.arg(likelihood) - mix[c(2,3),] <- switch(param, - ab=mix[c(2,3),], - ms=t(ms2gamma(mix[2,], mix[3,], FALSE)), - mn=t(mn2gamma(mix[2,], mix[3,], likelihood, FALSE)) - ) - rownames(mix) <- c("w", "a", "b") - assert_that(all(mix["a",] > 0)) - assert_that(all(mix["b",] > 0)) - class(mix) <- c("gammaMix", "mix") - likelihood(mix) <- likelihood - mix +mixgamma <- function(..., param = c("ab", "ms", "mn"), likelihood = c("poisson", "exp")) { + mix <- mixdist3(...) + assert_matrix(mix, nrows = 3, any.missing = FALSE) + param <- match.arg(param) + likelihood <- match.arg(likelihood) + mix[c(2, 3), ] <- switch(param, + ab = mix[c(2, 3), ], + ms = t(ms2gamma(mix[2, ], mix[3, ], FALSE)), + mn = t(mn2gamma(mix[2, ], mix[3, ], likelihood, FALSE)) + ) + rownames(mix) <- c("w", "a", "b") + assert_that(all(mix["a", ] > 0)) + assert_that(all(mix["b", ] > 0)) + class(mix) <- c("gammaMix", "mix") + likelihood(mix) <- likelihood + mix } #' @rdname mixgamma #' @export -ms2gamma <- function(m, s, drop=TRUE) { - b <- m/s^2 - ab <- cbind(a=m*b, b=b) - if(drop) ab <- drop(ab) - ab +ms2gamma <- function(m, s, drop = TRUE) { + b <- m / s^2 + ab <- cbind(a = m * b, b = b) + if (drop) ab <- drop(ab) + ab } #' @rdname mixgamma #' @export -mn2gamma <- function(m, n, likelihood=c("poisson", "exp"), drop=TRUE) { - assert_that(all(n>=0)) - likelihood <- match.arg(likelihood) - ab <- switch(likelihood, poisson=cbind(a=m*n, b=n), exp=cbind(a=n, b=n/m)) - if(drop) ab <- drop(ab) - ab +mn2gamma <- function(m, n, likelihood = c("poisson", "exp"), drop = TRUE) { + assert_that(all(n >= 0)) + likelihood <- match.arg(likelihood) + ab <- switch(likelihood, + poisson = cbind(a = m * n, b = n), + exp = cbind(a = n, b = n / m) + ) + if (drop) ab <- drop(ab) + ab } #' @rdname mixgamma @@ -110,8 +115,8 @@ mn2gamma <- function(m, n, likelihood=c("poisson", "exp"), drop=TRUE) { #' @param x The mixture to print #' @export print.gammaMix <- function(x, ...) { - cat("Univariate Gamma mixture\n") - NextMethod() + cat("Univariate Gamma mixture\n") + NextMethod() } #' @rdname mixgamma @@ -119,8 +124,8 @@ print.gammaMix <- function(x, ...) { #' @param x The mixture to print #' @export print.gammaPoissonMix <- function(x, ...) { - cat("Univariate Gamma-Poisson mixture\n") - NextMethod() + cat("Univariate Gamma-Poisson mixture\n") + NextMethod() } #' @rdname mixgamma @@ -128,50 +133,50 @@ print.gammaPoissonMix <- function(x, ...) { #' @param x The mixture to print #' @export print.gammaExpMix <- function(x, ...) { - cat("Univariate Gamma-Exponential mixture\n") - NextMethod() + cat("Univariate Gamma-Exponential mixture\n") + NextMethod() } #' @rdname mixgamma #' @method summary gammaMix #' @export -summary.gammaMix <- function(object, probs=c(0.025,0.5,0.975), ...) { - p <- object[1,] - a <- object[2,] - b <- object[3,] - m <- a/b - v <- a/b^2 - ## calculate mean of the second moment - m2 <- v + m^2 - ## from this we can get the mean and variance of the mixture - mmix <- sum(p * m) - vmix <- sum(p * (m2 - (mmix)^2 ) ) - q <- c() - if(length(probs) != 0) { - q <- qmix.gammaMix(object, p=probs) - names(q) <- paste(format(probs*100,digits=2), "%", sep="") - } - c(mean=mmix, sd=sqrt(vmix), q) +summary.gammaMix <- function(object, probs = c(0.025, 0.5, 0.975), ...) { + p <- object[1, ] + a <- object[2, ] + b <- object[3, ] + m <- a / b + v <- a / b^2 + ## calculate mean of the second moment + m2 <- v + m^2 + ## from this we can get the mean and variance of the mixture + mmix <- sum(p * m) + vmix <- sum(p * (m2 - (mmix)^2)) + q <- c() + if (length(probs) != 0) { + q <- qmix.gammaMix(object, p = probs) + names(q) <- paste(format(probs * 100, digits = 2), "%", sep = "") + } + c(mean = mmix, sd = sqrt(vmix), q) } #' @rdname mixgamma #' @method summary gammaPoissonMix #' @export -summary.gammaPoissonMix <- function(object, probs=c(0.025,0.5,0.975), ...) { - n <- attr(object, "n") - p <- object[1,] - a <- object[2,] - b <- object[3,]/n - m <- a/b - v <- a *(b+1)/b^2 - ## calculate mean of the second moment - m2 <- v + m^2 - ## from this we can get the mean and variance of the mixture - mmix <- sum(p * m) - vmix <- sum(p * (m2 - (mmix)^2 ) ) - q <- qmix.gammaPoissonMix(object, p=probs) - if(length(q) != 0) - names(q) <- paste(format(probs*100,digits=2), "%", sep="") - c(mean=mmix, sd=sqrt(vmix), q) +summary.gammaPoissonMix <- function(object, probs = c(0.025, 0.5, 0.975), ...) { + n <- attr(object, "n") + p <- object[1, ] + a <- object[2, ] + b <- object[3, ] / n + m <- a / b + v <- a * (b + 1) / b^2 + ## calculate mean of the second moment + m2 <- v + m^2 + ## from this we can get the mean and variance of the mixture + mmix <- sum(p * m) + vmix <- sum(p * (m2 - (mmix)^2)) + q <- qmix.gammaPoissonMix(object, p = probs) + if (length(q) != 0) { + names(q) <- paste(format(probs * 100, digits = 2), "%", sep = "") + } + c(mean = mmix, sd = sqrt(vmix), q) } - diff --git a/R/mixmode.R b/R/mixmode.R index c2eecfe..266e522 100644 --- a/R/mixmode.R +++ b/R/mixmode.R @@ -1,23 +1,23 @@ -mixmode <- function(mix, interval=0.99, verbose=FALSE) { - tol <- .Machine$double.eps^0.25 - digits <- floor(abs(log10(tol))) - compmode <- function(comp) { - mixComp <- mix[[comp]] - mixComp[1,] <- 1 - qlow <- (1-interval)/2 - qup <- 1-qlow - optimise(function(x) dmix(mix, x, log=TRUE), qmix(mixComp, c(qlow, qup)), maximum = TRUE, tol=tol)$maximum - } - ## find around each component the maximum as otherwise optimise - ## can run into a local extremum - extrema <- sapply(seq(ncol(mix)), compmode) - res <- extrema[which.max(dmix(mix, extrema))] - ## identify distinct modes - ind <- duplicated(signif(extrema, digits)) - attr(res, "modes") <- extrema[!ind] - if(verbose) { - cat("Locations:",extrema[!ind], "\n") - cat("Density :",dmix(mix, extrema[!ind]), "\n") - } - res +mixmode <- function(mix, interval = 0.99, verbose = FALSE) { + tol <- .Machine$double.eps^0.25 + digits <- floor(abs(log10(tol))) + compmode <- function(comp) { + mixComp <- mix[[comp]] + mixComp[1, ] <- 1 + qlow <- (1 - interval) / 2 + qup <- 1 - qlow + optimise(function(x) dmix(mix, x, log = TRUE), qmix(mixComp, c(qlow, qup)), maximum = TRUE, tol = tol)$maximum + } + ## find around each component the maximum as otherwise optimise + ## can run into a local extremum + extrema <- sapply(seq(ncol(mix)), compmode) + res <- extrema[which.max(dmix(mix, extrema))] + ## identify distinct modes + ind <- duplicated(signif(extrema, digits)) + attr(res, "modes") <- extrema[!ind] + if (verbose) { + cat("Locations:", extrema[!ind], "\n") + cat("Density :", dmix(mix, extrema[!ind]), "\n") + } + res } diff --git a/R/mixmvnorm.R b/R/mixmvnorm.R index 57a76d2..55837d3 100644 --- a/R/mixmvnorm.R +++ b/R/mixmvnorm.R @@ -25,7 +25,7 @@ #' #' Each component defining vector can be specified in different ways #' as determined by the \code{param} option: -#' +#' #' \describe{ #' \item{ms}{Mean vector and covariance matrix \code{s}. Default.} #' \item{mn}{Mean vector and number of observations. \code{n} determines the covariance for each component via the relation \eqn{\Sigma/n} with \eqn{\Sigma} being the known reference covariance.} @@ -46,9 +46,11 @@ #' #' @examples #' -#' S <- diag(c(1, 2)) %*% matrix(c(1, 0.5, 0.5, 1), 2, 2) %*% diag(c(1, 2)) -#' mvnm1 <- mixmvnorm(rob=c(0.2, c(0, 0), diag(c(5, 5))), -#' inf=c(0.8, c(0.5, 1), S/10), sigma=S) +#' S <- diag(c(1, 2)) %*% matrix(c(1, 0.5, 0.5, 1), 2, 2) %*% diag(c(1, 2)) +#' mvnm1 <- mixmvnorm( +#' rob = c(0.2, c(0, 0), diag(c(5, 5))), +#' inf = c(0.8, c(0.5, 1), S / 10), sigma = S +#' ) #' #' print(mvnm1) #' summary(mvnm1) @@ -57,113 +59,117 @@ #' mixSamp1 <- rmix(mvnm1, 500) #' colMeans(mixSamp1) #' -#' NULL #' @rdname mixmvnorm #' @export -mixmvnorm <- function(..., sigma, param=c("ms", "mn")) { - ## length of first mean vector determines dimension - mix <- mixdist3(...) - dim_labels <- rownames(mix) - param <- match.arg(param) - Nc <- ncol(mix) - n <- colnames(mix) - if(param == "ms") { - ## mean vector & covariance parametrization - l <- nrow(mix) - p <- (sqrt(1 + 4 * (l - 1)) - 1) / 2 - assert_integerish(p, lower=1, any.missing=FALSE, len=1) - ## in this case we expect c(weight, mean, as.numeric(cov)) - mix <- do.call(mixdist3, - lapply(1:Nc, - function(co) c(mix[1,co], mvnorm(mix[2:(p+1),co], matrix(mix[(1+p+1):(1+p+p^2),co], p, p))) - )) - } - if(param == "mn") { - ## mean vector & number of observations - l <- nrow(mix) - p <- l - 2 - assert_integerish(p, lower=1, any.missing=FALSE, len=1) - assert_matrix(sigma, any.missing=FALSE, nrows=p, ncols=p) - mix <- do.call(mixdist3, lapply(1:Nc, - function(co) { - assert_numeric(mix[l,co], lower=0, finite=TRUE, any.missing=FALSE) - c(mix[1,co], mvnorm(mix[2:(p+1),co], sigma/mix[l,co] )) - } - )) - } - colnames(mix) <- n - p <- mvnormdim(mix[-1,1]) - if(is.null(dim_labels)) { - dim_labels <- as.character(1:p) - } else { - dim_labels <- dim_labels[2:(p+1)] - } - rownames(mix) <- c("w", mvnorm_label(mix[-1,1], dim_labels)) - if(!missing(sigma)) { - assert_matrix(sigma, any.missing=FALSE, nrows=p, ncols=p) - colnames(sigma) <- rownames(sigma) <- dim_labels - attr(mix, "sigma") <- sigma - } - class(mix) <- c("mvnormMix", "mix") - likelihood(mix) <- "mvnormal" - mix +mixmvnorm <- function(..., sigma, param = c("ms", "mn")) { + ## length of first mean vector determines dimension + mix <- mixdist3(...) + dim_labels <- rownames(mix) + param <- match.arg(param) + Nc <- ncol(mix) + n <- colnames(mix) + if (param == "ms") { + ## mean vector & covariance parametrization + l <- nrow(mix) + p <- (sqrt(1 + 4 * (l - 1)) - 1) / 2 + assert_integerish(p, lower = 1, any.missing = FALSE, len = 1) + ## in this case we expect c(weight, mean, as.numeric(cov)) + mix <- do.call( + mixdist3, + lapply( + 1:Nc, + function(co) c(mix[1, co], mvnorm(mix[2:(p + 1), co], matrix(mix[(1 + p + 1):(1 + p + p^2), co], p, p))) + ) + ) + } + if (param == "mn") { + ## mean vector & number of observations + l <- nrow(mix) + p <- l - 2 + assert_integerish(p, lower = 1, any.missing = FALSE, len = 1) + assert_matrix(sigma, any.missing = FALSE, nrows = p, ncols = p) + mix <- do.call(mixdist3, lapply( + 1:Nc, + function(co) { + assert_numeric(mix[l, co], lower = 0, finite = TRUE, any.missing = FALSE) + c(mix[1, co], mvnorm(mix[2:(p + 1), co], sigma / mix[l, co])) + } + )) + } + colnames(mix) <- n + p <- mvnormdim(mix[-1, 1]) + if (is.null(dim_labels)) { + dim_labels <- as.character(1:p) + } else { + dim_labels <- dim_labels[2:(p + 1)] + } + rownames(mix) <- c("w", mvnorm_label(mix[-1, 1], dim_labels)) + if (!missing(sigma)) { + assert_matrix(sigma, any.missing = FALSE, nrows = p, ncols = p) + colnames(sigma) <- rownames(sigma) <- dim_labels + attr(mix, "sigma") <- sigma + } + class(mix) <- c("mvnormMix", "mix") + likelihood(mix) <- "mvnormal" + mix } #' @keywords internal mvnorm <- function(mean, sigma) { - ## TODO: far more checks!!! Allow to pass in directly a cholesky factor - assert_numeric(mean, finite=TRUE, any.missing=FALSE) - p <- length(mean) - assert_matrix(sigma, any.missing=FALSE, nrows=p, ncols=p) - rho <- cov2cor(sigma) - s <- sqrt(diag(sigma)) - mvn <- c(mean, s, rho[lower.tri(rho)]) - names(mvn) <- mvnorm_label(mvn) - mvn + ## TODO: far more checks!!! Allow to pass in directly a cholesky factor + assert_numeric(mean, finite = TRUE, any.missing = FALSE) + p <- length(mean) + assert_matrix(sigma, any.missing = FALSE, nrows = p, ncols = p) + rho <- cov2cor(sigma) + s <- sqrt(diag(sigma)) + mvn <- c(mean, s, rho[lower.tri(rho)]) + names(mvn) <- mvnorm_label(mvn) + mvn } #' @keywords internal mvnormdim <- function(mvn) { - p <- (-3 + sqrt(9 + 8 * length(mvn))) / 2 - assert_integerish(p, lower=1, any.missing=FALSE, len=1) - as.integer(p) + p <- (-3 + sqrt(9 + 8 * length(mvn))) / 2 + assert_integerish(p, lower = 1, any.missing = FALSE, len = 1) + as.integer(p) } #' @keywords internal mvnorm_dim_labels <- function(mvn) { - p <- mvnormdim(mvn) - n <- names(mvn) - if(is.null(n)) { - return(as.character(1:p)) - } - return(gsub("\\]$", "", gsub("^[^\\[]*\\[", "", n[1:p]))) + p <- mvnormdim(mvn) + n <- names(mvn) + if (is.null(n)) { + return(as.character(1:p)) + } + return(gsub("\\]$", "", gsub("^[^\\[]*\\[", "", n[1:p]))) } #' @keywords internal mvnorm_label <- function(mvn, dim_labels) { - p <- mvnormdim(mvn) - if(missing(dim_labels)) - dim_labels <- mvnorm_dim_labels(mvn) - if(p > 1) { - Rho_labs_idx <- outer(dim_labels, dim_labels, paste, sep=",")[lower.tri(diag(p))] - lab <- c(paste0("m[", dim_labels,"]"), paste0("s[", dim_labels, "]"), paste0("rho[", Rho_labs_idx, "]")) - } else { - lab <- c(paste0("m[", dim_labels,"]"), paste0("s[", dim_labels, "]")) - } - lab + p <- mvnormdim(mvn) + if (missing(dim_labels)) { + dim_labels <- mvnorm_dim_labels(mvn) + } + if (p > 1) { + Rho_labs_idx <- outer(dim_labels, dim_labels, paste, sep = ",")[lower.tri(diag(p))] + lab <- c(paste0("m[", dim_labels, "]"), paste0("s[", dim_labels, "]"), paste0("rho[", Rho_labs_idx, "]")) + } else { + lab <- c(paste0("m[", dim_labels, "]"), paste0("s[", dim_labels, "]")) + } + lab } #' @keywords internal mvnormsigma <- function(mvn) { - p <- mvnormdim(mvn) - n <- length(mvn) - s <- mvn[(p+1):(2*p)] - Rho <- diag(p) - Rho[lower.tri(Rho)] <- mvn[(2*p+1):n] - Rho[upper.tri(Rho)] <- t(Rho)[upper.tri(Rho)] - diag(s, nrow=p) %*% Rho %*% diag(s, nrow=p) + p <- mvnormdim(mvn) + n <- length(mvn) + s <- mvn[(p + 1):(2 * p)] + Rho <- diag(p) + Rho[lower.tri(Rho)] <- mvn[(2 * p + 1):n] + Rho[upper.tri(Rho)] <- t(Rho)[upper.tri(Rho)] + diag(s, nrow = p) %*% Rho %*% diag(s, nrow = p) } @@ -172,36 +178,36 @@ mvnormsigma <- function(mvn) { #' @param x The mixture to print #' @export print.mvnormMix <- function(x, ...) { - cat("Multivariate normal mixture\n") - cat(paste0("Outcome dimension: ", mvnormdim(x[-1,1]), "\n")) - if(!is.null(sigma(x))) { - cat("Reference covariance:\n") - print(sigma(x), ...) - } - NextMethod() + cat("Multivariate normal mixture\n") + cat(paste0("Outcome dimension: ", mvnormdim(x[-1, 1]), "\n")) + if (!is.null(sigma(x))) { + cat("Reference covariance:\n") + print(sigma(x), ...) + } + NextMethod() } #' @rdname mixmvnorm #' @method summary mvnormMix #' @export summary.mvnormMix <- function(object, ...) { - w <- object[1,] - p <- mvnormdim(object[-1,1]) - m <- object[2:(p+1),,drop=FALSE] - Nc <- ncol(object) - mmix <- rowSums(sweep(m, 2, w, "*")) - ## Cov(x,x) = E(x x') - E(x) E(x') - ## E(x x') = Sigma + m m' (see matrix cookbook eq 377) - if(Nc == 1) { - S <- w[1] * mvnormsigma(object[-1,1]) - } else { - S <- -1 * tcrossprod(mmix) - for(i in 1:Nc) { - S <- S + w[i] * ( mvnormsigma(object[-1,i]) + tcrossprod(unname(m[,i,drop=FALSE]) )) - } + w <- object[1, ] + p <- mvnormdim(object[-1, 1]) + m <- object[2:(p + 1), , drop = FALSE] + Nc <- ncol(object) + mmix <- rowSums(sweep(m, 2, w, "*")) + ## Cov(x,x) = E(x x') - E(x) E(x') + ## E(x x') = Sigma + m m' (see matrix cookbook eq 377) + if (Nc == 1) { + S <- w[1] * mvnormsigma(object[-1, 1]) + } else { + S <- -1 * tcrossprod(mmix) + for (i in 1:Nc) { + S <- S + w[i] * (mvnormsigma(object[-1, i]) + tcrossprod(unname(m[, i, drop = FALSE]))) } - rownames(S) <- colnames(S) <- names(mmix) <- mvnorm_dim_labels(object[-1,1]) - list(mean=mmix, cov=S) + } + rownames(S) <- colnames(S) <- names(mmix) <- mvnorm_dim_labels(object[-1, 1]) + list(mean = mmix, cov = S) } #' @rdname mixmvnorm @@ -209,24 +215,25 @@ summary.mvnormMix <- function(object, ...) { #' @export #' @export sigma sigma.mvnormMix <- function(object, ...) { - attr(object, "sigma") + attr(object, "sigma") } #' @keywords internal is_mixmv <- function(mix) { - inherits(mix, "mvnormMix") + inherits(mix, "mvnormMix") } #' @keywords internal mvnorm_extract_dim <- function(mix, sub) { - Nc <- ncol(mix) - sub_comp <- list() - p <- mvnormdim(mix[-1,1]) - assert_numeric(sub, lower=1, upper=p, any.missing=FALSE) - for(i in seq_len(Nc)) { - sub_comp[[i]] <- c(mix["w", i], mix[1 + sub, i], mvnormsigma(mix[-1,i])[sub, sub, drop=FALSE]) - } - if(!is.null(sigma(mix))) - sub_comp$sigma <- sigma(mix) - do.call(mixmvnorm, sub_comp) + Nc <- ncol(mix) + sub_comp <- list() + p <- mvnormdim(mix[-1, 1]) + assert_numeric(sub, lower = 1, upper = p, any.missing = FALSE) + for (i in seq_len(Nc)) { + sub_comp[[i]] <- c(mix["w", i], mix[1 + sub, i], mvnormsigma(mix[-1, i])[sub, sub, drop = FALSE]) + } + if (!is.null(sigma(mix))) { + sub_comp$sigma <- sigma(mix) + } + do.call(mixmvnorm, sub_comp) } diff --git a/R/mixnorm.R b/R/mixnorm.R index f9dd7b8..5147553 100644 --- a/R/mixnorm.R +++ b/R/mixnorm.R @@ -44,7 +44,7 @@ #' #' @examples #' -#' nm <- mixnorm(rob=c(0.2, 0, 2), inf=c(0.8, 2, 2), sigma=5) +#' nm <- mixnorm(rob = c(0.2, 0, 2), inf = c(0.8, 2, 2), sigma = 5) #' #' print(nm) #' summary(nm) @@ -52,16 +52,16 @@ #' #' set.seed(57845) #' mixSamp <- rmix(nm, 500) -#' plot(nm, samp=mixSamp) +#' plot(nm, samp = mixSamp) #' #' # support defined by quantiles #' qmix(nm, c(0.01, 0.99)) #' #' # density function -#' dmix(nm, seq(-5,5,by=2)) +#' dmix(nm, seq(-5, 5, by = 2)) #' #' # distribution function -#' pmix(nm, seq(-5,5,by=2)) +#' pmix(nm, seq(-5, 5, by = 2)) #' #' # the reference scale can be changed (it determines the ESS) #' ess(nm) @@ -72,33 +72,33 @@ NULL #' @rdname mixnorm #' @export -mixnorm <- function(..., sigma, param=c("ms", "mn")) { - mix <- mixdist3(...) - assert_matrix(mix, nrows=3, any.missing=FALSE) - param <- match.arg(param) - mix[c(2,3),] <- switch(param, - ms=mix[c(2,3),], - mn=t(mn2norm(mix[2,], mix[3,], sigma, FALSE)) - ) - rownames(mix) <- c("w", "m", "s") - assert_that(all(mix["s",] > 0)) - if(!missing(sigma)) { - assert_number(sigma, lower=0) - attr(mix, "sigma") <- sigma - } - class(mix) <- c("normMix", "mix") - likelihood(mix) <- "normal" - mix +mixnorm <- function(..., sigma, param = c("ms", "mn")) { + mix <- mixdist3(...) + assert_matrix(mix, nrows = 3, any.missing = FALSE) + param <- match.arg(param) + mix[c(2, 3), ] <- switch(param, + ms = mix[c(2, 3), ], + mn = t(mn2norm(mix[2, ], mix[3, ], sigma, FALSE)) + ) + rownames(mix) <- c("w", "m", "s") + assert_that(all(mix["s", ] > 0)) + if (!missing(sigma)) { + assert_number(sigma, lower = 0) + attr(mix, "sigma") <- sigma + } + class(mix) <- c("normMix", "mix") + likelihood(mix) <- "normal" + mix } #' @rdname mixnorm #' @export -mn2norm <- function(m, n, sigma, drop=TRUE) { - assert_number(sigma, lower=0) - sigma_n <- sigma/sqrt(n) - ms <- cbind(m=m, s=sigma_n) - if(drop) ms <- drop(ms) - ms +mn2norm <- function(m, n, sigma, drop = TRUE) { + assert_number(sigma, lower = 0) + sigma_n <- sigma / sqrt(n) + ms <- cbind(m = m, s = sigma_n) + if (drop) ms <- drop(ms) + ms } #' @rdname mixnorm @@ -106,30 +106,31 @@ mn2norm <- function(m, n, sigma, drop=TRUE) { #' @param x The mixture to print #' @export print.normMix <- function(x, ...) { - cat("Univariate normal mixture\n") - if(!is.null(sigma(x))) - cat("Reference scale: ", sigma(x), "\n", sep="") - NextMethod() + cat("Univariate normal mixture\n") + if (!is.null(sigma(x))) { + cat("Reference scale: ", sigma(x), "\n", sep = "") + } + NextMethod() } #' @rdname mixnorm #' @method summary normMix #' @export -summary.normMix <- function(object, probs=c(0.025,0.5,0.975), ...) { - p <- object[1,] - m <- object[2,] - v <- object[3,]^2 - ## calculate mean of the second moment - m2 <- v + m^2 - ## from this we can get the mean and variance of the mixture - mmix <- sum(p * m) - vmix <- sum(p * (m2 - (mmix)^2)) - q <- c() - if(length(probs) != 0) { - q <- qmix.normMix(object, p=probs) - names(q) <- paste(format(probs*100,digits=2), "%", sep="") - } - c(mean=mmix, sd=sqrt(vmix), q) +summary.normMix <- function(object, probs = c(0.025, 0.5, 0.975), ...) { + p <- object[1, ] + m <- object[2, ] + v <- object[3, ]^2 + ## calculate mean of the second moment + m2 <- v + m^2 + ## from this we can get the mean and variance of the mixture + mmix <- sum(p * m) + vmix <- sum(p * (m2 - (mmix)^2)) + q <- c() + if (length(probs) != 0) { + q <- qmix.normMix(object, p = probs) + names(q) <- paste(format(probs * 100, digits = 2), "%", sep = "") + } + c(mean = mmix, sd = sqrt(vmix), q) } #' @rdname mixnorm @@ -138,14 +139,13 @@ summary.normMix <- function(object, probs=c(0.025,0.5,0.975), ...) { #' @export sigma #' @rawNamespace importFrom(stats, sigma) sigma.normMix <- function(object, ...) { - attr(object, "sigma") + attr(object, "sigma") } #' @describeIn mixnorm Allows to assign a new reference scale \code{sigma}. #' @export -'sigma<-' <- function(object, value) { - assert_number(value, lower=0, null.ok=TRUE) - attr(object, "sigma") <- value - object +"sigma<-" <- function(object, value) { + assert_number(value, lower = 0, null.ok = TRUE) + attr(object, "sigma") <- unname(value) + object } - diff --git a/R/mixplot.R b/R/mixplot.R index 972ef1a..b08f904 100644 --- a/R/mixplot.R +++ b/R/mixplot.R @@ -1,5 +1,5 @@ #' @name mixplot -#' +#' #' @title Plot mixture distributions #' #' @description Plotting for mixture distributions @@ -28,32 +28,35 @@ #' @family mixdist #' @examples #' # beta with two informative components -#' bm <- mixbeta(inf=c(0.5, 10, 100), inf2=c(0.5, 30, 80)) +#' bm <- mixbeta(inf = c(0.5, 10, 100), inf2 = c(0.5, 30, 80)) #' plot(bm) -#' plot(bm, fun=pmix) +#' plot(bm, fun = pmix) #' #' # for customizations of the plot we need to load ggplot2 first #' library(ggplot2) #' #' # show a histogram along with the density -#' plot(bm) + geom_histogram(data=data.frame(x=rmix(bm, 1000)), -#' aes(y=..density..), bins=50, alpha=0.4) +#' plot(bm) + geom_histogram( +#' data = data.frame(x = rmix(bm, 1000)), +#' aes(y = ..density..), bins = 50, alpha = 0.4 +#' ) #' #' \donttest{ #' # note: we can also use bayesplot for histogram plots with a density ... #' library(bayesplot) -#' mh <- mcmc_hist(data.frame(x=rmix(bm, 1000)), freq=FALSE) + -#' overlay_function(fun=dmix, args=list(mix=bm)) +#' mh <- mcmc_hist(data.frame(x = rmix(bm, 1000)), freq = FALSE) + +#' overlay_function(fun = dmix, args = list(mix = bm)) #' # ...and even add each component -#' for(k in 1:ncol(bm)) -#' mh <- mh + overlay_function(fun=dmix, args=list(mix=bm[[k]]), linetype=I(2)) +#' for (k in 1:ncol(bm)) { +#' mh <- mh + overlay_function(fun = dmix, args = list(mix = bm[[k]]), linetype = I(2)) +#' } #' print(mh) #' } #' #' # normal mixture -#' nm <- mixnorm(rob=c(0.2, 0, 2), inf=c(0.8, 6, 2), sigma=5) +#' nm <- mixnorm(rob = c(0.2, 0, 2), inf = c(0.8, 6, 2), sigma = 5) #' plot(nm) -#' plot(nm, fun=qmix) +#' plot(nm, fun = qmix) #' #' # obtain ggplot2 object and change title #' pl <- plot(nm) @@ -62,59 +65,59 @@ #' @rdname mixplot #' @method plot mix #' @export -plot.mix <- function(x, prob=0.99, fun=dmix, log=FALSE, comp=TRUE, size=1.25, ...) { - funStr <- deparse(substitute(fun)) - if(length(prob) == 1) { - plow <- (1-prob)/2 - pup <- 1-plow - if(funStr != "qmix") { - interval <- qmix(x, c(plow, pup)) - } else { - interval <- c(plow, pup) - } +plot.mix <- function(x, prob = 0.99, fun = dmix, log = FALSE, comp = TRUE, size = 1.25, ...) { + funStr <- deparse(substitute(fun)) + if (length(prob) == 1) { + plow <- (1 - prob) / 2 + pup <- 1 - plow + if (funStr != "qmix") { + interval <- qmix(x, c(plow, pup)) } else { - plow <- prob[1] - pup <- prob[2] - interval <- prob + interval <- c(plow, pup) } - assert_that(plow < pup) - assert_that(interval[1] < interval[2]) - fun <- match.fun(fun) - discrete <- ifelse(all(is.integer(interval)), TRUE, FALSE ) - if(discrete) { - plot_fun <- function(x, ...) fun(floor(x), ...) - plot_geom <- "step" - } else { - plot_fun <- function(x, ...) fun(x, ...) - plot_geom <- "line" - } - n_fun <- 501 + } else { + plow <- prob[1] + pup <- prob[2] + interval <- prob + } + assert_that(plow < pup) + assert_that(interval[1] < interval[2]) + fun <- match.fun(fun) + discrete <- ifelse(all(is.integer(interval)), TRUE, FALSE) + if (discrete) { + plot_fun <- function(x, ...) fun(floor(x), ...) + plot_geom <- "step" + } else { + plot_fun <- function(x, ...) fun(x, ...) + plot_geom <- "line" + } + n_fun <- 501 - num_comp <- ncol(x) - pl <- ggplot(data.frame(x=interval), aes(x=x)) + - stat_function(geom=plot_geom, fun = plot_fun, args=list(mix=x, log=log), n=n_fun, linewidth=size) + - bayesplot::bayesplot_theme_get() + num_comp <- ncol(x) + pl <- ggplot(data.frame(x = interval), aes(x = x)) + + stat_function(geom = plot_geom, fun = plot_fun, args = list(mix = x, log = log), n = n_fun, linewidth = size) + + bayesplot::bayesplot_theme_get() - if(funStr=="dmix") { - pl <- pl + ylab("density") + xlab("parameter") - } else if(funStr=="pmix") { - pl <- pl + ylab("cumulative density") + xlab("quantile") - } else if(funStr=="qmix") { - pl <- pl + ylab("quantile") + xlab("cumulative density") - } - if(funStr=="dmix" & comp) { - comp_df <- list() - for(i in seq_len(num_comp)) { - pl <- pl + stat_function(geom=plot_geom, data=data.frame(comp=factor(i, levels=seq_len(num_comp))), mapping=aes(colour=comp), fun=plot_fun, args=list(mix=x[[i]], log=log), n=n_fun, linetype=I(2), linewidth=size, inherit.aes=FALSE) - } - pl <- pl + scale_colour_manual("Comp. [%]", values=2:(num_comp+1), labels=paste0(colnames(x), " ", format(100*x[1,],digits=1,nsmall=1))) + if (funStr == "dmix") { + pl <- pl + ylab("density") + xlab("parameter") + } else if (funStr == "pmix") { + pl <- pl + ylab("cumulative density") + xlab("quantile") + } else if (funStr == "qmix") { + pl <- pl + ylab("quantile") + xlab("cumulative density") + } + if (funStr == "dmix" & comp) { + comp_df <- list() + for (i in seq_len(num_comp)) { + pl <- pl + stat_function(geom = plot_geom, data = data.frame(comp = factor(i, levels = seq_len(num_comp))), mapping = aes(colour = comp), fun = plot_fun, args = list(mix = x[[i]], log = log), n = n_fun, linetype = I(2), linewidth = size, inherit.aes = FALSE) } - pl + pl <- pl + scale_colour_manual("Comp. [%]", values = 2:(num_comp + 1), labels = paste0(colnames(x), " ", format(100 * x[1, ], digits = 1, nsmall = 1))) + } + pl } #' @rdname mixplot #' @method plot mvnormMix #' @export -plot.mvnormMix <- function(x, prob=0.99, fun=dmix, log=FALSE, comp=TRUE, size=1.25, ...) { - stop("Multivariate normal mixture plotting not supported.") +plot.mvnormMix <- function(x, prob = 0.99, fun = dmix, log = FALSE, comp = TRUE, size = 1.25, ...) { + stop("Multivariate normal mixture plotting not supported.") } diff --git a/R/mixstanvar.R b/R/mixstanvar.R index 6da68e8..00863a7 100644 --- a/R/mixstanvar.R +++ b/R/mixstanvar.R @@ -67,75 +67,79 @@ #' \dontrun{ #' # The mixstanvar adapter requires the optional packages brms and glue #' stopifnot(require("brms"), require("glue")) -#' +#' #' # Assume we prefer a logistic regression MCMC analysis rather than a #' # beta-binomial analysis for the responder endpoint of the ankylosing #' # spondylitis (AS) example. Reasons to prefer a regression analysis is #' # to allow for baseline covariate adjustments, for example. #' map_AS_beta <- mixbeta(c(0.62, 19.2, 57.8), c(0.38, 3.5, 9.4)) -#' +#' #' # First we need to convert the beta mixture to a respective mixture on #' # the log odds scale and approximate it with a normal mixture density. #' map_AS_samp <- rmix(map_AS_beta, 1E4) -#' map_AS <- mixfit(logit(map_AS_samp), type="norm", Nc=2) -#' +#' map_AS <- mixfit(logit(map_AS_samp), type = "norm", Nc = 2) +#' #' # Trial results for placebo and secukinumab. -#' trial <- data.frame(n=c(6, 24), -#' r=c(1, 15), -#' arm=factor(c("placebo", "secukinumab"))) -#' +#' trial <- data.frame( +#' n = c(6, 24), +#' r = c(1, 15), +#' arm = factor(c("placebo", "secukinumab")) +#' ) +#' #' # Define brms model such that the overall intercept corresponds to the #' # placebo response rate on the logit scale. NOTE: The use of #' # center=FALSE is required here as detailed in the note above. -#' model <- bf(r | trials(n) ~ 1 + arm, family=binomial, center=FALSE) +#' model <- bf(r | trials(n) ~ 1 + arm, family = binomial, center = FALSE) #' # to obtain detailed information on the declared model parameters use #' # get_prior(model, data=trial) #' # declare model prior with reference to mixture normal map prior... -#' model_prior <- prior(mixnorm(map_w, map_m, map_s), coef=Intercept) + -#' prior(normal(0, 2), class=b) +#' model_prior <- prior(mixnorm(map_w, map_m, map_s), coef = Intercept) + +#' prior(normal(0, 2), class = b) #' #' # ... which must be made available to brms using the mixstanvar adapter. #' # Note that the map_AS prior is labeled "map" as referred to in the #' # previous prior declaration. -#' analysis <- brm(model, data=trial, prior=model_prior, -#' stanvars=mixstanvar(map=map_AS), -#' seed=365634, refresh=0) -#' +#' analysis <- brm(model, +#' data = trial, prior = model_prior, +#' stanvars = mixstanvar(map = map_AS), +#' seed = 365634, refresh = 0 +#' ) +#' #' # Let's compare the logistic regression estimate for the probability #' # of a positive treatment effect (secukinumab response rate exceeding #' # the response rate of placebo) to the direct beta-binomial analysis: #' hypothesis(analysis, "armsecukinumab > 0") -#' -#' post_secukinumab <- postmix(mixbeta(c(1, 0.5, 1)), r=15, n=24) -#' post_placebo <- postmix(map_AS_beta, r=1, n=6) -#' pmixdiff(post_secukinumab, post_placebo, 0, lower.tail=FALSE) +#' +#' post_secukinumab <- postmix(mixbeta(c(1, 0.5, 1)), r = 15, n = 24) +#' post_placebo <- postmix(map_AS_beta, r = 1, n = 6) +#' pmixdiff(post_secukinumab, post_placebo, 0, lower.tail = FALSE) #' # The posterior probability for a positive treatment effect #' # is very close to unity in both cases. #' } #' @export -mixstanvar <- function(..., verbose=FALSE) { - .assert_namespace("brms") - .assert_namespace("glue") - default_variable_names <- lapply(rlang::enquos(...), rlang::as_label) - mixpriors <- list(...) - if(is.null(names(mixpriors))) { - variable_names <- default_variable_names - } else { - variable_names <- names(mixpriors) - not_set <- which(variable_names == "") - variable_names[not_set] <- default_variable_names[not_set] - } - assert_list(variable_names, "character", unique=TRUE) - sv <- mix2brms(mixpriors[[1]], variable_names[[1]], verbose) - for(i in seq_len(length(mixpriors)-1)) { - mix <- mixpriors[[i+1]] - variable <- variable_names[[i+1]] - sv <- sv + mix2brms(mix, variable, verbose) - } - includes_density <- function(density) any(sapply(mixpriors, inherits, density)) +mixstanvar <- function(..., verbose = FALSE) { + .assert_namespace("brms") + .assert_namespace("glue") + default_variable_names <- lapply(rlang::enquos(...), rlang::as_label) + mixpriors <- list(...) + if (is.null(names(mixpriors))) { + variable_names <- default_variable_names + } else { + variable_names <- names(mixpriors) + not_set <- which(variable_names == "") + variable_names[not_set] <- default_variable_names[not_set] + } + assert_list(variable_names, "character", unique = TRUE) + sv <- mix2brms(mixpriors[[1]], variable_names[[1]], verbose) + for (i in seq_len(length(mixpriors) - 1)) { + mix <- mixpriors[[i + 1]] + variable <- variable_names[[i + 1]] + sv <- sv + mix2brms(mix, variable, verbose) + } + includes_density <- function(density) any(sapply(mixpriors, inherits, density)) - if(includes_density("mvnormMix")) { - sv <- sv + brms::stanvar(name="mixmvnorm_lpdf", scode=" + if (includes_density("mvnormMix")) { + sv <- sv + brms::stanvar(name = "mixmvnorm_lpdf", scode = " real mixmvnorm_lpdf(vector y, vector w, array[] vector m, array[] matrix L) { int Nc = rows(w); vector[Nc] lp_mix; @@ -143,10 +147,10 @@ real mixmvnorm_lpdf(vector y, vector w, array[] vector m, array[] matrix L) { lp_mix[i] = multi_normal_cholesky_lpdf(y | m[i], L[i]); } return log_sum_exp(log(w) + lp_mix); -}", block="functions") - } - mixdensity_template <- function(mixdens, standens, arg1, arg2) { - brms::stanvar(name=glue::glue("{mixdens}_lpdf"), scode=glue::glue(" +}", block = "functions") + } + mixdensity_template <- function(mixdens, standens, arg1, arg2) { + brms::stanvar(name = glue::glue("{mixdens}_lpdf"), scode = glue::glue(" real {{mixdens}}_lpdf(real y, vector w, vector {{arg1}}, vector {{arg2}}) { int Nc = rows(w); vector[Nc] lp_mix; @@ -179,107 +183,108 @@ real {{mixdens}}_cdf(real y, vector w, vector {{arg1}}, vector {{arg2}}) { } return sum(w + p_mix); } -", .open="{{", .close="}}"), block="functions") - } - if(includes_density("normMix")) { - sv <- sv + mixdensity_template("mixnorm", "normal", "m", "s") - } - if(includes_density("betaMix")) { - sv <- sv + mixdensity_template("mixbeta", "beta", "a", "b") - } - if(includes_density("gammaMix")) { - sv <- sv + mixdensity_template("mixgamma", "gamma", "a", "b") - } - - sv +", .open = "{{", .close = "}}"), block = "functions") + } + if (includes_density("normMix")) { + sv <- sv + mixdensity_template("mixnorm", "normal", "m", "s") + } + if (includes_density("betaMix")) { + sv <- sv + mixdensity_template("mixbeta", "beta", "a", "b") + } + if (includes_density("gammaMix")) { + sv <- sv + mixdensity_template("mixgamma", "gamma", "a", "b") + } + + sv } #' @keywords internal -mix2brms <- function(mix, name, verbose=FALSE) UseMethod("mix2brms") +mix2brms <- function(mix, name, verbose = FALSE) UseMethod("mix2brms") #' @keywords internal -mix2brms.default <- function(mix, name, verbose=FALSE) { - stop("Mixture density not supported in mixstanvar.") +mix2brms.default <- function(mix, name, verbose = FALSE) { + stop("Mixture density not supported in mixstanvar.") } #' @keywords internal -mix2brms.mvnormMix <- function(mix, name, verbose=FALSE) { - Nc <- ncol(mix) - p <- mvnormdim(mix[-1,1]) - Sigma <- array(NA, dim=c(Nc, p, p)) - for(i in 1:Nc) { - Rho_c <- diag(nrow=p) - Rho_c[lower.tri(Rho_c)] <- mix[(1+2*p+1):nrow(mix),i,drop=FALSE] - Rho_c[upper.tri(Rho_c)] <- t(Rho_c)[upper.tri(Rho_c)] - s <- mix[(1+p+1):(1+p+p),i,drop=TRUE] - Sigma[i,,] <- diag(s, nrow=p) %*% Rho_c %*% diag(s, nrow=p) - } - prefix <- paste0(name, "_") - mvprior <- brms::stanvar(Nc, glue::glue("{prefix}Nc")) + - brms::stanvar(p, glue::glue("{prefix}p")) + - brms::stanvar(array(mix[1,,drop=TRUE], dim=Nc), glue::glue("{prefix}w"), scode=glue::glue("vector[{prefix}Nc] {prefix}w;")) + - brms::stanvar(t(mix[2:(p+1),,drop=FALSE]), glue::glue("{prefix}m"), scode=glue::glue("array[{prefix}Nc] vector[{prefix}p] {prefix}m;")) + - brms::stanvar(Sigma, glue::glue("{prefix}sigma"), scode=glue::glue("array[{prefix}Nc] matrix[{prefix}p, {prefix}p] {prefix}sigma;")) + - brms::stanvar(scode=glue::glue(" +mix2brms.mvnormMix <- function(mix, name, verbose = FALSE) { + Nc <- ncol(mix) + p <- mvnormdim(mix[-1, 1]) + Sigma <- array(NA, dim = c(Nc, p, p)) + for (i in 1:Nc) { + Rho_c <- diag(nrow = p) + Rho_c[lower.tri(Rho_c)] <- mix[(1 + 2 * p + 1):nrow(mix), i, drop = FALSE] + Rho_c[upper.tri(Rho_c)] <- t(Rho_c)[upper.tri(Rho_c)] + s <- mix[(1 + p + 1):(1 + p + p), i, drop = TRUE] + Sigma[i, , ] <- diag(s, nrow = p) %*% Rho_c %*% diag(s, nrow = p) + } + prefix <- paste0(name, "_") + mvprior <- brms::stanvar(Nc, glue::glue("{prefix}Nc")) + + brms::stanvar(p, glue::glue("{prefix}p")) + + brms::stanvar(array(mix[1, , drop = TRUE], dim = Nc), glue::glue("{prefix}w"), scode = glue::glue("vector[{prefix}Nc] {prefix}w;")) + + brms::stanvar(t(mix[2:(p + 1), , drop = FALSE]), glue::glue("{prefix}m"), scode = glue::glue("array[{prefix}Nc] vector[{prefix}p] {prefix}m;")) + + brms::stanvar(Sigma, glue::glue("{prefix}sigma"), scode = glue::glue("array[{prefix}Nc] matrix[{prefix}p, {prefix}p] {prefix}sigma;")) + + brms::stanvar(scode = glue::glue(" array[{{prefix}}Nc] matrix[{{prefix}}p, {{prefix}}p] {{prefix}}sigma_L; for (i in 1:{{prefix}}Nc) { {{prefix}}sigma_L[i] = cholesky_decompose({{prefix}}sigma[i]); -}", .open="{{", .close="}}"), block="tdata") - if(verbose) { - mvprior <- mvprior + - brms::stanvar(scode=glue::glue(' +}", .open = "{{", .close = "}}"), block = "tdata") + if (verbose) { + mvprior <- mvprior + + brms::stanvar(scode = glue::glue(' print("Mixture prior {{name}}"); for(i in 1:{{prefix}}Nc) { print("Component ", i, ": w = ", {{prefix}}w[i]); print("Component ", i, ": m = ", {{prefix}}m[i]); print("Component ", i, ": Sigma = ", {{prefix}}sigma[i]); } -', .open="{{", .close="}}"), position="end", block="tdata") - } - mvprior +', .open = "{{", .close = "}}"), position = "end", block = "tdata") + } + mvprior } #' @keywords internal -mix2brms.normMix <- function(mix, name, verbose=FALSE) { - .declare_scalar_mixture_components(mix, c("w", "m", "s"), name, verbose) +mix2brms.normMix <- function(mix, name, verbose = FALSE) { + .declare_scalar_mixture_components(mix, c("w", "m", "s"), name, verbose) } #' @keywords internal -mix2brms.betaMix <- function(mix, name, verbose=FALSE) { - .declare_scalar_mixture_components(mix, c("w", "a", "b"), name, verbose) +mix2brms.betaMix <- function(mix, name, verbose = FALSE) { + .declare_scalar_mixture_components(mix, c("w", "a", "b"), name, verbose) } #' @keywords internal -mix2brms.gammaMix <- function(mix, name, verbose=FALSE) { - .declare_scalar_mixture_components(mix, c("w", "a", "b"), name, verbose) +mix2brms.gammaMix <- function(mix, name, verbose = FALSE) { + .declare_scalar_mixture_components(mix, c("w", "a", "b"), name, verbose) } #' @keywords internal -.declare_scalar_mixture_components <- function(mix, vars, name, verbose=FALSE) { - assert_that(length(vars) == 3, msg="Each mixture component density is expected to have 3 arguments.") - Nc <- ncol(mix) - prefix <- paste0(name, "_") - sv <- brms::stanvar(Nc, glue::glue("{prefix}Nc")) - for(i in 1:3) { - arg <- vars[i] - sv <- sv + brms::stanvar(array(mix[i,,drop=TRUE], dim=Nc), glue::glue("{prefix}{arg}"), scode=glue::glue("vector[{prefix}Nc] {prefix}{arg};")) - } - if(verbose) { - sv <- sv + - brms::stanvar(name=paste0("verbose_", name), scode=glue::glue(' +.declare_scalar_mixture_components <- function(mix, vars, name, verbose = FALSE) { + assert_that(length(vars) == 3, msg = "Each mixture component density is expected to have 3 arguments.") + Nc <- ncol(mix) + prefix <- paste0(name, "_") + sv <- brms::stanvar(Nc, glue::glue("{prefix}Nc")) + for (i in 1:3) { + arg <- vars[i] + sv <- sv + brms::stanvar(array(mix[i, , drop = TRUE], dim = Nc), glue::glue("{prefix}{arg}"), scode = glue::glue("vector[{prefix}Nc] {prefix}{arg};")) + } + if (verbose) { + sv <- sv + + brms::stanvar(name = paste0("verbose_", name), scode = glue::glue(' print("Mixture prior {{name}}"); for(i in 1:{{prefix}}Nc) { print("Component ", i, ": w = ", {{prefix}}{vars[1]}[i]); print("Component ", i, ": m = ", {{prefix}}{vars[2]}[i]); print("Component ", i, ": s = ", {{prefix}}{vars[3]}[i]); } -', .open="{{", .close="}}"), position="end", block="tdata") - } - sv +', .open = "{{", .close = "}}"), position = "end", block = "tdata") + } + sv } #' @keywords internal .assert_namespace <- function(package) { - assert_that(requireNamespace(package, quietly=TRUE), - msg=paste0("Package ", package, " must be installed first.")) + assert_that(requireNamespace(package, quietly = TRUE), + msg = paste0("Package ", package, " must be installed first.") + ) } diff --git a/R/oc1S.R b/R/oc1S.R index 27a96b1..16e3c25 100644 --- a/R/oc1S.R +++ b/R/oc1S.R @@ -17,7 +17,7 @@ #' sample size and the decision function, \eqn{D(y)}. These uniquely #' define the decision boundary, see #' \code{\link{decision1S_boundary}}. -#' +#' #' When calling the \code{oc1S} function, then internally the critical #' value \eqn{y_c} (using \code{\link{decision1S_boundary}}) is #' calculated and a function is returns which can be used to @@ -31,45 +31,45 @@ #' returned function takes vectors arguments. #' #' @family design1S -#' +#' #' @examples #' #' # non-inferiority example using normal approximation of log-hazard #' # ratio, see ?decision1S for all details #' s <- 2 -#' flat_prior <- mixnorm(c(1,0,100), sigma=s) +#' flat_prior <- mixnorm(c(1, 0, 100), sigma = s) #' nL <- 233 #' theta_ni <- 0.4 #' theta_a <- 0 #' alpha <- 0.05 -#' beta <- 0.2 -#' za <- qnorm(1-alpha) -#' zb <- qnorm(1-beta) -#' n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +#' beta <- 0.2 +#' za <- qnorm(1 - alpha) +#' zb <- qnorm(1 - beta) +#' n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) #' theta_c <- theta_ni - za * s / sqrt(n1) #' #' # standard NI design -#' decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) -#' +#' decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) +#' #' # double criterion design #' # statistical significance (like NI design) -#' dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +#' dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) #' # require mean to be at least as good as theta_c -#' dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +#' dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) #' # combination -#' decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) -#' -#' theta_eval <- c(theta_a, theta_c, theta_ni) -#' +#' decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) +#' +#' theta_eval <- c(theta_a, theta_c, theta_ni) +#' #' # evaluate different designs at two sample sizes -#' designA_n1 <- oc1S(flat_prior, n1, decA) -#' designA_nL <- oc1S(flat_prior, nL, decA) -#' designC_n1 <- oc1S(flat_prior, n1, decComb) -#' designC_nL <- oc1S(flat_prior, nL, decComb) +#' designA_n1 <- oc1S(flat_prior, n1, decA) +#' designA_nL <- oc1S(flat_prior, nL, decA) +#' designC_n1 <- oc1S(flat_prior, n1, decComb) +#' designC_nL <- oc1S(flat_prior, nL, decComb) #' #' # evaluate designs at the key log-HR of positive treatment (HR<1), #' # the indecision point and the NI margin -#' +#' #' designA_n1(theta_eval) #' designA_nL(theta_eval) #' designC_n1(theta_eval) @@ -87,7 +87,6 @@ #' #' # see also ?decision1S_boundary to see which of the two criterions #' # will drive the decision -#' #' #' @export oc1S <- function(prior, n, decision, ...) UseMethod("oc1S") @@ -98,66 +97,64 @@ oc1S.default <- function(prior, n, decision, ...) "Unknown density" #' @template design1S-binomial #' @export oc1S.betaMix <- function(prior, n, decision, ...) { + crit <- decision1S_boundary(prior, n, decision) + lower.tail <- attr(decision, "lower.tail") - crit <- decision1S_boundary(prior, n, decision) - lower.tail <- attr(decision, "lower.tail") - - design_fun <- function(theta) { - if(missing(theta)) { - deprecated("Use of no argument", "decision1S_boundary") - return(crit) - } - pbinom(crit, n, theta, lower.tail=lower.tail) + design_fun <- function(theta) { + if (missing(theta)) { + deprecated("Use of no argument", "decision1S_boundary") + return(crit) } - design_fun + pbinom(crit, n, theta, lower.tail = lower.tail) + } + design_fun } #' @templateVar fun oc1S #' @template design1S-normal #' @export -oc1S.normMix <- function(prior, n, decision, sigma, eps=1e-6, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - if(missing(sigma)) { - sigma <- RBesT::sigma(prior) - message("Using default prior reference scale ", sigma) - } - assert_number(sigma, lower=0) - - sd_samp <- sigma / sqrt(n) - sigma(prior) <- sigma +oc1S.normMix <- function(prior, n, decision, sigma, eps = 1e-6, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + if (missing(sigma)) { + sigma <- RBesT::sigma(prior) + message("Using default prior reference scale ", sigma) + } + assert_number(sigma, lower = 0) + + sd_samp <- sigma / sqrt(n) + sigma(prior) <- sigma - crit <- decision1S_boundary(prior, n, decision, sigma, eps) - - ## check where the decision is 1, i.e. left or right - lower.tail <- attr(decision, "lower.tail") + crit <- decision1S_boundary(prior, n, decision, sigma, eps) - design_fun <- function(theta) { - if(missing(theta)) { - deprecated("Use of no argument", "decision1S_boundary") - return(crit) - } - pnorm(crit, theta, sd_samp, lower.tail=lower.tail) + ## check where the decision is 1, i.e. left or right + lower.tail <- attr(decision, "lower.tail") + + design_fun <- function(theta) { + if (missing(theta)) { + deprecated("Use of no argument", "decision1S_boundary") + return(crit) } - design_fun + pnorm(crit, theta, sd_samp, lower.tail = lower.tail) + } + design_fun } #' @templateVar fun oc1S #' @template design1S-poisson #' @export -oc1S.gammaMix <- function(prior, n, decision, eps=1e-6, ...) { - - crit <- decision1S_boundary(prior, n, decision, eps) - lower.tail <- attr(decision, "lower.tail") +oc1S.gammaMix <- function(prior, n, decision, eps = 1e-6, ...) { + crit <- decision1S_boundary(prior, n, decision, eps) + lower.tail <- attr(decision, "lower.tail") - design_fun <- function(theta) { - if(missing(theta)) { - deprecated("Use of no argument", "decision1S_boundary") - return(crit) - } - ppois(crit, n*theta, lower.tail=lower.tail) + design_fun <- function(theta) { + if (missing(theta)) { + deprecated("Use of no argument", "decision1S_boundary") + return(crit) } - design_fun + ppois(crit, n * theta, lower.tail = lower.tail) + } + design_fun } diff --git a/R/oc2S.R b/R/oc2S.R index a37babe..76830b6 100644 --- a/R/oc2S.R +++ b/R/oc2S.R @@ -43,11 +43,11 @@ #' @examples #' #' # example from Schmidli et al., 2014 -#' dec <- decision2S(0.975, 0, lower.tail=FALSE) +#' dec <- decision2S(0.975, 0, lower.tail = FALSE) #' #' prior_inf <- mixbeta(c(1, 4, 16)) -#' prior_rob <- robustify(prior_inf, weight=0.2, mean=0.5) -#' prior_uni <- mixbeta(c(1, 1, 1)) +#' prior_rob <- robustify(prior_inf, weight = 0.2, mean = 0.5) +#' prior_uni <- mixbeta(c(1, 1, 1)) #' #' N <- 40 #' N_ctl <- N - 20 @@ -58,15 +58,14 @@ #' design_rob <- oc2S(prior_uni, prior_rob, N, N_ctl, dec) #' #' # type I error -#' curve(design_inf(x,x), 0, 1) -#' curve(design_uni(x,x), lty=2, add=TRUE) -#' curve(design_rob(x,x), lty=3, add=TRUE) +#' curve(design_inf(x, x), 0, 1) +#' curve(design_uni(x, x), lty = 2, add = TRUE) +#' curve(design_rob(x, x), lty = 3, add = TRUE) #' #' # power -#' curve(design_inf(0.2+x,0.2), 0, 0.5) -#' curve(design_uni(0.2+x,0.2), lty=2, add=TRUE) -#' curve(design_rob(0.2+x,0.2), lty=3, add=TRUE) -#' +#' curve(design_inf(0.2 + x, 0.2), 0, 0.5) +#' curve(design_uni(0.2 + x, 0.2), lty = 2, add = TRUE) +#' curve(design_rob(0.2 + x, 0.2), lty = 3, add = TRUE) #' #' @export oc2S <- function(prior1, prior2, n1, n2, decision, ...) UseMethod("oc2S") @@ -77,234 +76,240 @@ oc2S.default <- function(prior1, prior2, n1, n2, decision, ...) "Unknown density #' @template design2S-binomial #' @export oc2S.betaMix <- function(prior1, prior2, n1, n2, decision, eps, ...) { - if(missing(eps) & ((n1+1)*(n2+1) > 1e7)) { - warning("Large sample space. Consider setting eps=1e-6.") + if (missing(eps) & ((n1 + 1) * (n2 + 1) > 1e7)) { + warning("Large sample space. Consider setting eps=1e-6.") + } + + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) + + lower.tail <- attr(decision, "lower.tail") + + approx_method <- !missing(eps) + + design_fun <- function(theta1, theta2, y2) { + ## other-wise we calculate the frequencies at which the + ## decision is 1 (probability mass with decision==1) + + ## in case n2==0, then theta2 is irrelevant + if (n2 == 0 & missing(theta2)) { + theta2 <- 0.5 } - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) - - lower.tail <- attr(decision, "lower.tail") - - approx_method <- !missing(eps) - - design_fun <- function(theta1, theta2, y2) { - ## other-wise we calculate the frequencies at which the - ## decision is 1 (probability mass with decision==1) - - ## in case n2==0, then theta2 is irrelevant - if(n2 == 0 & missing(theta2)) - theta2 <- 0.5 - - if(!missing(y2)) { - deprecated("Use of y2 argument", "decision2S_boundary") - return(crit_y1(y2, lim1=c(0, n1))) - } - - assert_numeric(theta1, lower=0, upper=1, finite=TRUE) - assert_numeric(theta2, lower=0, upper=1, finite=TRUE) - - T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names=NULL)) - if (inherits(T, "try-error")) { - stop("theta1 and theta2 need to be of same size") - } - - ## now get the decision boundary in the needed range - lim1 <- c(0,n1) - lim2 <- c(0,n2) - - ## in case we use the approximate method, we restrict the - ## evaluation of the decision function range - if(approx_method) { - lim1[1] <- qbinom( eps/2, n1, min(theta1)) - lim1[2] <- qbinom(1-eps/2, n1, max(theta1)) - lim2[1] <- qbinom( eps/2, n2, min(theta2)) - lim2[2] <- qbinom(1-eps/2, n2, max(theta2)) - } - - ## for each 0:n1 of the possible outcomes, calculate the - ## probability mass past the boundary (log space) weighted with - ## the density as the value for 1 occures (due to theta1) - boundary <- crit_y1(lim2[1]:lim2[2], lim1=c(0,n1)) - res <- matrix(-Inf, nrow=diff(lim2)+1, ncol=nrow(T)) - - for(i in lim2[1]:lim2[2]) { - y2ind <- i - lim2[1] + 1 - if(boundary[y2ind] == -1) { - ## decision was always 0 - res[y2ind,] <- -Inf - } else if(boundary[y2ind] == n1+1) { - ## decision was always 1 - res[y2ind,] <- 0 - } else { - ## calculate for all requested theta1 the probability mass - ## past (or before) the boundary - res[y2ind,] <- pbinom(boundary[y2ind], n1, T$theta1, lower.tail=lower.tail, log.p=TRUE) - } - ## finally weight with the density according to the occurence - ## of i due to theta2; the pmax avoids -Inf in a case of Prob==0 - ##res[y2ind,] <- res[y2ind,] + pmax(dbinom(i, n2, T$theta2, log=TRUE), -700) - res[y2ind,] <- res[y2ind,] + dbinom(i, n2, T$theta2, log=TRUE) - } - ##exp(log_colSum_exp(res)) - exp(matrixStats::colLogSumExps(res)) + if (!missing(y2)) { + deprecated("Use of y2 argument", "decision2S_boundary") + return(crit_y1(y2, lim1 = c(0, n1))) } - design_fun + + assert_numeric(theta1, lower = 0, upper = 1, finite = TRUE) + assert_numeric(theta2, lower = 0, upper = 1, finite = TRUE) + + T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names = NULL)) + if (inherits(T, "try-error")) { + stop("theta1 and theta2 need to be of same size") + } + + ## now get the decision boundary in the needed range + lim1 <- c(0, n1) + lim2 <- c(0, n2) + + ## in case we use the approximate method, we restrict the + ## evaluation of the decision function range + if (approx_method) { + lim1[1] <- qbinom(eps / 2, n1, min(theta1)) + lim1[2] <- qbinom(1 - eps / 2, n1, max(theta1)) + lim2[1] <- qbinom(eps / 2, n2, min(theta2)) + lim2[2] <- qbinom(1 - eps / 2, n2, max(theta2)) + } + + ## for each 0:n1 of the possible outcomes, calculate the + ## probability mass past the boundary (log space) weighted with + ## the density as the value for 1 occures (due to theta1) + boundary <- crit_y1(lim2[1]:lim2[2], lim1 = c(0, n1)) + res <- matrix(-Inf, nrow = diff(lim2) + 1, ncol = nrow(T)) + + for (i in lim2[1]:lim2[2]) { + y2ind <- i - lim2[1] + 1 + if (boundary[y2ind] == -1) { + ## decision was always 0 + res[y2ind, ] <- -Inf + } else if (boundary[y2ind] == n1 + 1) { + ## decision was always 1 + res[y2ind, ] <- 0 + } else { + ## calculate for all requested theta1 the probability mass + ## past (or before) the boundary + res[y2ind, ] <- pbinom(boundary[y2ind], n1, T$theta1, lower.tail = lower.tail, log.p = TRUE) + } + ## finally weight with the density according to the occurence + ## of i due to theta2; the pmax avoids -Inf in a case of Prob==0 + ## res[y2ind,] <- res[y2ind,] + pmax(dbinom(i, n2, T$theta2, log=TRUE), -700) + res[y2ind, ] <- res[y2ind, ] + dbinom(i, n2, T$theta2, log = TRUE) + } + ## exp(log_colSum_exp(res)) + exp(matrixStats::colLogSumExps(res)) + } + design_fun } #' @templateVar fun oc2S #' @template design2S-normal #' @export -oc2S.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps=1e-6, Ngrid=10, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - if(missing(sigma1)) { - sigma1 <- RBesT::sigma(prior1) - message("Using default prior 1 reference scale ", sigma1) - } - if(missing(sigma2)) { - sigma2 <- RBesT::sigma(prior2) - message("Using default prior 2 reference scale ", sigma2) +oc2S.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps = 1e-6, Ngrid = 10, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + if (missing(sigma1)) { + sigma1 <- RBesT::sigma(prior1) + message("Using default prior 1 reference scale ", sigma1) + } + if (missing(sigma2)) { + sigma2 <- RBesT::sigma(prior2) + message("Using default prior 2 reference scale ", sigma2) + } + assert_number(sigma1, lower = 0) + assert_number(sigma2, lower = 0) + + sigma(prior1) <- sigma1 + sigma(prior2) <- sigma2 + + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps, Ngrid) + + lower.tail <- attr(decision, "lower.tail") + + sem1 <- sigma1 / sqrt(n1) + sem2 <- sigma2 / sqrt(n2) + + if (n2 == 0) sem2 <- sigma(prior2) / sqrt(1E-1) + + ## change the reference scale of the prior such that the prior + ## represents the distribution of the respective means + mean_prior1 <- prior1 + sigma(mean_prior1) <- sem1 + ## mean_prior2 <- prior2 + ## sigma(mean_prior2) <- sem2 + + freq <- function(theta1, theta2) { + lim1 <- qnorm(c(eps / 2, 1 - eps / 2), theta1, sem1) + lim2 <- qnorm(c(eps / 2, 1 - eps / 2), theta2, sem2) + if (n2 == 0) { + return(pnorm(crit_y1(theta2), theta1, sem1, lower.tail = lower.tail)) + } else { + return(integrate_density_log(function(x) pnorm(crit_y1(x, lim1 = lim1), theta1, sem1, lower.tail = lower.tail, log.p = TRUE), mixnorm(c(1, theta2, sem2), sigma = sem2), logit(eps / 2), logit(1 - eps / 2))) } - assert_number(sigma1, lower=0) - assert_number(sigma2, lower=0) + } - sigma(prior1) <- sigma1 - sigma(prior2) <- sigma2 + Vfreq <- Vectorize(freq) - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps, Ngrid) + design_fun <- function(theta1, theta2, y2) { + if (!missing(y2)) { + theta2 <- y2 + } - lower.tail <- attr(decision, "lower.tail") + ## in case n2==0, then theta2 is irrelevant + if (n2 == 0 & missing(theta2)) { + theta2 <- theta1 + } + + lim2 <- c( + qnorm(p = eps / 2, mean = min(theta2), sd = sem2), + qnorm(p = 1 - eps / 2, mean = max(theta2), sd = sem2) + ) - sem1 <- sigma1 / sqrt(n1) - sem2 <- sigma2 / sqrt(n2) + if (!missing(y2)) { + deprecated("Use of y2 argument", "decision2S_boundary") + return(crit_y1(y2)) + } - if(n2 == 0) sem2 <- sigma(prior2) / sqrt(1E-1) + ## ensure that boundary is calculated for the full range + ## needed + lim1 <- c(qnorm(eps / 2, min(theta1), sem1), qnorm(1 - eps / 2, max(theta1), sem1)) + lim2 <- c(qnorm(eps / 2, min(theta2), sem2), qnorm(1 - eps / 2, max(theta2), sem2)) - ## change the reference scale of the prior such that the prior - ## represents the distribution of the respective means - mean_prior1 <- prior1 - sigma(mean_prior1) <- sem1 - ##mean_prior2 <- prior2 - ##sigma(mean_prior2) <- sem2 + ## call boundary function to cache all results for all + ## requested computations + crit_y1(lim2, lim1 = lim1) - freq <- function(theta1, theta2) { - lim1 <- qnorm(c(eps/2, 1-eps/2), theta1, sem1) - lim2 <- qnorm(c(eps/2, 1-eps/2), theta2, sem2) - if(n2 == 0) { - return(pnorm(crit_y1(theta2), theta1, sem1, lower.tail=lower.tail)) - } else { - return(integrate_density_log(function(x) pnorm(crit_y1(x, lim1=lim1), theta1, sem1, lower.tail=lower.tail, log.p=TRUE), mixnorm(c(1, theta2, sem2), sigma=sem2), logit(eps/2), logit(1-eps/2) )) - } + T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names = NULL)) + if (inherits(T, "try-error")) { + stop("theta1 and theta2 need to be of same size") } - Vfreq <- Vectorize(freq) + do.call(Vfreq, T) + } - design_fun <- function(theta1, theta2, y2) { - if(!missing(y2)) - theta2 <- y2 + design_fun +} + +#' @templateVar fun oc2S +#' @template design2S-poisson +#' @export +oc2S.gammaMix <- function(prior1, prior2, n1, n2, decision, eps = 1e-6, ...) { + assert_that(likelihood(prior1) == "poisson") + assert_that(likelihood(prior2) == "poisson") - ## in case n2==0, then theta2 is irrelevant - if(n2 == 0 & missing(theta2)) - theta2 <- theta1 + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) - lim2 <- c(qnorm(p= eps/2, mean=min(theta2), sd=sem2) - ,qnorm(p=1-eps/2, mean=max(theta2), sd=sem2)) + lower.tail <- attr(decision, "lower.tail") - if(!missing(y2)) { - deprecated("Use of y2 argument", "decision2S_boundary") - return(crit_y1(y2)) - } + freq <- function(theta1, theta2) { + lambda1 <- theta1 * n1 + lambda2 <- theta2 * n2 + lim1 <- qpois(c(eps / 2, 1 - eps / 2), lambda1) + grid <- seq(qpois(eps / 2, lambda2), qpois(1 - eps / 2, lambda2)) - ## ensure that boundary is calculated for the full range - ## needed - lim1 <- c(qnorm(eps/2, min(theta1), sem1), qnorm(1-eps/2, max(theta1), sem1)) - lim2 <- c(qnorm(eps/2, min(theta2), sem2), qnorm(1-eps/2, max(theta2), sem2)) + exp(matrixStats::logSumExp(dpois(grid, lambda2, log = TRUE) + + ppois(crit_y1(grid, lim1 = lim1), lambda1, lower.tail = lower.tail, log.p = TRUE))) + } - ## call boundary function to cache all results for all - ## requested computations - crit_y1(lim2, lim1=lim1) + Vfreq <- Vectorize(freq) - T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names=NULL)) - if (inherits(T, "try-error")) { - stop("theta1 and theta2 need to be of same size") - } + design_fun <- function(theta1, theta2, y2) { + ## in case n2==0, then theta2 is irrelevant + if (n2 == 0 & missing(theta2)) { + theta2 <- theta1 + } - do.call(Vfreq, T) + if (!missing(y2)) { + if (missing(theta1)) { + theta1 <- summary(prior1)["mean"] + } + lambda2 <- y2 + } else { + lambda2 <- theta2 * n2 } - design_fun -} + lambda1 <- theta1 * n1 -#' @templateVar fun oc2S -#' @template design2S-poisson -#' @export -oc2S.gammaMix <- function(prior1, prior2, n1, n2, decision, eps=1e-6, ...) { - assert_that(likelihood(prior1) == "poisson") - assert_that(likelihood(prior2) == "poisson") + lim1 <- c(0, 0) + lim1[1] <- qpois(eps / 2, min(lambda1)) + lim1[2] <- qpois(1 - eps / 2, max(lambda1)) - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) + if (n2 == 0) { + lim2 <- c(0, 0) + } else { + lim2 <- c(0, 0) + lim2[1] <- qpois(eps / 2, min(lambda2)) + lim2[2] <- qpois(1 - eps / 2, max(lambda2)) + } - lower.tail <- attr(decision, "lower.tail") + ## force lower limit of lim1 to be 0 such that we will get and + ## answer in most cases; performance wise it should be ok as + ## we run a O(log(N)) search + lim1[1] <- 0 - freq <- function(theta1, theta2) { - lambda1 <- theta1 * n1 - lambda2 <- theta2 * n2 - lim1 <- qpois(c(eps/2, 1-eps/2), lambda1) - grid <- seq(qpois(eps/2, lambda2), qpois(1-eps/2, lambda2)) + ## ensure that the boundaries are cached + crit_y1(lim2, lim1 = lim1) - exp(matrixStats::logSumExp(dpois(grid, lambda2, log=TRUE) - + ppois(crit_y1(grid, lim1=lim1), lambda1, lower.tail=lower.tail, log.p=TRUE))) + if (!missing(y2)) { + deprecated("Use of y2 argument", "decision2S_boundary") + return(crit_y1(y2, lim1 = lim1)) } - Vfreq <- Vectorize(freq) - - design_fun <- function(theta1, theta2, y2) { - - ## in case n2==0, then theta2 is irrelevant - if(n2 == 0 & missing(theta2)) - theta2 <- theta1 - - if(!missing(y2)) { - if(missing(theta1)) - theta1 <- summary(prior1)["mean"] - lambda2 <- y2 - } else { - lambda2 <- theta2 * n2 - } - - lambda1 <- theta1 * n1 - - lim1 <- c(0, 0) - lim1[1] <- qpois( eps/2, min(lambda1)) - lim1[2] <- qpois(1-eps/2, max(lambda1)) - - if(n2 == 0) { - lim2 <- c(0,0) - } else { - lim2 <- c(0, 0) - lim2[1] <- qpois( eps/2, min(lambda2)) - lim2[2] <- qpois(1-eps/2, max(lambda2)) - } - - ## force lower limit of lim1 to be 0 such that we will get and - ## answer in most cases; performance wise it should be ok as - ## we run a O(log(N)) search - lim1[1] <- 0 - - ## ensure that the boundaries are cached - crit_y1(lim2, lim1=lim1) - - if(!missing(y2)) { - deprecated("Use of y2 argument", "decision2S_boundary") - return(crit_y1(y2, lim1=lim1)) - } - - T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names=NULL)) - if (inherits(T, "try-error")) { - stop("theta1 and theta2 need to be of same size") - } - do.call(Vfreq, T) + T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names = NULL)) + if (inherits(T, "try-error")) { + stop("theta1 and theta2 need to be of same size") } - design_fun + do.call(Vfreq, T) + } + design_fun } diff --git a/R/plot_gMAP.R b/R/plot_gMAP.R index a9a9d83..c8690c8 100644 --- a/R/plot_gMAP.R +++ b/R/plot_gMAP.R @@ -1,5 +1,5 @@ #' Diagnostic plots for gMAP analyses -#' +#' #' @param x \code{\link{gMAP}} object #' @param size Controls line sizes of traceplots and forest plot. #' @param ... Ignored. @@ -10,71 +10,77 @@ #' \code{\link{forest_plot}}. #' #' @template plot-help -#' +#' #' @return The function returns a list of \code{\link[ggplot2:ggplot]{ggplot}} #' objects. #' #' @method plot gMAP #' @export -plot.gMAP <- function(x, size=NULL, ...) { - pl <- list() +plot.gMAP <- function(x, size = NULL, ...) { + pl <- list() + + draws_all <- rstan::extract(x$fit, permuted = FALSE, inc_warmup = TRUE) + thin <- attr(x$fit, "sim")$thin + n_warmup <- floor(attr(x$fit, "sim")$warmup / thin) + draws <- draws_all[-(1:n_warmup), , ] + nuts_diag <- bayesplot::nuts_params(x$fit, inc_warmup = FALSE) + + ## by default we return a small set of plots only + plot_verbose <- getOption("RBesT.verbose", FALSE) - draws_all <- rstan::extract(x$fit, permuted=FALSE, inc_warmup=TRUE) - thin <- attr(x$fit, "sim")$thin - n_warmup <- floor(attr(x$fit, "sim")$warmup / thin) - draws <- draws_all[- (1:n_warmup),,] - nuts_diag <- bayesplot::nuts_params(x$fit, inc_warmup=FALSE) + div_opts <- list() + if (sum(nuts_diag$Value[nuts_diag$Parameter == "divergent__"]) > 0) { + div_opts$np <- bayesplot::nuts_params(x$fit, inc_warmup = TRUE) + plot_verbose <- TRUE ## if any divergent transition happens, + ## then we plot verbose in any case + } - ## by default we return a small set of plots only - plot_verbose <- getOption("RBesT.verbose", FALSE) - - div_opts <- list() - if(sum(nuts_diag$Value[nuts_diag$Parameter=="divergent__"]) > 0) { - div_opts$np <- bayesplot::nuts_params(x$fit, inc_warmup=TRUE) - plot_verbose <- TRUE ## if any divergent transition happens, - ## then we plot verbose in any case - } + tau_pars <- grep("tau\\[", dimnames(draws)$parameters, value = TRUE) + beta_pars <- grep("beta\\[", dimnames(draws)$parameters, value = TRUE) - tau_pars <- grep("tau\\[", dimnames(draws)$parameters, value=TRUE) - beta_pars <- grep("beta\\[", dimnames(draws)$parameters, value=TRUE) + tau_log_trans <- as.list(rep("log", length(tau_pars))) + names(tau_log_trans) <- tau_pars - tau_log_trans <- as.list(rep("log", length(tau_pars))) - names(tau_log_trans) <- tau_pars + if (plot_verbose) { + ## traces are only shown if in verbose mode... + pl$traceBeta <- do.call(bayesplot::mcmc_trace, c(list( + x = draws_all, pars = beta_pars, size = size, n_warmup = n_warmup, + facet_args = list(labeller = ggplot2::label_parsed) + ), div_opts)) + + ggtitle(expression(paste("Trace of Regression Coefficient ", beta))) + + bayesplot::facet_text(length(beta_pars) != 1) + xlab("Iteration") + pl$traceTau <- do.call(bayesplot::mcmc_trace, c(list( + x = draws_all, pars = tau_pars, size = size, n_warmup = n_warmup, + facet_args = list(labeller = ggplot2::label_parsed) + ), div_opts)) + + bayesplot::facet_text(length(tau_pars) != 1) + + ggtitle(expression(paste("Trace of Heterogeneity Parameter ", tau))) + + xlab("Iteration") + pl$traceLogTau <- do.call(bayesplot::mcmc_trace, c(list( + x = draws_all, pars = tau_pars, size = size, n_warmup = n_warmup, + facet_args = list(labeller = ggplot2::label_parsed), transformations = tau_log_trans + ), div_opts)) + + bayesplot::facet_text(length(tau_pars) != 1) + + ggtitle(expression(paste("Trace of Heterogeneity Parameter ", tau, " on log-scale"))) + + xlab("Iteration") - if(plot_verbose) { - ## traces are only shown if in verbose mode... - pl$traceBeta <- do.call(bayesplot::mcmc_trace, c(list(x=draws_all, pars=beta_pars, size=size, n_warmup=n_warmup, - facet_args = list(labeller = ggplot2::label_parsed)), div_opts)) + - ggtitle(expression(paste("Trace of Regression Coefficient ", beta))) + - bayesplot::facet_text(length(beta_pars)!=1) + xlab("Iteration") - pl$traceTau <- do.call(bayesplot::mcmc_trace, c(list(x=draws_all, pars=tau_pars, size=size, n_warmup=n_warmup, - facet_args = list(labeller = ggplot2::label_parsed)), div_opts)) + - bayesplot::facet_text(length(tau_pars)!=1) + - ggtitle(expression(paste("Trace of Heterogeneity Parameter ", tau))) + - xlab("Iteration") - pl$traceLogTau <- do.call(bayesplot::mcmc_trace, c(list(x=draws_all, pars=tau_pars, size=size, n_warmup=n_warmup, - facet_args = list(labeller = ggplot2::label_parsed), transformations=tau_log_trans), div_opts)) + - bayesplot::facet_text(length(tau_pars)!=1) + - ggtitle(expression(paste("Trace of Heterogeneity Parameter ", tau, " on log-scale"))) + - xlab("Iteration") + ## ... as well as auxilary model parameters + pl$densityBeta <- bayesplot::mcmc_dens_overlay(x = draws, pars = beta_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position = "bottom")) + + ggtitle(expression(paste("Density of Regression Coefficient ", beta))) + pl$densityTau <- bayesplot::mcmc_dens_overlay(x = draws, pars = tau_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position = "bottom")) + + ggtitle(expression(paste("Density of Heterogeneity Parameter ", tau))) + pl$densityLogTau <- bayesplot::mcmc_dens_overlay(x = draws, pars = tau_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position = "bottom"), transformations = tau_log_trans) + + ggtitle(expression(paste("Density of Heterogeneity Parameter ", tau, " on log-scale"))) + } - ## ... as well as auxilary model parameters - pl$densityBeta <- bayesplot::mcmc_dens_overlay(x=draws, pars=beta_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position="bottom")) + - ggtitle(expression(paste("Density of Regression Coefficient ", beta))) - pl$densityTau <- bayesplot::mcmc_dens_overlay(x=draws, pars=tau_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position="bottom")) + - ggtitle(expression(paste("Density of Heterogeneity Parameter ", tau))) - pl$densityLogTau <- bayesplot::mcmc_dens_overlay(x=draws, pars=tau_pars, facet_args = list(labeller = ggplot2::label_parsed, strip.position="bottom"), transformations=tau_log_trans) + - ggtitle(expression(paste("Density of Heterogeneity Parameter ", tau, " on log-scale"))) - } + if (x$has_intercept) { + pl$densityThetaStar <- bayesplot::mcmc_dens_overlay(x = draws, pars = "theta_resp_pred") + xlab(expression(theta[symbol("*")])) + bayesplot::facet_text(FALSE) + ggtitle(expression(paste("Density of MAP Prior ", theta[symbol("*")]))) + pl$densityThetaStarLink <- bayesplot::mcmc_dens_overlay(x = draws, pars = "theta_pred") + xlab(expression(theta[symbol("*")])) + bayesplot::facet_text(FALSE) + ggtitle(expression(paste("Density of MAP Prior ", theta[symbol("*")], " (link scale)"))) - if(x$has_intercept) { - pl$densityThetaStar <- bayesplot::mcmc_dens_overlay(x=draws, pars="theta_resp_pred") + xlab(expression(theta[symbol("*")])) + bayesplot::facet_text(FALSE) + ggtitle(expression(paste("Density of MAP Prior ", theta[symbol("*")]))) - pl$densityThetaStarLink <- bayesplot::mcmc_dens_overlay(x=draws, pars="theta_pred") + xlab(expression(theta[symbol("*")])) + bayesplot::facet_text(FALSE) + ggtitle(expression(paste("Density of MAP Prior ", theta[symbol("*")], " (link scale)"))) + pl$forest_model <- forest_plot(x, model = "both", size = if (is.null(size)) 1.25 else size) + } else { + message("No intercept defined.") + } - pl$forest_model <- forest_plot(x, model="both", size=if(is.null(size)) 1.25 else size) - } else { - message("No intercept defined.") - } - - return(pl) + return(pl) } diff --git a/R/pos1S.R b/R/pos1S.R index dd5a1df..13c9009 100644 --- a/R/pos1S.R +++ b/R/pos1S.R @@ -39,24 +39,24 @@ #' # non-inferiority example using normal approximation of log-hazard #' # ratio, see ?decision1S for all details #' s <- 2 -#' flat_prior <- mixnorm(c(1,0,100), sigma=s) +#' flat_prior <- mixnorm(c(1, 0, 100), sigma = s) #' nL <- 233 #' theta_ni <- 0.4 #' theta_a <- 0 #' alpha <- 0.05 -#' beta <- 0.2 -#' za <- qnorm(1-alpha) -#' zb <- qnorm(1-beta) -#' n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +#' beta <- 0.2 +#' za <- qnorm(1 - alpha) +#' zb <- qnorm(1 - beta) +#' n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) #' theta_c <- theta_ni - za * s / sqrt(n1) #' #' # assume we would like to conduct at an interim analysis #' # of PoS after having observed 20 events with a HR of 0.8. #' # We first need the posterior at the interim ... -#' post_ia <- postmix(flat_prior, m=log(0.8), n=20) +#' post_ia <- postmix(flat_prior, m = log(0.8), n = 20) #' #' # dual criterion -#' decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +#' decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) #' #' # ... and we would like to know the PoS for a successful #' # trial at the end when observing 10 more events @@ -66,7 +66,6 @@ #' # interim such that the PoS is #' pos_ia(post_ia) #' -#' #' @export pos1S <- function(prior, n, decision, ...) UseMethod("pos1S") #' @export @@ -76,56 +75,54 @@ pos1S.default <- function(prior, n, decision, ...) "Unknown density" #' @template design1S-binomial #' @export pos1S.betaMix <- function(prior, n, decision, ...) { + crit <- decision1S_boundary(prior, n, decision) + lower.tail <- attr(decision, "lower.tail") - crit <- decision1S_boundary(prior, n, decision) - lower.tail <- attr(decision, "lower.tail") - - design_fun <- function(mix) { - pred_dtheta <- preddist(mix, n=n) - pmix(pred_dtheta, crit, lower.tail=lower.tail) - } - design_fun + design_fun <- function(mix) { + pred_dtheta <- preddist(mix, n = n) + pmix(pred_dtheta, crit, lower.tail = lower.tail) + } + design_fun } #' @templateVar fun pos1S #' @template design1S-normal #' @export -pos1S.normMix <- function(prior, n, decision, sigma, eps=1e-6, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - if(missing(sigma)) { - sigma <- RBesT::sigma(prior) - message("Using default prior reference scale ", sigma) - } - assert_number(sigma, lower=0) +pos1S.normMix <- function(prior, n, decision, sigma, eps = 1e-6, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + if (missing(sigma)) { + sigma <- RBesT::sigma(prior) + message("Using default prior reference scale ", sigma) + } + assert_number(sigma, lower = 0) - sigma(prior) <- sigma + sigma(prior) <- sigma - crit <- decision1S_boundary(prior, n, decision, sigma, eps) + crit <- decision1S_boundary(prior, n, decision, sigma, eps) - ## check where the decision is 1, i.e. left or right - lower.tail <- attr(decision, "lower.tail") + ## check where the decision is 1, i.e. left or right + lower.tail <- attr(decision, "lower.tail") - design_fun <- function(mix) { - pred_dtheta_mean <- preddist(mix, n=n, sigma=sigma) - pmix(pred_dtheta_mean, crit, lower.tail=lower.tail) - } - design_fun + design_fun <- function(mix) { + pred_dtheta_mean <- preddist(mix, n = n, sigma = sigma) + pmix(pred_dtheta_mean, crit, lower.tail = lower.tail) + } + design_fun } #' @templateVar fun pos1S #' @template design1S-poisson #' @export -pos1S.gammaMix <- function(prior, n, decision, eps=1e-6, ...) { - - crit <- decision1S_boundary(prior, n, decision, eps) - lower.tail <- attr(decision, "lower.tail") +pos1S.gammaMix <- function(prior, n, decision, eps = 1e-6, ...) { + crit <- decision1S_boundary(prior, n, decision, eps) + lower.tail <- attr(decision, "lower.tail") - design_fun <- function(mix) { - assert_that(likelihood(prior) == "poisson") - pred_dtheta_sum <- preddist(mix, n=n) - pmix(pred_dtheta_sum, crit, lower.tail=lower.tail) - } - design_fun + design_fun <- function(mix) { + assert_that(likelihood(prior) == "poisson") + pred_dtheta_sum <- preddist(mix, n = n) + pmix(pred_dtheta_sum, crit, lower.tail = lower.tail) + } + design_fun } diff --git a/R/pos2S.R b/R/pos2S.R index 2ef1e2c..1a2e201 100644 --- a/R/pos2S.R +++ b/R/pos2S.R @@ -51,15 +51,15 @@ #' @examples #' #' # see ?decision2S for details of example -#' priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -#' priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +#' priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +#' priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") #' # the success criteria is for delta which are larger than some #' # threshold value which is why we set lower.tail=FALSE -#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +#' successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) #' #' # example interim outcome -#' postP_interim <- postmix(priorP, n=10, m=-50) -#' postT_interim <- postmix(priorT, n=20, m=-80) +#' postP_interim <- postmix(priorP, n = 10, m = -50) +#' postT_interim <- postmix(priorT, n = 20, m = -80) #' #' # assume that mean -50 / -80 were observed at the interim for #' # placebo control(n=10) / active treatment(n=20) which gives @@ -81,158 +81,155 @@ pos2S.default <- function(prior1, prior2, n1, n2, decision, ...) "Unknown densit #' @template design2S-binomial #' @export pos2S.betaMix <- function(prior1, prior2, n1, n2, decision, eps, ...) { + if (missing(eps) & (n1 * n2 > 1e7)) { + warning("Large sample space. Consider setting eps=1e-6.") + } - if(missing(eps) & (n1*n2 > 1e7)) { - warning("Large sample space. Consider setting eps=1e-6.") + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) + + lower.tail <- attr(decision, "lower.tail") + + approx_method <- !missing(eps) + + design_fun <- function(mix1, mix2) { + ## for each 0:n1 of the possible outcomes, calculate the + ## probability mass past the boundary (log space) weighted with + ## the density as the value for 1 occures (due to theta1) + + pred_mix1 <- preddist(mix1, n = n1) + pred_mix2 <- preddist(mix2, n = n2) + + assert_that(inherits(pred_mix1, "betaBinomialMix")) + assert_that(inherits(pred_mix2, "betaBinomialMix")) + + ## now get the decision boundary in the needed range + lim1 <- c(0, n1) + lim2 <- c(0, n2) + + ## in case we use the approximate method, we restrict the + ## evaluation of the decision function range + if (approx_method) { + lim1 <- qmix(pred_mix1, c(eps / 2, 1 - eps / 2)) + lim2 <- qmix(pred_mix2, c(eps / 2, 1 - eps / 2)) } - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) - - lower.tail <- attr(decision, "lower.tail") - - approx_method <- !missing(eps) - - design_fun <- function(mix1, mix2) { - - ## for each 0:n1 of the possible outcomes, calculate the - ## probability mass past the boundary (log space) weighted with - ## the density as the value for 1 occures (due to theta1) - - pred_mix1 <- preddist(mix1, n=n1) - pred_mix2 <- preddist(mix2, n=n2) - - assert_that(inherits(pred_mix1, "betaBinomialMix")) - assert_that(inherits(pred_mix2, "betaBinomialMix")) - - ## now get the decision boundary in the needed range - lim1 <- c(0,n1) - lim2 <- c(0,n2) - - ## in case we use the approximate method, we restrict the - ## evaluation of the decision function range - if(approx_method) { - lim1 <- qmix(pred_mix1, c(eps/2, 1-eps/2)) - lim2 <- qmix(pred_mix2, c(eps/2, 1-eps/2)) - } - - boundary <- crit_y1(lim2[1]:lim2[2], lim1=lim1) - res <- rep(-Inf, times=length(boundary)) - - for(i in lim2[1]:lim2[2]) { - y2ind <- i - lim2[1] + 1 - if(boundary[y2ind] == -1) { - ## decision was always 0 - res[y2ind] <- -Inf - } else if(boundary[y2ind] == n1+1) { - ## decision was always 1 - res[y2ind] <- 0 - } else { - ## calculate for the predictive for dtheta1 the - ## probability mass past (or before) the boundary - res[y2ind] <- pmix(pred_mix1, boundary[y2ind], lower.tail=lower.tail, log.p=TRUE) - } - ## finally weight with the density according to the occurence - ## of i due to theta2; the pmax avoids -Inf in a case of Prob==0 - res[y2ind] <- res[y2ind] + dmix(pred_mix2, i, log=TRUE) - } - exp(matrixStats::logSumExp(res)) + boundary <- crit_y1(lim2[1]:lim2[2], lim1 = lim1) + res <- rep(-Inf, times = length(boundary)) + + for (i in lim2[1]:lim2[2]) { + y2ind <- i - lim2[1] + 1 + if (boundary[y2ind] == -1) { + ## decision was always 0 + res[y2ind] <- -Inf + } else if (boundary[y2ind] == n1 + 1) { + ## decision was always 1 + res[y2ind] <- 0 + } else { + ## calculate for the predictive for dtheta1 the + ## probability mass past (or before) the boundary + res[y2ind] <- pmix(pred_mix1, boundary[y2ind], lower.tail = lower.tail, log.p = TRUE) + } + ## finally weight with the density according to the occurence + ## of i due to theta2; the pmax avoids -Inf in a case of Prob==0 + res[y2ind] <- res[y2ind] + dmix(pred_mix2, i, log = TRUE) } - design_fun + exp(matrixStats::logSumExp(res)) + } + design_fun } #' @templateVar fun pos2S #' @template design2S-normal #' @export -pos2S.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps=1e-6, Ngrid=10, ...) { - ## distributions of the means of the data generating distributions - ## for now we assume that the underlying standard deviation - ## matches the respective reference scales - - if(missing(sigma1)) { - sigma1 <- RBesT::sigma(prior1) - message("Using default prior 1 reference scale ", sigma1) +pos2S.normMix <- function(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps = 1e-6, Ngrid = 10, ...) { + ## distributions of the means of the data generating distributions + ## for now we assume that the underlying standard deviation + ## matches the respective reference scales + + if (missing(sigma1)) { + sigma1 <- RBesT::sigma(prior1) + message("Using default prior 1 reference scale ", sigma1) + } + assert_number(sigma1, lower = 0) + sigma(prior1) <- sigma1 + + if (missing(sigma2)) { + sigma2 <- RBesT::sigma(prior2) + message("Using default prior 2 reference scale ", sigma2) + } + assert_number(sigma2, lower = 0) + sigma(prior2) <- sigma2 + + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps, Ngrid) + + lower.tail <- attr(decision, "lower.tail") + + design_fun <- function(mix1, mix2) { + ## get the predictive of the mean + pred_mix1_mean <- preddist(mix1, n = n1, sigma = sigma1) + if (n2 == 0) { + ## gets ignored anyway + pred_mix2_mean <- preddist(mix2, n = 1, sigma = sigma2) + } else { + pred_mix2_mean <- preddist(mix2, n = n2, sigma = sigma2) } - assert_number(sigma1, lower=0) - sigma(prior1) <- sigma1 - if(missing(sigma2)) { - sigma2 <- RBesT::sigma(prior2) - message("Using default prior 2 reference scale ", sigma2) - } - assert_number(sigma2, lower=0) - sigma(prior2) <- sigma2 - - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, sigma1, sigma2, eps, Ngrid) - - lower.tail <- attr(decision, "lower.tail") - - design_fun <- function(mix1, mix2) { + assert_that(inherits(pred_mix1_mean, "normMix")) + assert_that(inherits(pred_mix2_mean, "normMix")) - ## get the predictive of the mean - pred_mix1_mean <- preddist(mix1, n=n1, sigma=sigma1) - if(n2 == 0) { - ## gets ignored anyway - pred_mix2_mean <- preddist(mix2, n=1, sigma=sigma2) - } else { - pred_mix2_mean <- preddist(mix2, n=n2, sigma=sigma2) - } + lim1 <- qmix(pred_mix1_mean, c(eps / 2, 1 - eps / 2)) + lim2 <- qmix(pred_mix2_mean, c(eps / 2, 1 - eps / 2)) + crit_y1(lim2, lim1) - assert_that(inherits(pred_mix1_mean, "normMix")) - assert_that(inherits(pred_mix2_mean, "normMix")) + ## return(list(crit=crit_y1, m1=pred_dtheta1_mean, m2=pred_dtheta2_mean)) - lim1 <- qmix(pred_mix1_mean, c(eps/2, 1-eps/2)) - lim2 <- qmix(pred_mix2_mean, c(eps/2, 1-eps/2)) - crit_y1(lim2, lim1) - - ##return(list(crit=crit_y1, m1=pred_dtheta1_mean, m2=pred_dtheta2_mean)) - - if(n2 == 0) { - mean_prior2 <- summary(prior2, probs=c())["mean"] - return(pmix(pred_mix1_mean, crit_y1(mean_prior2), lower.tail=lower.tail)) - } else { - return(integrate_density_log(function(x) pmix(pred_mix1_mean, crit_y1(x, lim1=lim1), lower.tail=lower.tail, log.p=TRUE), pred_mix2_mean, logit(eps/2), logit(1-eps/2))) - } + if (n2 == 0) { + mean_prior2 <- summary(prior2, probs = c())["mean"] + return(pmix(pred_mix1_mean, crit_y1(mean_prior2), lower.tail = lower.tail)) + } else { + return(integrate_density_log(function(x) pmix(pred_mix1_mean, crit_y1(x, lim1 = lim1), lower.tail = lower.tail, log.p = TRUE), pred_mix2_mean, logit(eps / 2), logit(1 - eps / 2))) } + } - design_fun + design_fun } #' @templateVar fun pos2S #' @template design2S-poisson #' @export -pos2S.gammaMix <- function(prior1, prior2, n1, n2, decision, eps=1e-6, ...) { - assert_that(likelihood(prior1) == "poisson") - assert_that(likelihood(prior2) == "poisson") +pos2S.gammaMix <- function(prior1, prior2, n1, n2, decision, eps = 1e-6, ...) { + assert_that(likelihood(prior1) == "poisson") + assert_that(likelihood(prior2) == "poisson") - crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) + crit_y1 <- decision2S_boundary(prior1, prior2, n1, n2, decision, eps) - lower.tail <- attr(decision, "lower.tail") + lower.tail <- attr(decision, "lower.tail") - design_fun <- function(mix1, mix2) { - assert_that(likelihood(mix1) == "poisson") - assert_that(likelihood(mix2) == "poisson") + design_fun <- function(mix1, mix2) { + assert_that(likelihood(mix1) == "poisson") + assert_that(likelihood(mix2) == "poisson") - ## get the predictive of the sum - pred_mix1_sum <- preddist(mix1, n=n1) - pred_mix2_sum <- preddist(mix2, n=n2) + ## get the predictive of the sum + pred_mix1_sum <- preddist(mix1, n = n1) + pred_mix2_sum <- preddist(mix2, n = n2) - assert_that(inherits(pred_mix1_sum, "gammaPoissonMix")) - assert_that(inherits(pred_mix2_sum, "gammaPoissonMix")) + assert_that(inherits(pred_mix1_sum, "gammaPoissonMix")) + assert_that(inherits(pred_mix2_sum, "gammaPoissonMix")) - lim1 <- qmix(pred_mix1_sum, c(eps/2, 1-eps/2)) - lim2 <- qmix(pred_mix2_sum, c(eps/2, 1-eps/2)) + lim1 <- qmix(pred_mix1_sum, c(eps / 2, 1 - eps / 2)) + lim2 <- qmix(pred_mix2_sum, c(eps / 2, 1 - eps / 2)) - ## force lower limit of lim1 to be 0 such that we will get and - ## answer in most cases; performance wise it should be ok as - ## we run a O(log(N)) search - lim1[1] <- 0 + ## force lower limit of lim1 to be 0 such that we will get and + ## answer in most cases; performance wise it should be ok as + ## we run a O(log(N)) search + lim1[1] <- 0 - ## ensure that the boundaries are cached - crit_y1(lim2, lim1=lim1) - grid <- seq(lim2[1], lim2[2]) - exp(matrixStats::logSumExp(dmix(pred_mix2_sum, grid, log=TRUE) - + pmix(pred_mix1_sum, crit_y1(grid, lim1=lim1), lower.tail=lower.tail, log.p=TRUE))) - } - design_fun + ## ensure that the boundaries are cached + crit_y1(lim2, lim1 = lim1) + grid <- seq(lim2[1], lim2[2]) + exp(matrixStats::logSumExp(dmix(pred_mix2_sum, grid, log = TRUE) + + pmix(pred_mix1_sum, crit_y1(grid, lim1 = lim1), lower.tail = lower.tail, log.p = TRUE))) + } + design_fun } diff --git a/R/postmix.R b/R/postmix.R index 5d4219d..5f9f7f4 100644 --- a/R/postmix.R +++ b/R/postmix.R @@ -2,7 +2,7 @@ #' #' @description #' Calculates the posterior distribution for data \code{data} given a prior -#' \code{priormix}, where the prior is a mixture of conjugate distributions. +#' \code{priormix}, where the prior is a mixture of conjugate distributions. #' The posterior is then also a mixture of conjugate distributions. #' #' @param priormix prior (mixture of conjugate distributions). @@ -15,9 +15,9 @@ #' property that the posterior is in the same distributional class as #' the prior. This property also applies to mixtures of conjugate #' priors. Let -#' +#' #' \deqn{p(\theta;\mathbf{w},\mathbf{a},\mathbf{b})}{p(\theta;w,a,b)} -#' +#' #' denote a conjugate mixture prior density for data #' #' \deqn{y|\theta \sim f(y|\theta),}{y|\theta ~ f(y|\theta),} @@ -26,7 +26,7 @@ #' again a mixture with each component \eqn{k} equal to the respective #' posterior of the \eqn{k}th prior component and updated weights #' \eqn{w'_k}, -#' +#' #' \deqn{p(\theta;\mathbf{w'},\mathbf{a'},\mathbf{b'}|y) = \sum_{k=1}^K w'_k \, p_k(\theta;a'_k,b'_k|y).}{p(\theta;w',a',b'|y) = \sum_{k=1}^K w'_k * p(\theta;a'_k,b'_k|y).} #' #' The weight \eqn{w'_k} for \eqn{k}th component is determined by the @@ -47,13 +47,13 @@ #' \emph{Note:} The prior weights \eqn{w_k} are fixed, but the #' posterior weights \eqn{w'_k \neq w_k} still change due to the #' changing normalization. -#' +#' #' The data \eqn{y} can either be given as individual data or as #' summary data (sufficient statistics). See below for details for the #' implemented conjugate mixture prior densities. -#' +#' #' @template conjugate_pairs -#' +#' #' @references Schmidli H, Gsteiger S, Roychoudhury S, O'Hagan A, Spiegelhalter D, Neuenschwander B. #' Robust meta-analytic-predictive priors in clinical trials with historical control information. #' \emph{Biometrics} 2014;70(4):1023-1032. @@ -62,31 +62,33 @@ #' #' # binary example with individual data (1=event,0=no event), uniform prior #' prior.unif <- mixbeta(c(1, 1, 1)) -#' data.indiv <- c(1,0,1,1,0,1) -#' posterior.indiv <- postmix(prior.unif, data.indiv) +#' data.indiv <- c(1, 0, 1, 1, 0, 1) +#' posterior.indiv <- postmix(prior.unif, data.indiv) #' print(posterior.indiv) #' # or with summary data (number of events and number of patients) -#' r <- sum(data.indiv); n <- length(data.indiv) -#' posterior.sum <- postmix(prior.unif, n=n, r=r) +#' r <- sum(data.indiv) +#' n <- length(data.indiv) +#' posterior.sum <- postmix(prior.unif, n = n, r = r) #' print(posterior.sum) -#' +#' #' # binary example with robust informative prior and conflicting data -#' prior.rob <- mixbeta(c(0.5,4,10),c(0.5,1,1)) -#' posterior.rob <- postmix(prior.rob, n=20, r=18) +#' prior.rob <- mixbeta(c(0.5, 4, 10), c(0.5, 1, 1)) +#' posterior.rob <- postmix(prior.rob, n = 20, r = 18) #' print(posterior.rob) -#' +#' #' # normal example with individual data #' sigma <- 88 #' prior.mean <- -49 -#' prior.se <- sigma/sqrt(20) -#' prior <- mixnorm(c(1,prior.mean,prior.se),sigma=sigma) -#' data.indiv <- c(-46,-227,41,-65,-103,-22,7,-169,-69,90) +#' prior.se <- sigma / sqrt(20) +#' prior <- mixnorm(c(1, prior.mean, prior.se), sigma = sigma) +#' data.indiv <- c(-46, -227, 41, -65, -103, -22, 7, -169, -69, 90) #' posterior.indiv <- postmix(prior, data.indiv) #' # or with summary data (mean and number of patients) -#' mn <- mean(data.indiv); n <- length(data.indiv) -#' posterior.sum <- postmix(prior, m=mn, n=n) +#' mn <- mean(data.indiv) +#' n <- length(data.indiv) +#' posterior.sum <- postmix(prior, m = mn, n = n) #' print(posterior.sum) -#' +#' #' @export postmix <- function(priormix, data, ...) UseMethod("postmix") @@ -101,17 +103,17 @@ postmix.default <- function(priormix, data, ...) "Unknown distribution" #' @param r Number of successes. #' @export postmix.betaMix <- function(priormix, data, n, r, ...) { - if(!missing(data)) { - assert_that(all(data %in% c(0,1))) - r <- sum(data) - n <- length(data) - } - w <- log(priormix[1,,drop=FALSE]) + dBetaBinomial(r, n, priormix[2,,drop=FALSE], priormix[3,,drop=FALSE], log=TRUE) - priormix[1,] <- exp(w - matrixStats::logSumExp(w)) - priormix[2,] <- priormix[2,,drop=FALSE] + r - priormix[3,] <- priormix[3,,drop=FALSE] + n - r - class(priormix) <- c("betaMix", "mix") - priormix + if (!missing(data)) { + assert_that(all(data %in% c(0, 1))) + r <- sum(data) + n <- length(data) + } + w <- log(priormix[1, , drop = FALSE]) + dBetaBinomial(r, n, priormix[2, , drop = FALSE], priormix[3, , drop = FALSE], log = TRUE) + priormix[1, ] <- exp(w - matrixStats::logSumExp(w)) + priormix[2, ] <- priormix[2, , drop = FALSE] + r + priormix[3, ] <- priormix[3, , drop = FALSE] + n - r + class(priormix) <- c("betaMix", "mix") + priormix } @@ -130,38 +132,39 @@ postmix.betaMix <- function(priormix, data, n, r, ...) { #' @param se Sample standard error. #' @export postmix.normMix <- function(priormix, data, n, m, se, ...) { - if(!missing(data)) { - m <- mean(data) - n <- length(data) - se <- sd(data)/sqrt(n) - } else { - if(missing(m) & (missing(n) | missing(se))) - stop("Either raw data or summary data (m and se) must be given.") - if(!missing(se) & !missing(n)) { - sigma(priormix) <- se * sqrt(n) - message(paste0("Updating reference scale to ", sigma(priormix), ".\nIt is recommended to use the sigma command instead.\nSee ?sigma or ?mixnorm.")) - } - if(missing(se) & !missing(n)) { - message("Using default prior reference scale ", sigma(priormix)) - se <- sigma(priormix)/sqrt(n) - } + if (!missing(data)) { + m <- mean(data) + n <- length(data) + se <- sd(data) / sqrt(n) + } else { + if (missing(m) & (missing(n) | missing(se))) { + stop("Either raw data or summary data (m and se) must be given.") } - dataPrec <- 1/se^2 - ## prior precision - priorPrec <- 1/priormix[3,,drop=FALSE]^2 - ## posterior precision is prior + data precision - postPrec <- priorPrec + dataPrec - ## old weights times the likelihood under the predictive of each - ## component in log space - sigmaPred <- sqrt(priormix[3,,drop=FALSE]^2 + se^2) - lw <- log(priormix[1,,drop=FALSE]) + dnorm(m, priormix[2,,drop=FALSE], sigmaPred, log=TRUE) - priormix[1,] <- exp(lw - matrixStats::logSumExp(lw)) - ## posterior means are precision weighted average of prior mean - ## and data - priormix[2,] <- (priormix[2,,drop=FALSE] * priorPrec + m * dataPrec) / postPrec - priormix[3,] <- 1/sqrt(postPrec) - class(priormix) <- c("normMix", "mix") - priormix + if (!missing(se) & !missing(n)) { + sigma(priormix) <- se * sqrt(n) + message(paste0("Updating reference scale to ", sigma(priormix), ".\nIt is recommended to use the sigma command instead.\nSee ?sigma or ?mixnorm.")) + } + if (missing(se) & !missing(n)) { + message("Using default prior reference scale ", sigma(priormix)) + se <- sigma(priormix) / sqrt(n) + } + } + dataPrec <- 1 / se^2 + ## prior precision + priorPrec <- 1 / priormix[3, , drop = FALSE]^2 + ## posterior precision is prior + data precision + postPrec <- priorPrec + dataPrec + ## old weights times the likelihood under the predictive of each + ## component in log space + sigmaPred <- sqrt(priormix[3, , drop = FALSE]^2 + se^2) + lw <- log(priormix[1, , drop = FALSE]) + dnorm(m, priormix[2, , drop = FALSE], sigmaPred, log = TRUE) + priormix[1, ] <- exp(lw - matrixStats::logSumExp(lw)) + ## posterior means are precision weighted average of prior mean + ## and data + priormix[2, ] <- (priormix[2, , drop = FALSE] * priorPrec + m * dataPrec) / postPrec + priormix[3, ] <- 1 / sqrt(postPrec) + class(priormix) <- c("normMix", "mix") + priormix } #' @describeIn postmix Calculates the posterior gamma mixture @@ -169,25 +172,27 @@ postmix.normMix <- function(priormix, data, n, m, se, ...) { #' Poisson case is supported in this version. #' @export postmix.gammaMix <- function(priormix, data, n, m, ...) { - type <- likelihood(priormix) - if(type != "poisson") - stop("NOT YET SUPPORTED: Updating Gamma priors is not yet supported for", type, "data. Sorry.") - if(!missing(data)) { - s <- sum(data) - n <- length(data) - } else { - s <- m*n - } - ## assert_int(s) - ## the predictive distribution for n events with sufficient - ## statistics s is the negative binomial with beta->beta/n - if(n>0) - w <- log(priormix[1,,drop=FALSE]) + .dnbinomAB(s, priormix[2,], priormix[3,]/n, log=TRUE) - else ## case n=0 - w <- log(priormix[1,,drop=FALSE]) - priormix[1,] <- exp(w - matrixStats::logSumExp(w)) - priormix[2,] <- priormix[2,,drop=FALSE] + s - priormix[3,] <- priormix[3,,drop=FALSE] + n - class(priormix) <- c("gammaMix", "mix") - priormix + type <- likelihood(priormix) + if (type != "poisson") { + stop("NOT YET SUPPORTED: Updating Gamma priors is not yet supported for", type, "data. Sorry.") + } + if (!missing(data)) { + s <- sum(data) + n <- length(data) + } else { + s <- m * n + } + ## assert_int(s) + ## the predictive distribution for n events with sufficient + ## statistics s is the negative binomial with beta->beta/n + if (n > 0) { + w <- log(priormix[1, , drop = FALSE]) + .dnbinomAB(s, priormix[2, ], priormix[3, ] / n, log = TRUE) + } else { ## case n=0 + w <- log(priormix[1, , drop = FALSE]) + } + priormix[1, ] <- exp(w - matrixStats::logSumExp(w)) + priormix[2, ] <- priormix[2, , drop = FALSE] + s + priormix[3, ] <- priormix[3, , drop = FALSE] + n + class(priormix) <- c("gammaMix", "mix") + priormix } diff --git a/R/preddist.R b/R/preddist.R index 34c6eb0..d45bfab 100644 --- a/R/preddist.R +++ b/R/preddist.R @@ -34,8 +34,8 @@ #' @examples #' #' # Example 1: predictive distribution from uniform prior. -#' bm <- mixbeta(c(1,1,1)) -#' bmPred <- preddist(bm, n=10) +#' bm <- mixbeta(c(1, 1, 1)) +#' bmPred <- preddist(bm, n = 10) #' # predictive proabilities and cumulative predictive probabilities #' x <- 0:10 #' d <- dmix(bmPred, x) @@ -45,32 +45,32 @@ #' names(cd) <- x #' barplot(cd) #' # median -#' mdn <- qmix(bmPred,0.5) +#' mdn <- qmix(bmPred, 0.5) #' mdn #' #' # Example 2: 2-comp Beta mixture #' -#' bm <- mixbeta( inf=c(0.8,15,50),rob=c(0.2,1,1)) +#' bm <- mixbeta(inf = c(0.8, 15, 50), rob = c(0.2, 1, 1)) #' plot(bm) -#' bmPred <- preddist(bm,n=10) +#' bmPred <- preddist(bm, n = 10) #' plot(bmPred) -#' mdn <- qmix(bmPred,0.5) +#' mdn <- qmix(bmPred, 0.5) #' mdn -#' d <- dmix(bmPred,x=0:10) +#' d <- dmix(bmPred, x = 0:10) #' \donttest{ #' n.sim <- 100000 -#' r <- rmix(bmPred,n.sim) +#' r <- rmix(bmPred, n.sim) #' d -#' table(r)/n.sim +#' table(r) / n.sim #' } #' #' # Example 3: 3-comp Normal mixture #' -#' m3 <- mixnorm( c(0.50,-0.2,0.1),c(0.25,0,0.2), c(0.25,0,0.5), sigma=10) +#' m3 <- mixnorm(c(0.50, -0.2, 0.1), c(0.25, 0, 0.2), c(0.25, 0, 0.5), sigma = 10) #' print(m3) #' summary(m3) #' plot(m3) -#' predm3 <- preddist(m3,n=2) +#' predm3 <- preddist(m3, n = 2) #' plot(predm3) #' print(predm3) #' summary(predm3) @@ -83,10 +83,10 @@ preddist.default <- function(mix, ...) stop("Unknown distribution") #' @describeIn preddist Obtain the matching predictive distribution #' for a beta distribution, the BetaBinomial. #' @export -preddist.betaMix <- function(mix, n=1, ...) { - attr(mix, "n") <- n - class(mix) <- c("betaBinomialMix", "mix") - mix +preddist.betaMix <- function(mix, n = 1, ...) { + attr(mix, "n") <- n + class(mix) <- c("betaBinomialMix", "mix") + mix } #' @describeIn preddist Obtain the matching predictive distribution @@ -97,35 +97,36 @@ preddist.betaMix <- function(mix, n=1, ...) { #' unspecified, the default reference scale of the mixture is #' assumed. #' @export -preddist.normMix <- function(mix, n=1, sigma, ...) { - if(missing(sigma)) { - sigma <- RBesT::sigma(mix) - message("Using default mixture reference scale ", sigma) - } - assert_number(sigma, lower=0) - sigma_ref <- sigma - ## note: this is effectivley a hierarchical model as we give the - ## distribution of the sum of n variables which have exactly the - ## same mean (which is sampled from the normal) - ## old: sum over y_i - ##mix[2,] <- mix[2,] * n - ##mix[3,] <- sqrt(mix[3,]^2 * n^2 + tau^2 * n ) - ## now: predictive for \bar{y}_n, the mean - mix[3,] <- sqrt(mix[3,]^2 + sigma_ref^2/n ) - class(mix) <- c("normMix", "mix") - mix +preddist.normMix <- function(mix, n = 1, sigma, ...) { + if (missing(sigma)) { + sigma <- RBesT::sigma(mix) + message("Using default mixture reference scale ", sigma) + } + assert_number(sigma, lower = 0) + sigma_ref <- sigma + ## note: this is effectivley a hierarchical model as we give the + ## distribution of the sum of n variables which have exactly the + ## same mean (which is sampled from the normal) + ## old: sum over y_i + ## mix[2,] <- mix[2,] * n + ## mix[3,] <- sqrt(mix[3,]^2 * n^2 + tau^2 * n ) + ## now: predictive for \bar{y}_n, the mean + mix[3, ] <- sqrt(mix[3, ]^2 + sigma_ref^2 / n) + class(mix) <- c("normMix", "mix") + mix } #' @describeIn preddist Obtain the matching predictive distribution #' for a Gamma. Only Poisson likelihoods are supported. #' @export -preddist.gammaMix <- function(mix, n=1, ...) { - assert_set_equal(likelihood(mix), "poisson") - attr(mix, "n") <- n - class(mix) <- c(switch(likelihood(mix), - poisson="gammaPoissonMix", - exp="gammaExpMix"), "mix") - mix +preddist.gammaMix <- function(mix, n = 1, ...) { + assert_set_equal(likelihood(mix), "poisson") + attr(mix, "n") <- n + class(mix) <- c(switch(likelihood(mix), + poisson = "gammaPoissonMix", + exp = "gammaExpMix" + ), "mix") + mix } #' @describeIn preddist Multivariate normal mixtures predictive diff --git a/R/predict_gMAP.R b/R/predict_gMAP.R index b9f19c4..15e03d1 100644 --- a/R/predict_gMAP.R +++ b/R/predict_gMAP.R @@ -28,131 +28,143 @@ #' @rdname predict.gMAP #' @method predict gMAP #' @export -predict.gMAP <- function(object, newdata, type=c("response", "link"), probs = c(0.025, 0.5, 0.975), na.action = na.pass, thin, ...) { - f <- object$formula - mf <- object$model - tt <- terms(f, data=mf, lhs=1, rhs=1) - type <- match.arg(type) - if (missing(newdata)) { - posterior_predict <- TRUE - X <- model.matrix(f, mf, rhs=1) - log_offset <- object$log_offset - group.factor <- model.part(f, data = mf, rhs = 2) - } else { - posterior_predict <- FALSE - Terms <- delete.response(tt) - ## replace model frame with newdata context - m <- model.frame(Terms, newdata, na.action = na.action, - xlev = .getXlevels(tt, mf)) - if (!is.null(cl <- attr(Terms, "dataClasses"))) - .checkMFClasses(cl, m) - X <- model.matrix(Terms, m, contrasts.arg = attr(model.matrix(f, mf, rhs=1), "contrasts")) - log_offset <- rep(0, nrow(X)) - if (!is.null(off.num <- attr(tt, "offset"))) - for (i in off.num) log_offset <- log_offset + eval(attr(tt, - "variables")[[i + 1]], newdata) - if (!is.null(object$call$offset)) - log_offset <- log_offset + eval(object$call$offset, newdata) - - group.factor <- model.part(f, data = newdata, rhs = 2) +predict.gMAP <- function(object, newdata, type = c("response", "link"), probs = c(0.025, 0.5, 0.975), na.action = na.pass, thin, ...) { + f <- object$formula + mf <- object$model + tt <- terms(f, data = mf, lhs = 1, rhs = 1) + type <- match.arg(type) + if (missing(newdata)) { + posterior_predict <- TRUE + X <- model.matrix(f, mf, rhs = 1) + log_offset <- object$log_offset + group.factor <- model.part(f, data = mf, rhs = 2) + } else { + posterior_predict <- FALSE + Terms <- delete.response(tt) + ## replace model frame with newdata context + m <- model.frame(Terms, newdata, + na.action = na.action, + xlev = .getXlevels(tt, mf) + ) + if (!is.null(cl <- attr(Terms, "dataClasses"))) { + .checkMFClasses(cl, m) } - - if(ncol(group.factor) != 1) - stop("Grouping factor must be a single term (study).") - group.factor <- group.factor[,1] - - if (!is.factor(group.factor)) { - group.factor <- factor(group.factor) + X <- model.matrix(Terms, m, contrasts.arg = attr(model.matrix(f, mf, rhs = 1), "contrasts")) + log_offset <- rep(0, nrow(X)) + if (!is.null(off.num <- attr(tt, "offset"))) { + for (i in off.num) { + log_offset <- log_offset + eval(attr( + tt, + "variables" + )[[i + 1]], newdata) + } } - labels <- as.character(group.factor) - group.index <- array(as.integer(group.factor)) - - ## nubmer of groups coded by the factor - n.groups <- nlevels(group.factor) - ## number of groups actually observed in the data - n.groups.obs <- length(unique(group.index)) - - if(missing(thin)) { - thin <- object$thin + if (!is.null(object$call$offset)) { + log_offset <- log_offset + eval(object$call$offset, newdata) } - beta <- rstan::extract(object$fit, inc_warmup=FALSE, permuted=FALSE, pars="beta") - n.pred <- nrow(X) - n.iter <- dim(beta)[1] - n.chains <- dim(beta)[2] - - if(posterior_predict) { - pred <- aperm(rstan::extract(object$fit, inc_warmup=FALSE, permuted=FALSE, pars="theta"), c(3,1,2)) - } else { - pred <- apply(beta, c(1,2), function(x) X %*% x) - if(n.pred==1) - pred <- array(pred, dim=c(1,dim(pred))) + group.factor <- model.part(f, data = newdata, rhs = 2) + } + + if (ncol(group.factor) != 1) { + stop("Grouping factor must be a single term (study).") + } + group.factor <- group.factor[, 1] + + if (!is.factor(group.factor)) { + group.factor <- factor(group.factor) + } + labels <- as.character(group.factor) + group.index <- array(as.integer(group.factor)) + + ## nubmer of groups coded by the factor + n.groups <- nlevels(group.factor) + ## number of groups actually observed in the data + n.groups.obs <- length(unique(group.index)) + + if (missing(thin)) { + thin <- object$thin + } + + beta <- rstan::extract(object$fit, inc_warmup = FALSE, permuted = FALSE, pars = "beta") + n.pred <- nrow(X) + n.iter <- dim(beta)[1] + n.chains <- dim(beta)[2] + + if (posterior_predict) { + pred <- aperm(rstan::extract(object$fit, inc_warmup = FALSE, permuted = FALSE, pars = "theta"), c(3, 1, 2)) + } else { + pred <- apply(beta, c(1, 2), function(x) X %*% x) + if (n.pred == 1) { + pred <- array(pred, dim = c(1, dim(pred))) } + } - sub_ind <- seq(1,n.iter,by=thin) - - pred <- t(matrix(pred[,sub_ind,], nrow=n.pred)) - - if(!posterior_predict) { - ## in case we make a prediction unconditional on the fitted - ## data, we draw random effects here (one for each study per - ## iteration) - - S <- nrow(pred) - ## sample random effects for as many groups defined, which can - ## be more than the ones in the data set, since we sample for - ## all defined factor levels - tau <- as.vector(rstan::extract(object$fit, inc_warmup=FALSE, permuted=FALSE, pars=paste0("tau[", object$tau.strata.pred, "]"))[sub_ind,,]) - if(object$REdist == "normal") { - re <- tau * matrix(rnorm(n.groups * S, 0, 1), nrow=S) - } - if(object$REdist == "t") { - re <- tau * matrix(rt(n.groups * S, df=object$t.df), nrow=S) - } - - ## ... and add it to predictions - pred <- pred + re[,group.index] - } + sub_ind <- seq(1, n.iter, by = thin) - if(type == "response") - pred <- object$family$linkinv(pred) + pred <- t(matrix(pred[, sub_ind, ], nrow = n.pred)) - predNames <- NULL - if(!is.null(rownames(X))) - predNames <- rownames(X) - dimnames(pred) <- list(NULL, predNames) + if (!posterior_predict) { + ## in case we make a prediction unconditional on the fitted + ## data, we draw random effects here (one for each study per + ## iteration) - stat <- SimSum(pred, probs=probs, margin=2) - attr(pred, "summary") <- stat - attr(pred, "type") <- type - attr(pred, "family") <- object$family - attr(pred, "sigma_ref") <- object$sigma_ref - invisible(structure(pred, class=c("gMAPpred"))) + S <- nrow(pred) + ## sample random effects for as many groups defined, which can + ## be more than the ones in the data set, since we sample for + ## all defined factor levels + tau <- as.vector(rstan::extract(object$fit, inc_warmup = FALSE, permuted = FALSE, pars = paste0("tau[", object$tau.strata.pred, "]"))[sub_ind, , ]) + if (object$REdist == "normal") { + re <- tau * matrix(rnorm(n.groups * S, 0, 1), nrow = S) + } + if (object$REdist == "t") { + re <- tau * matrix(rt(n.groups * S, df = object$t.df), nrow = S) + } + + ## ... and add it to predictions + pred <- pred + re[, group.index] + } + + if (type == "response") { + pred <- object$family$linkinv(pred) + } + + predNames <- NULL + if (!is.null(rownames(X))) { + predNames <- rownames(X) + } + dimnames(pred) <- list(NULL, predNames) + + stat <- SimSum(pred, probs = probs, margin = 2) + attr(pred, "summary") <- stat + attr(pred, "type") <- type + attr(pred, "family") <- object$family + attr(pred, "sigma_ref") <- object$sigma_ref + invisible(structure(pred, class = c("gMAPpred"))) } #' @rdname predict.gMAP #' @method print gMAPpred #' @export -print.gMAPpred <- function(x, digits=3, ...) { - cat("Meta-Analytic-Predictive Prior Predictions\n") - cat("Scale:", attr(x, "type"),"\n") - cat("\n") - cat("Summary:\n") - print(signif(attr(x, "summary"), digits=digits)) +print.gMAPpred <- function(x, digits = 3, ...) { + cat("Meta-Analytic-Predictive Prior Predictions\n") + cat("Scale:", attr(x, "type"), "\n") + cat("\n") + cat("Summary:\n") + print(signif(attr(x, "summary"), digits = digits)) } #' @rdname predict.gMAP #' @method summary gMAPpred #' @export summary.gMAPpred <- function(object, ...) { - attr(object, "summary") + attr(object, "summary") } #' @rdname predict.gMAP #' @method as.matrix gMAPpred #' @export as.matrix.gMAPpred <- function(x, ...) { - class(x) <- "matrix" - x + class(x) <- "matrix" + x } - diff --git a/R/robustify.R b/R/robustify.R index 62eda0c..7de3b1b 100644 --- a/R/robustify.R +++ b/R/robustify.R @@ -27,7 +27,7 @@ #' #' @return New mixture with an extra non-informative component named #' \code{robust}. -#' +#' #' @references Schmidli H, Gsteiger S, Roychoudhury S, O'Hagan A, #' Spiegelhalter D, Neuenschwander B. Robust meta-analytic-predictive #' priors in clinical trials with historical control information. @@ -38,31 +38,31 @@ #' Amer Statist Assoc} 1995; 90(431):928-934. #' #' @seealso \code{\link{mixcombine}} -#' +#' #' @examples -#' bmix <- mixbeta(inf1=c(0.2, 8, 3), inf2=c(0.8, 10, 2)) +#' bmix <- mixbeta(inf1 = c(0.2, 8, 3), inf2 = c(0.8, 10, 2)) #' plot(bmix) -#' rbmix <- robustify(bmix, weight=0.1, mean=0.5) +#' rbmix <- robustify(bmix, weight = 0.1, mean = 0.5) #' rbmix #' plot(rbmix) -#' -#' gmnMix <- mixgamma(inf1=c(0.2, 2, 3), inf2=c(0.8, 2, 5), param="mn") +#' +#' gmnMix <- mixgamma(inf1 = c(0.2, 2, 3), inf2 = c(0.8, 2, 5), param = "mn") #' plot(gmnMix) -#' rgmnMix <- robustify(gmnMix, weight=0.1, mean=2) +#' rgmnMix <- robustify(gmnMix, weight = 0.1, mean = 2) #' rgmnMix #' plot(rgmnMix) -#' -#' nm <- mixnorm(inf1=c(0.2, 0.5, 0.7), inf2=c(0.8, 2, 1), sigma=2) +#' +#' nm <- mixnorm(inf1 = c(0.2, 0.5, 0.7), inf2 = c(0.8, 2, 1), sigma = 2) #' plot(nm) -#' rnMix <- robustify(nm, weight=0.1, mean=0, sigma=2) +#' rnMix <- robustify(nm, weight = 0.1, mean = 0, sigma = 2) #' rnMix #' plot(rnMix) -#' +#' #' @export -robustify <- function(priormix, weight, mean, n=1, ...) UseMethod("robustify") +robustify <- function(priormix, weight, mean, n = 1, ...) UseMethod("robustify") #' @export -robustify.default <- function(priormix, weight, mean, n=1, ...) "Unknown density" +robustify.default <- function(priormix, weight, mean, n = 1, ...) "Unknown density" #' @describeIn robustify The default \code{mean} is set to 1/2 which #' represents no difference between the occurrence rates for one of the @@ -72,33 +72,33 @@ robustify.default <- function(priormix, weight, mean, n=1, ...) "Unknown density #' the \code{Beta(1/2,1/2)} which strictly defined would be the unit #' information prior in this case. #' @export -robustify.betaMix <- function(priormix, weight, mean, n=1, ...) { - assert_number(weight, lower=0, upper=1) - assert_number(n, lower=0, finite=TRUE) - if(missing(mean)) { - message("Using default mean for robust component of 1/2.") - mean <- 1/2 - } - assert_number(mean, lower=0, upper=1) - rob <- mixbeta(robust=c(1, mean, n+1), param="mn") - mixcombine(priormix, rob, weight=c(1-weight, weight)) +robustify.betaMix <- function(priormix, weight, mean, n = 1, ...) { + assert_number(weight, lower = 0, upper = 1) + assert_number(n, lower = 0, finite = TRUE) + if (missing(mean)) { + message("Using default mean for robust component of 1/2.") + mean <- 1 / 2 + } + assert_number(mean, lower = 0, upper = 1) + rob <- mixbeta(robust = c(1, mean, n + 1), param = "mn") + mixcombine(priormix, rob, weight = c(1 - weight, weight)) } #' @describeIn robustify The default \code{mean} is set to the mean of the #' prior mixture. It is strongly recommended to explicitly set the #' mean to the location of the null hypothesis. #' @export -robustify.gammaMix <- function(priormix, weight, mean, n=1, ...) { - assert_number(weight, lower=0, upper=1) - assert_number(n, lower=0, finite=TRUE) - if(missing(mean)) { - s <- summary(priormix) - message(paste("Using default mean for robust component; the mean of the prior which is", s["mean"], ".")) - mean <- s["mean"] - } - assert_number(mean, lower=0, finite=TRUE) - rob <- mixgamma(robust=c(1, mean, n), param="mn", likelihood=likelihood(priormix)) - mixcombine(priormix, rob, weight=c(1-weight, weight)) +robustify.gammaMix <- function(priormix, weight, mean, n = 1, ...) { + assert_number(weight, lower = 0, upper = 1) + assert_number(n, lower = 0, finite = TRUE) + if (missing(mean)) { + s <- summary(priormix) + message(paste("Using default mean for robust component; the mean of the prior which is", s["mean"], ".")) + mean <- s["mean"] + } + assert_number(mean, lower = 0, finite = TRUE) + rob <- mixgamma(robust = c(1, mean, n), param = "mn", likelihood = likelihood(priormix)) + mixcombine(priormix, rob, weight = c(1 - weight, weight)) } #' @describeIn robustify The default \code{mean} is set to the mean @@ -109,20 +109,19 @@ robustify.gammaMix <- function(priormix, weight, mean, n=1, ...) { #' @param sigma Sampling standard deviation for the case of Normal #' mixtures. #' @export -robustify.normMix <- function(priormix, weight, mean, n=1, ..., sigma) { - assert_number(weight, lower=0, upper=1) - assert_number(n, lower=0, finite=TRUE) - if(missing(mean)) { - s <- summary(priormix) - message(paste("Using default mean for robust component; the mean of the prior which is", s["mean"], ".")) - mean <- s["mean"] - } - assert_number(mean, finite=TRUE) - if(missing(sigma)) { - message("Using default prior reference scale ", RBesT::sigma(priormix)) - sigma <- RBesT::sigma(priormix) - } - rob <- mixnorm(robust=c(1, mean, n), param="mn", sigma=sigma) - mixcombine(priormix, rob, weight=c(1-weight, weight)) +robustify.normMix <- function(priormix, weight, mean, n = 1, ..., sigma) { + assert_number(weight, lower = 0, upper = 1) + assert_number(n, lower = 0, finite = TRUE) + if (missing(mean)) { + s <- summary(priormix) + message(paste("Using default mean for robust component; the mean of the prior which is", s["mean"], ".")) + mean <- s["mean"] + } + assert_number(mean, finite = TRUE) + if (missing(sigma)) { + message("Using default prior reference scale ", RBesT::sigma(priormix)) + sigma <- RBesT::sigma(priormix) + } + rob <- mixnorm(robust = c(1, mean, n), param = "mn", sigma = sigma) + mixcombine(priormix, rob, weight = c(1 - weight, weight)) } - diff --git a/R/support.R b/R/support.R index 43ab9d2..11f9b81 100644 --- a/R/support.R +++ b/R/support.R @@ -9,10 +9,10 @@ support <- function(mix) UseMethod("support") #' @export support.default <- function(mix) stop("Unknown mixture") #' @export -support.betaMix <- function(mix) mixlink(mix, c(0,1)) +support.betaMix <- function(mix) mixlink(mix, c(0, 1)) #' @export -support.gammaMix <- function(mix) mixlink(mix, c(0,Inf)) +support.gammaMix <- function(mix) mixlink(mix, c(0, Inf)) #' @export -support.normMix <- function(mix) mixlink(mix, c(-Inf,Inf)) +support.normMix <- function(mix) mixlink(mix, c(-Inf, Inf)) #' @export -support.mvnormMix <- function(mix) matrix(c(-Inf, Inf), nrow=mvnormdim(mix[-1,1]), ncol=2) +support.mvnormMix <- function(mix) matrix(c(-Inf, Inf), nrow = mvnormdim(mix[-1, 1]), ncol = 2) diff --git a/R/sysdata.rda b/R/sysdata.rda index f58c2da..c26bf63 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/uniroot_int.R b/R/uniroot_int.R index 1be47f4..ab6ec6d 100644 --- a/R/uniroot_int.R +++ b/R/uniroot_int.R @@ -5,51 +5,59 @@ #' #' @keywords internal uniroot_int <- function(f, interval, ..., - f.lower=f(interval[1], ...), - f.upper=f(interval[2], ...), - maxIter=1000) { - lo <- interval[1] - hi <- interval[2] + f.lower = f(interval[1], ...), + f.upper = f(interval[2], ...), + maxIter = 1000) { + lo <- interval[1] + hi <- interval[2] - assert_that(interval[1] < interval[2]) + assert_that(interval[1] < interval[2]) - fleft <- f.lower - fright <- f.upper + fleft <- f.lower + fright <- f.upper - if(f.lower*f.upper > 0) { - ##warning("Minimum not in range!") - ##return(ifelse(abs(flo) < abs(fhi), lo, hi)) - return(numeric()) - } + if (f.lower * f.upper > 0) { + ## warning("Minimum not in range!") + ## return(ifelse(abs(flo) < abs(fhi), lo, hi)) + return(numeric()) + } - iter <- 0 - while ((hi-lo) > 1 & iter < maxIter) { - mid <- floor((lo + hi) / 2) - fmid <- f(mid, ...) - if (f.lower * fmid < 0) { hi <- mid; fright <- fmid; } - else if (f.upper * fmid < 0) { lo <- mid; fleft <- fmid; } - iter <- iter + 1 + iter <- 0 + while ((hi - lo) > 1 & iter < maxIter) { + mid <- floor((lo + hi) / 2) + fmid <- f(mid, ...) + if (f.lower * fmid < 0) { + hi <- mid + fright <- fmid + } else if (f.upper * fmid < 0) { + lo <- mid + fleft <- fmid } - if(iter == maxIter) - warning("Maximum number of iterations reached.") - return(ifelse(abs(fleft) < abs(fright), lo, hi)) + iter <- iter + 1 + } + if (iter == maxIter) { + warning("Maximum number of iterations reached.") + } + return(ifelse(abs(fleft) < abs(fright), lo, hi)) } -uniroot_int.all <- function (f, interval, maxIter=1000, n = 100, ...) -{ - assert_that(interval[1] < interval[2]) +uniroot_int.all <- function(f, interval, maxIter = 1000, n = 100, ...) { + assert_that(interval[1] < interval[2]) - xseq <- round(seq(interval[1], interval[2], len = n + 1)) - xseq <- xseq[!duplicated(xseq)] - nu <- length(xseq) - 1 - mod <- f(xseq, ...) - Equi <- xseq[which(mod == 0)] - ss <- mod[1:nu] * mod[2:(nu + 1)] - print(ss) - ii <- which(ss < 0) - print(ii) - print(xseq[c(ii, ii[length(ii)] + 1)]) - for (i in ii) Equi <- c(Equi, uniroot_int(f, c(xseq[i], xseq[i + 1]), ..., - maxIter=maxIter)) - return(Equi) + xseq <- round(seq(interval[1], interval[2], len = n + 1)) + xseq <- xseq[!duplicated(xseq)] + nu <- length(xseq) - 1 + mod <- f(xseq, ...) + Equi <- xseq[which(mod == 0)] + ss <- mod[1:nu] * mod[2:(nu + 1)] + print(ss) + ii <- which(ss < 0) + print(ii) + print(xseq[c(ii, ii[length(ii)] + 1)]) + for (i in ii) { + Equi <- c(Equi, uniroot_int(f, c(xseq[i], xseq[i + 1]), ..., + maxIter = maxIter + )) + } + return(Equi) } diff --git a/R/zzz.R b/R/zzz.R index 083a9df..a250c9f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,11 +1,10 @@ .onLoad <- function(libname, pkgname) { - if (!("methods" %in% .packages())) attachNamespace("methods") - modules <- paste0("stan_fit4", names(stanmodels), "_mod") - for (m in modules) loadModule(m, what = TRUE) + if (!("methods" %in% .packages())) attachNamespace("methods") + modules <- paste0("stan_fit4", names(stanmodels), "_mod") + for (m in modules) loadModule(m, what = TRUE) } .onAttach <- function(...) { - ver <- utils::packageVersion("RBesT") - packageStartupMessage("This is RBesT version ", ver, " (released ", format(pkg_create_date, "%F"), ", git-sha ", pkg_sha, ")") + ver <- utils::packageVersion("RBesT") + packageStartupMessage("This is RBesT version ", ver, " (released ", format(pkg_create_date, "%F"), ", git-sha ", pkg_sha, ")") } - diff --git a/demo/oc2S-tte.R b/demo/oc2S-tte.R index 3439288..7d306c7 100644 --- a/demo/oc2S-tte.R +++ b/demo/oc2S-tte.R @@ -18,7 +18,7 @@ library(parallel) library(checkmate) ## recommended -options(mc.cores=detectCores(logical=FALSE)) +options(mc.cores = detectCores(logical = FALSE)) ######## Utility functions ######## @@ -26,46 +26,46 @@ options(mc.cores=detectCores(logical=FALSE)) ## with event_crit events. Positive time-points correspond to events, ## negative ones are censored cases. sim_trial <- function(n_1, n_2, event_rate_1, event_rate_2, events_crit, accrual_rate) { - n <- n_1 + n_2 - assert_that(events_crit <= n) - accrual <- cumsum(c(0, rexp(n-1, accrual_rate))) - idx_1 <- sample.int(n, n_1) - idx_2 <- setdiff(1:n, idx_1) - event_1 <- rexp(n_1, event_rate_1) - event_2 <- rexp(n_2, event_rate_2) - event <- rep(0, n) - group <- rep(1, n) - group[idx_2] <- 2 - event[idx_1] <- event_1 - event[idx_2] <- event_2 - event_calendar <- accrual + event - o <- order(event_calendar) - cens_calendar <- event_calendar[o[events_crit]] - is_event <- event_calendar <= cens_calendar - is_enrolled <- cens_calendar >= accrual - follow_up <- ifelse(is_event, event_calendar - accrual, -1 * (cens_calendar - accrual) ) - follow_up[!is_enrolled] <- 0 - cbind(follow_up=follow_up, group=group) + n <- n_1 + n_2 + assert_that(events_crit <= n) + accrual <- cumsum(c(0, rexp(n - 1, accrual_rate))) + idx_1 <- sample.int(n, n_1) + idx_2 <- setdiff(1:n, idx_1) + event_1 <- rexp(n_1, event_rate_1) + event_2 <- rexp(n_2, event_rate_2) + event <- rep(0, n) + group <- rep(1, n) + group[idx_2] <- 2 + event[idx_1] <- event_1 + event[idx_2] <- event_2 + event_calendar <- accrual + event + o <- order(event_calendar) + cens_calendar <- event_calendar[o[events_crit]] + is_event <- event_calendar <= cens_calendar + is_enrolled <- cens_calendar >= accrual + follow_up <- ifelse(is_event, event_calendar - accrual, -1 * (cens_calendar - accrual)) + follow_up[!is_enrolled] <- 0 + cbind(follow_up = follow_up, group = group) } ## given the follow_up from one arm calculates the posterior from the ## given prior -analyze_arm <- function(prior, follow_up) { - assert_set_equal(likelihood(prior), "poisson") - ## total time-units - exposure_time <- sum(ceiling(abs(follow_up))) - ## total events - num_events <- sum(follow_up > 0) - postmix(prior, m=num_events/exposure_time, n=exposure_time) +analyze_arm <- function(prior, follow_up) { + assert_set_equal(likelihood(prior), "poisson") + ## total time-units + exposure_time <- sum(ceiling(abs(follow_up))) + ## total events + num_events <- sum(follow_up > 0) + postmix(prior, m = num_events / exposure_time, n = exposure_time) } ## analyzes a simulated trial. Returns 0 for failure or 1 for success ## depending on the decision function. analyze_trial <- function(trial, prior_1, prior_2, decision) { - is_grp_1 <- trial[,"group"] == 1 - post_1 <- analyze_arm(prior_1, trial[is_grp_1, "follow_up"]) - post_2 <- analyze_arm(prior_2, trial[!is_grp_1, "follow_up"]) - decision(post_1, post_2) + is_grp_1 <- trial[, "group"] == 1 + post_1 <- analyze_arm(prior_1, trial[is_grp_1, "follow_up"]) + post_2 <- analyze_arm(prior_2, trial[!is_grp_1, "follow_up"]) + decision(post_1, post_2) } #' @param prior_1,prior_2 prior for each arm @@ -79,51 +79,52 @@ oc2S_tte <- function(prior_1, prior_2, events_crit, accrual_rate, decision, - num_sim=1E3) { - - fn <- function(event_rate_1, event_rate_2) { - sim <- replicate(num_sim, sim_trial(n_1, n_2, event_rate_1, event_rate_2, events_crit, accrual_rate)) - mean(apply(sim, 3, partial(analyze_trial, - prior_1=prior_1, prior_2=prior_2, - decision=decision))) - } - function(theta1, theta2) { - T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names=NULL)) - if (inherits(T, "try-error")) { - stop("theta1 and theta2 need to be of same size") - } - mcmapply(fn, T$theta1, T$theta2) + num_sim = 1E3) { + fn <- function(event_rate_1, event_rate_2) { + sim <- replicate(num_sim, sim_trial(n_1, n_2, event_rate_1, event_rate_2, events_crit, accrual_rate)) + mean(apply(sim, 3, partial(analyze_trial, + prior_1 = prior_1, prior_2 = prior_2, + decision = decision + ))) + } + function(theta1, theta2) { + T <- try(data.frame(theta1 = theta1, theta2 = theta2, row.names = NULL)) + if (inherits(T, "try-error")) { + stop("theta1 and theta2 need to be of same size") } + mcmapply(fn, T$theta1, T$theta2) + } } ## Example with one historical study ## Historical data (assume constant hazard) given in month time-units -hist_data <- data.frame(events=14, exposure_m=220, study ="HISTDATA") +hist_data <- data.frame(events = 14, exposure_m = 220, study = "HISTDATA") ## changing time-units so that we have about 1 event per time-unit => ## so we use years in this case days_in_year <- 365.25 months_in_year <- 12 -days_in_month <- days_in_year/months_in_year +days_in_month <- days_in_year / months_in_year hist_data <- hist_data %>% - mutate(exposure_y=exposure_m/months_in_year) + mutate(exposure_y = exposure_m / months_in_year) set.seed(456747) mc_map <- gMAP(events ~ 1 + offset(log(exposure_y)) | study, - data = hist_data, - tau.dist = "LogNormal", - tau.prior = c(log(0.125), log(2)/1.96), ## assuming moderate heterogeniety - beta.prior = 1, - family = "poisson") + data = hist_data, + tau.dist = "LogNormal", + tau.prior = c(log(0.125), log(2) / 1.96), ## assuming moderate heterogeniety + beta.prior = 1, + family = "poisson" +) plot(mc_map)$forest_model -map <- mixfit(mc_map, Nc=2) +map <- mixfit(mc_map, Nc = 2) plot(map)$mix @@ -138,23 +139,23 @@ likelihood(map) <- "poisson" ## OC setup ## decision criteria (trt - ctl) -success <- decision2S(0.975, 0, lower.tail=TRUE, link="log") +success <- decision2S(0.975, 0, lower.tail = TRUE, link = "log") ## weakly-informative prior for treatment (encoding that the events ## are on year scale when using days as basic unit) -prior_noninf <- mixgamma(c(1, 1/days_in_year, 1), param="mn", likelihood="exp") +prior_noninf <- mixgamma(c(1, 1 / days_in_year, 1), param = "mn", likelihood = "exp") prior_noninf ## change to poisson likelihood -likelihood(prior_noninf) <- "poisson" +likelihood(prior_noninf) <- "poisson" ## change map from years units to days -map_d <- map -map_d["b",] <- map_d["b",] * days_in_year +map_d <- map +map_d["b", ] <- map_d["b", ] * days_in_year ## event rate in units of per day; 0.07 is per month -lambda_ctl <- 0.07 / days_in_month -lambda_trt <- 0.04 / days_in_month +lambda_ctl <- 0.07 / days_in_month +lambda_trt <- 0.04 / days_in_month ## test 100 vs 50 patients and trial is stopped at 100 events total. ## assuming a 15 pts / month accrual rate @@ -163,30 +164,34 @@ lambda_trt <- 0.04 / days_in_month ## options(mc.cores=1) ## not using a prior -design_noninf <- oc2S_tte(prior_noninf, prior_noninf, - 100, 50, ## sample size per arm - 100, ## critical number of events when trial is censored - 15/days_in_month, ## accrual in # of pts per day - success - ) +design_noninf <- oc2S_tte( + prior_noninf, prior_noninf, + 100, 50, ## sample size per arm + 100, ## critical number of events when trial is censored + 15 / days_in_month, ## accrual in # of pts per day + success +) -oc <- data.frame(theta1=c(lambda_trt, lambda_ctl, lambda_trt), - theta2=c(lambda_ctl, lambda_ctl, lambda_trt)) %>% - mutate(noninf=design_noninf(theta1, theta2)) +oc <- data.frame( + theta1 = c(lambda_trt, lambda_ctl, lambda_trt), + theta2 = c(lambda_ctl, lambda_ctl, lambda_trt) +) %>% + mutate(noninf = design_noninf(theta1, theta2)) ## with map prior on ctl summary(map_d) lambda_ctl -design_map <- oc2S_tte(prior_noninf, map_d, - 100, 50, ## sample size per arm - 100, ## critical number of events when trial is censored - 15/days_in_month, ## accrual in # of pts per day - success - ) +design_map <- oc2S_tte( + prior_noninf, map_d, + 100, 50, ## sample size per arm + 100, ## critical number of events when trial is censored + 15 / days_in_month, ## accrual in # of pts per day + success +) oc <- oc %>% - mutate(map=design_map(theta1, theta2)) + mutate(map = design_map(theta1, theta2)) oc diff --git a/demo/robustMAP.R b/demo/robustMAP.R index 5b4e0da..f50d885 100644 --- a/demo/robustMAP.R +++ b/demo/robustMAP.R @@ -41,8 +41,8 @@ library(RBesT) library(knitr) theme_set(theme_bw()) knitr::opts_chunk$set( - fig.width = 7, - fig.height = 4 + fig.width = 7, + fig.height = 4 ) #' @@ -51,13 +51,13 @@ knitr::opts_chunk$set( #' the different priors map <- list() -map$beta <- mixbeta(c(1.0, 4, 16) ) +map$beta <- mixbeta(c(1.0, 4, 16)) map$mix90 <- mixbeta(c(0.9, 4, 16), c(0.1, 1, 1)) -##map$mix70 <- mixbeta(c(0.7, 4, 16), c(0.3, 1, 1)) +## map$mix70 <- mixbeta(c(0.7, 4, 16), c(0.3, 1, 1)) map$mix50 <- mixbeta(c(0.5, 4, 16), c(0.5, 1, 1)) -##map$mix30 <- mixbeta(c(0.3, 4, 16), c(0.7, 1, 1)) -##map$mix10 <- mixbeta(c(0.1, 4, 16), c(0.9, 1, 1)) -map$unif <- mixbeta( c(1.0, 1, 1)) +## map$mix30 <- mixbeta(c(0.3, 4, 16), c(0.7, 1, 1)) +## map$mix10 <- mixbeta(c(0.1, 4, 16), c(0.9, 1, 1)) +map$unif <- mixbeta(c(1.0, 1, 1)) unif <- map$unif @@ -66,38 +66,39 @@ unif <- map$unif ## by the ESS at the intermediate OC_adaptBinary2S <- function(N1, Ntarget, Nmin, M, ctl.prior, treat.prior, pc, pt, decision) { - ## calculate the different possible ESS values which we get after - ## stage1 - r1 <- 0:N1 - ESSstage1 <- vector("double", N1+1) - for(r in r1) - ESSstage1[r+1] <- round(ess(postmix(ctl.prior, r=r, n=N1), method="morita")) - - ## number of patients enrolled in stage 2 - N2 <- pmax(Ntarget-ESSstage1, Nmin) - - ## total number of patients enrolled - N <- N1 + N2 - - P <- try(data.frame(pc = pc, pt = pt)) - if (inherits(P, "try-error")) { - stop("pc and pt need to be of same size") - } - - ## calculate for each scenario and sample size of the control the - ## power - power_all <- matrix(0, N1+1, nrow(P)) - for(r in r1) { - ##power_all[r+1,] <- OC_binary2S(N[r+1], M, ctl.prior, treat.prior, P$pc, P$pt, crit) - design_calc <- oc2S(treat.prior, ctl.prior, M, N[r+1], decision) - power_all[r+1,] <- design_calc(P$pt, P$pc) - } - - ## finally take the mean with the respective weight which corresponds - ## to the weight how the respective sample size occur - w <- sapply(P$pc, function(p) dbinom(r1, N1, p)) - - data.frame(power=colSums(power_all * w), samp=colSums(w * N)) + ## calculate the different possible ESS values which we get after + ## stage1 + r1 <- 0:N1 + ESSstage1 <- vector("double", N1 + 1) + for (r in r1) { + ESSstage1[r + 1] <- round(ess(postmix(ctl.prior, r = r, n = N1), method = "morita")) + } + + ## number of patients enrolled in stage 2 + N2 <- pmax(Ntarget - ESSstage1, Nmin) + + ## total number of patients enrolled + N <- N1 + N2 + + P <- try(data.frame(pc = pc, pt = pt)) + if (inherits(P, "try-error")) { + stop("pc and pt need to be of same size") + } + + ## calculate for each scenario and sample size of the control the + ## power + power_all <- matrix(0, N1 + 1, nrow(P)) + for (r in r1) { + ## power_all[r+1,] <- OC_binary2S(N[r+1], M, ctl.prior, treat.prior, P$pc, P$pt, crit) + design_calc <- oc2S(treat.prior, ctl.prior, M, N[r + 1], decision) + power_all[r + 1, ] <- design_calc(P$pt, P$pc) + } + + ## finally take the mean with the respective weight which corresponds + ## to the weight how the respective sample size occur + w <- sapply(P$pc, function(p) dbinom(r1, N1, p)) + + data.frame(power = colSums(power_all * w), samp = colSums(w * N)) } @@ -111,73 +112,74 @@ Ntarget <- 40 M <- 40 ## decision function: P(x1 - x2 > 0) > 0.975 -dec <- decision2S(0.975, 0, lower.tail=FALSE) +dec <- decision2S(0.975, 0, lower.tail = FALSE) -cases <- expand.grid(prior=names(map), pc=seq(0.1,0.6,by=0.1), delta=c(0,0.3)) +cases <- expand.grid(prior = names(map), pc = seq(0.1, 0.6, by = 0.1), delta = c(0, 0.3)) ## the mixture cases have a varying ess at the interim and need the ## adaptive function ... -cases.mix <- grep("mix", names(map), value=TRUE) -cases.fix <- grep("mix", names(map), value=TRUE, invert=TRUE) +cases.mix <- grep("mix", names(map), value = TRUE) +cases.fix <- grep("mix", names(map), value = TRUE, invert = TRUE) -resMix <- foreach(i=cases.mix, .combine=rbind) %do% { - design <- subset(cases, prior==i) - cbind(design, OC_adaptBinary2S(N1, Ntarget, Nmin, M, map[[i]], unif, design$pc, design$pc+design$delta, dec)) +resMix <- foreach(i = cases.mix, .combine = rbind) %do% { + design <- subset(cases, prior == i) + cbind(design, OC_adaptBinary2S(N1, Ntarget, Nmin, M, map[[i]], unif, design$pc, design$pc + design$delta, dec)) } ## ... for the non-mixture priors the ESS is fixed at the intermediate ## step such that the much faster oc2S can be used directly -resFix <- foreach(i=cases.fix, .combine=rbind) %do% { - design <- subset(cases, prior==i) - prior <- map[[i]] - Nc <- Ntarget - round(ess(prior, method="morita")) - design_calc <- oc2S(unif, prior, M, Nc, dec) - cbind(design, power=design_calc(design$pc+design$delta, design$pc), samp=Nc) +resFix <- foreach(i = cases.fix, .combine = rbind) %do% { + design <- subset(cases, prior == i) + prior <- map[[i]] + Nc <- Ntarget - round(ess(prior, method = "morita")) + design_calc <- oc2S(unif, prior, M, Nc, dec) + cbind(design, power = design_calc(design$pc + design$delta, design$pc), samp = Nc) } powerTable <- rbind(resMix, resFix) -P <- expand.grid(pc=c(0.2,0.3,0.4,0.5), pt=seq(0.05,0.95,by=0.025)) +P <- expand.grid(pc = c(0.2, 0.3, 0.4, 0.5), pt = seq(0.05, 0.95, by = 0.025)) -powerMix <- foreach(i=cases.mix, .combine=rbind) %do% { - cbind(P, prior=i, OC_adaptBinary2S(N1, Ntarget, Nmin, M, map[[i]], unif, P$pc, P$pt, dec)) +powerMix <- foreach(i = cases.mix, .combine = rbind) %do% { + cbind(P, prior = i, OC_adaptBinary2S(N1, Ntarget, Nmin, M, map[[i]], unif, P$pc, P$pt, dec)) } -powerFix <- foreach(i=cases.fix, .combine=rbind) %do% { - prior <- map[[i]] - Nc <- Ntarget - round(ess(prior, method="morita")) - design_calc <- oc2S(unif, prior, M, Nc, dec) - cbind(P, prior=i, power=design_calc(P$pt, P$pc), samp=Nc) - ##cbind(P, prior=i, power=OC_binary2S(Nc, M, prior, unif, P$pc, P$pt, dec), samp=Nc) +powerFix <- foreach(i = cases.fix, .combine = rbind) %do% { + prior <- map[[i]] + Nc <- Ntarget - round(ess(prior, method = "morita")) + design_calc <- oc2S(unif, prior, M, Nc, dec) + cbind(P, prior = i, power = design_calc(P$pt, P$pc), samp = Nc) + ## cbind(P, prior=i, power=OC_binary2S(Nc, M, prior, unif, P$pc, P$pt, dec), samp=Nc) } power <- rbind(powerMix, powerFix) -ocAdapt <- powerTable[,-ncol(powerTable)] %>% - unite(case, delta, prior) %>% - transform(power=100*power) %>% - spread(case, power) -ocAdaptSamp <- powerTable[,- ( ncol(powerTable)-1 )] %>% - unite(case, delta, prior) %>% - spread(case, samp) +ocAdapt <- powerTable[, -ncol(powerTable)] %>% + unite(case, delta, prior) %>% + transform(power = 100 * power) %>% + spread(case, power) +ocAdaptSamp <- powerTable[, -(ncol(powerTable) - 1)] %>% + unite(case, delta, prior) %>% + spread(case, samp) -kable(ocAdapt, digits=1, caption="Type I error and power") +kable(ocAdapt, digits = 1, caption = "Type I error and power") -kable(ocAdaptSamp, digits=1, caption="Sample size") +kable(ocAdaptSamp, digits = 1, caption = "Sample size") #' #' ## Additional power Figure under varying pc #' -ggplot(power, aes(pt-pc, power, colour=prior)) + geom_line() + - facet_wrap(~pc) + - scale_y_continuous(breaks=seq(0,1,by=0.2)) + - scale_x_continuous(breaks=seq(-0.8,0.8,by=0.2)) + - coord_cartesian(xlim=c(-0.15,0.5)) + - geom_hline(yintercept=0.025, linetype=2) + - geom_hline(yintercept=0.8, linetype=2) + - ggtitle("Prob. for alternative for different pc") +ggplot(power, aes(pt - pc, power, colour = prior)) + + geom_line() + + facet_wrap(~pc) + + scale_y_continuous(breaks = seq(0, 1, by = 0.2)) + + scale_x_continuous(breaks = seq(-0.8, 0.8, by = 0.2)) + + coord_cartesian(xlim = c(-0.15, 0.5)) + + geom_hline(yintercept = 0.025, linetype = 2) + + geom_hline(yintercept = 0.8, linetype = 2) + + ggtitle("Prob. for alternative for different pc") #' #' ## Bias and rMSE, Figure 1 @@ -186,86 +188,89 @@ ggplot(power, aes(pt-pc, power, colour=prior)) + geom_line() + #' -plot(map$beta, prob=1) +plot(map$beta, prob = 1) plot(map$mix50) #' The bias and rMSE calculations are slightly involved as the sample #' size depends on the first stage. -est <- foreach(case=names(map), .combine=rbind) %do% { - - ## prior to consider - prior <- map[[case]] - - ## calculate the different possible ESS values which we get after - ## stage1 - r1 <- 0:N1 - ESSstage1 <- c() - for(r in r1) { - ESSstage1 <- c(ESSstage1, round(ess(postmix(prior, r=r, n=N1), method="morita", loc="mode"))) +est <- foreach(case = names(map), .combine = rbind) %do% { + ## prior to consider + prior <- map[[case]] + + ## calculate the different possible ESS values which we get after + ## stage1 + r1 <- 0:N1 + ESSstage1 <- c() + for (r in r1) { + ESSstage1 <- c(ESSstage1, round(ess(postmix(prior, r = r, n = N1), method = "morita", loc = "mode"))) + } + + ## number of patients enrolled in stage 2 + N2 <- pmax(Ntarget - ESSstage1, 5) + + ## total number of patients enrolled + N <- N1 + N2 + + ## we need the maximal possible number of patients + Nmax <- max(N) + + ## calculate for each i = 0 to N1 possible responders in stage one + ## the posterior when observing 0 to N[i] in total. Calculate for + ## each scenario outcome E(p) and E(p^2) + m <- matrix(0, N1 + 1, Nmax + 1) + m2 <- matrix(0, N1 + 1, Nmax + 1) + for (i in seq_along(N)) { + n <- N[i] + for (r in 0:n) { + res <- summary(postmix(prior, r = r, n = n))[c("mean", "sd")] + m[i, r + 1] <- res["mean"] + m2[i, r + 1] <- res["sd"]^2 + m[i, r + 1]^2 } - - ## number of patients enrolled in stage 2 - N2 <- pmax(Ntarget-ESSstage1, 5) - - ## total number of patients enrolled - N <- N1 + N2 - - ## we need the maximal possible number of patients - Nmax <- max(N) - - ## calculate for each i = 0 to N1 possible responders in stage one - ## the posterior when observing 0 to N[i] in total. Calculate for - ## each scenario outcome E(p) and E(p^2) - m <- matrix(0, N1+1, Nmax+1) - m2 <- matrix(0, N1+1, Nmax+1) - for(i in seq_along(N)) { - n <- N[i] - for(r in 0:n) { - res <- summary(postmix(prior,r=r,n=n))[c("mean", "sd")] - m[i,r+1] <- res["mean"] - m2[i,r+1] <- res["sd"]^2 + m[i,r+1]^2 - } + } + + ## now collect the terms correctly weighted for each assumed true rate + bias <- rMSE <- c() + pt <- seq(0, 1, length = 101) + for (p in pt) { + ## weight for each possible N at stage 1 + wnp <- dbinom(0:N1, N1, p) + + ## E(p) and E(p^2) for each possible N at stage 1 + Mnm <- rep(0, N1 + 1) + Mnm2 <- rep(0, N1 + 1) + + ## for a given weight at stage 1.... + for (i in seq(N1 + 1)) { + n <- N[i] + ## weights of possible outcomes when having n draws in + ## stage1, we go up to Nmax+1 to get a vector of correct + ## length; all entries above n are set to 0 from dbinom as + ## expected as we can never observe more counts than the + ## number of trials... + wp <- dbinom(0:Nmax, n, p) + + Mnm[i] <- sum(m[i, ] * wp) + Mnm2[i] <- sum(m2[i, ] * wp) } - ## now collect the terms correctly weighted for each assumed true rate - bias <- rMSE <- c() - pt <- seq(0,1,length=101) - for(p in pt) { - ## weight for each possible N at stage 1 - wnp <- dbinom(0:N1, N1, p) - - ## E(p) and E(p^2) for each possible N at stage 1 - Mnm <- rep(0, N1+1) - Mnm2 <- rep(0, N1+1) - - ## for a given weight at stage 1.... - for(i in seq(N1+1)) { - n <- N[i] - ## weights of possible outcomes when having n draws in - ## stage1, we go up to Nmax+1 to get a vector of correct - ## length; all entries above n are set to 0 from dbinom as - ## expected as we can never observe more counts than the - ## number of trials... - wp <- dbinom(0:Nmax, n, p) - - Mnm[i] <- sum(m[i,] * wp) - Mnm2[i] <- sum(m2[i,] * wp) - } - - ## ... which we average over possible outcomes in stage 1 - Mm <- sum(wnp * Mnm) - Mm2 <- sum(wnp * Mnm2) - - bias <- c(bias, (Mm - p)) - rMSE <- c(rMSE, sqrt(Mm2 - 2 * p * Mm + p^2)) - } - data.frame(p=pt, bias=bias, rMSE=rMSE, prior=case) + ## ... which we average over possible outcomes in stage 1 + Mm <- sum(wnp * Mnm) + Mm2 <- sum(wnp * Mnm2) + + bias <- c(bias, (Mm - p)) + rMSE <- c(rMSE, sqrt(Mm2 - 2 * p * Mm + p^2)) + } + data.frame(p = pt, bias = bias, rMSE = rMSE, prior = case) } -ggplot(est, aes(p, 100*bias, colour=prior)) + geom_line() + ggtitle("Bias") -ggplot(est, aes(p, 100*rMSE, colour=prior)) + geom_line() + ggtitle("rMSE") +ggplot(est, aes(p, 100 * bias, colour = prior)) + + geom_line() + + ggtitle("Bias") +ggplot(est, aes(p, 100 * rMSE, colour = prior)) + + geom_line() + + ggtitle("rMSE") #' @@ -277,12 +282,13 @@ ggplot(est, aes(p, 100*rMSE, colour=prior)) + geom_line() + ggtitle("rMSE") ## set seed to guarantee exact reproducible results set.seed(25445) -map <- gMAP(cbind(r, n-r) ~ 1 | study, - family=binomial, - data=colitis, - tau.dist="HalfNormal", - beta.prior=2, - tau.prior=1) +map <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = colitis, + tau.dist = "HalfNormal", + beta.prior = 2, + tau.prior = 1 +) map_auto <- automixfit(map) @@ -303,14 +309,14 @@ pl$mix + ggtitle("MAP prior for ulcerative colitis") #' mapCol <- list( - one = mixbeta(c(1,2.3,16)), - two = mixbeta(c(0.77, 6.2, 50.8), c(1-0.77, 1.0, 4.7)), - three = mixbeta(c(0.53, 2.5, 19.1), c(0.38, 14.6, 120.2), c(0.08, 0.9, 2.9)) - ) -mapCol <- c(mapCol, list(twoRob=robustify(mapCol$two, weight=0.1, mean=1/2), - threeRob=robustify(mapCol$three, weight=0.1, mean=1/2) - ) - ) + one = mixbeta(c(1, 2.3, 16)), + two = mixbeta(c(0.77, 6.2, 50.8), c(1 - 0.77, 1.0, 4.7)), + three = mixbeta(c(0.53, 2.5, 19.1), c(0.38, 14.6, 120.2), c(0.08, 0.9, 2.9)) +) +mapCol <- c(mapCol, list( + twoRob = robustify(mapCol$two, weight = 0.1, mean = 1 / 2), + threeRob = robustify(mapCol$three, weight = 0.1, mean = 1 / 2) +)) #' #' Posterior for different remission rates, Figure 3 @@ -318,17 +324,20 @@ mapCol <- c(mapCol, list(twoRob=robustify(mapCol$two, weight=0.1, mean=1/2), N <- 20 -post <- foreach(prior=names(mapCol), .combine=rbind) %do% { - res <- data.frame(mean=rep(NA, N+1), sd=0, r=0:N) - for(r in 0:N) { - res[r+1,1:2] <- summary(postmix(mapCol[[prior]], r=r, n=N))[c("mean", "sd")] - } - res$prior <- prior - res +post <- foreach(prior = names(mapCol), .combine = rbind) %do% { + res <- data.frame(mean = rep(NA, N + 1), sd = 0, r = 0:N) + for (r in 0:N) { + res[r + 1, 1:2] <- summary(postmix(mapCol[[prior]], r = r, n = N))[c("mean", "sd")] + } + res$prior <- prior + res } -ggplot(post, aes(r, mean, colour=prior, shape=prior)) + geom_point() + geom_abline(slope=1/20) -ggplot(post, aes(r, sd, colour=prior, shape=prior)) + geom_point() + coord_cartesian(ylim=c(0,0.17)) +ggplot(post, aes(r, mean, colour = prior, shape = prior)) + + geom_point() + + geom_abline(slope = 1 / 20) +ggplot(post, aes(r, sd, colour = prior, shape = prior)) + + geom_point() + + coord_cartesian(ylim = c(0, 0.17)) sessionInfo() - diff --git a/inst/examples/ess.R b/inst/examples/ess.R index dfe433e..c363772 100644 --- a/inst/examples/ess.R +++ b/inst/examples/ess.R @@ -4,10 +4,10 @@ b <- 15 prior <- mixbeta(c(1, a, b)) ess(prior) -(a+b) +(a + b) # Beta mixture example -bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) +bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) ess(bmix, "elir") @@ -21,35 +21,47 @@ ab_matched <- ms2beta(bmix_sum["mean"], bmix_sum["sd"]) # to number of responders/non-responders respectivley round(sum(ab_matched)) -ess(bmix, method="morita") +ess(bmix, method = "morita") + +# One may also calculate the ESS on the logit scale, which +# gives slightly different results due to the parameter +# transformation, e.g.: +prior_logit <- mixnorm(c(1, log(5 / 15), sqrt(1 / 5 + 1 / 15))) +ess(prior_logit, family = binomial) + +bmix_logit <- mixnorm(rob = c(0.2, 0, 2), inf = c(0.8, log(10 / 2), sqrt(1 / 10 + 1 / 2))) +ess(bmix_logit, family = binomial) # Predictive consistency of elir n_forward <- 1E1 -bmixPred <- preddist(bmix, n=n_forward) +bmixPred <- preddist(bmix, n = n_forward) pred_samp <- rmix(bmixPred, 1E2) -# use more samples here for greater accuracy -# pred_samp <- rmix(bmixPred, 1E3) -pred_ess <- sapply(pred_samp, function(r) ess(postmix(bmix, r=r, n=n_forward), "elir") ) +# use more samples here for greater accuracy, e.g. +# pred_samp <- rmix(bmixPred, 1E3) +pred_ess <- sapply(pred_samp, function(r) ess(postmix(bmix, r = r, n = n_forward), "elir")) ess(bmix, "elir") mean(pred_ess) - n_forward # Normal mixture example -nmix <- mixnorm(rob=c(0.5, 0, 2), inf=c(0.5, 3, 4), sigma=10) +nmix <- mixnorm(rob = c(0.5, 0, 2), inf = c(0.5, 3, 4), sigma = 10) ess(nmix, "elir") ess(nmix, "moment") -## the reference scale determines the ESS +# the reference scale determines the ESS sigma(nmix) <- 20 ess(nmix) +# we may also interpret normal mixtures as densities assigned to +# parameters of a logit transformed response rate of a binomial +nmix_logit <- mixnorm(c(1, logit(1 / 4), 2 / sqrt(10))) +ess(nmix_logit, family = binomial) + # Gamma mixture example -gmix <- mixgamma(rob=c(0.3, 20, 4), inf=c(0.7, 50, 10)) +gmix <- mixgamma(rob = c(0.3, 20, 4), inf = c(0.7, 50, 10)) ess(gmix) ## interpreted as appropriate for a Poisson likelihood (default) likelihood(gmix) <- "exp" ess(gmix) ## interpreted as appropriate for an exponential likelihood - - diff --git a/inst/examples/mixcombine.R b/inst/examples/mixcombine.R index f2ca36f..fe48dfd 100644 --- a/inst/examples/mixcombine.R +++ b/inst/examples/mixcombine.R @@ -1,6 +1,6 @@ # beta with two informative components -bm <- mixbeta(inf=c(0.5, 10, 100), inf2=c(0.5, 30, 80)) +bm <- mixbeta(inf = c(0.5, 10, 100), inf2 = c(0.5, 30, 80)) # robustified with mixcombine, i.e. a 10% uninformative part added -unif <- mixbeta(rob=c(1,1,1)) -mixcombine(bm, unif, weight=c(9, 1)) +unif <- mixbeta(rob = c(1, 1, 1)) +mixcombine(bm, unif, weight = c(9, 1)) diff --git a/inst/examples/predict_gMAP.R b/inst/examples/predict_gMAP.R index 56dc59c..e8ec7bb 100644 --- a/inst/examples/predict_gMAP.R +++ b/inst/examples/predict_gMAP.R @@ -1,17 +1,18 @@ # create a fake data set with a covariate -trans_cov <- transform(transplant, country=cut(1:11, c(0,5,8,Inf), c("CH", "US", "DE"))) +trans_cov <- transform(transplant, country = cut(1:11, c(0, 5, 8, Inf), c("CH", "US", "DE"))) set.seed(34246) -map <- gMAP(cbind(r, n-r) ~ 1 + country | study, - data=trans_cov, - tau.dist="HalfNormal", - tau.prior=1, - # Note on priors: we make the overall intercept weakly-informative - # and the regression coefficients must have tighter sd as these are - # deviations in the default contrast parametrization - beta.prior=rbind(c(0,2), c(0,1), c(0,1)), - family=binomial, - ## ensure fast example runtime - thin=1, chains=1) +map <- gMAP(cbind(r, n - r) ~ 1 + country | study, + data = trans_cov, + tau.dist = "HalfNormal", + tau.prior = 1, + # Note on priors: we make the overall intercept weakly-informative + # and the regression coefficients must have tighter sd as these are + # deviations in the default contrast parametrization + beta.prior = rbind(c(0, 2), c(0, 1), c(0, 1)), + family = binomial, + ## ensure fast example runtime + thin = 1, chains = 1 +) # posterior predictive distribution for each input data item (shrinkage estimates) pred_cov <- predict(map) @@ -29,5 +30,5 @@ pred_cov_pred summary(pred_cov) # obtain a prediction for new data with specific covariates -pred_new <- predict(map, data.frame(country="CH", study=12)) +pred_new <- predict(map, data.frame(country = "CH", study = 12)) pred_new diff --git a/inst/examples/robustify.R b/inst/examples/robustify.R index 3b4c40e..38c52d2 100644 --- a/inst/examples/robustify.R +++ b/inst/examples/robustify.R @@ -1,22 +1,22 @@ -bmix <- mixbeta(inf1=c(0.2, 8, 3), inf2=c(0.8, 10, 2)) +bmix <- mixbeta(inf1 = c(0.2, 8, 3), inf2 = c(0.8, 10, 2)) plot(bmix) -rbmix <- robustify(bmix, weight=0.1, mean=0.5) +rbmix <- robustify(bmix, weight = 0.1, mean = 0.5) rbmix plot(rbmix) -gmnMix <- mixgamma(inf1=c(0.2, 2, 3), inf2=c(0.8, 2, 5), param="mn") +gmnMix <- mixgamma(inf1 = c(0.2, 2, 3), inf2 = c(0.8, 2, 5), param = "mn") plot(gmnMix) -rgmnMix <- robustify(gmnMix, weight=0.1, mean=2) +rgmnMix <- robustify(gmnMix, weight = 0.1, mean = 2) rgmnMix plot(rgmnMix) -nm <- mixnorm(inf1=c(0.2, 0.5, 0.7), inf2=c(0.8, 2, 1), sigma=2) +nm <- mixnorm(inf1 = c(0.2, 0.5, 0.7), inf2 = c(0.8, 2, 1), sigma = 2) plot(nm) -rnMix <- robustify(nm, weight=0.1, mean=0, sigma=2) +rnMix <- robustify(nm, weight = 0.1, mean = 0, sigma = 2) rnMix plot(rnMix) diff --git a/inst/extra/run-oq.R b/inst/extra/run-oq.R index 6cb0db4..4dbacac 100644 --- a/inst/extra/run-oq.R +++ b/inst/extra/run-oq.R @@ -7,19 +7,19 @@ cat("TESTING PACKAGE:\n") print(packageDescription("RBesT")) ## enforce that all tests are run -Sys.setenv(NOT_CRAN="true") +Sys.setenv(NOT_CRAN = "true") cat("RUNNING PACKAGE TESTS:\n") ## run each section separatley to get subsequent numbering per section ## of the TAP reporter; execution order is in line with vignette steps -for(test in c("gMAP", "EM", "oc1S", "oc2S", "mixdist", "mixdiff", "preddist", "postmix", "utils", "pos1S", "pos2S")) { - test_package("RBesT", filter=test, reporter="tap") +for (test in c("gMAP", "EM", "oc1S", "oc2S", "mixdist", "mixdiff", "preddist", "postmix", "utils", "pos1S", "pos2S")) { + test_package("RBesT", filter = test, reporter = "tap") } ## finally run all tests once more, but with the stop reporter. This ## ensures that the last line of this script is only displayed if and ## only if all tests run successful -test_package("RBesT", reporter="stop") +test_package("RBesT", reporter = "stop") cat("\n\nR SESSION INFO:\n") @@ -27,4 +27,3 @@ print(sessionInfo()) cat("\nTEST FINISH DATE:", date(), "\n") cat("\n\nALL TESTS SUCCESSFUL\n") - diff --git a/inst/sbc/make_reference_rankhist.R b/inst/sbc/make_reference_rankhist.R index 20fc4e3..cbd183c 100755 --- a/inst/sbc/make_reference_rankhist.R +++ b/inst/sbc/make_reference_rankhist.R @@ -1,6 +1,6 @@ #! /usr/bin/env Rscript -start_time <- Sys.time() +start_time <- Sys.time() here::i_am("inst/sbc/make_reference_rankhist.R") library(here) @@ -12,17 +12,17 @@ rbest_source_dir <- here() ## loaded. ## code to use if one wants the more conservative load_OB2_dev_install routine to be used setwd(here()) -system("make dev-install", ignore.stdout=TRUE, ignore.stderr=TRUE) +system("make dev-install", ignore.stdout = TRUE, ignore.stderr = TRUE) setwd(here("inst", "sbc")) pkg <- c("assertthat", "rstan", "mvtnorm", "checkmate", "Formula", "abind", "dplyr", "tidyr", "here", "bayesplot") -sapply(pkg, require, character.only=TRUE) +sapply(pkg, require, character.only = TRUE) library(clustermq) library(data.table) library(knitr) sbc_tools <- new.env() -source(here("inst", "sbc", "sbc_tools.R"), local=sbc_tools) +source(here("inst", "sbc", "sbc_tools.R"), local = sbc_tools) set.seed(45348346) sbc_tools$rbest_lib_dir <- rbest_lib_dir @@ -31,22 +31,22 @@ sbc_tools$load_rbest_dev() scheduler <- getOption("clustermq.scheduler") -if(is.null(scheduler)) { - ## in this case we enable the multiprocess option to leverage local CPUs - options(clustermq.scheduler="multiprocess") +if (is.null(scheduler)) { + ## in this case we enable the multiprocess option to leverage local CPUs + options(clustermq.scheduler = "multiprocess") } scheduler <- getOption("clustermq.scheduler") -##options(clustermq.scheduler="LOCAL") +## options(clustermq.scheduler="LOCAL") n_jobs <- 1 -if(scheduler == "multiprocess") { - ## on a local machine we only use as many CPUs as available - n_jobs <- as.numeric(system2("nproc", stdout=TRUE)) +if (scheduler == "multiprocess") { + ## on a local machine we only use as many CPUs as available + n_jobs <- as.numeric(system2("nproc", stdout = TRUE)) } -if(scheduler %in% c("LSF", "SGE", "SLURM", "PBS", "Torque")) { - ## on a queinging enabled backend, we use a lot more parallelism - n_jobs <- 200 +if (scheduler %in% c("LSF", "SGE", "SLURM", "PBS", "Torque")) { + ## on a queinging enabled backend, we use a lot more parallelism + n_jobs <- 200 } cat("Using clustermq backend", scheduler, "with", n_jobs, "concurrent jobs.\n") @@ -55,25 +55,28 @@ cat("Using clustermq backend", scheduler, "with", n_jobs, "concurrent jobs.\n") #' - Dense: 10 trials with 40 entries each #' - Sparse: 3 trials with 40 entries each -base_scenarios <- list(dense=list(group=rep(1:10, each=40)), - sparse=list(group=rep(1:3, each=40))) +base_scenarios <- list( + dense = list(group = rep(1:10, each = 40)), + sparse = list(group = rep(1:3, each = 40)) +) ## family, mean_mu, sd_mu, sd_tau, samp_sd cases <- data.frame( - family=c("binomial", "gaussian", "poisson"), - mean_mu=c(-1, 0, 0), - sd_mu=c(1), - sd_tau=c(rep(0.5, 3), rep(1, 3)), - samp_sd=c(1), - stringsAsFactors=FALSE) + family = c("binomial", "gaussian", "poisson"), + mean_mu = c(-1, 0, 0), + sd_mu = c(1), + sd_tau = c(rep(0.5, 3), rep(1, 3)), + samp_sd = c(1), + stringsAsFactors = FALSE +) ## replications to use S <- 1E4 -scenarios <- merge(expand.grid(repl=1:S, data_scenario=c("dense", "sparse"), stringsAsFactors=FALSE), cases, by=NULL) -##scenarios <- merge(expand.grid(repl=1:S, data_scenario=c("sparse"), stringsAsFactors=FALSE), cases, by=NULL) +scenarios <- merge(expand.grid(repl = 1:S, data_scenario = c("dense", "sparse"), stringsAsFactors = FALSE), cases, by = NULL) +## scenarios <- merge(expand.grid(repl=1:S, data_scenario=c("sparse"), stringsAsFactors=FALSE), cases, by=NULL) -scenarios <- cbind(job.id=1:nrow(scenarios), scenarios) +scenarios <- cbind(job.id = 1:nrow(scenarios), scenarios) num_simulations <- nrow(scenarios) @@ -83,97 +86,100 @@ RNGkind("L'Ecuyer-CMRG") set.seed(269698974) rng_seeds <- sbc_tools$setup_lecuyer_seeds(.Random.seed, num_simulations) -sim_result <- Q_rows(scenarios, sbc_tools$run_sbc_case, const=list(base_scenarios=base_scenarios, seeds=rng_seeds), export=as.list(sbc_tools), n_jobs=n_jobs, pkgs=pkg) +sim_result <- Q_rows(scenarios, sbc_tools$run_sbc_case, const = list(base_scenarios = base_scenarios, seeds = rng_seeds), export = as.list(sbc_tools), n_jobs = n_jobs, pkgs = pkg) -assert_that(num_simulations == length(sim_result), msg="Check if all simulations were processed.") +assert_that(num_simulations == length(sim_result), msg = "Check if all simulations were processed.") -calibration_data <- merge(scenarios, bind_rows(sim_result), by="job.id") +calibration_data <- merge(scenarios, bind_rows(sim_result), by = "job.id") ## convert to data.table setDT(calibration_data) ## collect sampler diagnostics sampler_diagnostics <- calibration_data %>% - group_by(family, data_scenario, sd_tau) %>% - summarize(N=n(), - total_divergent=sum(n_divergent), - total_divergent_sim_fraction=mean(n_divergent>0), - min_ess=min(min_Neff), - max_Rhat=max(max_Rhat), - total_large_Rhat=sum(max_Rhat > 1.2), - min_lp_ess_bulk=min(lp_ess_bulk), - min_lp_ess_tail=min(lp_ess_tail)) + group_by(family, data_scenario, sd_tau) %>% + summarize( + N = n(), + total_divergent = sum(n_divergent), + total_divergent_sim_fraction = mean(n_divergent > 0), + min_ess = min(min_Neff), + max_Rhat = max(max_Rhat), + total_large_Rhat = sum(max_Rhat > 1.2), + min_lp_ess_bulk = min(lp_ess_bulk), + min_lp_ess_tail = min(lp_ess_tail) + ) cat("\nSampler diagnostics:\n\n") -kable(sampler_diagnostics, digits=3) +kable(sampler_diagnostics, digits = 3) cat("\n") -if(sum(sampler_diagnostics$total_divergent) != 0) { - warning("There were some divergent transitions!") +if (sum(sampler_diagnostics$total_divergent) != 0) { + warning("There were some divergent transitions!") } -if(any(sampler_diagnostics$max_Rhat > 1.2) ) { - warning("There were some parameters with large Rhat!") +if (any(sampler_diagnostics$max_Rhat > 1.2)) { + warning("There were some parameters with large Rhat!") } #' Bin raw data as used in the analysis. -scale64 <- sbc_tools$scale_ranks(1024, 2^4) +scale64 <- sbc_tools$scale_ranks(1024, 2^4) B <- 1024L / 2^4 -calibration_data_binned <- calibration_data[, scale64(.SD), by=c("data_scenario", "family", "sd_tau")] +calibration_data_binned <- calibration_data[, scale64(.SD), by = c("data_scenario", "family", "sd_tau")] #' Save as data.frame to avoid data.table dependency. calibration_data <- as.data.frame(calibration_data) calibration_data_binned <- as.data.frame(calibration_data_binned) #' Further identification and verification data of run -git_hash <- system2("git", c("rev-parse", "HEAD"), stdout=TRUE) +git_hash <- system2("git", c("rev-parse", "HEAD"), stdout = TRUE) created <- Sys.time() -created_str <- format(created, "%F %T %Z", tz="UTC") +created_str <- format(created, "%F %T %Z", tz = "UTC") -calibration <- list(## raw=calibration_data, ## stop storing raw results, which are not needed for SBC reports - data=calibration_data_binned, - sampler_diagnostics = sampler_diagnostics, - S=S, - B=B, - git_hash=git_hash, - created=created) +calibration <- list( ## raw=calibration_data, ## stop storing raw results, which are not needed for SBC reports + data = calibration_data_binned, + sampler_diagnostics = sampler_diagnostics, + S = S, + B = B, + git_hash = git_hash, + created = created +) -saveRDS(calibration, file="calibration.rds") -saveRDS(calibration_data, file="calibration_data.rds") +saveRDS(calibration, file = "calibration.rds") +saveRDS(calibration_data, file = "calibration_data.rds") library(tools) md5 <- md5sum("calibration.rds") -cat(paste0("Created: ", created_str, "\ngit hash: ", git_hash, "\nMD5: ", md5, "\n"), file="calibration.md5") +cat(paste0("Created: ", created_str, "\ngit hash: ", git_hash, "\nMD5: ", md5, "\n"), file = "calibration.md5") #' #' Summarize execution time #' job_report <- calibration_data[c("job.id", "time.running", names(scenarios))] setDT(job_report) -job_report$time.running <- job_report$time.running / 60 ## convert to minutes +job_report$time.running <- job_report$time.running / 60 ## convert to minutes -runtime_by_problem_family <- job_report %>% - group_by(family, data_scenario) %>% - summarize(total=sum(time.running), mean=mean(time.running), max=max(time.running)) +runtime_by_problem_family <- job_report %>% + group_by(family, data_scenario) %>% + summarize(total = sum(time.running), mean = mean(time.running), max = max(time.running)) -runtime_by_problem <- job_report %>% - group_by(data_scenario) %>% - summarize(total=sum(time.running), mean=mean(time.running), max=max(time.running)) +runtime_by_problem <- job_report %>% + group_by(data_scenario) %>% + summarize(total = sum(time.running), mean = mean(time.running), max = max(time.running)) -runtime <- job_report %>% - group_by(family) %>% - summarize(total=sum(time.running), mean=mean(time.running), max=max(time.running)) +runtime <- job_report %>% + group_by(family) %>% + summarize(total = sum(time.running), mean = mean(time.running), max = max(time.running)) cat("Summary on job runtime on cluster:\n\n") cat("\nRuntime by problem and family:\n") -kable(runtime_by_problem_family, digits=2) +kable(runtime_by_problem_family, digits = 2) cat("\nRuntime by family:\n") -kable(runtime, digits=2) +kable(runtime, digits = 2) cat("\nRuntime by problem:\n") -kable(runtime_by_problem, digits=2) +kable(runtime_by_problem, digits = 2) end_time <- Sys.time() diff --git a/inst/sbc/sbc_report.R b/inst/sbc/sbc_report.R index 612afbc..859d24c 100644 --- a/inst/sbc/sbc_report.R +++ b/inst/sbc/sbc_report.R @@ -27,11 +27,11 @@ library(rstan) library(purrr) knitr::opts_chunk$set( - fig.width = 1.62*4, - fig.height = 4, - cache=FALSE, - echo=FALSE - ) + fig.width = 1.62 * 4, + fig.height = 4, + cache = FALSE, + echo = FALSE +) #' #' This report documents the results of a simulation based calibration #' (SBC) run for `RBesT`. The calibration data will be generated @@ -44,7 +44,7 @@ knitr::opts_chunk$set( #' #' The calibration data presented here has been generated at and with #' the `RBesT` git version as: -cat(readLines(here("inst", "sbc", "calibration.md5")), sep="\n") +cat(readLines(here("inst", "sbc", "calibration.md5")), sep = "\n") #' #' The MD5 hash of the calibration data file presented here must match #' the above listed MD5: @@ -111,8 +111,9 @@ md5sum(here("inst", "sbc", "calibration.rds")) calibration <- readRDS(here("inst", "sbc", "calibration.rds")) include_plots <- TRUE -if("params" %in% ls()) - include_plots <- params$include_plots +if ("params" %in% ls()) { + include_plots <- params$include_plots +} # The summary function we use here scales down the $L+1=1024$ bins to # smaller number of rank bins. This improves the number of counts @@ -122,24 +123,24 @@ if("params" %in% ls()) # of $2$ can be used to scale down the number of bins. plot_binned <- function(count, rank, group) { - S <- sum(count[group==group[1]]) - num_ranks <- length(rank[group==group[1]]) - c95 <- qbinom(c(0.025, 0.5, 0.975), S, 1/num_ranks) - dd <- arrange(data.frame(count=count, rank=rank, group=group, stringsAsFactors=FALSE), group, rank) %>% - group_by(group) %>% - mutate(ecdf=cumsum(count)/S, ecdf_ref=(rank+1)/(num_ranks)) %>% - separate(group, into=c("g1", "g2"), sep="/") - pl <- list() - pl[["hist"]] <- ggplot(dd, aes(rank, count)) + - facet_grid(g1~g2) + - geom_col() + - geom_hline(yintercept=c95[c(1,3)], linetype=I(2)) + - geom_hline(yintercept=c95[c(2)], linetype=I(3)) - pl[["ecdf_diff"]] <- ggplot(dd, aes(rank, ecdf-ecdf_ref)) + - facet_grid(g1~g2) + - geom_step() + - geom_hline(yintercept=0, linetype=I(3)) - pl + S <- sum(count[group == group[1]]) + num_ranks <- length(rank[group == group[1]]) + c95 <- qbinom(c(0.025, 0.5, 0.975), S, 1 / num_ranks) + dd <- arrange(data.frame(count = count, rank = rank, group = group, stringsAsFactors = FALSE), group, rank) %>% + group_by(group) %>% + mutate(ecdf = cumsum(count) / S, ecdf_ref = (rank + 1) / (num_ranks)) %>% + separate(group, into = c("g1", "g2"), sep = "/") + pl <- list() + pl[["hist"]] <- ggplot(dd, aes(rank, count)) + + facet_grid(g1 ~ g2) + + geom_col() + + geom_hline(yintercept = c95[c(1, 3)], linetype = I(2)) + + geom_hline(yintercept = c95[c(2)], linetype = I(3)) + pl[["ecdf_diff"]] <- ggplot(dd, aes(rank, ecdf - ecdf_ref)) + + facet_grid(g1 ~ g2) + + geom_step() + + geom_hline(yintercept = 0, linetype = I(3)) + pl } @@ -147,40 +148,40 @@ B <- calibration$B S <- calibration$S calibration_binned <- calibration$data %>% - unite(family, sd_tau, col="group", sep="/") %>% - group_by(data_scenario, group) + unite(family, sd_tau, col = "group", sep = "/") %>% + group_by(data_scenario, group) -calibration_binned <- calibration_binned %>% - gather(starts_with("count"), key="parameter", value="count") %>% - mutate(parameter=sub("^count.", "", parameter)) +calibration_binned <- calibration_binned %>% + gather(starts_with("count"), key = "parameter", value = "count") %>% + mutate(parameter = sub("^count.", "", parameter)) ## filter out cases where count == 0 for all entries of the parameters ## (happens due the way data is processed for the sparse cases) -calibration_binned <- calibration_binned %>% - group_by(data_scenario, group, parameter) %>% - mutate(all_zero=all(count == 0)) %>% - ungroup() %>% - subset(!all_zero) %>% - mutate(all_zero=NULL) +calibration_binned <- calibration_binned %>% + group_by(data_scenario, group, parameter) %>% + mutate(all_zero = all(count == 0)) %>% + ungroup() %>% + subset(!all_zero) %>% + mutate(all_zero = NULL) -calibration_dense <- subset(calibration_binned, data_scenario=="dense") -calibration_sparse <- subset(calibration_binned, data_scenario=="sparse") +calibration_dense <- subset(calibration_binned, data_scenario == "dense") +calibration_sparse <- subset(calibration_binned, data_scenario == "sparse") -pl_dense <- calibration_dense %>% - split(.$parameter) %>% - map(~ plot_binned(.$count, .$rank, .$group)) +pl_dense <- calibration_dense %>% + split(.$parameter) %>% + map(~ plot_binned(.$count, .$rank, .$group)) -pl_sparse <- calibration_sparse %>% - split(.$parameter) %>% - map(~ plot_binned(.$count, .$rank, .$group)) +pl_sparse <- calibration_sparse %>% + split(.$parameter) %>% + map(~ plot_binned(.$count, .$rank, .$group)) #' # SBC results #' #' ## Sampler Diagnostics Overview #' -kable(calibration$sampler_diagnostics, digits=3) +kable(calibration$sampler_diagnostics, digits = 3) #' #' Note: Large Rhat is defined as exceeding 1.2. @@ -192,26 +193,26 @@ kable(calibration$sampler_diagnostics, digits=3) #' ## $\chi^2$ Statistic, $\mu$ #' -chisq <- calibration_binned %>% - group_by(data_scenario, group, parameter) %>% - group_map( ~cbind(case=.y, tidy(chisq.test(.$count))[,c(1,3,2)]) ) %>% - bind_rows() %>% - rename(df=parameter, data_scenario=case.data_scenario, group=case.group, parameter=case.parameter) %>% - separate(group, into=c("likelihood", "sd_tau"), sep="/") +chisq <- calibration_binned %>% + group_by(data_scenario, group, parameter) %>% + group_map(~ cbind(case = .y, tidy(chisq.test(.$count))[, c(1, 3, 2)])) %>% + bind_rows() %>% + rename(df = parameter, data_scenario = case.data_scenario, group = case.group, parameter = case.parameter) %>% + separate(group, into = c("likelihood", "sd_tau"), sep = "/") -kable(subset(chisq, parameter=="mu"), digits=3) +kable(subset(chisq, parameter == "mu"), digits = 3) #' #' ## $\chi^2$ Statistic, $\tau$ #' -kable(subset(chisq, parameter=="tau"), digits=3) +kable(subset(chisq, parameter == "tau"), digits = 3) #' #' ## $\chi^2$ Statistic, group estimates $\theta$ #' -kable(subset(chisq, parameter!="tau" & parameter!="mu"), digits=3) +kable(subset(chisq, parameter != "tau" & parameter != "mu"), digits = 3) #+ results="asis", include=include_plots, eval=include_plots spin_child("sbc_report_plots.R") @@ -220,4 +221,3 @@ spin_child("sbc_report_plots.R") #' ## Session Info #' sessionInfo() - diff --git a/inst/sbc/sbc_report_plots.R b/inst/sbc/sbc_report_plots.R index 368a303..45e3e98 100644 --- a/inst/sbc/sbc_report_plots.R +++ b/inst/sbc/sbc_report_plots.R @@ -30,4 +30,3 @@ print(pl_sparse$mu$ecdf_diff) print(pl_sparse$tau$hist) print(pl_sparse$tau$ecdf_diff) - diff --git a/inst/sbc/sbc_tools.R b/inst/sbc/sbc_tools.R index db65eb4..88e9a54 100644 --- a/inst/sbc/sbc_tools.R +++ b/inst/sbc/sbc_tools.R @@ -2,28 +2,28 @@ #' Utilities for SBC validation #' load_rbest_dev <- function() { - if(rbest_lib_dir != .libPaths()[1]) { - cat("Unloading RBesT and setting libPaths to dev RBesT install.\n") - unloadNamespace("RBesT") - .libPaths(c(rbest_lib_dir, .libPaths())) - } - if(!("RBesT" %in% .packages())) { - require(RBesT, lib.loc=rbest_lib_dir) - } + if (rbest_lib_dir != .libPaths()[1]) { + cat("Unloading RBesT and setting libPaths to dev RBesT install.\n") + unloadNamespace("RBesT") + .libPaths(c(rbest_lib_dir, .libPaths())) + } + if (!("RBesT" %in% .packages())) { + require(RBesT, lib.loc = rbest_lib_dir) + } } setup_lecuyer_seeds <- function(lecuyer_seed, num) { - ## note: seed have the format from L'Ecuyer. Just set - ## RNGkind("L'Ecuyer-CMRG") - ## and then use .Random.seed - job_seeds <- list() - job_seeds[[1]] <- parallel::nextRNGStream(lecuyer_seed) - i <- 2 - while(i < num+1) { - job_seeds[[i]] <- parallel::nextRNGSubStream(job_seeds[[i-1]]) - i <- i + 1 - } - job_seeds + ## note: seed have the format from L'Ecuyer. Just set + ## RNGkind("L'Ecuyer-CMRG") + ## and then use .Random.seed + job_seeds <- list() + job_seeds[[1]] <- parallel::nextRNGStream(lecuyer_seed) + i <- 2 + while (i < num + 1) { + job_seeds[[i]] <- parallel::nextRNGSubStream(job_seeds[[i - 1]]) + i <- i + 1 + } + job_seeds } #' @@ -33,35 +33,37 @@ setup_lecuyer_seeds <- function(lecuyer_seed, num) { #' determine the scenario (choices for the prior). #' simulate_fake <- function(data, family, mean_mu, sd_mu, sd_tau, samp_sd) { - G <- length(unique(data$group)) - N <- length(data$group) - rl <- rle(data$group) - Ng <- rl$lengths - mu <- rnorm(1, mean_mu, sd_mu) - tau <- abs(rnorm(1, 0, sd_tau)) - theta <- rnorm(G, mu, tau) - family <- get(family, mode = "function", envir = parent.frame()) - inv_link <- family()$linkinv - alpha <- inv_link(rep(theta, times=Ng)) - likelihood <- family()$family - if (likelihood == "binomial") { - r <- rbinom(N, 1, alpha) - y <- as.numeric(tapply(r, data$group, sum)) - fake <- data.frame(r=y, nr=Ng-y, group=1:G) - } - if (likelihood == "poisson") { - count <- rpois(N, alpha) - y <- as.numeric(tapply(count, data$group, sum)) - fake <- data.frame(y=y, n=Ng, group=1:G) - } - if (likelihood == "gaussian") { - y_i <- rnorm(N, alpha, samp_sd) - y <- as.numeric(tapply(y_i, data$group, mean)) - fake <- data.frame(y=y, y_se=samp_sd/sqrt(Ng), group=1:G) - } - list(fake=fake, - draw=c(mu=mu, tau=tau), - draw_theta=theta) + G <- length(unique(data$group)) + N <- length(data$group) + rl <- rle(data$group) + Ng <- rl$lengths + mu <- rnorm(1, mean_mu, sd_mu) + tau <- abs(rnorm(1, 0, sd_tau)) + theta <- rnorm(G, mu, tau) + family <- get(family, mode = "function", envir = parent.frame()) + inv_link <- family()$linkinv + alpha <- inv_link(rep(theta, times = Ng)) + likelihood <- family()$family + if (likelihood == "binomial") { + r <- rbinom(N, 1, alpha) + y <- as.numeric(tapply(r, data$group, sum)) + fake <- data.frame(r = y, nr = Ng - y, group = 1:G) + } + if (likelihood == "poisson") { + count <- rpois(N, alpha) + y <- as.numeric(tapply(count, data$group, sum)) + fake <- data.frame(y = y, n = Ng, group = 1:G) + } + if (likelihood == "gaussian") { + y_i <- rnorm(N, alpha, samp_sd) + y <- as.numeric(tapply(y_i, data$group, mean)) + fake <- data.frame(y = y, y_se = samp_sd / sqrt(Ng), group = 1:G) + } + list( + fake = fake, + draw = c(mu = mu, tau = tau), + draw_theta = theta + ) } #' @@ -72,94 +74,102 @@ simulate_fake <- function(data, family, mean_mu, sd_mu, sd_tau, samp_sd) { #' fit_rbest <- function(fake, draw, draw_theta, family, prior_mean_mu, prior_sd_mu, prior_sd_tau, samp_sd) { - Ng <- length(draw_theta) - - ##pars <- job$pars$prob.pars - ##prior_mean_mu <- pars$mean_mu - ##prior_sd_mu <- pars$sd_mu - ##prior_sd_tau <- pars$sd_tau - ##samp_sd <- pars$samp_sd - ##family <- pars$family - - model <- switch(family, - binomial=cbind(r, nr) ~ 1 | group, - poisson=y ~ 1 + offset(log(n)) | group, - gaussian=cbind(y, y_se) ~ 1 | group) - - options(RBesT.MC.warmup=2000, RBesT.MC.iter=4000, RBesT.MC.thin=1, RBesT.MC.init=0.1, - RBesT.MC.control=list(##adapt_delta=0.999, ## 2024-11-21 lowered to 0.95 for the sake of performance - adapt_delta=0.95, - stepsize=0.01, max_treedepth=10, - adapt_init_buffer=100, adapt_term_buffer=300)) - - if(Ng > 5) { - ## for the dense case we can be a bit less aggressive with the sampling tuning parameters - options(RBesT.MC.control=list(##adapt_delta=0.95, - adapt_delta=0.90, - stepsize=0.01, max_treedepth=10, - adapt_init_buffer=100, adapt_term_buffer=300)) - } - fit <- gMAP(model, data=fake, family=family, - tau.dist="HalfNormal", - tau.prior=cbind(0, prior_sd_tau), - beta.prior=cbind(c(prior_mean_mu),c(prior_sd_mu)), - chains=2) - - params <- c("beta[1]", "tau[1]") - params_group <- paste0("theta[", 1:Ng, "]") - - sampler_params <- rstan::get_sampler_params(fit$fit, inc_warmup=FALSE) - n_divergent <- sum(sapply(sampler_params, function(x) sum(x[,'divergent__'])) ) - - fit_sum <- rstan::summary(fit$fit)$summary - samp_diags <- fit_sum[params, c("n_eff", "Rhat")] - min_Neff <- ceiling(min(samp_diags[, "n_eff"], na.rm=TRUE)) - max_Rhat <- max(samp_diags[, "Rhat"], na.rm=TRUE) - - lp_ess <- as.numeric(rstan::monitor(as.array(fit$fit, pars="lp__"), print=FALSE)[1, c("Bulk_ESS", "Tail_ESS")]) - - post <- as.matrix(fit)[,params] - post_group <- as.matrix(fit)[,params_group] - S <- nrow(post) - ## thin down to 1023 draws so that we get 1024 bins - idx <- round(seq(1, S, length=1024-1)) - post <- post[idx,] - post_group <- post_group[idx,] - colnames(post) <- c("mu", "tau") - unlist(list(rank=c(colSums(sweep(post, 2, draw) < 0), colSums(sweep(post_group, 2, draw_theta) < 0)), - min_Neff = min_Neff, - n_divergent = n_divergent, - max_Rhat = max_Rhat, - lp_ess_bulk = lp_ess[1], - lp_ess_tail = lp_ess[2])) + Ng <- length(draw_theta) + + ## pars <- job$pars$prob.pars + ## prior_mean_mu <- pars$mean_mu + ## prior_sd_mu <- pars$sd_mu + ## prior_sd_tau <- pars$sd_tau + ## samp_sd <- pars$samp_sd + ## family <- pars$family + + model <- switch(family, + binomial = cbind(r, nr) ~ 1 | group, + poisson = y ~ 1 + offset(log(n)) | group, + gaussian = cbind(y, y_se) ~ 1 | group + ) + + options( + RBesT.MC.warmup = 2000, RBesT.MC.iter = 4000, RBesT.MC.thin = 1, RBesT.MC.init = 0.1, + RBesT.MC.control = list( ## adapt_delta=0.999, ## 2024-11-21 lowered to 0.95 for the sake of performance + adapt_delta = 0.95, + stepsize = 0.01, max_treedepth = 10, + adapt_init_buffer = 100, adapt_term_buffer = 300 + ) + ) + + if (Ng > 5) { + ## for the dense case we can be a bit less aggressive with the sampling tuning parameters + options(RBesT.MC.control = list( ## adapt_delta=0.95, + adapt_delta = 0.90, + stepsize = 0.01, max_treedepth = 10, + adapt_init_buffer = 100, adapt_term_buffer = 300 + )) + } + fit <- gMAP(model, + data = fake, family = family, + tau.dist = "HalfNormal", + tau.prior = cbind(0, prior_sd_tau), + beta.prior = cbind(c(prior_mean_mu), c(prior_sd_mu)), + chains = 2 + ) + + params <- c("beta[1]", "tau[1]") + params_group <- paste0("theta[", 1:Ng, "]") + + sampler_params <- rstan::get_sampler_params(fit$fit, inc_warmup = FALSE) + n_divergent <- sum(sapply(sampler_params, function(x) sum(x[, "divergent__"]))) + + fit_sum <- rstan::summary(fit$fit)$summary + samp_diags <- fit_sum[params, c("n_eff", "Rhat")] + min_Neff <- ceiling(min(samp_diags[, "n_eff"], na.rm = TRUE)) + max_Rhat <- max(samp_diags[, "Rhat"], na.rm = TRUE) + + lp_ess <- as.numeric(rstan::monitor(as.array(fit$fit, pars = "lp__"), print = FALSE)[1, c("Bulk_ESS", "Tail_ESS")]) + + post <- as.matrix(fit)[, params] + post_group <- as.matrix(fit)[, params_group] + S <- nrow(post) + ## thin down to 1023 draws so that we get 1024 bins + idx <- round(seq(1, S, length = 1024 - 1)) + post <- post[idx, ] + post_group <- post_group[idx, ] + colnames(post) <- c("mu", "tau") + unlist(list( + rank = c(colSums(sweep(post, 2, draw) < 0), colSums(sweep(post_group, 2, draw_theta) < 0)), + min_Neff = min_Neff, + n_divergent = n_divergent, + max_Rhat = max_Rhat, + lp_ess_bulk = lp_ess[1], + lp_ess_tail = lp_ess[2] + )) } -scale_ranks <- function(Nbins, scale=1) { - ## scale must evenly divide the total number of bins - assert_that(round(Nbins/scale) == Nbins/scale) - breaks <- (0:(Nbins/scale)) - Nbreaks <- length(breaks) - function(scen) { - vars <- grep("^rank.", names(scen), value=TRUE) - res <- lapply(vars, function(v) hist(ceiling((scen[[v]]+1)/scale), breaks=breaks, plot=FALSE, include.lowest=FALSE)$counts) - names(res) <- gsub("^rank", "count", vars) - res$rank <- breaks[-Nbreaks] - res <- as.data.frame(do.call(cbind, res)) - res - } +scale_ranks <- function(Nbins, scale = 1) { + ## scale must evenly divide the total number of bins + assert_that(round(Nbins / scale) == Nbins / scale) + breaks <- (0:(Nbins / scale)) + Nbreaks <- length(breaks) + function(scen) { + vars <- grep("^rank.", names(scen), value = TRUE) + res <- lapply(vars, function(v) hist(ceiling((scen[[v]] + 1) / scale), breaks = breaks, plot = FALSE, include.lowest = FALSE)$counts) + names(res) <- gsub("^rank", "count", vars) + res$rank <- breaks[-Nbreaks] + res <- as.data.frame(do.call(cbind, res)) + res + } } run_sbc_case <- function(job.id, repl, data_scenario, family, mean_mu, sd_mu, sd_tau, samp_sd, base_scenarios, seeds) { - RNGkind("L'Ecuyer-CMRG") - .Random.seed <<- seeds[[job.id]] - - runtime <- system.time({ - suppressMessages(load_rbest_dev()) - data <- base_scenarios[[data_scenario]] - fake <- simulate_fake(data, family, mean_mu, sd_mu, sd_tau, samp_sd) - fit <- fit_rbest(fake$fake, fake$draw, fake$draw_theta, family, mean_mu, sd_mu, sd_tau, samp_sd) - }) - c(list(job.id=job.id, time.running=runtime["elapsed"]), fit) + RNGkind("L'Ecuyer-CMRG") + .Random.seed <<- seeds[[job.id]] + + runtime <- system.time({ + suppressMessages(load_rbest_dev()) + data <- base_scenarios[[data_scenario]] + fake <- simulate_fake(data, family, mean_mu, sd_mu, sd_tau, samp_sd) + fit <- fit_rbest(fake$fake, fake$draw, fake$draw_theta, family, mean_mu, sd_mu, sd_tau, samp_sd) + }) + c(list(job.id = job.id, time.running = runtime["elapsed"]), fit) } - diff --git a/inst/stan/gMAP.stan b/inst/stan/gMAP.stan index b9bcc4d..39d07b5 100644 --- a/inst/stan/gMAP.stan +++ b/inst/stan/gMAP.stan @@ -5,58 +5,58 @@ data { // number of input historical trials int H; - + // link function (1=normal, 2=binary, 3=poisson) - int link; - + int link; + // normal data, link=identity=1 vector[H] y; vector[H] y_se; // binomial data, link=logit=2 - array[H] int r; - array[H] int r_n; - + array[H] int r; + array[H] int r_n; + // count data, link=log=3 array[H] int count; - vector[H] log_offset; - + vector[H] log_offset; + // exchangeability cluster mapping int n_groups; - array[H] int group_index; - + array[H] int group_index; + // tau prediction stratum - int n_tau_strata; - int tau_strata_pred; + int n_tau_strata; + int tau_strata_pred; // data item to tau stratum mapping - array[H] int tau_strata_index; - + array[H] int tau_strata_index; + // number of predictors int mX; // design matrix - matrix[H,mX] X; + matrix[H, mX] X; // design matrix prediction (not used, only intercept prediction) //matrix[H,mX] Xpred; - + // priors - matrix[mX,2] beta_prior; - matrix[n_tau_strata,2] tau_prior; - + matrix[mX, 2] beta_prior; + matrix[n_tau_strata, 2] tau_prior; + // model user choices - int tau_prior_dist; - int re_dist; + int tau_prior_dist; + int re_dist; real re_dist_t_df; - + // ncp parametrization? - int ncp; - + int ncp; + // guesses on the parameter location and scales array[2] vector[mX] beta_raw_guess; - array[2] real tau_raw_guess; - + array[2] real tau_raw_guess; + // sample from prior predictive (do not add data to likelihood) - int prior_PD; + int prior_PD; } transformed data { array[2] vector[mX] beta_prior_stan; @@ -65,19 +65,20 @@ transformed data { //matrix[H, n_groups] Z; matrix[H, mX] X_param; // group index to tau stratum mapping - array[n_groups] int tau_strata_gindex = rep_array(tau_strata_pred, n_groups); - - for (i in 1:mX) { - beta_prior_stan[1,i] = beta_prior[i,1]; - beta_prior_stan[2,i] = beta_prior[i,2]; + array[n_groups] int tau_strata_gindex = rep_array(tau_strata_pred, + n_groups); + + for (i in 1 : mX) { + beta_prior_stan[1, i] = beta_prior[i, 1]; + beta_prior_stan[2, i] = beta_prior[i, 2]; } - for (i in 1:n_tau_strata) { - tau_prior_stan[1,i] = tau_prior[i,1]; - tau_prior_stan[2,i] = tau_prior[i,2]; + for (i in 1 : n_tau_strata) { + tau_prior_stan[1, i] = tau_prior[i, 1]; + tau_prior_stan[2, i] = tau_prior[i, 2]; } - for (i in 1:H) { + for (i in 1 : H) { tau_strata_gindex[group_index[i]] = tau_strata_index[i]; } @@ -94,122 +95,167 @@ transformed data { */ print("Stan gMAP analysis"); - - if(link == 1) print("likelihood: Normal (identity link)"); - if(link == 2) print("likelihood: Binomial (logit link)"); - if(link == 3) print("likelihood: Poisson (log link)"); - - if(tau_prior_dist == -1) print("tau distrib.: Fixed"); - if(tau_prior_dist == 0) print("tau distrib.: HalfNormal"); - if(tau_prior_dist == 1) print("tau distrib.: TruncNormal"); - if(tau_prior_dist == 2) print("tau distrib.: Uniform"); - if(tau_prior_dist == 3) print("tau distrib.: Gamma"); - if(tau_prior_dist == 4) print("tau distrib.: InvGamma"); - if(tau_prior_dist == 5) print("tau distrib.: LogNormal"); - if(tau_prior_dist == 6) print("tau distrib.: TruncCauchy"); - if(tau_prior_dist == 7) print("tau distrib.: Exponential"); - - if(re_dist == 0) print("random effects: Normal"); - if(re_dist == 1) print("random effects: Student-t, df = ", re_dist_t_df); - - if(ncp) { + + if (link == 1) + print("likelihood: Normal (identity link)"); + if (link == 2) + print("likelihood: Binomial (logit link)"); + if (link == 3) + print("likelihood: Poisson (log link)"); + + if (tau_prior_dist == -1) + print("tau distrib.: Fixed"); + if (tau_prior_dist == 0) + print("tau distrib.: HalfNormal"); + if (tau_prior_dist == 1) + print("tau distrib.: TruncNormal"); + if (tau_prior_dist == 2) + print("tau distrib.: Uniform"); + if (tau_prior_dist == 3) + print("tau distrib.: Gamma"); + if (tau_prior_dist == 4) + print("tau distrib.: InvGamma"); + if (tau_prior_dist == 5) + print("tau distrib.: LogNormal"); + if (tau_prior_dist == 6) + print("tau distrib.: TruncCauchy"); + if (tau_prior_dist == 7) + print("tau distrib.: Exponential"); + + if (re_dist == 0) + print("random effects: Normal"); + if (re_dist == 1) + print("random effects: Student-t, df = ", re_dist_t_df); + + if (ncp) { X_param = X; print("parametrization: Non-Centered"); } else { print("parametrization: Centered"); X_param = X; - for (i in 1:H) { - if(X_param[i,1] != 1) + for (i in 1 : H) { + if (X_param[i, 1] != 1) reject("Centered parametrization requires treatment contrast parametrization!"); - X_param[i,1] = 0; + X_param[i, 1] = 0; } } - if(prior_PD) + if (prior_PD) print("Info: Sampling from prior predictive distribution."); } parameters { - vector[mX] beta_raw; + vector[mX] beta_raw; vector[n_tau_strata] tau_raw; - vector[n_groups] xi_eta; + vector[n_groups] xi_eta; } transformed parameters { vector[H] theta; vector[mX] beta; vector[n_tau_strata] tau; - + beta = beta_raw_guess[1] + beta_raw_guess[2] .* beta_raw; - + // fixed tau distribution ignores raw_tau - if(tau_prior_dist == -1) + if (tau_prior_dist == -1) tau = tau_prior_stan[1]; - else + else tau = exp(tau_raw_guess[1] + tau_raw_guess[2] * tau_raw); - + // expand random effect to groups in loop for performance reasons - if(ncp) { - if(n_tau_strata == 1) { + if (ncp) { + if (n_tau_strata == 1) { // most common case of just one stratum which simplifies things // and in ncp mode - for(h in 1:H) { - theta[h] = X_param[h] * beta + xi_eta[ group_index[h] ] * tau[1]; + for (h in 1 : H) { + theta[h] = X_param[h] * beta + xi_eta[group_index[h]] * tau[1]; } } else { - for(h in 1:H) { - theta[h] = X_param[h] * beta + xi_eta[ group_index[h] ] * tau[ tau_strata_gindex[ group_index[h] ] ]; + for (h in 1 : H) { + theta[h] = X_param[h] * beta + + xi_eta[group_index[h]] + * tau[tau_strata_gindex[group_index[h]]]; } } } else { - for(h in 1:H) { - theta[h] = X_param[h] * beta + beta_raw_guess[1,1] + beta_raw_guess[2,1] * xi_eta[ group_index[h] ]; + for (h in 1 : H) { + theta[h] = X_param[h] * beta + beta_raw_guess[1, 1] + + beta_raw_guess[2, 1] * xi_eta[group_index[h]]; } } } model { if (ncp) { // standardized random effect distribution (aka Matt trick) - if(re_dist == 0) xi_eta ~ normal( 0, 1); - if(re_dist == 1) xi_eta ~ student_t(re_dist_t_df, 0, 1); + if (re_dist == 0) + xi_eta ~ normal(0, 1); + if (re_dist == 1) + xi_eta ~ student_t(re_dist_t_df, 0, 1); } else { // random effect distribution - if(re_dist == 0) xi_eta ~ normal( (beta[1] - beta_raw_guess[1,1])/beta_raw_guess[2,1], tau[tau_strata_gindex] / beta_raw_guess[2,1]); - if(re_dist == 1) xi_eta ~ student_t(re_dist_t_df, (beta[1] - beta_raw_guess[1,1])/beta_raw_guess[2,1], tau[tau_strata_gindex] / beta_raw_guess[2,1]); + if (re_dist == 0) + xi_eta ~ normal((beta[1] - beta_raw_guess[1, 1]) / beta_raw_guess[2, 1], + tau[tau_strata_gindex] / beta_raw_guess[2, 1]); + if (re_dist == 1) + xi_eta ~ student_t(re_dist_t_df, + (beta[1] - beta_raw_guess[1, 1]) + / beta_raw_guess[2, 1], + tau[tau_strata_gindex] / beta_raw_guess[2, 1]); } - + // assign priors to coefficients beta ~ normal(beta_prior_stan[1], beta_prior_stan[2]); - + // fixed (needs fake assignment) - if(tau_prior_dist == -1) tau_raw ~ normal( 0, 1); + if (tau_prior_dist == -1) + tau_raw ~ normal(0, 1); // half-normal - if(tau_prior_dist == 0) tau ~ normal( 0, tau_prior_stan[2]); + if (tau_prior_dist == 0) + tau ~ normal(0, tau_prior_stan[2]); // truncated normal - if(tau_prior_dist == 1) tau ~ normal( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 2) tau ~ uniform( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 3) tau ~ gamma( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 4) tau ~ inv_gamma( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 5) tau ~ lognormal( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 6) tau ~ cauchy( tau_prior_stan[1], tau_prior_stan[2]); - if(tau_prior_dist == 7) tau ~ exponential(tau_prior_stan[1]); - + if (tau_prior_dist == 1) + tau ~ normal(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 2) + tau ~ uniform(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 3) + tau ~ gamma(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 4) + tau ~ inv_gamma(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 5) + tau ~ lognormal(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 6) + tau ~ cauchy(tau_prior_stan[1], tau_prior_stan[2]); + if (tau_prior_dist == 7) + tau ~ exponential(tau_prior_stan[1]); + // add Jacobian adjustement due to shifting and transforming tau_raw - if(tau_prior_dist != -1) target += tau_raw_guess[2] * tau_raw; + if (tau_prior_dist != -1) + target += tau_raw_guess[2] * tau_raw; // finally compute data-likelihood - if(!prior_PD) { - if(link == 1) y ~ normal( theta, y_se); - if(link == 2) r ~ binomial_logit(r_n, theta); - if(link == 3) count ~ poisson_log(log_offset + theta); + if (!prior_PD) { + if (link == 1) + y ~ normal(theta, y_se); + if (link == 2) + r ~ binomial_logit(r_n, theta); + if (link == 3) + count ~ poisson_log(log_offset + theta); } } generated quantities { real theta_pred; real theta_resp_pred; - + // make intercept only prediction - if(re_dist == 0) theta_pred = normal_rng( beta[1], tau[tau_strata_pred]); - if(re_dist == 1) theta_pred = student_t_rng(re_dist_t_df, beta[1], tau[tau_strata_pred]); - - if(link == 1) theta_resp_pred = theta_pred; - if(link == 2) theta_resp_pred = inv_logit(theta_pred); - if(link == 3) theta_resp_pred = exp( theta_pred); + if (re_dist == 0) + theta_pred = normal_rng(beta[1], tau[tau_strata_pred]); + if (re_dist == 1) + theta_pred = student_t_rng(re_dist_t_df, beta[1], tau[tau_strata_pred]); + + if (link == 1) + theta_resp_pred = theta_pred; + if (link == 2) + theta_resp_pred = inv_logit(theta_pred); + if (link == 3) + theta_resp_pred = exp(theta_pred); } + + diff --git a/inst/stan/include/copyright_novartis.stan b/inst/stan/include/copyright_novartis.stan index 2bdc1ae..4e8b4f0 100644 --- a/inst/stan/include/copyright_novartis.stan +++ b/inst/stan/include/copyright_novartis.stan @@ -1,2 +1,2 @@ // This file is part of RBesT. -// Copyright (C) 2017 Novartis Pharma AG +// Copyright (C) 2024 Novartis Pharma AG diff --git a/man/AS.Rd b/man/AS.Rd index a6f1372..ecb9542 100644 --- a/man/AS.Rd +++ b/man/AS.Rd @@ -29,11 +29,12 @@ Society criteria for improvement (ASAS20) at week 6. RBesT.MC.chains=2, RBesT.MC.thin=1) set.seed(34563) -map_AS <- gMAP(cbind(r, n-r) ~ 1 | study, - family=binomial, - data=AS, - tau.dist="HalfNormal", tau.prior=1, - beta.prior=2) +map_AS <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = AS, + tau.dist = "HalfNormal", tau.prior = 1, + beta.prior = 2 +) ## Recover user set sampling defaults options(.user_mc_options) diff --git a/man/BinaryExactCI.Rd b/man/BinaryExactCI.Rd index e315295..1d0ddc8 100644 --- a/man/BinaryExactCI.Rd +++ b/man/BinaryExactCI.Rd @@ -24,14 +24,14 @@ This function calculates the exact confidendence interval for a response rate presented by \eqn{n} and \eqn{r}. } \details{ -Confidence intervals are obtained by a procedure first given in -Clopper and Pearson (1934). This guarantees that the confidence +Confidence intervals are obtained by a procedure first given in +Clopper and Pearson (1934). This guarantees that the confidence level is at least (1-\eqn{\alpha}). Details can be found in the publication listed below. } \examples{ -BinaryExactCI(3,20,0.05) +BinaryExactCI(3, 20, 0.05) } \references{ diff --git a/man/automixfit.Rd b/man/automixfit.Rd index 63d57a4..5aba0be 100644 --- a/man/automixfit.Rd +++ b/man/automixfit.Rd @@ -48,19 +48,18 @@ complex models. To favor mixtures with fewer components a value of } \examples{ # random sample of size 1000 from a mixture of 2 beta components -bm <- mixbeta(beta1=c(0.4, 20, 90), beta2=c(0.6, 35, 65)) +bm <- mixbeta(beta1 = c(0.4, 20, 90), beta2 = c(0.6, 35, 65)) bmSamp <- rmix(bm, 1000) # fit with EM mixture models with up to 10 components and stop if # AIC increases -bmFit <- automixfit(bmSamp, Nc=1:10, thresh=0, type="beta") +bmFit <- automixfit(bmSamp, Nc = 1:10, thresh = 0, type = "beta") bmFit # advanced usage: find out about all discarded models bmFitAll <- attr(bmFit, "models") -sapply(bmFitAll, AIC, k=6) - +sapply(bmFitAll, AIC, k = 6) } \references{ diff --git a/man/crohn.Rd b/man/crohn.Rd index e19987e..e1f32b8 100644 --- a/man/crohn.Rd +++ b/man/crohn.Rd @@ -30,11 +30,12 @@ from baseline endpoint is approximately 88. set.seed(546346) map_crohn <- gMAP(cbind(y, y.se) ~ 1 | study, - family=gaussian, - data=transform(crohn, y.se=88/sqrt(n)), - weights=n, - tau.dist="HalfNormal", tau.prior=44, - beta.prior=cbind(0,88)) + family = gaussian, + data = transform(crohn, y.se = 88 / sqrt(n)), + weights = n, + tau.dist = "HalfNormal", tau.prior = 44, + beta.prior = cbind(0, 88) +) ## Recover user set sampling defaults options(.user_mc_options) diff --git a/man/decision1S.Rd b/man/decision1S.Rd index dbdc976..3f2b3f5 100644 --- a/man/decision1S.Rd +++ b/man/decision1S.Rd @@ -76,18 +76,18 @@ s <- 2 theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 -za <- qnorm(1-alpha) -zb <- qnorm(1-beta) -n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) # n for which design was intended +beta <- 0.2 +za <- qnorm(1 - alpha) +zb <- qnorm(1 - beta) +n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) # n for which design was intended nL <- 233 c1 <- theta_ni - za * s / sqrt(n1) # flat prior -flat_prior <- mixnorm(c(1,0,100), sigma=s) +flat_prior <- mixnorm(c(1, 0, 100), sigma = s) # standard NI design -decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) +decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) # for double criterion with indecision point (mean estimate must be # lower than this) @@ -95,13 +95,13 @@ theta_c <- c1 # double criterion design # statistical significance (like NI design) -dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) # require mean to be at least as good as theta_c -dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) # combination -decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) -theta_eval <- c(theta_a, theta_c, theta_ni) +theta_eval <- c(theta_a, theta_c, theta_ni) # we can display the decision function definition decComb @@ -112,8 +112,7 @@ decComb decComb(flat_prior) # or for a possible outcome of the trial # here with HR of 0.8 for 40 events -decComb(postmix(flat_prior, m=log(0.8), n=40)) - +decComb(postmix(flat_prior, m = log(0.8), n = 40)) } \references{ diff --git a/man/decision1S_boundary.Rd b/man/decision1S_boundary.Rd index 7cc2e93..af68aab 100644 --- a/man/decision1S_boundary.Rd +++ b/man/decision1S_boundary.Rd @@ -91,24 +91,24 @@ the boundary is searched for \eqn{y}. # non-inferiority example using normal approximation of log-hazard # ratio, see ?decision1S for all details s <- 2 -flat_prior <- mixnorm(c(1,0,100), sigma=s) +flat_prior <- mixnorm(c(1, 0, 100), sigma = s) nL <- 233 theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 -za <- qnorm(1-alpha) -zb <- qnorm(1-beta) -n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +beta <- 0.2 +za <- qnorm(1 - alpha) +zb <- qnorm(1 - beta) +n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) theta_c <- theta_ni - za * s / sqrt(n1) # double criterion design # statistical significance (like NI design) -dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) # require mean to be at least as good as theta_c -dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) # combination -decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) # critical value of double criterion design decision1S_boundary(flat_prior, nL, decComb) diff --git a/man/decision2S.Rd b/man/decision2S.Rd index 11d4cd9..874af75 100644 --- a/man/decision2S.Rd +++ b/man/decision2S.Rd @@ -91,32 +91,32 @@ quantiles \code{qc} must be given on the transformed scale. \examples{ # see Gsponer et al., 2010 -priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") # the success criteria is for delta which are larger than some # threshold value which is why we set lower.tail=FALSE -successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) # the futility criterion acts in the opposite direction -futilityCrit <- decision2S(c(0.90) , c(40), TRUE) +futilityCrit <- decision2S(c(0.90), c(40), TRUE) print(successCrit) print(futilityCrit) # consider decision for specific outcomes -postP_interim <- postmix(priorP, n=10, m=-50) -postT_interim <- postmix(priorT, n=20, m=-80) -futilityCrit( postP_interim, postT_interim ) -successCrit( postP_interim, postT_interim ) +postP_interim <- postmix(priorP, n = 10, m = -50) +postT_interim <- postmix(priorT, n = 20, m = -80) +futilityCrit(postP_interim, postT_interim) +successCrit(postP_interim, postT_interim) # Binary endpoint with double criterion decision on log-odds scale # 95\% certain positive difference and an odds ratio of 2 at least -decL2 <- decision2S(c(0.95, 0.5), c(0, log(2)), lower.tail=FALSE, link="logit") +decL2 <- decision2S(c(0.95, 0.5), c(0, log(2)), lower.tail = FALSE, link = "logit") # 95\% certain positive difference and an odds ratio of 3 at least -decL3 <- decision2S(c(0.95, 0.5), c(0, log(3)), lower.tail=FALSE, link="logit") +decL3 <- decision2S(c(0.95, 0.5), c(0, log(3)), lower.tail = FALSE, link = "logit") # data scenario -post1 <- postmix(mixbeta(c(1, 1, 1)), n=40, r=10) -post2 <- postmix(mixbeta(c(1, 1, 1)), n=40, r=18) +post1 <- postmix(mixbeta(c(1, 1, 1)), n = 40, r = 10) +post2 <- postmix(mixbeta(c(1, 1, 1)), n = 40, r = 18) # positive outcome and a median odds ratio of at least 2 ... decL2(post2, post1) diff --git a/man/decision2S_boundary.Rd b/man/decision2S_boundary.Rd index 68b6054..35b2684 100644 --- a/man/decision2S_boundary.Rd +++ b/man/decision2S_boundary.Rd @@ -119,13 +119,13 @@ boundary is searched for \eqn{y_1} and \eqn{y_2}, respectively. \examples{ # see ?decision2S for details of example -priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") # the success criteria is for delta which are larger than some # threshold value which is why we set lower.tail=FALSE -successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) # the futility criterion acts in the opposite direction -futilityCrit <- decision2S(c(0.90) , c(40), TRUE) +futilityCrit <- decision2S(c(0.90), c(40), TRUE) # success criterion boundary successBoundary <- decision2S_boundary(priorP, priorT, 10, 20, successCrit) @@ -133,15 +133,15 @@ successBoundary <- decision2S_boundary(priorP, priorT, 10, 20, successCrit) # futility criterion boundary futilityBoundary <- decision2S_boundary(priorP, priorT, 10, 20, futilityCrit) -curve(successBoundary(x), -25:25 - 49, xlab="y2", ylab="critical y1") -curve(futilityBoundary(x), lty=2, add=TRUE) +curve(successBoundary(x), -25:25 - 49, xlab = "y2", ylab = "critical y1") +curve(futilityBoundary(x), lty = 2, add = TRUE) # hence, for mean in sample 2 of 10, the critical value for y1 is y1c <- futilityBoundary(-10) # around the critical value the decision for futility changes -futilityCrit(postmix(priorP, m=y1c+1E-3, n=10), postmix(priorT, m=-10, n=20)) -futilityCrit(postmix(priorP, m=y1c-1E-3, n=10), postmix(priorT, m=-10, n=20)) +futilityCrit(postmix(priorP, m = y1c + 1E-3, n = 10), postmix(priorT, m = -10, n = 20)) +futilityCrit(postmix(priorP, m = y1c - 1E-3, n = 10), postmix(priorT, m = -10, n = 20)) } \seealso{ diff --git a/man/ess.Rd b/man/ess.Rd index 464388a..e52c203 100644 --- a/man/ess.Rd +++ b/man/ess.Rd @@ -13,7 +13,14 @@ ess(mix, method = c("elir", "moment", "morita"), ...) \method{ess}{gammaMix}(mix, method = c("elir", "moment", "morita"), ..., s = 100, eps = 1e-04) -\method{ess}{normMix}(mix, method = c("elir", "moment", "morita"), ..., sigma, s = 100) +\method{ess}{normMix}( + mix, + method = c("elir", "moment", "morita"), + ..., + family = gaussian, + sigma, + s = 100 +) } \arguments{ \item{mix}{Prior (mixture of conjugate distributions).} @@ -31,6 +38,9 @@ et al. (2008) for details.} of the expected information for the Poisson-Gamma case of Morita method (defaults to 1E-4).} +\item{family}{defines data likelihood and link function +(\code{binomial}, \code{gaussian}, or \code{poisson}).} + \item{sigma}{reference scale.} } \value{ @@ -44,18 +54,25 @@ equivalent to. \details{ The ESS is calculated using either the expected local information ratio (elir) \emph{Neuenschwander et - al. (submitted)}, the moments approach or the method by + al. (2020)}, the moments approach or the method by \emph{Morita et al. (2008)}. -The elir approach is the only ESS which fulfills predictive -consistency. The predictive consistency of the ESS requires that -the ESS of a prior is the same as averaging the posterior ESS after -a fixed amount of events over the prior predictive distribution -from which the number of forward simulated events is -subtracted. The elir approach results in ESS estimates which are -neither conservative nor liberal whereas the moments method yields -conservative and the morita method liberal results. See the example -section for a demonstration of predictive consistency. +The elir approach measures effective sample size in terms of the +average curvature of the prior in relation to the Fisher +information. Informally this corresponds to the average peakiness +of the prior in relation to the information content of a single +observation. The elir approach is the only ESS which fulfills +predictive consistency. The predictive consistency of the ESS +requires that the ESS of a prior is consistent when considering an +averaged posterior ESS of additional data distributed according to +the predictive distribution of the prior. The expectation of the +posterior ESS is taken wrt to the prior predictive distribution and +the averaged posterior ESS corresponds to the sum of the prior ESS +and the number of forward simulated data items. The elir approach +results in ESS estimates which are neither conservative nor liberal +whereas the moments method yields conservative and the morita +method liberal results. See the example section for a demonstration +of predictive consistency. For the moments method the mean and standard deviation of the mixture are calculated and then approximated by the conjugate @@ -70,6 +87,13 @@ contains many components. The calculation of the Morita approach here follows the approach presented in Neuenschwander B. et all (2019) which avoids the need for a minimization and does not restrict the ESS to be an integer. + +The arguments \code{sigma} and \code{family} are specific for +normal mixture densities. These specify the sampling standard +deviation for a \code{gaussian} family (the default) while also +allowing to consider the ESS of standard one-parameter exponential +families, i.e. \code{binomial} or \code{poisson}. The function +supports non-gaussian families with unit dispersion only. } \section{Methods (by class)}{ \itemize{ @@ -100,10 +124,10 @@ b <- 15 prior <- mixbeta(c(1, a, b)) ess(prior) -(a+b) +(a + b) # Beta mixture example -bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) +bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) ess(bmix, "elir") @@ -117,45 +141,58 @@ ab_matched <- ms2beta(bmix_sum["mean"], bmix_sum["sd"]) # to number of responders/non-responders respectivley round(sum(ab_matched)) -ess(bmix, method="morita") +ess(bmix, method = "morita") + +# One may also calculate the ESS on the logit scale, which +# gives slightly different results due to the parameter +# transformation, e.g.: +prior_logit <- mixnorm(c(1, log(5 / 15), sqrt(1 / 5 + 1 / 15))) +ess(prior_logit, family = binomial) + +bmix_logit <- mixnorm(rob = c(0.2, 0, 2), inf = c(0.8, log(10 / 2), sqrt(1 / 10 + 1 / 2))) +ess(bmix_logit, family = binomial) # Predictive consistency of elir n_forward <- 1E1 -bmixPred <- preddist(bmix, n=n_forward) +bmixPred <- preddist(bmix, n = n_forward) pred_samp <- rmix(bmixPred, 1E2) -# use more samples here for greater accuracy -# pred_samp <- rmix(bmixPred, 1E3) -pred_ess <- sapply(pred_samp, function(r) ess(postmix(bmix, r=r, n=n_forward), "elir") ) +# use more samples here for greater accuracy, e.g. +# pred_samp <- rmix(bmixPred, 1E3) +pred_ess <- sapply(pred_samp, function(r) ess(postmix(bmix, r = r, n = n_forward), "elir")) ess(bmix, "elir") mean(pred_ess) - n_forward # Normal mixture example -nmix <- mixnorm(rob=c(0.5, 0, 2), inf=c(0.5, 3, 4), sigma=10) +nmix <- mixnorm(rob = c(0.5, 0, 2), inf = c(0.5, 3, 4), sigma = 10) ess(nmix, "elir") ess(nmix, "moment") -## the reference scale determines the ESS +# the reference scale determines the ESS sigma(nmix) <- 20 ess(nmix) +# we may also interpret normal mixtures as densities assigned to +# parameters of a logit transformed response rate of a binomial +nmix_logit <- mixnorm(c(1, logit(1 / 4), 2 / sqrt(10))) +ess(nmix_logit, family = binomial) + # Gamma mixture example -gmix <- mixgamma(rob=c(0.3, 20, 4), inf=c(0.7, 50, 10)) +gmix <- mixgamma(rob = c(0.3, 20, 4), inf = c(0.7, 50, 10)) ess(gmix) ## interpreted as appropriate for a Poisson likelihood (default) likelihood(gmix) <- "exp" ess(gmix) ## interpreted as appropriate for an exponential likelihood - - } \references{ -Morita S, Thall PF, Mueller P. -Determining the effective sample size of a parametric prior. -\emph{Biometrics} 2008;64(2):595-602. - -Neuenschwander B, Weber S, Schmidli H, O'Hagen A. -Predictively Consistent Prior Effective Sample Sizes. -\emph{pre-print} 2019; arXiv:1907.04185 +Morita S, Thall PF, Mueller P. Determining the + effective sample size of a parametric prior. \emph{Biometrics} + 2008;64(2):595-602. + +Neuenschwander B., Weber S., Schmidli H., O’Hagan + A. (2020). Predictively consistent prior effective sample + sizes. \emph{Biometrics}, 76(2), + 578–587. https://doi.org/10.1111/biom.13252 } diff --git a/man/forest_plot.Rd b/man/forest_plot.Rd index 260fb5f..69dad20 100644 --- a/man/forest_plot.Rd +++ b/man/forest_plot.Rd @@ -71,7 +71,7 @@ example(AS) forest_plot(map_AS) # standard forest plot (only stratified estimate and Mean) -forest_plot(map_AS, est=c("Mean"), model="stratified") +forest_plot(map_AS, est = c("Mean"), model = "stratified") # to further customize these plots, first load bayesplot and ggplot2 library(bayesplot) @@ -80,15 +80,16 @@ library(ggplot2) # to make plots with red colors, big fonts for presentations, suppress # the x axis label and add another title (with a subtitle) color_scheme_set("red") -theme_set(theme_default(base_size=16)) -forest_plot(map_AS, size=2) + - yaxis_title(FALSE) + - ggtitle("Ankylosing Spondylitis Forest Plot", - subtitle="Control Group Response Rate") +theme_set(theme_default(base_size = 16)) +forest_plot(map_AS, size = 2) + + yaxis_title(FALSE) + + ggtitle("Ankylosing Spondylitis Forest Plot", + subtitle = "Control Group Response Rate" + ) # the defaults are set with color_scheme_set("blue") -theme_set(theme_default(base_size=12)) +theme_set(theme_default(base_size = 12)) } \seealso{ diff --git a/man/gMAP.Rd b/man/gMAP.Rd index ee9055d..36f965d 100644 --- a/man/gMAP.Rd +++ b/man/gMAP.Rd @@ -52,12 +52,12 @@ gMAP( \item{formula}{the model formula describing the linear predictor and encoding the grouping; see details} -\item{family}{the family of distributions defining the statistical -model (\code{binomial}, \code{gaussian}, or \code{poisson})} +\item{family}{defines data likelihood and link function +(\code{binomial}, \code{gaussian}, or \code{poisson})} \item{data}{optional data frame containing the variables of the -model. If not found in \code{data}, the variables are taken from -\code{environment(formula)}.} +model. If not found in \code{data}, the variables are taken +from \code{environment(formula)}.} \item{weights}{optional weight vector; see details below.} @@ -66,27 +66,33 @@ data} \item{tau.strata}{sets the exchangability stratum per study. That is, it is expected that each study belongs to a single -stratum. Default is to assign all studies to stratum 1. See section -differential heterogeniety below.} +stratum. Default is to assign all studies to stratum 1. See +section differential heterogeniety below.} \item{tau.dist}{type of prior distribution for \code{tau}; supported priors are \code{HalfNormal} (default), -\code{TruncNormal}, \code{Uniform}, \code{Gamma}, \code{InvGamma}, -\code{LogNormal}, \code{TruncCauchy}, \code{Exp} and \code{Fixed}.} +\code{TruncNormal}, \code{Uniform}, \code{Gamma}, +\code{InvGamma}, \code{LogNormal}, \code{TruncCauchy}, +\code{Exp} and \code{Fixed}.} \item{tau.prior}{parameters of prior distribution for \code{tau}; see section prior specification below.} -\item{tau.strata.pred}{the index for the prediction stratum; default is 1.} +\item{tau.strata.pred}{the index for the prediction stratum; +default is 1.} \item{beta.prior}{mean and standard deviation for normal priors of regression coefficients, see section prior specification below.} -\item{prior_PD}{logical to indicate if the prior predictive distribution should be sampled (no conditioning on the data). Defaults to \code{FALSE}.} +\item{prior_PD}{logical to indicate if the prior predictive +distribution should be sampled (no conditioning on the +data). Defaults to \code{FALSE}.} -\item{REdist}{type of random effects distribution. \code{Normal} (default) or \code{t}.} +\item{REdist}{type of random effects distribution. \code{Normal} +(default) or \code{t}.} -\item{t.df}{degrees of freedom if random-effects distribution is \code{t}.} +\item{t.df}{degrees of freedom if random-effects distribution is +\code{t}.} \item{contrasts}{an optional list; See \code{contrasts.arg} from \code{\link[stats:model.matrix.default]{model.matrix.default}}.} @@ -105,7 +111,8 @@ unconstrained space for random initialization. See \item{cores}{number of cores for parallel sampling of chains.} -\item{x, object}{\code{gMAP} analysis object created by \code{gMAP} function} +\item{x, object}{\code{gMAP} analysis object created by \code{gMAP} +function} \item{digits}{number of displayed significant digits.} @@ -113,7 +120,8 @@ unconstrained space for random initialization. See \item{...}{optional arguments are ignored} -\item{type}{sets reported scale (\code{response} (default) or \code{link}).} +\item{type}{sets reported scale (\code{response} (default) or +\code{link}).} } \value{ The function returns a S3 object of type \code{gMAP}. See @@ -376,11 +384,12 @@ parameters. # illustrated below. # for exact reproducible results, the seed must be set set.seed(34563) -map_AS <- gMAP(cbind(r, n-r) ~ 1 | study, - family=binomial, - data=AS, - tau.dist="HalfNormal", tau.prior=1, - beta.prior=2) +map_AS <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = AS, + tau.dist = "HalfNormal", tau.prior = 1, + beta.prior = 2 +) print(map_AS) # obtain numerical summaries @@ -408,7 +417,7 @@ fitted(map_AS) coef(map_AS) # finally fit MAP prior with parametric mixture -map_mix <- mixfit(map_AS, Nc=2) +map_mix <- mixfit(map_AS, Nc = 2) plot(map_mix)$mix \donttest{ @@ -425,25 +434,27 @@ plot(map_automix)$mix # n_infinity concept as discussed in Neuenschwander et al., 2010. # This assumes a normal approximation which applies for the colitis # data set as: -p_bar <- mean(with(colitis, r/n)) -s <- round(1/sqrt(p_bar * (1-p_bar)), 1) +p_bar <- mean(with(colitis, r / n)) +s <- round(1 / sqrt(p_bar * (1 - p_bar)), 1) # s is the approximate sampling standard deviation and a # conservative prior is tau ~ HalfNormal(0,s/2) -tau_prior_sd <- s/2 +tau_prior_sd <- s / 2 # Evaluate HalfNormal prior for tau -tau_cat <- c(pooling=0 - ,small=0.0625 - ,moderate=0.125 - ,substantial=0.25 - ,large=0.5 - ,veryLarge=1 - ,stratified=Inf) +tau_cat <- c( + pooling = 0, + small = 0.0625, + moderate = 0.125, + substantial = 0.25, + large = 0.5, + veryLarge = 1, + stratified = Inf +) # Interval probabilites (basically saying we are assuming # heterogeniety to be smaller than very large) -diff(2*pnorm(tau_cat * s, 0, tau_prior_sd)) +diff(2 * pnorm(tau_cat * s, 0, tau_prior_sd)) # Cumulative probabilities as 1-F -1 - 2*(pnorm(tau_cat * s, 0, tau_prior_sd) - 0.5) +1 - 2 * (pnorm(tau_cat * s, 0, tau_prior_sd) - 0.5) ## Recover user set sampling defaults options(.user_mc_options) diff --git a/man/mix.Rd b/man/mix.Rd index 8a65722..3f7923a 100644 --- a/man/mix.Rd +++ b/man/mix.Rd @@ -105,16 +105,15 @@ Gamma \tab Exponential \tab Gamma-Exp (\emph{not supported}) \tab \code{n}, \cod \examples{ ## a beta mixture -bm <- mixbeta(weak=c(0.2, 2, 10), inf=c(0.4, 10, 100), inf2=c(0.4, 30, 80)) +bm <- mixbeta(weak = c(0.2, 2, 10), inf = c(0.4, 10, 100), inf2 = c(0.4, 30, 80)) ## extract the two most informative components -bm[[c(2,3)]] +bm[[c(2, 3)]] ## rescaling needed in order to plot -plot(bm[[c(2,3),rescale=TRUE]]) +plot(bm[[c(2, 3), rescale = TRUE]]) summary(bm) - } \seealso{ \code{\link{plot.mix}} diff --git a/man/mixbeta.Rd b/man/mixbeta.Rd index e930df4..c543407 100644 --- a/man/mixbeta.Rd +++ b/man/mixbeta.Rd @@ -68,16 +68,16 @@ parametrizations which is set by the \code{param} option: } \examples{ ## a beta mixture -bm <- mixbeta(rob=c(0.2, 2, 10), inf=c(0.4, 10, 100), inf2=c(0.4, 30, 80)) +bm <- mixbeta(rob = c(0.2, 2, 10), inf = c(0.4, 10, 100), inf2 = c(0.4, 30, 80)) # mean/standard deviation parametrization -bm2 <- mixbeta(rob=c(0.2, 0.3, 0.2), inf=c(0.8, 0.4, 0.01), param="ms") +bm2 <- mixbeta(rob = c(0.2, 0.3, 0.2), inf = c(0.8, 0.4, 0.01), param = "ms") # mean/observations parametrization -bm3 <- mixbeta(rob=c(0.2, 0.3, 5), inf=c(0.8, 0.4, 30), param="mn") +bm3 <- mixbeta(rob = c(0.2, 0.3, 5), inf = c(0.8, 0.4, 30), param = "mn") # even mixed is possible -bm4 <- mixbeta(rob=c(0.2, mn2beta(0.3, 5)), inf=c(0.8, ms2beta(0.4, 0.1))) +bm4 <- mixbeta(rob = c(0.2, mn2beta(0.3, 5)), inf = c(0.8, ms2beta(0.4, 0.1))) # print methods are defined bm4 diff --git a/man/mixcombine.Rd b/man/mixcombine.Rd index eb43676..21a841e 100644 --- a/man/mixcombine.Rd +++ b/man/mixcombine.Rd @@ -30,11 +30,11 @@ variable to form a new mixture distribution. } \examples{ # beta with two informative components -bm <- mixbeta(inf=c(0.5, 10, 100), inf2=c(0.5, 30, 80)) +bm <- mixbeta(inf = c(0.5, 10, 100), inf2 = c(0.5, 30, 80)) # robustified with mixcombine, i.e. a 10\% uninformative part added -unif <- mixbeta(rob=c(1,1,1)) -mixcombine(bm, unif, weight=c(9, 1)) +unif <- mixbeta(rob = c(1, 1, 1)) +mixcombine(bm, unif, weight = c(9, 1)) } \seealso{ \code{\link{robustify}} diff --git a/man/mixdiff.Rd b/man/mixdiff.Rd index d156570..05da5ab 100644 --- a/man/mixdiff.Rd +++ b/man/mixdiff.Rd @@ -66,29 +66,29 @@ pmixdiff(mix1, mix2, 0, FALSE) pmixdiff(mix1, mix2, 0.3) - pmixdiff(mix1, mix2, 0) # 2. two distributions, one of them a mixture -m1 <- mixbeta( c(1,30,50)) -m2 <- mixbeta( c(0.75,20,50),c(0.25,1,1)) +m1 <- mixbeta(c(1, 30, 50)) +m2 <- mixbeta(c(0.75, 20, 50), c(0.25, 1, 1)) # random sample of difference set.seed(23434) rM <- rmixdiff(m1, m2, 1E4) # histogram of random numbers and exact density -hist(rM,prob=TRUE,new=TRUE,nclass=40) -curve(dmixdiff(m1,m2,x), add=TRUE, n=51) +hist(rM, prob = TRUE, new = TRUE, nclass = 40) +curve(dmixdiff(m1, m2, x), add = TRUE, n = 51) # threshold probabilities for difference, at 0 and 0.2 pmixdiff(m1, m2, 0) -mean(rM<0) -pmixdiff(m1,m2,0.2) -mean(rM<0.2) +mean(rM < 0) +pmixdiff(m1, m2, 0.2) +mean(rM < 0.2) # median of difference mdn <- qmixdiff(m1, m2, 0.5) -mean(rM 0") -post_secukinumab <- postmix(mixbeta(c(1, 0.5, 1)), r=15, n=24) -post_placebo <- postmix(map_AS_beta, r=1, n=6) -pmixdiff(post_secukinumab, post_placebo, 0, lower.tail=FALSE) +post_secukinumab <- postmix(mixbeta(c(1, 0.5, 1)), r = 15, n = 24) +post_placebo <- postmix(map_AS_beta, r = 1, n = 6) +pmixdiff(post_secukinumab, post_placebo, 0, lower.tail = FALSE) # The posterior probability for a positive treatment effect # is very close to unity in both cases. } diff --git a/man/oc1S.Rd b/man/oc1S.Rd index 9884172..a16f4cc 100644 --- a/man/oc1S.Rd +++ b/man/oc1S.Rd @@ -88,35 +88,35 @@ the boundary is searched for \eqn{y}. # non-inferiority example using normal approximation of log-hazard # ratio, see ?decision1S for all details s <- 2 -flat_prior <- mixnorm(c(1,0,100), sigma=s) +flat_prior <- mixnorm(c(1, 0, 100), sigma = s) nL <- 233 theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 -za <- qnorm(1-alpha) -zb <- qnorm(1-beta) -n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +beta <- 0.2 +za <- qnorm(1 - alpha) +zb <- qnorm(1 - beta) +n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) theta_c <- theta_ni - za * s / sqrt(n1) # standard NI design -decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) +decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) # double criterion design # statistical significance (like NI design) -dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) # require mean to be at least as good as theta_c -dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) # combination -decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) -theta_eval <- c(theta_a, theta_c, theta_ni) +theta_eval <- c(theta_a, theta_c, theta_ni) # evaluate different designs at two sample sizes -designA_n1 <- oc1S(flat_prior, n1, decA) -designA_nL <- oc1S(flat_prior, nL, decA) -designC_n1 <- oc1S(flat_prior, n1, decComb) -designC_nL <- oc1S(flat_prior, nL, decComb) +designA_n1 <- oc1S(flat_prior, n1, decA) +designA_nL <- oc1S(flat_prior, nL, decA) +designC_n1 <- oc1S(flat_prior, n1, decComb) +designC_nL <- oc1S(flat_prior, nL, decComb) # evaluate designs at the key log-HR of positive treatment (HR<1), # the indecision point and the NI margin @@ -139,7 +139,6 @@ designC2_nL(theta_eval) # see also ?decision1S_boundary to see which of the two criterions # will drive the decision - } \seealso{ Other design1S: diff --git a/man/oc2S.Rd b/man/oc2S.Rd index 7ff428b..e156a44 100644 --- a/man/oc2S.Rd +++ b/man/oc2S.Rd @@ -119,11 +119,11 @@ boundary is searched for \eqn{y_1} and \eqn{y_2}, respectively. \examples{ # example from Schmidli et al., 2014 -dec <- decision2S(0.975, 0, lower.tail=FALSE) +dec <- decision2S(0.975, 0, lower.tail = FALSE) prior_inf <- mixbeta(c(1, 4, 16)) -prior_rob <- robustify(prior_inf, weight=0.2, mean=0.5) -prior_uni <- mixbeta(c(1, 1, 1)) +prior_rob <- robustify(prior_inf, weight = 0.2, mean = 0.5) +prior_uni <- mixbeta(c(1, 1, 1)) N <- 40 N_ctl <- N - 20 @@ -134,15 +134,14 @@ design_inf <- oc2S(prior_uni, prior_inf, N, N_ctl, dec) design_rob <- oc2S(prior_uni, prior_rob, N, N_ctl, dec) # type I error -curve(design_inf(x,x), 0, 1) -curve(design_uni(x,x), lty=2, add=TRUE) -curve(design_rob(x,x), lty=3, add=TRUE) +curve(design_inf(x, x), 0, 1) +curve(design_uni(x, x), lty = 2, add = TRUE) +curve(design_rob(x, x), lty = 3, add = TRUE) # power -curve(design_inf(0.2+x,0.2), 0, 0.5) -curve(design_uni(0.2+x,0.2), lty=2, add=TRUE) -curve(design_rob(0.2+x,0.2), lty=3, add=TRUE) - +curve(design_inf(0.2 + x, 0.2), 0, 0.5) +curve(design_uni(0.2 + x, 0.2), lty = 2, add = TRUE) +curve(design_rob(0.2 + x, 0.2), lty = 3, add = TRUE) } \references{ diff --git a/man/plot.EM.Rd b/man/plot.EM.Rd index 4037c1a..941efb0 100644 --- a/man/plot.EM.Rd +++ b/man/plot.EM.Rd @@ -52,9 +52,9 @@ site}. \examples{ -bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) +bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) bsamp <- rmix(bmix, 1000) -bfit <- mixfit(bsamp, type="beta", Nc=2) +bfit <- mixfit(bsamp, type = "beta", Nc = 2) pl <- plot(bfit) print(pl$mixdens) @@ -62,7 +62,7 @@ print(pl$mix) \donttest{ # a number of additional plots are generated in verbose mode -.user_option <- options(RBesT.verbose=TRUE) +.user_option <- options(RBesT.verbose = TRUE) pl_all <- plot(bfit) # recover previous user options diff --git a/man/pos1S.Rd b/man/pos1S.Rd index 63d9aa9..ad77204 100644 --- a/man/pos1S.Rd +++ b/man/pos1S.Rd @@ -90,24 +90,24 @@ the boundary is searched for \eqn{y}. # non-inferiority example using normal approximation of log-hazard # ratio, see ?decision1S for all details s <- 2 -flat_prior <- mixnorm(c(1,0,100), sigma=s) +flat_prior <- mixnorm(c(1, 0, 100), sigma = s) nL <- 233 theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 -za <- qnorm(1-alpha) -zb <- qnorm(1-beta) -n1 <- round( (s * (za + zb)/(theta_ni - theta_a))^2 ) +beta <- 0.2 +za <- qnorm(1 - alpha) +zb <- qnorm(1 - beta) +n1 <- round((s * (za + zb) / (theta_ni - theta_a))^2) theta_c <- theta_ni - za * s / sqrt(n1) # assume we would like to conduct at an interim analysis # of PoS after having observed 20 events with a HR of 0.8. # We first need the posterior at the interim ... -post_ia <- postmix(flat_prior, m=log(0.8), n=20) +post_ia <- postmix(flat_prior, m = log(0.8), n = 20) # dual criterion -decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) # ... and we would like to know the PoS for a successful # trial at the end when observing 10 more events @@ -117,7 +117,6 @@ pos_ia <- pos1S(post_ia, 10, decComb) # interim such that the PoS is pos_ia(post_ia) - } \seealso{ Other design1S: diff --git a/man/pos2S.Rd b/man/pos2S.Rd index 4486039..bfa4bbe 100644 --- a/man/pos2S.Rd +++ b/man/pos2S.Rd @@ -131,15 +131,15 @@ boundary is searched for \eqn{y_1} and \eqn{y_2}, respectively. \examples{ # see ?decision2S for details of example -priorT <- mixnorm(c(1, 0, 0.001), sigma=88, param="mn") -priorP <- mixnorm(c(1, -49, 20 ), sigma=88, param="mn") +priorT <- mixnorm(c(1, 0, 0.001), sigma = 88, param = "mn") +priorP <- mixnorm(c(1, -49, 20), sigma = 88, param = "mn") # the success criteria is for delta which are larger than some # threshold value which is why we set lower.tail=FALSE -successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) +successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) # example interim outcome -postP_interim <- postmix(priorP, n=10, m=-50) -postT_interim <- postmix(priorT, n=20, m=-80) +postP_interim <- postmix(priorP, n = 10, m = -50) +postT_interim <- postmix(priorT, n = 20, m = -80) # assume that mean -50 / -80 were observed at the interim for # placebo control(n=10) / active treatment(n=20) which gives diff --git a/man/postmix.Rd b/man/postmix.Rd index 0f3ae95..0c4eb8d 100644 --- a/man/postmix.Rd +++ b/man/postmix.Rd @@ -33,7 +33,7 @@ summary data has to be provided (see below).} } \description{ Calculates the posterior distribution for data \code{data} given a prior -\code{priormix}, where the prior is a mixture of conjugate distributions. +\code{priormix}, where the prior is a mixture of conjugate distributions. The posterior is then also a mixture of conjugate distributions. } \details{ @@ -120,29 +120,31 @@ Gamma \tab Exponential \tab Gamma-Exp (\emph{not supported}) \tab \code{n}, \cod # binary example with individual data (1=event,0=no event), uniform prior prior.unif <- mixbeta(c(1, 1, 1)) -data.indiv <- c(1,0,1,1,0,1) -posterior.indiv <- postmix(prior.unif, data.indiv) +data.indiv <- c(1, 0, 1, 1, 0, 1) +posterior.indiv <- postmix(prior.unif, data.indiv) print(posterior.indiv) # or with summary data (number of events and number of patients) -r <- sum(data.indiv); n <- length(data.indiv) -posterior.sum <- postmix(prior.unif, n=n, r=r) +r <- sum(data.indiv) +n <- length(data.indiv) +posterior.sum <- postmix(prior.unif, n = n, r = r) print(posterior.sum) # binary example with robust informative prior and conflicting data -prior.rob <- mixbeta(c(0.5,4,10),c(0.5,1,1)) -posterior.rob <- postmix(prior.rob, n=20, r=18) +prior.rob <- mixbeta(c(0.5, 4, 10), c(0.5, 1, 1)) +posterior.rob <- postmix(prior.rob, n = 20, r = 18) print(posterior.rob) # normal example with individual data sigma <- 88 prior.mean <- -49 -prior.se <- sigma/sqrt(20) -prior <- mixnorm(c(1,prior.mean,prior.se),sigma=sigma) -data.indiv <- c(-46,-227,41,-65,-103,-22,7,-169,-69,90) +prior.se <- sigma / sqrt(20) +prior <- mixnorm(c(1, prior.mean, prior.se), sigma = sigma) +data.indiv <- c(-46, -227, 41, -65, -103, -22, 7, -169, -69, 90) posterior.indiv <- postmix(prior, data.indiv) # or with summary data (mean and number of patients) -mn <- mean(data.indiv); n <- length(data.indiv) -posterior.sum <- postmix(prior, m=mn, n=n) +mn <- mean(data.indiv) +n <- length(data.indiv) +posterior.sum <- postmix(prior, m = mn, n = n) print(posterior.sum) } diff --git a/man/preddist.Rd b/man/preddist.Rd index ac2c6e7..97627c7 100644 --- a/man/preddist.Rd +++ b/man/preddist.Rd @@ -89,8 +89,8 @@ Gamma \tab Exponential \tab Gamma-Exp (\emph{not supported}) \tab \code{n}, \cod \examples{ # Example 1: predictive distribution from uniform prior. -bm <- mixbeta(c(1,1,1)) -bmPred <- preddist(bm, n=10) +bm <- mixbeta(c(1, 1, 1)) +bmPred <- preddist(bm, n = 10) # predictive proabilities and cumulative predictive probabilities x <- 0:10 d <- dmix(bmPred, x) @@ -100,32 +100,32 @@ cd <- pmix(bmPred, x) names(cd) <- x barplot(cd) # median -mdn <- qmix(bmPred,0.5) +mdn <- qmix(bmPred, 0.5) mdn # Example 2: 2-comp Beta mixture -bm <- mixbeta( inf=c(0.8,15,50),rob=c(0.2,1,1)) +bm <- mixbeta(inf = c(0.8, 15, 50), rob = c(0.2, 1, 1)) plot(bm) -bmPred <- preddist(bm,n=10) +bmPred <- preddist(bm, n = 10) plot(bmPred) -mdn <- qmix(bmPred,0.5) +mdn <- qmix(bmPred, 0.5) mdn -d <- dmix(bmPred,x=0:10) +d <- dmix(bmPred, x = 0:10) \donttest{ n.sim <- 100000 -r <- rmix(bmPred,n.sim) +r <- rmix(bmPred, n.sim) d -table(r)/n.sim +table(r) / n.sim } # Example 3: 3-comp Normal mixture -m3 <- mixnorm( c(0.50,-0.2,0.1),c(0.25,0,0.2), c(0.25,0,0.5), sigma=10) +m3 <- mixnorm(c(0.50, -0.2, 0.1), c(0.25, 0, 0.2), c(0.25, 0, 0.5), sigma = 10) print(m3) summary(m3) plot(m3) -predm3 <- preddist(m3,n=2) +predm3 <- preddist(m3, n = 2) plot(predm3) print(predm3) summary(predm3) diff --git a/man/predict.gMAP.Rd b/man/predict.gMAP.Rd index c87e32d..ed86d79 100644 --- a/man/predict.gMAP.Rd +++ b/man/predict.gMAP.Rd @@ -57,19 +57,20 @@ to \code{\link{predict.glm}} and the example below. RBesT.MC.chains=2, RBesT.MC.thin=1) # create a fake data set with a covariate -trans_cov <- transform(transplant, country=cut(1:11, c(0,5,8,Inf), c("CH", "US", "DE"))) +trans_cov <- transform(transplant, country = cut(1:11, c(0, 5, 8, Inf), c("CH", "US", "DE"))) set.seed(34246) -map <- gMAP(cbind(r, n-r) ~ 1 + country | study, - data=trans_cov, - tau.dist="HalfNormal", - tau.prior=1, - # Note on priors: we make the overall intercept weakly-informative - # and the regression coefficients must have tighter sd as these are - # deviations in the default contrast parametrization - beta.prior=rbind(c(0,2), c(0,1), c(0,1)), - family=binomial, - ## ensure fast example runtime - thin=1, chains=1) +map <- gMAP(cbind(r, n - r) ~ 1 + country | study, + data = trans_cov, + tau.dist = "HalfNormal", + tau.prior = 1, + # Note on priors: we make the overall intercept weakly-informative + # and the regression coefficients must have tighter sd as these are + # deviations in the default contrast parametrization + beta.prior = rbind(c(0, 2), c(0, 1), c(0, 1)), + family = binomial, + ## ensure fast example runtime + thin = 1, chains = 1 +) # posterior predictive distribution for each input data item (shrinkage estimates) pred_cov <- predict(map) @@ -87,7 +88,7 @@ pred_cov_pred summary(pred_cov) # obtain a prediction for new data with specific covariates -pred_new <- predict(map, data.frame(country="CH", study=12)) +pred_new <- predict(map, data.frame(country = "CH", study = 12)) pred_new ## Recover user set sampling defaults options(.user_mc_options) diff --git a/man/robustify.Rd b/man/robustify.Rd index 7932f06..d42e0e7 100644 --- a/man/robustify.Rd +++ b/man/robustify.Rd @@ -76,21 +76,21 @@ sampling standard deviation using the \code{sigma} argument. }} \examples{ -bmix <- mixbeta(inf1=c(0.2, 8, 3), inf2=c(0.8, 10, 2)) +bmix <- mixbeta(inf1 = c(0.2, 8, 3), inf2 = c(0.8, 10, 2)) plot(bmix) -rbmix <- robustify(bmix, weight=0.1, mean=0.5) +rbmix <- robustify(bmix, weight = 0.1, mean = 0.5) rbmix plot(rbmix) -gmnMix <- mixgamma(inf1=c(0.2, 2, 3), inf2=c(0.8, 2, 5), param="mn") +gmnMix <- mixgamma(inf1 = c(0.2, 2, 3), inf2 = c(0.8, 2, 5), param = "mn") plot(gmnMix) -rgmnMix <- robustify(gmnMix, weight=0.1, mean=2) +rgmnMix <- robustify(gmnMix, weight = 0.1, mean = 2) rgmnMix plot(rgmnMix) -nm <- mixnorm(inf1=c(0.2, 0.5, 0.7), inf2=c(0.8, 2, 1), sigma=2) +nm <- mixnorm(inf1 = c(0.2, 0.5, 0.7), inf2 = c(0.8, 2, 1), sigma = 2) plot(nm) -rnMix <- robustify(nm, weight=0.1, mean=0, sigma=2) +rnMix <- robustify(nm, weight = 0.1, mean = 0, sigma = 2) rnMix plot(rnMix) diff --git a/tests/testthat.R b/tests/testthat.R index 2ec38bb..f754ccc 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,6 +1,6 @@ -if(Sys.getenv("NOT_CRAN") == "true") { - library(testthat) - library(RBesT) +if (Sys.getenv("NOT_CRAN") == "true") { + library(testthat) + library(RBesT) - test_check("RBesT") + test_check("RBesT") } diff --git a/tests/testthat/helper-utils.R b/tests/testthat/helper-utils.R index 95db7f2..b3f8e9e 100644 --- a/tests/testthat/helper-utils.R +++ b/tests/testthat/helper-utils.R @@ -1,10 +1,10 @@ - -source_example <- function(example, env=parent.frame(), disable_plots=TRUE) { - ex_source <- readLines(system.file("examples", example, package="RBesT", mustWork=TRUE)) - if(disable_plots) { - ex_source <- grep("plot\\(", ex_source, value=TRUE, invert=TRUE) - } - suppressMessages(ex <- source(textConnection(ex_source), - local=env, echo=FALSE, verbose=FALSE)) - invisible(ex) +source_example <- function(example, env = parent.frame(), disable_plots = TRUE) { + ex_source <- readLines(system.file("examples", example, package = "RBesT", mustWork = TRUE)) + if (disable_plots) { + ex_source <- grep("plot\\(", ex_source, value = TRUE, invert = TRUE) + } + suppressMessages(ex <- source(textConnection(ex_source), + local = env, echo = FALSE, verbose = FALSE + )) + invisible(ex) } diff --git a/tests/testthat/test-EM.R b/tests/testthat/test-EM.R index c1eae92..49b7428 100644 --- a/tests/testthat/test-EM.R +++ b/tests/testthat/test-EM.R @@ -1,4 +1,4 @@ -#context("EM: Expectation-Maximization") +# context("EM: Expectation-Maximization") ## test that the EM algorithms recover reliably test distributions; ## test criterium is a "sufficiently" small KL divergence @@ -13,15 +13,15 @@ ## number of samples drawn from test distributions if (identical(Sys.getenv("NOT_CRAN"), "true")) { - ## through testing if not on CRAN - Nsim <- 1e4 - verbose <- FALSE - KLthresh <- 1e-2 + ## through testing if not on CRAN + Nsim <- 1e4 + verbose <- FALSE + KLthresh <- 1e-2 } else { - ## on CRAN we shortcut - Nsim <- 1e3 - verbose <- FALSE - KLthresh <- 1e-1 + ## on CRAN we shortcut + Nsim <- 1e3 + verbose <- FALSE + KLthresh <- 1e-1 } @@ -30,16 +30,19 @@ if (identical(Sys.getenv("NOT_CRAN"), "true")) { ref <- list() ref$norm_single <- mixnorm(c(1, 1, 5), - param="mn", sigma=1) + param = "mn", sigma = 1 +) ref$norm_heavy <- mixnorm(c(0.5, 0, 0.25), - c(0.5, 1, 5), - param="mn", sigma=1) + c(0.5, 1, 5), + param = "mn", sigma = 1 +) ref$norm_bi <- mixnorm(c(0.5, 0, 0.5), - c(0.25, 1, 5), - c(0.25, -1, 2), - param="mn", sigma=1) + c(0.25, 1, 5), + c(0.25, -1, 2), + param = "mn", sigma = 1 +) p <- 4 Rho <- diag(p) @@ -50,125 +53,176 @@ S <- diag(s, p) %*% Rho %*% diag(s, p) zero <- rep(0, p) ref$mvnorm_single <- mixmvnorm(c(1, zero, 5), - param="mn", sigma=S) + param = "mn", sigma = S +) ref$mvnorm_heavy <- mixmvnorm(c(0.5, zero, 0.25), - c(0.5, zero + 1, 5), - param="mn", sigma=S) + c(0.5, zero + 1, 5), + param = "mn", sigma = S +) ref$mvnorm_bi <- mixmvnorm(c(0.5, zero, 0.5), - c(0.25, zero + 1, 5), - c(0.25, zero - 1, 2), - param="mn", sigma=S) + c(0.25, zero + 1, 5), + c(0.25, zero - 1, 2), + param = "mn", sigma = S +) ref$mvnorm_bi_1D <- mixmvnorm(c(0.5, 0, 0.5), - c(0.25, 1, 5), - c(0.25, -1, 2), - param="mn", sigma=S[1,1,drop=FALSE]) + c(0.25, 1, 5), + c(0.25, -1, 2), + param = "mn", sigma = S[1, 1, drop = FALSE] +) ref$beta_single <- mixbeta(c(1, 0.3, 10), - param="mn") + param = "mn" +) ## density which is challenging for the constrained version of the ## beta EM (and leads to a large KLdiv) -ref$beta_single_alt <- mixbeta(c(1, 0.2, 3)) +ref$beta_single_alt <- mixbeta(c(1, 0.2, 3)) ref$beta_heavy <- mixbeta(c(0.8, 0.3, 10), - c(0.2, 0.5, 2.5), - param="mn") + c(0.2, 0.5, 2.5), + param = "mn" +) ref$beta_bi <- mixbeta(c(0.3, 0.3, 20), - c(0.2, 0.5, 2), - c(0.5, 0.7, 10), - param="mn") + c(0.2, 0.5, 2), + c(0.5, 0.7, 10), + param = "mn" +) ref$gamma_single <- mixgamma(c(1, 7.5, 5), - param="mn", - likelihood="poisson") + param = "mn", + likelihood = "poisson" +) ref$gamma_heavy <- mixgamma(c(0.5, 7.5, 0.5), - c(0.5, 5, 10), - param="mn", - likelihood="poisson") + c(0.5, 5, 10), + param = "mn", + likelihood = "poisson" +) ref$gamma_bi <- mixgamma(c(0.5, 7.5, 1), - c(0.25, 15, 15), - c(0.25, 5, 10), - param="mn", - likelihood="poisson") - -EM_test <- function(mixTest, seed, Nsim=1e4, verbose=FALSE, ...) { - set.seed(seed) - samp <- rmix(mixTest, Nsim) - set.seed(seed) - EMmix1 <- mixfit(samp, - type=switch(class(mixTest)[1], gammaMix="gamma", normMix="norm", betaMix="beta", mvnormMix="mvnorm"), - thin=1, - eps=2, - Nc=ncol(mixTest), - verbose=verbose, ...) - kl1 <- abs(KLdivmix(mixTest, EMmix1)) - expect_true(kl1 < KLthresh) - ## results must not depend on the seed, but only on the order of - ## the input sample - set.seed(seed + 657858) - EMmix2 <- mixfit(samp, - type=switch(class(mixTest)[1], gammaMix="gamma", normMix="norm", betaMix="beta", mvnormMix="mvnorm"), - thin=1, - eps=2, - Nc=ncol(mixTest), - verbose=verbose, ...) - expect_true(all(EMmix1 == EMmix2), info="Result of EM is independent of random seed.") -} + c(0.25, 15, 15), + c(0.25, 5, 10), + param = "mn", + likelihood = "poisson" +) -EM_mvn_test <- function(mixTest, seed, Nsim=1e4, verbose=FALSE, ...) { - set.seed(seed) - samp <- rmix(mixTest, Nsim) - set.seed(seed) - EMmix1 <- mixfit(samp, - type="mvnorm", - thin=1, - eps=2, - Nc=ncol(mixTest), - verbose=verbose, ...) - expect_equal(summary(mixTest)$mean, summary(EMmix1)$mean, tolerance=0.1) - expect_equal(summary(mixTest)$cov, summary(EMmix1)$cov, tolerance=0.1) - expect_equal(likelihood(EMmix1), likelihood(mixTest)) - set.seed(seed + 476767) - EMmix2 <- mixfit(samp, - type="mvnorm", - thin=1, - eps=2, - Nc=ncol(mixTest), - verbose=verbose, ...) - expect_true(all(EMmix1 == EMmix2), info="Result of EM is independent of random seed.") +EM_test <- function(mixTest, seed, Nsim = 1e4, verbose = FALSE, ...) { + set.seed(seed) + samp <- rmix(mixTest, Nsim) + set.seed(seed) + EMmix1 <- mixfit(samp, + type = switch(class(mixTest)[1], + gammaMix = "gamma", + normMix = "norm", + betaMix = "beta", + mvnormMix = "mvnorm" + ), + thin = 1, + eps = 2, + Nc = ncol(mixTest), + verbose = verbose, ... + ) + kl1 <- abs(KLdivmix(mixTest, EMmix1)) + expect_true(kl1 < KLthresh) + ## results must not depend on the seed, but only on the order of + ## the input sample + set.seed(seed + 657858) + EMmix2 <- mixfit(samp, + type = switch(class(mixTest)[1], + gammaMix = "gamma", + normMix = "norm", + betaMix = "beta", + mvnormMix = "mvnorm" + ), + thin = 1, + eps = 2, + Nc = ncol(mixTest), + verbose = verbose, ... + ) + expect_true(all(EMmix1 == EMmix2), info = "Result of EM is independent of random seed.") } -test_that("Normal EM fits single component", { EM_test(ref$norm_single, 3453563, Nsim, verbose) }) -test_that("Normal EM fits heavy-tailed mixture", { EM_test(ref$norm_heavy, 9275624, Nsim, verbose) }) -test_that("Normal EM fits bi-modal mixture", { EM_test(ref$norm_bi, 9345726, Nsim, verbose) }) - -test_that("Multivariate Normal EM fits single component", { EM_mvn_test(ref$mvnorm_single, 3453563, max(1E4, Nsim), verbose) }) -test_that("Multivariate Normal EM fits heavy-tailed mixture", { EM_mvn_test(ref$mvnorm_heavy, 9275624, max(1E4, Nsim), verbose) }) -test_that("Multivariate Normal EM fits bi-modal mixture", { EM_mvn_test(ref$mvnorm_bi, 9345726, max(1E4, Nsim), verbose) }) -test_that("Multivariate Normal EM fits bi-modal mixture 1D", { EM_mvn_test(ref$mvnorm_bi_1D, 9345726, max(1E4, Nsim), verbose) }) - -test_that("Gamma EM fits single component", { EM_test(ref$gamma_single, 9345835, Nsim, verbose) }) -test_that("Gamma EM fits heavy-tailed mixture", { EM_test(ref$gamma_heavy, 5629389, Nsim, verbose) }) -test_that("Gamma EM fits bi-modal mixture", { EM_test(ref$gamma_bi, 9373515, Nsim, verbose) }) +EM_mvn_test <- function(mixTest, seed, Nsim = 1e4, verbose = FALSE, ...) { + set.seed(seed) + samp <- rmix(mixTest, Nsim) + set.seed(seed) + EMmix1 <- mixfit(samp, + type = "mvnorm", + thin = 1, + eps = 2, + Nc = ncol(mixTest), + verbose = verbose, ... + ) + expect_equal(summary(mixTest)$mean, summary(EMmix1)$mean, tolerance = 0.1) + expect_equal(summary(mixTest)$cov, summary(EMmix1)$cov, tolerance = 0.1) + expect_equal(likelihood(EMmix1), likelihood(mixTest)) + set.seed(seed + 476767) + EMmix2 <- mixfit(samp, + type = "mvnorm", + thin = 1, + eps = 2, + Nc = ncol(mixTest), + verbose = verbose, ... + ) + expect_true(all(EMmix1 == EMmix2), info = "Result of EM is independent of random seed.") +} -test_that("Beta EM fits single component", { EM_test(ref$beta_single, 7265355, Nsim, verbose) }) -test_that("Beta EM fits single component with mass at boundary", { EM_test(ref$beta_single_alt, 7265355, Nsim, verbose, constrain_gt1=FALSE) }) -test_that("Beta EM fits heavy-tailed mixture", { EM_test(ref$beta_heavy, 2946562, Nsim, verbose) }) -test_that("Beta EM fits bi-modal mixture", { EM_test(ref$beta_bi, 9460370, Nsim, verbose) }) +test_that("Normal EM fits single component", { + EM_test(ref$norm_single, 3453563, Nsim, verbose) +}) +test_that("Normal EM fits heavy-tailed mixture", { + EM_test(ref$norm_heavy, 9275624, Nsim, verbose) +}) +test_that("Normal EM fits bi-modal mixture", { + EM_test(ref$norm_bi, 9345726, Nsim, verbose) +}) + +test_that("Multivariate Normal EM fits single component", { + EM_mvn_test(ref$mvnorm_single, 3453563, max(1E4, Nsim), verbose) +}) +test_that("Multivariate Normal EM fits heavy-tailed mixture", { + EM_mvn_test(ref$mvnorm_heavy, 9275624, max(1E4, Nsim), verbose) +}) +test_that("Multivariate Normal EM fits bi-modal mixture", { + EM_mvn_test(ref$mvnorm_bi, 9345726, max(1E4, Nsim), verbose) +}) +test_that("Multivariate Normal EM fits bi-modal mixture 1D", { + EM_mvn_test(ref$mvnorm_bi_1D, 9345726, max(1E4, Nsim), verbose) +}) + +test_that("Gamma EM fits single component", { + EM_test(ref$gamma_single, 9345835, Nsim, verbose) +}) +test_that("Gamma EM fits heavy-tailed mixture", { + EM_test(ref$gamma_heavy, 5629389, Nsim, verbose) +}) +test_that("Gamma EM fits bi-modal mixture", { + EM_test(ref$gamma_bi, 9373515, Nsim, verbose) +}) + +test_that("Beta EM fits single component", { + EM_test(ref$beta_single, 7265355, Nsim, verbose) +}) +test_that("Beta EM fits single component with mass at boundary", { + EM_test(ref$beta_single_alt, 7265355, Nsim, verbose, constrain_gt1 = FALSE) +}) +test_that("Beta EM fits heavy-tailed mixture", { + EM_test(ref$beta_heavy, 2946562, Nsim, verbose) +}) +test_that("Beta EM fits bi-modal mixture", { + EM_test(ref$beta_bi, 9460370, Nsim, verbose) +}) test_that("Constrained Beta EM respects a>1 & b>1", { - unconstrained <- mixbeta(c(0.6, 2.8, 64), c(0.25, 0.5, 0.92), c(0.15, 3, 15)) - set.seed(45747) - samp <- rmix(unconstrained, Nsim) - constrained <- mixfit(samp, type="beta", Nc=3, constrain_gt1=TRUE) - expect_numeric(constrained[2,], lower=1, any.missing=FALSE, len=3) - expect_numeric(constrained[3,], lower=1, any.missing=FALSE, len=3) -} -) + unconstrained <- mixbeta(c(0.6, 2.8, 64), c(0.25, 0.5, 0.92), c(0.15, 3, 15)) + set.seed(45747) + samp <- rmix(unconstrained, Nsim) + constrained <- mixfit(samp, type = "beta", Nc = 3, constrain_gt1 = TRUE) + expect_numeric(constrained[2, ], lower = 1, any.missing = FALSE, len = 3) + expect_numeric(constrained[3, ], lower = 1, any.missing = FALSE, len = 3) +}) diff --git a/tests/testthat/test-gMAP.R b/tests/testthat/test-gMAP.R index be4b222..27936e4 100644 --- a/tests/testthat/test-gMAP.R +++ b/tests/testthat/test-gMAP.R @@ -1,4 +1,3 @@ - ## test gMAP results using SBC and with matching rstanarm models suppressPackageStartupMessages(library(rstan)) @@ -7,217 +6,228 @@ suppressWarnings(suppressPackageStartupMessages(library(rstanarm))) eps <- 2e-1 -probs <- seq(0.1, 0.9, by=0.1) +probs <- seq(0.1, 0.9, by = 0.1) -fast_sampling <- list(RBesT.MC.warmup=250, RBesT.MC.iter=500, RBesT.MC.chains=2) -std_sampling <- list(RBesT.MC.warmup=NULL, RBesT.MC.iter=NULL, RBesT.MC.chains=NULL, RBesT.MC.control=NULL, RBesT.MC.ncp=NULL) -bad_sampling <- list(RBesT.MC.chains=1, RBesT.MC.control=list(adapt_delta=0.75, stepsize=1), RBesT.MC.ncp=0) +fast_sampling <- list(RBesT.MC.warmup = 250, RBesT.MC.iter = 500, RBesT.MC.chains = 2) +std_sampling <- list(RBesT.MC.warmup = NULL, RBesT.MC.iter = NULL, RBesT.MC.chains = NULL, RBesT.MC.control = NULL, RBesT.MC.ncp = NULL) +bad_sampling <- list(RBesT.MC.chains = 1, RBesT.MC.control = list(adapt_delta = 0.75, stepsize = 1), RBesT.MC.ncp = 0) ## standardize posterior by median and IQR get_std_quants <- function(sim, med, disp) { - if(missing(med)) - med <- median(sim) - if(missing(disp)) - disp <- IQR(sim)/1.34 - sim_std <- scale(sim, center=med, scale=disp) - ref_quants <- quantile(sim_std, prob=probs) - list(ref=ref_quants, med=med, disp=disp) + if (missing(med)) { + med <- median(sim) + } + if (missing(disp)) { + disp <- IQR(sim) / 1.34 + } + sim_std <- scale(sim, center = med, scale = disp) + ref_quants <- quantile(sim_std, prob = probs) + list(ref = ref_quants, med = med, disp = disp) } ## used for now for comparisons to rstanarm (maybe drop as we have SBC ## now?) cmp_reference <- function(best_gmap, OB_ref) { - best_sim <- rstan::extract(best_gmap$fit, pars=c("beta", "tau", "theta_resp_pred")) - for(n in names(best_sim)) { - OB_case <- OB_ref[[n]] - case <- modifyList(OB_case, list(ref=NULL, sim=best_sim[[n]])) - best_std <- do.call(get_std_quants, case) - res <- abs(best_std$ref - OB_case$ref) - ##cat("Testing", n, ":", signif(res, 3), "\n") - ##cat(n, " = ", paste(round(res, 4), collapse=", "), "\n") - expect_true(all(res < eps)) - } + best_sim <- rstan::extract(best_gmap$fit, pars = c("beta", "tau", "theta_resp_pred")) + for (n in names(best_sim)) { + OB_case <- OB_ref[[n]] + case <- modifyList(OB_case, list(ref = NULL, sim = best_sim[[n]])) + best_std <- do.call(get_std_quants, case) + res <- abs(best_std$ref - OB_case$ref) + ## cat("Testing", n, ":", signif(res, 3), "\n") + ## cat(n, " = ", paste(round(res, 4), collapse=", "), "\n") + expect_true(all(res < eps)) + } } make_rstanarm_ref <- function(stanreg) { - pred_arm <- stanreg$family$linkinv(posterior_linpred(stanreg, newdata=data.frame(study="MAP", e=1))) - arm_post <- cbind(as.matrix(stanreg, pars=c("(Intercept)", "Sigma[study:(Intercept),(Intercept)]")), pred_arm) - arm_post[,2] <- sqrt(arm_post[,2]) - colnames(arm_post) <- c("beta", "tau", "theta_resp_pred") - arm_ref <- lapply(1:3, function(v) get_std_quants(arm_post[,v])) - names(arm_ref) <- colnames(arm_post) - arm_ref + pred_arm <- stanreg$family$linkinv(posterior_linpred(stanreg, newdata = data.frame(study = "MAP", e = 1))) + arm_post <- cbind(as.matrix(stanreg, pars = c("(Intercept)", "Sigma[study:(Intercept),(Intercept)]")), pred_arm) + arm_post[, 2] <- sqrt(arm_post[, 2]) + colnames(arm_post) <- c("beta", "tau", "theta_resp_pred") + arm_ref <- lapply(1:3, function(v) get_std_quants(arm_post[, v])) + names(arm_ref) <- colnames(arm_post) + arm_ref } ## these examples need very high adapt_delta to avoid divergent ## transitions do.call(options, std_sampling) -options(RBesT.MC.control=list(adapt_delta=0.999, stepsize=0.01)) +options(RBesT.MC.control = list(adapt_delta = 0.999, stepsize = 0.01)) test_that("gMAP meets SBC requirements wrt to a Chi-Square statistic.", { - require(dplyr) - require(tidyr) - sbc_chisq_test <- RBesT:::calibration_data %>% - gather(count.mu, count.tau, key="param", value="count") %>% - group_by(data_scenario, family, sd_tau, param) %>% - do(as.data.frame(chisq.test(.$count)[c("statistic", "p.value")])) - num_tests <- nrow(sbc_chisq_test) - num_failed <- sum(sbc_chisq_test$p.value < 0.05) - pv <- pbinom(num_failed, num_tests, 0.05) - expect_true( pv > 0.025 & pv < 0.975 ) -} -) + require(dplyr) + require(tidyr) + sbc_chisq_test <- RBesT:::calibration_data %>% + gather(count.mu, count.tau, key = "param", value = "count") %>% + group_by(data_scenario, family, sd_tau, param) %>% + do(as.data.frame(chisq.test(.$count)[c("statistic", "p.value")])) + num_tests <- nrow(sbc_chisq_test) + num_failed <- sum(sbc_chisq_test$p.value < 0.05) + pv <- pbinom(num_failed, num_tests, 0.05) + expect_true(pv > 0.025 & pv < 0.975) +}) test_that("gMAP meets SBC requirements per bin.", { - require(dplyr) - require(tidyr) - B <- RBesT:::calibration_meta$B - S <- RBesT:::calibration_meta$S - alpha <- 0.2 - ptrue <- 1/B - crit_low <- qbinom(alpha/2, S, ptrue) - crit_high <- qbinom(1-alpha/2, S, ptrue) - sbc_binom_test <- RBesT:::calibration_data %>% - gather(count.mu, count.tau, key="param", value="count") %>% - group_by(data_scenario, family, sd_tau, param) %>% - summarise(crit=sum(count < crit_low | count > crit_high)) %>% - mutate(pvalue=pbinom(crit, B, alpha), extreme=pvalue<0.025|pvalue>0.975) - num_tests <- nrow(sbc_binom_test) - num_failed <- sum(sbc_binom_test$extreme) - pv <- pbinom(num_failed, num_tests, 0.05) - expect_true( pv > 0.025 & pv < 0.975 ) -} -) + require(dplyr) + require(tidyr) + B <- RBesT:::calibration_meta$B + S <- RBesT:::calibration_meta$S + alpha <- 0.2 + ptrue <- 1 / B + crit_low <- qbinom(alpha / 2, S, ptrue) + crit_high <- qbinom(1 - alpha / 2, S, ptrue) + sbc_binom_test <- RBesT:::calibration_data %>% + gather(count.mu, count.tau, key = "param", value = "count") %>% + group_by(data_scenario, family, sd_tau, param) %>% + summarise(crit = sum(count < crit_low | count > crit_high)) %>% + mutate(pvalue = pbinom(crit, B, alpha), extreme = pvalue < 0.025 | pvalue > 0.975) + num_tests <- nrow(sbc_binom_test) + num_failed <- sum(sbc_binom_test$extreme) + pv <- pbinom(num_failed, num_tests, 0.05) + expect_true(pv > 0.025 & pv < 0.975) +}) test_that("SBC data was up to date at package creation.", { - calibration_datum <- RBesT:::calibration_meta$created - package_datum <- RBesT:::pkg_create_date - delta <- difftime(package_datum, calibration_datum, units="weeks") - expect_true(delta < 52./2.) -} -) + calibration_datum <- RBesT:::calibration_meta$created + package_datum <- RBesT:::pkg_create_date + delta <- difftime(package_datum, calibration_datum, units = "weeks") + expect_true(delta < 52. / 2.) +}) ## match against respective rstanarm model set.seed(92575) -rate <- round(-log(0.05)/2, 1) +rate <- round(-log(0.05) / 2, 1) test_that("gMAP matches RStanArm binomial family", { - skip("RStanArm has issues loading since 2024-01-02 on CI/CD systems.") - skip_on_cran() - suppressWarnings( best_run <- gMAP(cbind(r, n-r) ~ 1 | study, - data=AS, - family=binomial, - tau.dist="Exp", - tau.prior=c(rate), - beta.prior=cbind(0, 2) - ) ) - suppressWarnings( out <- capture.output(rstanarm_run <- make_rstanarm_ref( - stan_glmer(cbind(r, n-r) ~ 1 + (1|study), - data=AS, - family=binomial, - refresh=0, - iter=4000, - warmup=1000, - adapt_delta=0.999, - seed=4356, - chains=4, - prior=normal(0,2,autoscale=FALSE), - prior_intercept=normal(0,2,autoscale=FALSE), - prior_covariance=decov(1, 1, 1, 1/rate) - ))) - ) - cmp_reference(best_gmap=best_run, OB_ref=rstanarm_run) - }) + skip("RStanArm has issues loading since 2024-01-02 on CI/CD systems.") + skip_on_cran() + suppressWarnings(best_run <- gMAP(cbind(r, n - r) ~ 1 | study, + data = AS, + family = binomial, + tau.dist = "Exp", + tau.prior = c(rate), + beta.prior = cbind(0, 2) + )) + suppressWarnings(out <- capture.output(rstanarm_run <- make_rstanarm_ref( + stan_glmer(cbind(r, n - r) ~ 1 + (1 | study), + data = AS, + family = binomial, + refresh = 0, + iter = 4000, + warmup = 1000, + adapt_delta = 0.999, + seed = 4356, + chains = 4, + prior = normal(0, 2, autoscale = FALSE), + prior_intercept = normal(0, 2, autoscale = FALSE), + prior_covariance = decov(1, 1, 1, 1 / rate) + ) + ))) + cmp_reference(best_gmap = best_run, OB_ref = rstanarm_run) +}) ## the remaining tests do not rely on good sampling, hence speed it up do.call(options, fast_sampling) ## add test case with a single data test_that("gMAP processes single trial case", { - suppressMessages(suppressWarnings(map1 <- gMAP(cbind(r, n-r) ~ 1, - data=colitis[1,], - family=binomial, - tau.dist="HalfNormal", - ## prior are choosen super-tight to avoid sampling trouble - tau.prior=c(0.5), - beta.prior=cbind(0, 1) - ))) - expect_true(nrow(fitted(map1)) == 1) - } - ) + suppressMessages(suppressWarnings(map1 <- gMAP(cbind(r, n - r) ~ 1, + data = colitis[1, ], + family = binomial, + tau.dist = "HalfNormal", + ## prior are choosen super-tight to avoid sampling trouble + tau.prior = c(0.5), + beta.prior = cbind(0, 1) + ))) + expect_true(nrow(fitted(map1)) == 1) +}) test_that("gMAP processes not continuously labeled studies", { - suppressWarnings( out <- capture.output(map1 <- gMAP(cbind(r, n-r) ~ 1 | study, data=AS[-1,], - family=binomial, tau.dist="HalfNormal", tau.prior=0.5, - iter=100, warmup=50, chains=1, thin=1)) - ) - expect_true(nrow(fitted(map1)) == nrow(AS) - 1) - }) + suppressWarnings(out <- capture.output(map1 <- gMAP(cbind(r, n - r) ~ 1 | study, + data = AS[-1, ], + family = binomial, tau.dist = "HalfNormal", tau.prior = 0.5, + iter = 100, warmup = 50, chains = 1, thin = 1 + ))) + expect_true(nrow(fitted(map1)) == nrow(AS) - 1) +}) ## set bad sampling parameters to trigger divergences in the next test do.call(options, bad_sampling) set.seed(23434) test_that("gMAP reports divergences", { - suppressMessages(suppressWarnings(mcmc_div <- gMAP(cbind(r, n-r) ~ 1 | study, data=AS[1,,drop=FALSE], family=binomial, - tau.dist="Uniform", tau.prior=cbind(0, 1000), - beta.prior=cbind(0,1E5), - iter=1000, warmup=0, chains=1, thin=1, init=10))) - sp <- rstan::get_sampler_params(mcmc_div$fit, inc_warmup=FALSE)[[1]] - expect_true(sum(sp[,"divergent__"]) > 0) - }) + suppressMessages(suppressWarnings(mcmc_div <- gMAP(cbind(r, n - r) ~ 1 | study, + data = AS[1, , drop = FALSE], family = binomial, + tau.dist = "Uniform", tau.prior = cbind(0, 1000), + beta.prior = cbind(0, 1E5), + iter = 1000, warmup = 0, chains = 1, thin = 1, init = 10 + ))) + sp <- rstan::get_sampler_params(mcmc_div$fit, inc_warmup = FALSE)[[1]] + expect_true(sum(sp[, "divergent__"]) > 0) +}) ## set sampling back to standards do.call(options, std_sampling) test_that("gMAP handles extreme response rates", { - n <- 5 - data1 <- data.frame(n=c(n,n,n,n),r=c(5,5,5,5), study=1) - suppressWarnings( map1 <- gMAP(cbind(r, n-r) ~ 1 | study, family=binomial, - data=data1, tau.dist="HalfNormal", - tau.prior=2.0, beta.prior=2, - warmup=100, iter=200, chains=1, thin=1) ) - expect_true(nrow(fitted(map1)) == 4) - data2 <- data.frame(n=c(n,n,n,n),r=c(0,0,0,0), study=1) - suppressWarnings( map2 <- gMAP(cbind(r, n-r) ~ 1 | study, family=binomial, - data=data2, tau.dist="HalfNormal", - tau.prior=2.0, beta.prior=2, - warmup=100, iter=200, chains=1, thin=1) ) - expect_true(nrow(fitted(map2)) == 4) - data3 <- data.frame(n=c(n,n,n,n),r=c(5,5,5,5), study=c(1,1,2,2)) - suppressWarnings( map3 <- gMAP(cbind(r, n-r) ~ 1 | study, family=binomial, - data=data3, tau.dist="HalfNormal", - tau.prior=2.0, beta.prior=2, - warmup=100, iter=200, chains=1, thin=1) ) - expect_true(nrow(fitted(map3)) == 4) - }) + n <- 5 + data1 <- data.frame(n = c(n, n, n, n), r = c(5, 5, 5, 5), study = 1) + suppressWarnings(map1 <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = data1, tau.dist = "HalfNormal", + tau.prior = 2.0, beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + )) + expect_true(nrow(fitted(map1)) == 4) + data2 <- data.frame(n = c(n, n, n, n), r = c(0, 0, 0, 0), study = 1) + suppressWarnings(map2 <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = data2, tau.dist = "HalfNormal", + tau.prior = 2.0, beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + )) + expect_true(nrow(fitted(map2)) == 4) + data3 <- data.frame(n = c(n, n, n, n), r = c(5, 5, 5, 5), study = c(1, 1, 2, 2)) + suppressWarnings(map3 <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = data3, tau.dist = "HalfNormal", + tau.prior = 2.0, beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + )) + expect_true(nrow(fitted(map3)) == 4) +}) test_that("gMAP handles fixed tau case", { - suppressWarnings( map1 <- gMAP(cbind(r, n-r) ~ 1 | study, family=binomial, - data=AS, tau.dist="Fixed", - tau.prior=0.5, beta.prior=2, - warmup=100, iter=200, chains=1, thin=1) ) - expect_true(map1$Rhat.max >= 1) - }) + suppressWarnings(map1 <- gMAP(cbind(r, n - r) ~ 1 | study, + family = binomial, + data = AS, tau.dist = "Fixed", + tau.prior = 0.5, beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + )) + expect_true(map1$Rhat.max >= 1) +}) test_that("gMAP labels data rows correctly when using covariates", { - - data_covs <- data.frame(n=10, r=3, study=c(1,2,2), stratum=factor(c("A", "A", "B")) ) %>% - mutate(group=paste(study,stratum,sep="/"), id=as.integer(factor(group))) - - suppressMessages(suppressWarnings(map_covs <- gMAP(cbind(r, n-r) ~ 1 + stratum | study, family=binomial, - data=data_covs, tau.dist="Fixed", - tau.prior=0.25, beta.prior=2, - warmup=100, iter=200, chains=1, thin=1))) - - expect_true(all(rownames(fitted(map_covs)) == paste(data_covs$study, data_covs$stratum, sep="/"))) - - suppressMessages(suppressWarnings(map_tau_strata <- gMAP(cbind(r, n-r) ~ 1 | id, family=binomial, - tau.strata=stratum, - data=data_covs, tau.dist="Fixed", - tau.prior=c(0.25, 0.5), beta.prior=2, - warmup=100, iter=200, chains=1, thin=1))) - expect_true(all(rownames(fitted(map_tau_strata)) == as.character(data_covs$id))) - - }) + data_covs <- data.frame(n = 10, r = 3, study = c(1, 2, 2), stratum = factor(c("A", "A", "B"))) %>% + mutate(group = paste(study, stratum, sep = "/"), id = as.integer(factor(group))) + + suppressMessages(suppressWarnings(map_covs <- gMAP(cbind(r, n - r) ~ 1 + stratum | study, + family = binomial, + data = data_covs, tau.dist = "Fixed", + tau.prior = 0.25, beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + ))) + + expect_true(all(rownames(fitted(map_covs)) == paste(data_covs$study, data_covs$stratum, sep = "/"))) + + suppressMessages(suppressWarnings(map_tau_strata <- gMAP(cbind(r, n - r) ~ 1 | id, + family = binomial, + tau.strata = stratum, + data = data_covs, tau.dist = "Fixed", + tau.prior = c(0.25, 0.5), beta.prior = 2, + warmup = 100, iter = 200, chains = 1, thin = 1 + ))) + expect_true(all(rownames(fitted(map_tau_strata)) == as.character(data_covs$id))) +}) diff --git a/tests/testthat/test-mixdiff.R b/tests/testthat/test-mixdiff.R index 154d05c..fd52880 100644 --- a/tests/testthat/test-mixdiff.R +++ b/tests/testthat/test-mixdiff.R @@ -1,4 +1,3 @@ - ## test that calculations for the cumulative distribution function of ## differences in mixture distributions are correct by comparison with ## sampling @@ -11,88 +10,115 @@ eps <- 1e-2 ## number of samples used for sampling method Nsamp <- 1e6 -probs <- seq(0.1, 0.9, by=0.1) +probs <- seq(0.1, 0.9, by = 0.1) ## define the different test cases -beta <- list(mix1=mixbeta(c(1, 11, 4)), mix2=mixbeta(c(1, 8, 7)), q=c(0, 0.3), p=probs) -betaMix <- list(mix1=mixbeta(c(0.8, 11, 4), c(0.2, 1, 1)), mix2=mixbeta(c(0.8, 8, 7), c(0.2, 1, 1)), q=c(0, 0.3), p=probs) +beta <- list(mix1 = mixbeta(c(1, 11, 4)), mix2 = mixbeta(c(1, 8, 7)), q = c(0, 0.3), p = probs) +betaMix <- list(mix1 = mixbeta(c(0.8, 11, 4), c(0.2, 1, 1)), mix2 = mixbeta(c(0.8, 8, 7), c(0.2, 1, 1)), q = c(0, 0.3), p = probs) -gamma <- list(mix1=mixgamma(c(1, 20, 4)), mix2=mixgamma(c(1, 50, 10)), q=c(0, -2), p=probs) -gammaMix <- list(mix1=mixgamma(rob=c(0.75, 8, 0.5), inf=c(0.25, 9, 2), param="ms"), mix2=mixgamma(c(1, 50, 10)), q=c(0, -2), p=probs) +gamma <- list(mix1 = mixgamma(c(1, 20, 4)), mix2 = mixgamma(c(1, 50, 10)), q = c(0, -2), p = probs) +gammaMix <- list(mix1 = mixgamma(rob = c(0.75, 8, 0.5), inf = c(0.25, 9, 2), param = "ms"), mix2 = mixgamma(c(1, 50, 10)), q = c(0, -2), p = probs) -nm <- mixnorm(rob=c(0.2, 0, 2), inf=c(0.8, 2, 2), sigma=5) +nm <- mixnorm(rob = c(0.2, 0, 2), inf = c(0.8, 2, 2), sigma = 5) -norm <- list(mix1=mixnorm(c(1, 10, sqrt(1/4))), mix2=mixnorm(c(1, 11, sqrt(1/4))), q=c(0, 1.5), p=probs ) -norm_ref <- mixnorm(c(1,10-11,sqrt(1/4 + 1/4))) +norm <- list(mix1 = mixnorm(c(1, 10, sqrt(1 / 4))), mix2 = mixnorm(c(1, 11, sqrt(1 / 4))), q = c(0, 1.5), p = probs) +norm_ref <- mixnorm(c(1, 10 - 11, sqrt(1 / 4 + 1 / 4))) -normMix <- list(mix1=mixnorm(c(0.2, 0, 2), c(0.8, 2, 2)), mix2=mixnorm(c(1, 2, sqrt(4))), q=c(0, 1.5), p=probs ) -normMix_ref <- mixnorm(c(0.2, 0-2, sqrt(4 + 4)), c(0.8, 2-2, sqrt(4+4))) +normMix <- list(mix1 = mixnorm(c(0.2, 0, 2), c(0.8, 2, 2)), mix2 = mixnorm(c(1, 2, sqrt(4))), q = c(0, 1.5), p = probs) +normMix_ref <- mixnorm(c(0.2, 0 - 2, sqrt(4 + 4)), c(0.8, 2 - 2, sqrt(4 + 4))) -mixdiff_sample <- function(mix1, mix2, q, p, N=Nsamp) { - samp <- rmix(mix1, N) - rmix(mix2, N) - list(probs=vapply(q, function(v) mean(samp < v), c(p=0.1)), quants=quantile(samp, p)) +mixdiff_sample <- function(mix1, mix2, q, p, N = Nsamp) { + samp <- rmix(mix1, N) - rmix(mix2, N) + list(probs = vapply(q, function(v) mean(samp < v), c(p = 0.1)), quants = quantile(samp, p)) } -mixdiff_cmp <- function(case, rev=FALSE) { - ## skip for speed on CRAN - skip_on_cran() - ref_probs <- do.call(pmixdiff, case[c("mix1", "mix2", "q")]) - ref_quants <- do.call(qmixdiff, case[c("mix1", "mix2", "p")]) - test <- do.call(mixdiff_sample, case) - res_probs <- abs(ref_probs - test$probs) - res_quants <- abs(ref_quants - test$quants) - expect_true(all(res_probs < eps)) - expect_true(all(res_quants < eps)) - ## also check the reversed difference case - if(!rev) { - case_rev <- case - case_rev$mix1 <- case$mix2 - case_rev$mix2 <- case$mix1 - mixdiff_cmp(case_rev, TRUE) - } +mixdiff_cmp <- function(case, rev = FALSE) { + ## skip for speed on CRAN + skip_on_cran() + ref_probs <- do.call(pmixdiff, case[c("mix1", "mix2", "q")]) + ref_quants <- do.call(qmixdiff, case[c("mix1", "mix2", "p")]) + test <- do.call(mixdiff_sample, case) + res_probs <- abs(ref_probs - test$probs) + res_quants <- abs(ref_quants - test$quants) + expect_true(all(res_probs < eps)) + expect_true(all(res_quants < eps)) + ## also check the reversed difference case + if (!rev) { + case_rev <- case + case_rev$mix1 <- case$mix2 + case_rev$mix2 <- case$mix1 + mixdiff_cmp(case_rev, TRUE) + } } mixdiff_cmp_norm <- function(case, mixref) { - test_probs <- do.call(pmixdiff, case[c("mix1", "mix2", "q")]) - test_quants <- do.call(qmixdiff, case[c("mix1", "mix2", "p")]) - ref_probs <- pmix(mixref, case$q) - ref_quants <- qmix(mixref, case$p) - res_probs <- abs(ref_probs - test_probs) - res_quants <- abs(ref_quants - test_quants) - expect_true(all(res_probs < eps)) - expect_true(all(res_quants < eps)) + test_probs <- do.call(pmixdiff, case[c("mix1", "mix2", "q")]) + test_quants <- do.call(qmixdiff, case[c("mix1", "mix2", "p")]) + ref_probs <- pmix(mixref, case$q) + ref_quants <- qmix(mixref, case$p) + res_probs <- abs(ref_probs - test_probs) + res_quants <- abs(ref_quants - test_quants) + expect_true(all(res_probs < eps)) + expect_true(all(res_quants < eps)) } -test_that("Difference in beta variates evaluates correctly", { mixdiff_cmp(beta) }) -test_that("Difference in beta mixture variates evaluates correctly", { mixdiff_cmp(betaMix) }) - -test_that("Difference in gamma variates evaluates correctly", { mixdiff_cmp(gamma) }) -test_that("Difference in gamma mixture variates evaluates correctly", { mixdiff_cmp(gammaMix) }) - -test_that("Difference in normal variates evaluates correctly", { mixdiff_cmp(norm) }) -test_that("Difference in normal mixture variates evaluates correctly", { mixdiff_cmp(normMix) }) +test_that("Difference in beta variates evaluates correctly", { + mixdiff_cmp(beta) +}) +test_that("Difference in beta mixture variates evaluates correctly", { + mixdiff_cmp(betaMix) +}) + +test_that("Difference in gamma variates evaluates correctly", { + mixdiff_cmp(gamma) +}) +test_that("Difference in gamma mixture variates evaluates correctly", { + mixdiff_cmp(gammaMix) +}) + +test_that("Difference in normal variates evaluates correctly", { + mixdiff_cmp(norm) +}) +test_that("Difference in normal mixture variates evaluates correctly", { + mixdiff_cmp(normMix) +}) ## for the normal we can use exact analytical results -test_that("Difference in normal variates evaluates (analytically) correctly", { mixdiff_cmp_norm(norm,norm_ref) }) -test_that("Difference in normal mixture variates evaluates (analytically) correctly", { mixdiff_cmp_norm(normMix,normMix_ref) }) +test_that("Difference in normal variates evaluates (analytically) correctly", { + mixdiff_cmp_norm(norm, norm_ref) +}) +test_that("Difference in normal mixture variates evaluates (analytically) correctly", { + mixdiff_cmp_norm(normMix, normMix_ref) +}) ## now test difference distributions on the link-transformed scales ## (the cannonical cases) apply_link <- function(dists, link) { - RBesT:::dlink(dists$mix1) <- link - RBesT:::dlink(dists$mix2) <- link - dists + RBesT:::dlink(dists$mix1) <- link + RBesT:::dlink(dists$mix2) <- link + dists } - + ## log-odds -test_that("Difference in beta variates with logit link evaluates correctly", { mixdiff_cmp(apply_link(beta, RBesT:::logit_dlink)) }) -test_that("Difference in beta mixture variates with logit link evaluates correctly", { mixdiff_cmp(apply_link(betaMix, RBesT:::logit_dlink)) }) +test_that("Difference in beta variates with logit link evaluates correctly", { + mixdiff_cmp(apply_link(beta, RBesT:::logit_dlink)) +}) +test_that("Difference in beta mixture variates with logit link evaluates correctly", { + mixdiff_cmp(apply_link(betaMix, RBesT:::logit_dlink)) +}) ## relative risk -test_that("Difference in beta variates with log link evaluates correctly", { mixdiff_cmp(apply_link(beta, RBesT:::log_dlink)) }) -test_that("Difference in beta mixture variates with log link evaluates correctly", { mixdiff_cmp(apply_link(betaMix, RBesT:::log_dlink)) }) +test_that("Difference in beta variates with log link evaluates correctly", { + mixdiff_cmp(apply_link(beta, RBesT:::log_dlink)) +}) +test_that("Difference in beta mixture variates with log link evaluates correctly", { + mixdiff_cmp(apply_link(betaMix, RBesT:::log_dlink)) +}) ## relative counts -test_that("Difference in gamma variates with log link evaluates correctly", { mixdiff_cmp(apply_link(gamma, RBesT:::log_dlink)) }) -test_that("Difference in gamma mixture variates with log link evaluates correctly", { mixdiff_cmp(apply_link(gammaMix, RBesT:::log_dlink)) }) - +test_that("Difference in gamma variates with log link evaluates correctly", { + mixdiff_cmp(apply_link(gamma, RBesT:::log_dlink)) +}) +test_that("Difference in gamma mixture variates with log link evaluates correctly", { + mixdiff_cmp(apply_link(gammaMix, RBesT:::log_dlink)) +}) diff --git a/tests/testthat/test-mixdist.R b/tests/testthat/test-mixdist.R index 84a9cdf..9d8be76 100644 --- a/tests/testthat/test-mixdist.R +++ b/tests/testthat/test-mixdist.R @@ -1,4 +1,3 @@ - ## various tests around mixture distributions set.seed(234534) @@ -18,96 +17,138 @@ Nsamp_equant <- 1E6 beta <- mixbeta(c(1, 11, 4)) betaMix <- mixbeta(c(0.8, 11, 4), c(0.2, 1, 1)) -gamma <- mixgamma(c(1, 5, 10), param="mn") -gammaMix <- mixgamma(rob=c(0.25, 8, 0.5), inf=c(0.75, 8, 10), param="mn") - -norm <- mixnorm(c(1, 0, sqrt(2)), sigma=1) - -normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 2), sigma=1) -normMixWeak <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 2), c(0, 0, 1), sigma=1) - -pmix_lower_tail_test <- function(mix, N=Nsamp_quant) { - ## sample some random quantiles - do_test <- function(mix) { - q <- rmix(mix, N) - pl <- pmix(mix, q, lower.tail=TRUE) - pu <- pmix(mix, q, lower.tail=FALSE) - res <- abs(pl - (1-pu) ) - expect_true(all(res < eps_lower)) - } - ## now also test the respective predictive - do_test(mix) - do_test(preddist(mix, n=100)) +gamma <- mixgamma(c(1, 5, 10), param = "mn") +gammaMix <- mixgamma(rob = c(0.25, 8, 0.5), inf = c(0.75, 8, 10), param = "mn") + +norm <- mixnorm(c(1, 0, sqrt(2)), sigma = 1) + +normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 2), sigma = 1) +normMixWeak <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 2), c(0, 0, 1), sigma = 1) + +pmix_lower_tail_test <- function(mix, N = Nsamp_quant) { + ## sample some random quantiles + do_test <- function(mix) { + q <- rmix(mix, N) + pl <- pmix(mix, q, lower.tail = TRUE) + pu <- pmix(mix, q, lower.tail = FALSE) + res <- abs(pl - (1 - pu)) + expect_true(all(res < eps_lower)) + } + ## now also test the respective predictive + do_test(mix) + do_test(preddist(mix, n = 100)) } -test_that("Cumulative beta distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(beta) }) -test_that("Cumulative beta mixture distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(betaMix) }) +test_that("Cumulative beta distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(beta) +}) +test_that("Cumulative beta mixture distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(betaMix) +}) -test_that("Cumulative normal distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(norm) }) -test_that("Cumulative normal mixture distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(normMix) }) +test_that("Cumulative normal distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(norm) +}) +test_that("Cumulative normal mixture distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(normMix) +}) -test_that("Cumulative gamma distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(gamma) }) -test_that("Cumulative gamma mixture distribution function evaluates lower.tail correctly", { pmix_lower_tail_test(gammaMix) }) +test_that("Cumulative gamma distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(gamma) +}) +test_that("Cumulative gamma mixture distribution function evaluates lower.tail correctly", { + pmix_lower_tail_test(gammaMix) +}) ## tests the quantile and distribution function against simulated samples -mix_simul_test <- function(mix, eps, qtest, ptest = seq(0.1, 0.9, by=0.1), S=Nsamp_equant) { - samp <- rmix(mix, S) - qtest_samp <- quantile(samp, ptest) - qref_qmix <- qmix(mix, ptest) - res_quants <- abs(qref_qmix - qtest_samp) - expect_true(all(res_quants < eps)) - ptest_samp <- vapply(qtest, function(q) mean(samp < q), c(0.1)) - pref_pmix <- pmix(mix, qtest) - res_probs <- abs(pref_pmix - ptest_samp) - expect_true(all(res_probs < eps)) +mix_simul_test <- function(mix, eps, qtest, ptest = seq(0.1, 0.9, by = 0.1), S = Nsamp_equant) { + samp <- rmix(mix, S) + qtest_samp <- quantile(samp, ptest) + qref_qmix <- qmix(mix, ptest) + res_quants <- abs(qref_qmix - qtest_samp) + expect_true(all(res_quants < eps)) + ptest_samp <- vapply(qtest, function(q) mean(samp < q), c(0.1)) + pref_pmix <- pmix(mix, qtest) + res_probs <- abs(pref_pmix - ptest_samp) + expect_true(all(res_probs < eps)) } -test_that("Beta quantile function is correct", { mix_simul_test(beta, eps, c(0.1, 0.9)) }) -test_that("Beta mixture quantile function is correct", { mix_simul_test(betaMix, eps, c(0.1, 0.9)) }) +test_that("Beta quantile function is correct", { + mix_simul_test(beta, eps, c(0.1, 0.9)) +}) +test_that("Beta mixture quantile function is correct", { + mix_simul_test(betaMix, eps, c(0.1, 0.9)) +}) -test_that("Normal quantile function is correct", { mix_simul_test(norm, eps, c(-1, 0)) }) -test_that("Normal mixture quantile function is correct", { mix_simul_test(normMix, eps, c(4, 1)) }) -test_that("Normal mixture with very weak component quantile function is correct", { mix_simul_test(normMixWeak, eps, c(4, 1)) }) +test_that("Normal quantile function is correct", { + mix_simul_test(norm, eps, c(-1, 0)) +}) +test_that("Normal mixture quantile function is correct", { + mix_simul_test(normMix, eps, c(4, 1)) +}) +test_that("Normal mixture with very weak component quantile function is correct", { + mix_simul_test(normMixWeak, eps, c(4, 1)) +}) -test_that("Gamma quantile function is correct", { mix_simul_test(gamma, eps, c(2, 7)) }) -test_that("Gamma mixture quantile function is correct", { mix_simul_test(gammaMix, eps, c(2, 7), ptest = seq(0.2, 0.8, by=0.1)) }) +test_that("Gamma quantile function is correct", { + mix_simul_test(gamma, eps, c(2, 7)) +}) +test_that("Gamma mixture quantile function is correct", { + mix_simul_test(gammaMix, eps, c(2, 7), ptest = seq(0.2, 0.8, by = 0.1)) +}) ## problematic gamma (triggers internally a fallback to root finding) -gammaMix2 <- mixgamma(c(8.949227e-01, 7.051570e-01, 6.125121e-02), - c(1.049106e-01, 3.009986e-01, 5.169626e-04), - c(1.666667e-04, 1.836051e+04, 1.044005e-02)) - -test_that("Singular gamma mixture quantile function is correct", { mix_simul_test(gammaMix2, 10*eps, c(1, 1E3), ptest = seq(0.2, 0.8, by=0.1)) }) +gammaMix2 <- mixgamma( + c(8.949227e-01, 7.051570e-01, 6.125121e-02), + c(1.049106e-01, 3.009986e-01, 5.169626e-04), + c(1.666667e-04, 1.836051e+04, 1.044005e-02) +) + +test_that("Singular gamma mixture quantile function is correct", { + mix_simul_test(gammaMix2, 10 * eps, c(1, 1E3), ptest = seq(0.2, 0.8, by = 0.1)) +}) consistent_cdf <- function(mix, values) { - dens <- dmix(mix, values) - cdf <- pmix(mix, values) - lcdf <- pmix(mix, values, log.p=TRUE) - expect_true(all(diff(cdf) >= 0)) - expect_numeric(dens, lower=0, finite=TRUE, any.missing=FALSE) - expect_numeric(cdf, lower=0, upper=1, finite=TRUE, any.missing=FALSE) - expect_numeric(lcdf, upper=0, finite=FALSE, any.missing=FALSE) + dens <- dmix(mix, values) + cdf <- pmix(mix, values) + lcdf <- pmix(mix, values, log.p = TRUE) + expect_true(all(diff(cdf) >= 0)) + expect_numeric(dens, lower = 0, finite = TRUE, any.missing = FALSE) + expect_numeric(cdf, lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) + expect_numeric(lcdf, upper = 0, finite = FALSE, any.missing = FALSE) } consistent_ccdf <- function(mix, values) { - dens <- dmix(mix, values) - ccdf <- pmix(mix, values, FALSE) - lccdf <- pmix(mix, values, FALSE, TRUE) - expect_true(all(diff(ccdf) <= 0)) - expect_numeric(dens, lower=0, finite=TRUE, any.missing=FALSE) - expect_numeric(ccdf, lower=0, upper=1, finite=TRUE, any.missing=FALSE) - expect_numeric(lccdf, upper=0, finite=FALSE, any.missing=FALSE) + dens <- dmix(mix, values) + ccdf <- pmix(mix, values, FALSE) + lccdf <- pmix(mix, values, FALSE, TRUE) + expect_true(all(diff(ccdf) <= 0)) + expect_numeric(dens, lower = 0, finite = TRUE, any.missing = FALSE) + expect_numeric(ccdf, lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) + expect_numeric(lccdf, upper = 0, finite = FALSE, any.missing = FALSE) } -test_that("Beta CDF function is consistent", { consistent_cdf(beta, seq(0.1, 0.9, by=0.1)) }) -test_that("Beta mixture CDF function is consistent", { consistent_cdf(betaMix, seq(0.1, 0.9, by=0.1)) }) +test_that("Beta CDF function is consistent", { + consistent_cdf(beta, seq(0.1, 0.9, by = 0.1)) +}) +test_that("Beta mixture CDF function is consistent", { + consistent_cdf(betaMix, seq(0.1, 0.9, by = 0.1)) +}) -test_that("Normal CDF is consistent", { consistent_cdf(norm, seq(-2, 2, by=0.1)) }) -test_that("Normal mixture CDF is consistent", { consistent_cdf(norm, seq(-2, 2, by=0.1)) }) +test_that("Normal CDF is consistent", { + consistent_cdf(norm, seq(-2, 2, by = 0.1)) +}) +test_that("Normal mixture CDF is consistent", { + consistent_cdf(norm, seq(-2, 2, by = 0.1)) +}) -test_that("Gamma CDF function is consistent", { consistent_cdf(gamma, seq(2, 7, by=0.1)) }) -test_that("Gamma mixture CDF function is consistent", { consistent_cdf(gammaMix, seq(2, 7, by=0.1)) }) +test_that("Gamma CDF function is consistent", { + consistent_cdf(gamma, seq(2, 7, by = 0.1)) +}) +test_that("Gamma mixture CDF function is consistent", { + consistent_cdf(gammaMix, seq(2, 7, by = 0.1)) +}) ## problematic beta which triggers that the cumulative of the @@ -116,11 +157,19 @@ test_that("Gamma mixture CDF function is consistent", { consistent_cdf(gammaMix, ## problematic Beta density bm1 <- mixbeta(c(1.0, 298.30333970, 146.75306521)) -test_that("Problematic (1) BetaBinomial CDF function is consistent", { consistent_cdf(preddist(bm1, n=50), 0:50) }) -test_that("Problematic (1) BetaBinomial CCDF function is consistent", { consistent_ccdf(preddist(bm1, n=50), 0:50) }) -bm2 <- mixbeta(c(1.0, 3 + 1/3, 47 + 1/3)) -test_that("Problematic (2) BetaBinomial CDF function is consistent", { consistent_cdf(preddist(bm2, n=50), 0:50) }) -test_that("Problematic (2) BetaBinomial CCDF function is consistent", { consistent_ccdf(preddist(bm2, n=50), 0:50) }) +test_that("Problematic (1) BetaBinomial CDF function is consistent", { + consistent_cdf(preddist(bm1, n = 50), 0:50) +}) +test_that("Problematic (1) BetaBinomial CCDF function is consistent", { + consistent_ccdf(preddist(bm1, n = 50), 0:50) +}) +bm2 <- mixbeta(c(1.0, 3 + 1 / 3, 47 + 1 / 3)) +test_that("Problematic (2) BetaBinomial CDF function is consistent", { + consistent_cdf(preddist(bm2, n = 50), 0:50) +}) +test_that("Problematic (2) BetaBinomial CCDF function is consistent", { + consistent_ccdf(preddist(bm2, n = 50), 0:50) +}) ## tests for the multivariate normal mixture density p <- 4 @@ -132,66 +181,62 @@ S <- diag(s, p) %*% Rho %*% diag(s, p) rownames(S) <- colnames(S) <- 1:p mvn_consistent_dimension <- function(mix, p) { - s <- summary(mix) - expect_numeric(s$mean, any.missing=FALSE, len=p) - expect_matrix(s$cov, any.missing=FALSE, nrows=p, ncols=p) + s <- summary(mix) + expect_numeric(s$mean, any.missing = FALSE, len = p) + expect_matrix(s$cov, any.missing = FALSE, nrows = p, ncols = p) } -test_that("Multivariate normal mixture has consistent dimensionality", -{ - for(i in 1:(nrow(S)-1)) { - p_sub <- 4-i - S_sub <- S[-c(1:i), -c(1:i), drop=FALSE] - mvn_consistent_dimension(mixmvnorm(c(1, rep(0, p_sub), S_sub), sigma=S_sub), p_sub) - } -}) - -test_that("Multivariate normal mixture has consistent dimension naming", -{ - for(i in 1:(nrow(S)-1)) { - p_sub <- 4-i - S_sub <- S[-c(1:i), -c(1:i), drop=FALSE] - m_sub <- rep(0, p_sub) - dim_labels <- letters[1:p_sub] - names(m_sub) <- dim_labels - test_mix <- mixmvnorm(c(1, m_sub, S_sub), sigma=S_sub) - ## now test that names are used consistently - expect_equal(rownames(sigma(test_mix)), dim_labels) - expect_equal(colnames(sigma(test_mix)), dim_labels) - expect_equal(names(summary(test_mix)$mean), dim_labels) - expect_equal(rownames(summary(test_mix)$cov), dim_labels) - expect_equal(colnames(summary(test_mix)$cov), dim_labels) - expect_equal(colnames(rmix(test_mix, 1)), dim_labels) - } -}) - -test_that("Multivariate normal mixture has consistent initialization", -{ - p <- nrow(S) - mv1 <- mixmvnorm(c(1, rep(0, p), S), sigma=S, param="ms") - mv2 <- mixmvnorm(c(1, rep(0, p), 1), sigma=S, param="mn") - mv3 <- mixmvnorm(c(1, rep(0, p), 2), sigma=S, param="mn") - - expect_equal(summary(mv1)$cov, S, tolerance=eps_lower) - expect_equal(summary(mv2)$cov, S, tolerance=eps_lower) - expect_equal(summary(mv3)$cov, S/2, tolerance=eps_lower) -}) - -mvn_consistent_summaries <- function(mix, S=Nsamp_equant) { - samp <- rmix(mix, S) - m <- colMeans(samp) - expect_equal(colMeans(samp), summary(mix)$mean, tolerance=eps) - expect_equal(cov(samp), summary(mix)$cov, tolerance=eps) +test_that("Multivariate normal mixture has consistent dimensionality", { + for (i in 1:(nrow(S) - 1)) { + p_sub <- 4 - i + S_sub <- S[-c(1:i), -c(1:i), drop = FALSE] + mvn_consistent_dimension(mixmvnorm(c(1, rep(0, p_sub), S_sub), sigma = S_sub), p_sub) + } +}) + +test_that("Multivariate normal mixture has consistent dimension naming", { + for (i in 1:(nrow(S) - 1)) { + p_sub <- 4 - i + S_sub <- S[-c(1:i), -c(1:i), drop = FALSE] + m_sub <- rep(0, p_sub) + dim_labels <- letters[1:p_sub] + names(m_sub) <- dim_labels + test_mix <- mixmvnorm(c(1, m_sub, S_sub), sigma = S_sub) + ## now test that names are used consistently + expect_equal(rownames(sigma(test_mix)), dim_labels) + expect_equal(colnames(sigma(test_mix)), dim_labels) + expect_equal(names(summary(test_mix)$mean), dim_labels) + expect_equal(rownames(summary(test_mix)$cov), dim_labels) + expect_equal(colnames(summary(test_mix)$cov), dim_labels) + expect_equal(colnames(rmix(test_mix, 1)), dim_labels) + } +}) + +test_that("Multivariate normal mixture has consistent initialization", { + p <- nrow(S) + mv1 <- mixmvnorm(c(1, rep(0, p), S), sigma = S, param = "ms") + mv2 <- mixmvnorm(c(1, rep(0, p), 1), sigma = S, param = "mn") + mv3 <- mixmvnorm(c(1, rep(0, p), 2), sigma = S, param = "mn") + + expect_equal(summary(mv1)$cov, S, tolerance = eps_lower) + expect_equal(summary(mv2)$cov, S, tolerance = eps_lower) + expect_equal(summary(mv3)$cov, S / 2, tolerance = eps_lower) +}) + +mvn_consistent_summaries <- function(mix, S = Nsamp_equant) { + samp <- rmix(mix, S) + m <- colMeans(samp) + expect_equal(colMeans(samp), summary(mix)$mean, tolerance = eps) + expect_equal(cov(samp), summary(mix)$cov, tolerance = eps) } -test_that("Multivariate normal mixture has consistent summaries", -{ - p <- nrow(S) - mv1 <- mixmvnorm(c(1, rep(0, p), S), sigma=S, param="ms") - mv2 <- mixmvnorm(c(1, rep(0, p), 1), sigma=S, param="mn") - mv3 <- mixmvnorm(c(0.2, rep(0, p), 2), c(0.8, rep(1, p), 6), sigma=S, param="mn") +test_that("Multivariate normal mixture has consistent summaries", { + p <- nrow(S) + mv1 <- mixmvnorm(c(1, rep(0, p), S), sigma = S, param = "ms") + mv2 <- mixmvnorm(c(1, rep(0, p), 1), sigma = S, param = "mn") + mv3 <- mixmvnorm(c(0.2, rep(0, p), 2), c(0.8, rep(1, p), 6), sigma = S, param = "mn") - mvn_consistent_summaries(mv1) - mvn_consistent_summaries(mv2) - mvn_consistent_summaries(mv3) + mvn_consistent_summaries(mv1) + mvn_consistent_summaries(mv2) + mvn_consistent_summaries(mv3) }) diff --git a/tests/testthat/test-mixstanvar.R b/tests/testthat/test-mixstanvar.R index 813e814..769d9cc 100644 --- a/tests/testthat/test-mixstanvar.R +++ b/tests/testthat/test-mixstanvar.R @@ -1,21 +1,19 @@ - - skip_if_not_installed("brms") ## various tests around mixture distributions set.seed(234534) -if(getOption("brms.backend", "not_set") == "not_set") { - .brms_backend <- Sys.getenv("BRMS_BACKEND", "not_set") - if(.brms_backend != "not_set") { - options(brms.backend=.brms_backend) - } +if (getOption("brms.backend", "not_set") == "not_set") { + .brms_backend <- Sys.getenv("BRMS_BACKEND", "not_set") + if (.brms_backend != "not_set") { + options(brms.backend = .brms_backend) + } } -if(getOption("cmdstanr_write_stan_file_dir", "not_set") == "not_set") { - .brms_cache_dir <- Sys.getenv("BRMS_CACHE_DIR", "not_set") - if(.brms_cache_dir != "not_set") { - options(cmdstanr_write_stan_file_dir=.brms_cache_dir) - } +if (getOption("cmdstanr_write_stan_file_dir", "not_set") == "not_set") { + .brms_cache_dir <- Sys.getenv("BRMS_CACHE_DIR", "not_set") + if (.brms_cache_dir != "not_set") { + options(cmdstanr_write_stan_file_dir = .brms_cache_dir) + } } ## sample based match requirements @@ -25,100 +23,148 @@ eps <- 1E-1 beta <- mixbeta(c(1, 11, 4)) betaMix <- mixbeta(c(0.8, 11, 4), c(0.2, 1, 1)) -gamma <- mixgamma(c(1, 5, 10), param="mn") -gammaMix <- mixgamma(rob=c(0.25, 8, 0.5), inf=c(0.75, 8, 10), param="mn") +gamma <- mixgamma(c(1, 5, 10), param = "mn") +gammaMix <- mixgamma(rob = c(0.25, 8, 0.5), inf = c(0.75, 8, 10), param = "mn") -norm <- mixnorm(c(1, 0, sqrt(2)), sigma=1) +norm <- mixnorm(c(1, 0, sqrt(2)), sigma = 1) -normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 1, 2), sigma=1) -normMixWeak <- mixnorm(c(0.2, 0, 2), c(0.8, 1, 2), c(0, 0, 1), sigma=1) +normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 1, 2), sigma = 1) +normMixWeak <- mixnorm(c(0.2, 0, 2), c(0.8, 1, 2), c(0, 0, 1), sigma = 1) ## tests the quantile and distribution function against simulated ## samples when using brms prior sampling as reference mixstanvar_simul_test <- function(mix, brms_args, - eps, qtest, ptest = seq(0.2, 0.8, by=0.2)) { - skip_on_cran() - skip_on_ci() - capture.output(brms_prior <- do.call(brms::brm, c(brms_args, list(seed=1423545, refresh=0, sample_prior="only", stanvars=mixstanvar(prior=mix))))) - samp <- as.numeric(brms::as_draws_matrix(brms_prior, variable="b_Intercept")[,1]) - qtest_samp <- quantile(samp, ptest) - qref_qmix <- qmix(mix, ptest) - res_quants <- abs(qref_qmix - qtest_samp) - expect_true(all(res_quants < eps)) - ptest_samp <- vapply(qtest, function(q) mean(samp < q), c(0.1)) - pref_pmix <- pmix(mix, qtest) - res_probs <- abs(pref_pmix - ptest_samp) - expect_true(all(res_probs < eps)) + eps, qtest, ptest = seq(0.2, 0.8, by = 0.2)) { + skip_on_cran() + skip_on_ci() + capture.output(brms_prior <- do.call(brms::brm, c(brms_args, list(seed = 1423545, refresh = 0, sample_prior = "only", stanvars = mixstanvar(prior = mix))))) + samp <- as.numeric(brms::as_draws_matrix(brms_prior, variable = "b_Intercept")[, 1]) + qtest_samp <- quantile(samp, ptest) + qref_qmix <- qmix(mix, ptest) + res_quants <- abs(qref_qmix - qtest_samp) + expect_true(all(res_quants < eps)) + ptest_samp <- vapply(qtest, function(q) mean(samp < q), c(0.1)) + pref_pmix <- pmix(mix, qtest) + res_probs <- abs(pref_pmix - ptest_samp) + expect_true(all(res_probs < eps)) } mixstanvar_test <- function(mix, brms_args) { - brms_prior_empty <- do.call(brms::brm, c(brms_args, list(seed=1423545, refresh=0, sample_prior="only", stanvars=mixstanvar(prior=mix), empty=TRUE))) - mix_class <- gsub("Mix$", "", class(mix)[1]) - stan_dist_lpdf <- paste0("mix", mix_class, "_lpdf") - stan_dist_lcdf <- paste0("mix", mix_class, "_lcdf") - stan_dist_lccdf <- paste0("mix", mix_class, "_lccdf") - stan_dist_cdf <- paste0("mix", mix_class, "_cdf") - ## look for the declared density in Stan - stan_code <- brms::stancode(brms_prior_empty) - expect_true(grep(stan_dist_lpdf, stan_code) == 1, info="Looking for declared Stan mixture density pdf in generated brms Stan code.") - expect_true(grep(stan_dist_lcdf, stan_code) == 1, info="Looking for declared Stan mixture density cdf in generated brms Stan code.") - expect_true(grep(stan_dist_lccdf, stan_code) == 1, info="Looking for declared Stan mixture density ccdf in generated brms Stan code.") - expect_true(grep(stan_dist_cdf, stan_code) == 1, info="Looking for declared Stan mixture density natural scale cdf in generated brms Stan code.") - ## now check for the mixture being passed to Stan as data - stan_data <- brms::standata(brms_prior_empty) - for(i in 1:3) { - param <- paste0("prior_", rownames(mix)[i]) - expect_true(all(unname(mix[i,]) == unname(stan_data[[param]]))) - } + brms_prior_empty <- do.call(brms::brm, c(brms_args, list(seed = 1423545, refresh = 0, sample_prior = "only", stanvars = mixstanvar(prior = mix), empty = TRUE))) + mix_class <- gsub("Mix$", "", class(mix)[1]) + stan_dist_lpdf <- paste0("mix", mix_class, "_lpdf") + stan_dist_lcdf <- paste0("mix", mix_class, "_lcdf") + stan_dist_lccdf <- paste0("mix", mix_class, "_lccdf") + stan_dist_cdf <- paste0("mix", mix_class, "_cdf") + ## look for the declared density in Stan + stan_code <- brms::stancode(brms_prior_empty) + expect_true(grep(stan_dist_lpdf, stan_code) == 1, info = "Looking for declared Stan mixture density pdf in generated brms Stan code.") + expect_true(grep(stan_dist_lcdf, stan_code) == 1, info = "Looking for declared Stan mixture density cdf in generated brms Stan code.") + expect_true(grep(stan_dist_lccdf, stan_code) == 1, info = "Looking for declared Stan mixture density ccdf in generated brms Stan code.") + expect_true(grep(stan_dist_cdf, stan_code) == 1, info = "Looking for declared Stan mixture density natural scale cdf in generated brms Stan code.") + ## now check for the mixture being passed to Stan as data + stan_data <- brms::standata(brms_prior_empty) + for (i in 1:3) { + param <- paste0("prior_", rownames(mix)[i]) + expect_true(all(unname(mix[i, ]) == unname(stan_data[[param]]))) + } } -brms_beta_args <- list(formula=brms::bf(r | trials(n) ~ 1, family=brms::brmsfamily("binomial", link="identity"), center=FALSE), - data=data.frame(r=0, n=0), - prior=brms::prior(mixbeta(prior_w, prior_a, prior_b), coef=Intercept)) - -test_that("Beta quantiles are correct for brms sampled prior", { mixstanvar_simul_test(beta, brms_beta_args, eps, c(0.1, 0.9)) }) -test_that("Beta prior is declared correctly in brms generated model and data", { mixstanvar_test(beta, brms_beta_args) }) -test_that("Beta mixture quantiles are correct for brms sampled prior", { mixstanvar_simul_test(betaMix, brms_beta_args, eps, c(0.1, 0.9)) }) -test_that("Beta mixture prior is declared correctly in brms generated model and data", { mixstanvar_test(betaMix, brms_beta_args) }) - -brms_beta_trunc_args <- list(formula=brms::bf(r | trials(n) ~ 1, family=brms::brmsfamily("binomial", link="identity"), center=FALSE), - data=data.frame(r=0, n=0), - prior=brms::prior(mixbeta(prior_w, prior_a, prior_b), class=b, lb=0.1, ub=0.9)) -test_that("Beta (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(beta, brms_beta_trunc_args) }) -test_that("Beta mixture (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(betaMix, brms_beta_trunc_args) }) - -brms_normal_args <- list(formula=brms::bf(y ~ 1, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=0), - prior=brms::prior(mixnorm(prior_w, prior_m, prior_s), coef=Intercept) + brms::prior(constant(1), class=sigma)) -test_that("Normal quantiles are correct for brms sampled prior", { mixstanvar_simul_test(norm, brms_normal_args, eps, c(-1, 0)) }) -test_that("Normal prior is declared correctly in brms generated model and data", { mixstanvar_test(norm, brms_normal_args) }) -test_that("Normal mixture quantiles are correct for brms sampled prior", { mixstanvar_simul_test(normMix, brms_normal_args, eps, c(2, 1), ptest=c(0.3, 0.5, 0.7)) }) -test_that("Normal mixture prior is declared correctly in brms generated model and data", { mixstanvar_test(normMix, brms_normal_args) }) - -brms_normal_trunc_args <- list(formula=brms::bf(y ~ 1, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=0), - prior=brms::prior(mixnorm(prior_w, prior_m, prior_s), class=b, lb=-5, ub=5) + brms::prior(constant(1), class=sigma)) -test_that("Normal (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(norm, brms_normal_trunc_args) }) -test_that("Normal mixture (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(normMix, brms_normal_trunc_args) }) - -brms_gamma_args <- list(formula=brms::bf(y ~ 1, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=1), - prior=brms::prior(mixgamma(prior_w, prior_a, prior_b), coef=Intercept) + brms::prior(constant(1), class=sigma)) - -test_that("Gamma quantiles are correct for brms sampled prior", { mixstanvar_simul_test(gamma, brms_gamma_args, eps, c(2, 7)) }) -test_that("Gamma prior is declared correctly in brms generated model and data", { mixstanvar_test(gamma, brms_gamma_args) }) -test_that("Gamma mixture quantile function is correct for brms sampled prior", { mixstanvar_simul_test(gammaMix, brms_gamma_args, eps, c(2, 7), ptest = seq(0.2, 0.8, by=0.2)) }) -test_that("Gamma mixture prior is declared correctly in brms generated model and data", { mixstanvar_test(gammaMix, brms_gamma_args) }) - -brms_gamma_trunc_args <- list(formula=brms::bf(y ~ 1, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=1), - prior=brms::prior(mixgamma(prior_w, prior_a, prior_b), class=b, lb=0.1, ub=10) + brms::prior(constant(1), class=sigma)) - -test_that("Gamma (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(gamma, brms_gamma_trunc_args) }) -test_that("Gamma mixture (truncated) prior is declared correctly in brms generated model and data", { mixstanvar_test(gammaMix, brms_gamma_trunc_args) }) +brms_beta_args <- list( + formula = brms::bf(r | trials(n) ~ 1, family = brms::brmsfamily("binomial", link = "identity"), center = FALSE), + data = data.frame(r = 0, n = 0), + prior = brms::prior(mixbeta(prior_w, prior_a, prior_b), coef = Intercept) +) + +test_that("Beta quantiles are correct for brms sampled prior", { + mixstanvar_simul_test(beta, brms_beta_args, eps, c(0.1, 0.9)) +}) +test_that("Beta prior is declared correctly in brms generated model and data", { + mixstanvar_test(beta, brms_beta_args) +}) +test_that("Beta mixture quantiles are correct for brms sampled prior", { + mixstanvar_simul_test(betaMix, brms_beta_args, eps, c(0.1, 0.9)) +}) +test_that("Beta mixture prior is declared correctly in brms generated model and data", { + mixstanvar_test(betaMix, brms_beta_args) +}) + +brms_beta_trunc_args <- list( + formula = brms::bf(r | trials(n) ~ 1, family = brms::brmsfamily("binomial", link = "identity"), center = FALSE), + data = data.frame(r = 0, n = 0), + prior = brms::prior(mixbeta(prior_w, prior_a, prior_b), class = b, lb = 0.1, ub = 0.9) +) +test_that("Beta (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(beta, brms_beta_trunc_args) +}) +test_that("Beta mixture (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(betaMix, brms_beta_trunc_args) +}) + +brms_normal_args <- list( + formula = brms::bf(y ~ 1, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 0), + prior = brms::prior(mixnorm(prior_w, prior_m, prior_s), coef = Intercept) + brms::prior(constant(1), class = sigma) +) +test_that("Normal quantiles are correct for brms sampled prior", { + mixstanvar_simul_test(norm, brms_normal_args, eps, c(-1, 0)) +}) +test_that("Normal prior is declared correctly in brms generated model and data", { + mixstanvar_test(norm, brms_normal_args) +}) +test_that("Normal mixture quantiles are correct for brms sampled prior", { + mixstanvar_simul_test(normMix, brms_normal_args, eps, c(2, 1), ptest = c(0.3, 0.5, 0.7)) +}) +test_that("Normal mixture prior is declared correctly in brms generated model and data", { + mixstanvar_test(normMix, brms_normal_args) +}) + +brms_normal_trunc_args <- list( + formula = brms::bf(y ~ 1, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 0), + prior = brms::prior(mixnorm(prior_w, prior_m, prior_s), class = b, lb = -5, ub = 5) + brms::prior(constant(1), class = sigma) +) +test_that("Normal (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(norm, brms_normal_trunc_args) +}) +test_that("Normal mixture (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(normMix, brms_normal_trunc_args) +}) + +brms_gamma_args <- list( + formula = brms::bf(y ~ 1, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 1), + prior = brms::prior(mixgamma(prior_w, prior_a, prior_b), coef = Intercept) + brms::prior(constant(1), class = sigma) +) + +test_that("Gamma quantiles are correct for brms sampled prior", { + mixstanvar_simul_test(gamma, brms_gamma_args, eps, c(2, 7)) +}) +test_that("Gamma prior is declared correctly in brms generated model and data", { + mixstanvar_test(gamma, brms_gamma_args) +}) +test_that("Gamma mixture quantile function is correct for brms sampled prior", { + mixstanvar_simul_test(gammaMix, brms_gamma_args, eps, c(2, 7), ptest = seq(0.2, 0.8, by = 0.2)) +}) +test_that("Gamma mixture prior is declared correctly in brms generated model and data", { + mixstanvar_test(gammaMix, brms_gamma_args) +}) + +brms_gamma_trunc_args <- list( + formula = brms::bf(y ~ 1, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 1), + prior = brms::prior(mixgamma(prior_w, prior_a, prior_b), class = b, lb = 0.1, ub = 10) + brms::prior(constant(1), class = sigma) +) + +test_that("Gamma (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(gamma, brms_gamma_trunc_args) +}) +test_that("Gamma mixture (truncated) prior is declared correctly in brms generated model and data", { + mixstanvar_test(gammaMix, brms_gamma_trunc_args) +}) # Here we approximate the samples using a multi-variante normal via a # moment based approxmation and compare this to the respective @@ -128,50 +174,50 @@ test_that("Gamma mixture (truncated) prior is declared correctly in brms generat # correlations. See for details # https://statproofbook.github.io/P/mvn-kl.html KLdiv_mvnorm <- function(m_1, sigma_1, m_2, sigma_2) { - m_delta <- (m_2 - m_1) - inv_sigma_2 <- solve(sigma_2) - p <- length(m_1) - 0.5 * ( t(m_delta) %*% inv_sigma_2 %*% m_delta + sum(diag(inv_sigma_2 %*% sigma_1)) - log(det(sigma_1)) + log(det(sigma_2)) - p ) + m_delta <- (m_2 - m_1) + inv_sigma_2 <- solve(sigma_2) + p <- length(m_1) + 0.5 * (t(m_delta) %*% inv_sigma_2 %*% m_delta + sum(diag(inv_sigma_2 %*% sigma_1)) - log(det(sigma_1)) + log(det(sigma_2)) - p) } mixstanvar_simul_mv_test <- function(mvmix, brms_args, eps) { - skip_on_cran() - skip_on_ci() - capture.output(brms_prior <- do.call(brms::brm, c(brms_args, list(seed=1423545, refresh=0, sample_prior="only", stanvars=mixstanvar(prior=mvmix))))) - samp <- brms::as_draws_matrix(brms_prior, variable="^b_", regex=TRUE) - samp_m <- colMeans(samp) - samp_sigma <- cov(samp) - mix_m <- summary(mvmix)$mean - mix_sigma <- summary(mvmix)$cov - kl <- KLdiv_mvnorm(samp_m, samp_sigma, mix_m, mix_sigma) - expect_true(abs(kl) < eps) + skip_on_cran() + skip_on_ci() + capture.output(brms_prior <- do.call(brms::brm, c(brms_args, list(seed = 1423545, refresh = 0, sample_prior = "only", stanvars = mixstanvar(prior = mvmix))))) + samp <- brms::as_draws_matrix(brms_prior, variable = "^b_", regex = TRUE) + samp_m <- colMeans(samp) + samp_sigma <- cov(samp) + mix_m <- summary(mvmix)$mean + mix_sigma <- summary(mvmix)$cov + kl <- KLdiv_mvnorm(samp_m, samp_sigma, mix_m, mix_sigma) + expect_true(abs(kl) < eps) } mixstanvar_test_mvnormMix <- function(mix, brms_args) { - brms_prior_empty <- do.call(brms::brm, c(brms_args, list(seed=1423545, refresh=0, sample_prior="only", stanvars=mixstanvar(prior=mix), empty=TRUE))) - stan_dist <- paste0("mix", gsub("Mix$", "", class(mix)[1]), "_lpdf") - ## look for the declared density in Stan - expect_true(grep(stan_dist, brms::stancode(brms_prior_empty)) == 1, info="Looking for declared Stan mixture density in generated brms Stan code.") - ## now check for the mixture being passed to Stan as data - stan_data <- brms::standata(brms_prior_empty) - ## number of mixture components - Nc <- ncol(mix) - expect_equal(stan_data$prior_Nc, Nc) - ## dimensionality - p <- length(summary(mix)$mean) - expect_equal(stan_data$prior_p, p) - ## weights per component - expect_equal(stan_data$prior_w, array(unname(mix[1,]))) - ## means per component - expect_equal(unname(stan_data$prior_m), unname(t(mix[2:(p+1),]))) - ## covariance information - for(i in seq_len(Nc)) { - S_c <- matrix(stan_data$prior_sigma[i,,,drop=FALSE], p, p) - expect_equal(sqrt(diag(S_c)), unname(mix[(p+2):(1+2*p),i])) - Rho_c <- cov2cor(S_c) - expect_equal(Rho_c[lower.tri(Rho_c)], unname(mix[(1+2*p+1):nrow(mix),i])) - } + brms_prior_empty <- do.call(brms::brm, c(brms_args, list(seed = 1423545, refresh = 0, sample_prior = "only", stanvars = mixstanvar(prior = mix), empty = TRUE))) + stan_dist <- paste0("mix", gsub("Mix$", "", class(mix)[1]), "_lpdf") + ## look for the declared density in Stan + expect_true(grep(stan_dist, brms::stancode(brms_prior_empty)) == 1, info = "Looking for declared Stan mixture density in generated brms Stan code.") + ## now check for the mixture being passed to Stan as data + stan_data <- brms::standata(brms_prior_empty) + ## number of mixture components + Nc <- ncol(mix) + expect_equal(stan_data$prior_Nc, Nc) + ## dimensionality + p <- length(summary(mix)$mean) + expect_equal(stan_data$prior_p, p) + ## weights per component + expect_equal(stan_data$prior_w, array(unname(mix[1, ]))) + ## means per component + expect_equal(unname(stan_data$prior_m), unname(t(mix[2:(p + 1), ]))) + ## covariance information + for (i in seq_len(Nc)) { + S_c <- matrix(stan_data$prior_sigma[i, , , drop = FALSE], p, p) + expect_equal(sqrt(diag(S_c)), unname(mix[(p + 2):(1 + 2 * p), i])) + Rho_c <- cov2cor(S_c) + expect_equal(Rho_c[lower.tri(Rho_c)], unname(mix[(1 + 2 * p + 1):nrow(mix), i])) + } } p <- 4 @@ -185,36 +231,60 @@ m1 <- 0:3 m2 <- 1:4 mvnorm_single_4 <- mixmvnorm(c(1, m1, 5), - param="mn", sigma=S) + param = "mn", sigma = S +) mvnorm_heavy_4 <- mixmvnorm(c(0.5, m1, 0.25), - c(0.5, m2, 5), - param="mn", sigma=S) - - - -brms_mvn_4_args <- list(formula=brms::bf(y ~ 1 + l1 + l2 + l3, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=1, l1=0, l2=0, l3=0), - prior=brms::prior(mixmvnorm(prior_w, prior_m, prior_sigma_L), class=b) + brms::prior(constant(1), class=sigma)) - -test_that("Multivariate normal (4D) is correct for brms sampled prior", { mixstanvar_simul_mv_test(mvnorm_single_4, brms_mvn_4_args, eps) }) -test_that("Multivariate normal (4D) prior is declared correctly in brms generated model and data", { mixstanvar_test_mvnormMix(mvnorm_single_4, brms_mvn_4_args) }) -test_that("Multivariate normal with heavy (4D) tails is correct for brms sampled prior", { mixstanvar_simul_mv_test(mvnorm_heavy_4, brms_mvn_4_args, eps) }) -test_that("Multivariate normal with heavy (4D) tails is declared correctly in brms generated model and data", { mixstanvar_test_mvnormMix(mvnorm_heavy_4, brms_mvn_4_args) }) + c(0.5, m2, 5), + param = "mn", sigma = S +) + + + +brms_mvn_4_args <- list( + formula = brms::bf(y ~ 1 + l1 + l2 + l3, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 1, l1 = 0, l2 = 0, l3 = 0), + prior = brms::prior(mixmvnorm(prior_w, prior_m, prior_sigma_L), class = b) + brms::prior(constant(1), class = sigma) +) + +test_that("Multivariate normal (4D) is correct for brms sampled prior", { + mixstanvar_simul_mv_test(mvnorm_single_4, brms_mvn_4_args, eps) +}) +test_that("Multivariate normal (4D) prior is declared correctly in brms generated model and data", { + mixstanvar_test_mvnormMix(mvnorm_single_4, brms_mvn_4_args) +}) +test_that("Multivariate normal with heavy (4D) tails is correct for brms sampled prior", { + mixstanvar_simul_mv_test(mvnorm_heavy_4, brms_mvn_4_args, eps) +}) +test_that("Multivariate normal with heavy (4D) tails is declared correctly in brms generated model and data", { + mixstanvar_test_mvnormMix(mvnorm_heavy_4, brms_mvn_4_args) +}) mvnorm_single_2 <- mixmvnorm(c(1, m1[1:2], 5), - param="mn", sigma=S[1:2,1:2]) + param = "mn", sigma = S[1:2, 1:2] +) mvnorm_heavy_2 <- mixmvnorm(c(0.5, m1[1:2], 0.25), - c(0.5, m2[1:2], 5), - param="mn", sigma=S[1:2,1:2]) - -brms_mvn_2_args <- list(formula=brms::bf(y ~ 1 + l1, family=brms::brmsfamily("gaussian", link="identity"), center=FALSE), - data=data.frame(y=1, l1=0), - prior=brms::prior(mixmvnorm(prior_w, prior_m, prior_sigma_L), class=b) + brms::prior(constant(1), class=sigma)) - -test_that("Multivariate normal (2D) is correct for brms sampled prior", { mixstanvar_simul_mv_test(mvnorm_single_2, brms_mvn_2_args, eps) }) -test_that("Multivariate normal (2D) is declared correctly in brms generated model and data", { mixstanvar_test_mvnormMix(mvnorm_single_2, brms_mvn_2_args) }) -test_that("Multivariate normal with heavy (2D) tails is correct for brms sampled prior", { mixstanvar_simul_mv_test(mvnorm_heavy_2, brms_mvn_2_args, eps) }) -test_that("Multivariate normal with heavy (2D) is declared correctly in brms generated model and data", { mixstanvar_test_mvnormMix(mvnorm_heavy_2, brms_mvn_2_args) }) + c(0.5, m2[1:2], 5), + param = "mn", sigma = S[1:2, 1:2] +) + +brms_mvn_2_args <- list( + formula = brms::bf(y ~ 1 + l1, family = brms::brmsfamily("gaussian", link = "identity"), center = FALSE), + data = data.frame(y = 1, l1 = 0), + prior = brms::prior(mixmvnorm(prior_w, prior_m, prior_sigma_L), class = b) + brms::prior(constant(1), class = sigma) +) + +test_that("Multivariate normal (2D) is correct for brms sampled prior", { + mixstanvar_simul_mv_test(mvnorm_single_2, brms_mvn_2_args, eps) +}) +test_that("Multivariate normal (2D) is declared correctly in brms generated model and data", { + mixstanvar_test_mvnormMix(mvnorm_single_2, brms_mvn_2_args) +}) +test_that("Multivariate normal with heavy (2D) tails is correct for brms sampled prior", { + mixstanvar_simul_mv_test(mvnorm_heavy_2, brms_mvn_2_args, eps) +}) +test_that("Multivariate normal with heavy (2D) is declared correctly in brms generated model and data", { + mixstanvar_test_mvnormMix(mvnorm_heavy_2, brms_mvn_2_args) +}) diff --git a/tests/testthat/test-oc1S.R b/tests/testthat/test-oc1S.R index 910470c..b8fea48 100644 --- a/tests/testthat/test-oc1S.R +++ b/tests/testthat/test-oc1S.R @@ -1,4 +1,3 @@ - ## test the analytical OC function via brute force simulation set.seed(12354) @@ -14,9 +13,9 @@ theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 +beta <- 0.2 -za <- qnorm(1-alpha) +za <- qnorm(1 - alpha) n1 <- 155 c1 <- theta_ni - za * s / sqrt(n1) @@ -24,67 +23,89 @@ thetaA <- c(theta_a, theta_ni) ## standard NI design, tests only statistical significance to be ## smaller than theta_ni with 1-alpha certainty -decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) +decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) -prior <- mixnorm(c(1,0,100), sigma=s) +prior <- mixnorm(c(1, 0, 100), sigma = s) test_scenario <- function(oc_res, ref) { - resA <- oc_res - ref - expect_true(all(abs(resA) < eps)) + resA <- oc_res - ref + expect_true(all(abs(resA) < eps)) } -test_that("Classical NI design critical value", { expect_true( abs(decision1S_boundary(prior, 155, decA) - c1) < eps) }) +test_that("Classical NI design critical value", { + expect_true(abs(decision1S_boundary(prior, 155, decA) - c1) < eps) +}) ## n set to give power 80% to detect 0 and type I error 5% for no ## better than theta_ni -test_that("Classical NI design at target sample size for OCs", { test_scenario(oc1S(prior, 155, decA)(thetaA), c(1-beta, alpha)) }) -test_that("Classical NI design at increased sample size for OCs", { test_scenario(oc1S(prior, 233, decA)(thetaA), c(1-0.08, alpha)) }) -test_that("Classical NI design at decreased sample size for OCs", { test_scenario(oc1S(prior, 77, decA)(thetaA), c(1-0.45, alpha)) }) +test_that("Classical NI design at target sample size for OCs", { + test_scenario(oc1S(prior, 155, decA)(thetaA), c(1 - beta, alpha)) +}) +test_that("Classical NI design at increased sample size for OCs", { + test_scenario(oc1S(prior, 233, decA)(thetaA), c(1 - 0.08, alpha)) +}) +test_that("Classical NI design at decreased sample size for OCs", { + test_scenario(oc1S(prior, 77, decA)(thetaA), c(1 - 0.45, alpha)) +}) ## now double criterion with indecision point (mean estimate must be ## lower than this) theta_c <- c1 ## statistical significance -dec1 <- decision1S(1-alpha, theta_ni, lower.tail=TRUE) +dec1 <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) ## require mean to be at least as good as theta_c -dec2 <- decision1S(0.5, theta_c, lower.tail=TRUE) +dec2 <- decision1S(0.5, theta_c, lower.tail = TRUE) ## combination -decComb <- decision1S(c(1-alpha, 0.5), c(theta_ni, theta_c), lower.tail=TRUE) +decComb <- decision1S(c(1 - alpha, 0.5), c(theta_ni, theta_c), lower.tail = TRUE) thetaD <- c(theta_c, theta_ni) ## since theta_c == c1, both decision criteria are the same for n = ## 155 -test_that("Double criterion NI design at target sample size for OCs, combined ", { test_scenario(oc1S(prior, 155, decComb)(thetaD), c(0.50, alpha)) }) -test_that("Double criterion NI design at target sample size for OCs, stat criterion", { test_scenario(oc1S(prior, 155, dec1)(thetaD), c(0.50, alpha)) }) -test_that("Double criterion NI design at target sample size for OCs, mean criterion", { test_scenario(oc1S(prior, 155, dec2)(thetaD), c(0.50, alpha)) }) +test_that("Double criterion NI design at target sample size for OCs, combined ", { + test_scenario(oc1S(prior, 155, decComb)(thetaD), c(0.50, alpha)) +}) +test_that("Double criterion NI design at target sample size for OCs, stat criterion", { + test_scenario(oc1S(prior, 155, dec1)(thetaD), c(0.50, alpha)) +}) +test_that("Double criterion NI design at target sample size for OCs, mean criterion", { + test_scenario(oc1S(prior, 155, dec2)(thetaD), c(0.50, alpha)) +}) ## at an increased sample size only the mean criterion is active -test_that("Double criterion NI design at increased sample size for OCs, combined ", { test_scenario(oc1S(prior, 233, decComb)(thetaD), c(0.50, 0.02)) }) -test_that("Double criterion NI design at increased sample size for OCs, mean criterion", { test_scenario(oc1S(prior, 233, dec2)(thetaD), c(0.50, 0.02)) }) +test_that("Double criterion NI design at increased sample size for OCs, combined ", { + test_scenario(oc1S(prior, 233, decComb)(thetaD), c(0.50, 0.02)) +}) +test_that("Double criterion NI design at increased sample size for OCs, mean criterion", { + test_scenario(oc1S(prior, 233, dec2)(thetaD), c(0.50, 0.02)) +}) ## at a decreased sample size only the stat criterion is active -test_that("Double criterion NI design at decreased sample size for OCs, combined ", { test_scenario(oc1S(prior, 78, decComb)(thetaD), c(1-0.68, alpha)) }) -test_that("Double criterion NI design at decreased sample size for OCs, stat criterion", { test_scenario(oc1S(prior, 78, dec1)(thetaD), c(1-0.68, alpha)) }) +test_that("Double criterion NI design at decreased sample size for OCs, combined ", { + test_scenario(oc1S(prior, 78, decComb)(thetaD), c(1 - 0.68, alpha)) +}) +test_that("Double criterion NI design at decreased sample size for OCs, stat criterion", { + test_scenario(oc1S(prior, 78, dec1)(thetaD), c(1 - 0.68, alpha)) +}) ## test type 1 error and correctness of critical values wrt to ## lower.tail=TRUE/FALSE -dec1b <- decision1S(1-alpha, theta_ni, lower.tail=FALSE) +dec1b <- decision1S(1 - alpha, theta_ni, lower.tail = FALSE) ## design object, decision function, posterior function must return ## posterior after updatding the prior with the given value test_critical_discrete <- function(crit, decision, posterior) { - lower.tail <- attr(decision, "lower.tail") - if(lower.tail) { - expect_equal(decision(posterior(crit-1)), 1) - expect_equal(decision(posterior(crit )), 1) - expect_equal(decision(posterior(crit+1)), 0) - } else { - expect_equal(decision(posterior(crit-1)), 0) - expect_equal(decision(posterior(crit )), 0) - expect_equal(decision(posterior(crit+1)), 1) - } + lower.tail <- attr(decision, "lower.tail") + if (lower.tail) { + expect_equal(decision(posterior(crit - 1)), 1) + expect_equal(decision(posterior(crit)), 1) + expect_equal(decision(posterior(crit + 1)), 0) + } else { + expect_equal(decision(posterior(crit - 1)), 0) + expect_equal(decision(posterior(crit)), 0) + expect_equal(decision(posterior(crit + 1)), 1) + } } ## binary case @@ -93,23 +114,39 @@ design_binary <- oc1S(beta_prior, 1000, dec1) design_binaryB <- oc1S(beta_prior, 1000, dec1b) crit1 <- decision1S_boundary(beta_prior, 1000, dec1) crit1B <- decision1S_boundary(beta_prior, 1000, dec1b) -posterior_binary <- function(r) postmix(beta_prior, r=r, n=1000) -test_that("Binary type I error rate", { test_scenario(design_binary(theta_ni), alpha) }) -test_that("Binary crticial value, lower.tail=TRUE", { test_critical_discrete(crit1, dec1, posterior_binary) }) -test_that("Binary crticial value, lower.tail=FALSE", { test_critical_discrete(crit1B, dec1b, posterior_binary) }) - -test_that("Binary boundary case, lower.tail=TRUE", { expect_numeric(design_binary( 1), lower=0, upper=1, finite=TRUE, any.missing=FALSE) }) -test_that("Binary boundary case, lower.tail=FALSE", { expect_numeric(design_binaryB(0), lower=0, upper=1, finite=TRUE, any.missing=FALSE) }) +posterior_binary <- function(r) postmix(beta_prior, r = r, n = 1000) +test_that("Binary type I error rate", { + test_scenario(design_binary(theta_ni), alpha) +}) +test_that("Binary crticial value, lower.tail=TRUE", { + test_critical_discrete(crit1, dec1, posterior_binary) +}) +test_that("Binary crticial value, lower.tail=FALSE", { + test_critical_discrete(crit1B, dec1b, posterior_binary) +}) + +test_that("Binary boundary case, lower.tail=TRUE", { + expect_numeric(design_binary(1), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) +}) +test_that("Binary boundary case, lower.tail=FALSE", { + expect_numeric(design_binaryB(0), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) +}) ## poisson case gamma_prior <- mixgamma(c(1, 2, 2)) -dec_count <- decision1S(1-alpha, 1, lower.tail=TRUE) -dec_countB <- decision1S(1-alpha, 1, lower.tail=FALSE) -design_poisson <- oc1S(gamma_prior, 1000, dec_count) +dec_count <- decision1S(1 - alpha, 1, lower.tail = TRUE) +dec_countB <- decision1S(1 - alpha, 1, lower.tail = FALSE) +design_poisson <- oc1S(gamma_prior, 1000, dec_count) design_poissonB <- oc1S(gamma_prior, 1000, dec_countB) pcrit1 <- decision1S_boundary(gamma_prior, 1000, dec_count) pcrit1B <- decision1S_boundary(gamma_prior, 1000, dec_countB) -posterior_poisson <- function(m) postmix(gamma_prior, m=m/1000, n=1000) -test_that("Poisson type I error rate", { test_scenario(design_poisson(1), alpha) } ) -test_that("Poisson critical value, lower.tail=TRUE", { test_critical_discrete(pcrit1, dec_count, posterior_poisson) }) -test_that("Poisson critical value, lower.tail=FALSE", { test_critical_discrete(pcrit1B, dec_countB, posterior_poisson) }) +posterior_poisson <- function(m) postmix(gamma_prior, m = m / 1000, n = 1000) +test_that("Poisson type I error rate", { + test_scenario(design_poisson(1), alpha) +}) +test_that("Poisson critical value, lower.tail=TRUE", { + test_critical_discrete(pcrit1, dec_count, posterior_poisson) +}) +test_that("Poisson critical value, lower.tail=FALSE", { + test_critical_discrete(pcrit1B, dec_countB, posterior_poisson) +}) diff --git a/tests/testthat/test-oc2S.R b/tests/testthat/test-oc2S.R index 1978bef..17d1fa3 100644 --- a/tests/testthat/test-oc2S.R +++ b/tests/testthat/test-oc2S.R @@ -1,9 +1,8 @@ - ## test the analytical OC function via brute force simulation set.seed(12354) -prior1 <- mixnorm(c(0.3, -0.2, 2), c(0.7, 0, 50), sigma=1) -prior2 <- mixnorm(c(1.0, 0, 50), sigma=1) +prior1 <- mixnorm(c(0.3, -0.2, 2), c(0.7, 0, 50), sigma = 1) +prior2 <- mixnorm(c(1.0, 0, 50), sigma = 1) N1 <- 10 N2 <- 20 @@ -20,33 +19,33 @@ theta2 <- 0.5 Nsim <- 1e4 run_on_cran <- function() { - if (identical(Sys.getenv("NOT_CRAN"), "true")) { - return(FALSE) - } - return(TRUE) + if (identical(Sys.getenv("NOT_CRAN"), "true")) { + return(FALSE) + } + return(TRUE) } -oc2S_normal_MC <- function(prior1, prior2, N1, N2, theta1, theta2, pcrit=0.975, qcrit=0) { - mean_sd1 <- sigma(prior1) / sqrt(N1) - mean_sd2 <- sigma(prior2) / sqrt(N2) +oc2S_normal_MC <- function(prior1, prior2, N1, N2, theta1, theta2, pcrit = 0.975, qcrit = 0) { + mean_sd1 <- sigma(prior1) / sqrt(N1) + mean_sd2 <- sigma(prior2) / sqrt(N2) - mean_prior1 <- prior1 - sigma(mean_prior1) <- mean_sd1 - mean_prior2 <- prior2 - sigma(mean_prior2) <- mean_sd2 + mean_prior1 <- prior1 + sigma(mean_prior1) <- mean_sd1 + mean_prior2 <- prior2 + sigma(mean_prior2) <- mean_sd2 - mean_samp1 <- rnorm(Nsim, theta1, mean_sd1) - mean_samp2 <- rnorm(Nsim, theta2, mean_sd2) + mean_samp1 <- rnorm(Nsim, theta1, mean_sd1) + mean_samp2 <- rnorm(Nsim, theta2, mean_sd2) - dec <- rep(NA, Nsim) + dec <- rep(NA, Nsim) - for(i in 1:Nsim) { - post1 <- postmix(mean_prior1, m=mean_samp1[i], se=mean_sd1) - post2 <- postmix(mean_prior2, m=mean_samp2[i], se=mean_sd2) - dec[i] <- as.numeric(pmix(RBesT:::mixnormdiff(post1, post2), qcrit) > pcrit) - } + for (i in 1:Nsim) { + post1 <- postmix(mean_prior1, m = mean_samp1[i], se = mean_sd1) + post2 <- postmix(mean_prior2, m = mean_samp2[i], se = mean_sd2) + dec[i] <- as.numeric(pmix(RBesT:::mixnormdiff(post1, post2), qcrit) > pcrit) + } - mean(dec) + mean(dec) } Voc2S_normal_MC <- Vectorize(oc2S_normal_MC, c("theta1", "theta2")) @@ -55,290 +54,356 @@ Voc2S_normal_MC <- Vectorize(oc2S_normal_MC, c("theta1", "theta2")) ## works as expected test_that("Analytical convolution of normal mixture matches numerical integration result", { - skip_on_cran() - - pdiff <- RBesT:::mixnormdiff(prior1, prior2) - x <- seq(-20,20,length=21) - d1 <- dmix(pdiff, x) - d2 <- dmixdiff(prior1, prior2, x) - dres <- abs(d1-d2) - expect_equal(sum(dres > 1e-5), 0) - p1 <- pmix(pdiff, x) - p2 <- pmixdiff(prior1, prior2, x) - pres <- 100 * abs(p1-p2) - expect_equal(sum(pres > 2), 0) + skip_on_cran() + + pdiff <- RBesT:::mixnormdiff(prior1, prior2) + x <- seq(-20, 20, length = 21) + d1 <- dmix(pdiff, x) + d2 <- dmixdiff(prior1, prior2, x) + dres <- abs(d1 - d2) + expect_equal(sum(dres > 1e-5), 0) + p1 <- pmix(pdiff, x) + p2 <- pmixdiff(prior1, prior2, x) + pres <- 100 * abs(p1 - p2) + expect_equal(sum(pres > 2), 0) }) ## test that the type I error is matching, i.e. is not off by more than 2% test_that("Type I error is matching between MC and analytical computations in the normal mixture case", { - skip_on_cran() + skip_on_cran() - x <- c(-2, 0) - alpha <- oc2S(prior1, prior2, N1, N2, decision2S(pcrit, qcrit), sigma1=sigma(prior1), sigma2=sigma(prior2))(x,x) - alphaMC <- Voc2S_normal_MC(prior1, prior2, N1, N2, x, x, pcrit, qcrit) - res <- 100 * abs(alpha - alphaMC) - expect_equal(sum(res > 2) , 0) - }) + x <- c(-2, 0) + alpha <- oc2S(prior1, prior2, N1, N2, decision2S(pcrit, qcrit), sigma1 = sigma(prior1), sigma2 = sigma(prior2))(x, x) + alphaMC <- Voc2S_normal_MC(prior1, prior2, N1, N2, x, x, pcrit, qcrit) + res <- 100 * abs(alpha - alphaMC) + expect_equal(sum(res > 2), 0) +}) ## test that the power is matching, i.e. is not off by more than 2% test_that("Power is matching between MC and analytical computations in the normal mixture case", { - skip_on_cran() + skip_on_cran() - power <- oc2S(prior1, prior2, N1, N2, decision2S(pcrit, qcrit), sigma1=sigma(prior1), sigma2=sigma(prior2))(theta1, theta2) - powerMC <- oc2S_normal_MC(prior1, prior2, N1, N2, theta1, theta2, pcrit, qcrit) - res <- 100 * abs(power - powerMC) - expect_equal(sum(res > 2) , 0) - }) + power <- oc2S(prior1, prior2, N1, N2, decision2S(pcrit, qcrit), sigma1 = sigma(prior1), sigma2 = sigma(prior2))(theta1, theta2) + powerMC <- oc2S_normal_MC(prior1, prior2, N1, N2, theta1, theta2, pcrit, qcrit) + res <- 100 * abs(power - powerMC) + expect_equal(sum(res > 2), 0) +}) ## further test by cross-checking with Gsponer et. al, "A practical ## guide to Bayesian group sequential designs", Pharmaceut. Statist. ## (2014), 13 71-80, Table 1, Probability at interim test_that("Gsponer et al. results match (normal end-point)", { - skip_on_cran() + skip_on_cran() - ocRef <- data.frame(delta=c(0,40,50,60,70), - success=c(1.1,32.2,50.0,67.6,82.2), - futile=c(63.3,6.8,2.5,0.8,0.2)) - sigmaFixed <- 88 + ocRef <- data.frame( + delta = c(0, 40, 50, 60, 70), + success = c(1.1, 32.2, 50.0, 67.6, 82.2), + futile = c(63.3, 6.8, 2.5, 0.8, 0.2) + ) + sigmaFixed <- 88 - priorT <- mixnorm(c(1, 0, 0.001), sigma=sigmaFixed, param="mn") - priorP <- mixnorm(c(1, -49, 20 ), sigma=sigmaFixed, param="mn") + priorT <- mixnorm(c(1, 0, 0.001), sigma = sigmaFixed, param = "mn") + priorP <- mixnorm(c(1, -49, 20), sigma = sigmaFixed, param = "mn") - ## the success criteria is for delta which are larger than some - ## threshold value which is why we set lower.tail=FALSE - successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) - ## the futility criterion acts in the opposite direction - futilityCrit <- decision2S(c(0.90) , c(40), TRUE) + ## the success criteria is for delta which are larger than some + ## threshold value which is why we set lower.tail=FALSE + successCrit <- decision2S(c(0.95, 0.5), c(0, 50), FALSE) + ## the futility criterion acts in the opposite direction + futilityCrit <- decision2S(c(0.90), c(40), TRUE) - nT1 <- 20 - nP1 <- 10 + nT1 <- 20 + nP1 <- 10 - oc <- data.frame(delta=c(0,40,50,60,70)) + oc <- data.frame(delta = c(0, 40, 50, 60, 70)) - ## Note that due to the fact that only a single mixture component is - ## used, the decision boundary is a linear function such that only few - ## evaluations of the boundary are needed to estimate reliably the - ## spline function + ## Note that due to the fact that only a single mixture component is + ## used, the decision boundary is a linear function such that only few + ## evaluations of the boundary are needed to estimate reliably the + ## spline function - ## Table 1, probability for interim for success - oc$success <- oc2S(priorP, priorT, nP1, nT1, successCrit, Ngrid=1, sigma1=sigmaFixed, sigma2=sigmaFixed)(-49, -49-oc$delta) + ## Table 1, probability for interim for success + oc$success <- oc2S(priorP, priorT, nP1, nT1, successCrit, Ngrid = 1, sigma1 = sigmaFixed, sigma2 = sigmaFixed)(-49, -49 - oc$delta) - ## Table 1, probability for interim for futility - oc$futile <- oc2S(priorP, priorT, nP1, nT1, futilityCrit, Ngrid=1, sigma1=sigmaFixed, sigma2=sigmaFixed)(-49, -49-oc$delta) + ## Table 1, probability for interim for futility + oc$futile <- oc2S(priorP, priorT, nP1, nT1, futilityCrit, Ngrid = 1, sigma1 = sigmaFixed, sigma2 = sigmaFixed)(-49, -49 - oc$delta) - ## Table 1, first three columns, page 74 - oc[-1] <- lapply(100*oc[-1], round, 1) + ## Table 1, first three columns, page 74 + oc[-1] <- lapply(100 * oc[-1], round, 1) - resFutility <- abs(ocRef$futile - oc$futile) - resSuccess <- abs(ocRef$success - oc$success) + resFutility <- abs(ocRef$futile - oc$futile) + resSuccess <- abs(ocRef$success - oc$success) - expect_equal(sum(resFutility > 2) , 0, info="futility") - expect_equal(sum(resSuccess > 2) , 0, info="success") - }) + expect_equal(sum(resFutility > 2), 0, info = "futility") + expect_equal(sum(resSuccess > 2), 0, info = "success") +}) ## failure when doing repeated evaluations which came up in consulting test_that("Ensure that repeated oc2S evaluation works for normal case", { - skip_on_cran() - - samp_sigma <- 3 - - n_ia <- 38 - n_final <- 2*n_ia - n_ia_to_final <- n_final - n_ia - sem_ia <- samp_sigma/sqrt(n_ia) - - theta_ctl <- 0 - delta <- 1.04 - - obs_P <- 0.11 - obs_T <- 1.28 - - prior <- mixnorm(c(1, 0, 0.001), sigma=samp_sigma, param="mn") - postP_interim <- postmix(prior, m = obs_P, se=sem_ia) - postT_interim <- postmix(prior, m = obs_T, se=sem_ia) - - successCrit <- decision2S(c(0.9), c(0), FALSE) - - interim_CP <- oc2S( - postT_interim, postP_interim, - n_ia_to_final, n_ia_to_final, - successCrit, sigma1=samp_sigma, sigma2=samp_sigma) - - cpd_ia <- interim_CP(obs_T, obs_P) - cpd_ia2 <- interim_CP(theta_ctl + delta, theta_ctl) - - expect_number(cpd_ia, lower=0, upper=1, finite=TRUE) - expect_number(cpd_ia2, lower=0, upper=1, finite=TRUE) - - ## check that when calculating directly that the results - ## are close enough - interim_CPalt <- oc2S( - postT_interim, postP_interim, - n_ia_to_final, n_ia_to_final, - successCrit, sigma1=samp_sigma, sigma2=samp_sigma) - cpd_ia2alt <- interim_CPalt(theta_ctl + delta, theta_ctl) - expect_number(abs(cpd_ia2 - cpd_ia2alt), lower=0, upper=1E-3, finite=TRUE) - }) + skip_on_cran() + + samp_sigma <- 3 + + n_ia <- 38 + n_final <- 2 * n_ia + n_ia_to_final <- n_final - n_ia + sem_ia <- samp_sigma / sqrt(n_ia) + + theta_ctl <- 0 + delta <- 1.04 + + obs_P <- 0.11 + obs_T <- 1.28 + + prior <- mixnorm(c(1, 0, 0.001), sigma = samp_sigma, param = "mn") + postP_interim <- postmix(prior, m = obs_P, se = sem_ia) + postT_interim <- postmix(prior, m = obs_T, se = sem_ia) + + successCrit <- decision2S(c(0.9), c(0), FALSE) + + interim_CP <- oc2S( + postT_interim, postP_interim, + n_ia_to_final, n_ia_to_final, + successCrit, + sigma1 = samp_sigma, sigma2 = samp_sigma + ) + + cpd_ia <- interim_CP(obs_T, obs_P) + cpd_ia2 <- interim_CP(theta_ctl + delta, theta_ctl) + + expect_number(cpd_ia, lower = 0, upper = 1, finite = TRUE) + expect_number(cpd_ia2, lower = 0, upper = 1, finite = TRUE) + + ## check that when calculating directly that the results + ## are close enough + interim_CPalt <- oc2S( + postT_interim, postP_interim, + n_ia_to_final, n_ia_to_final, + successCrit, + sigma1 = samp_sigma, sigma2 = samp_sigma + ) + cpd_ia2alt <- interim_CPalt(theta_ctl + delta, theta_ctl) + expect_number(abs(cpd_ia2 - cpd_ia2alt), lower = 0, upper = 1E-3, finite = TRUE) +}) ## test against Schmidli et. al, "Robust Meta-Analytic-Predictive ## Priors", Table 2, unif and beta case test_that("Schmidli et al. results (binary end-point)", { - skip_on_cran() + skip_on_cran() - ocRef_inf <- expand.grid(pc=seq(0.1,0.6, by=0.1),delta=c(0,0.3)) - ocRef_inf$ref <- c(0, 1.6, 6.1, 13.7, 26.0, 44.4 ## beta/delta=0 - ,81.6, 87.8, 93.4, 97.9, 99.6, 100.0 ## beta/delta=0.3 - )/100 + ocRef_inf <- expand.grid(pc = seq(0.1, 0.6, by = 0.1), delta = c(0, 0.3)) + ocRef_inf$ref <- c( + 0, 1.6, 6.1, 13.7, 26.0, 44.4 ## beta/delta=0 + , 81.6, 87.8, 93.4, 97.9, 99.6, 100.0 ## beta/delta=0.3 + ) / 100 - ocRef_uni <- expand.grid(pc=seq(0.1,0.6, by=0.1),delta=c(0,0.3)) - ocRef_uni$ref <- c(1.8, 2.3, 2.4, 2.6, 2.8, 2.6 ## unif/delta=0 - ,89.7, 82.1, 79.5, 79.5, 81.9, 89.8 ## unif/delta=0.3 - )/100 - dec <- decision2S(0.975, 0, lower.tail=FALSE) + ocRef_uni <- expand.grid(pc = seq(0.1, 0.6, by = 0.1), delta = c(0, 0.3)) + ocRef_uni$ref <- c( + 1.8, 2.3, 2.4, 2.6, 2.8, 2.6 ## unif/delta=0 + , 89.7, 82.1, 79.5, 79.5, 81.9, 89.8 ## unif/delta=0.3 + ) / 100 + dec <- decision2S(0.975, 0, lower.tail = FALSE) - N <- 40 + N <- 40 - prior_inf <- mixbeta(c(1, 4, 16)) - prior_uni <- mixbeta(c(1, 1, 1)) + prior_inf <- mixbeta(c(1, 4, 16)) + prior_uni <- mixbeta(c(1, 1, 1)) - N_ctl_uni <- N - round(ess(prior_uni, method="morita")) - N_ctl_inf <- N - round(ess(prior_inf, method="morita")) + N_ctl_uni <- N - round(ess(prior_uni, method = "morita")) + N_ctl_inf <- N - round(ess(prior_inf, method = "morita")) - design_uni <- oc2S(prior_uni, prior_uni, N, N_ctl_uni, dec) - design_inf <- oc2S(prior_uni, prior_inf, N, N_ctl_inf, dec) + design_uni <- oc2S(prior_uni, prior_uni, N, N_ctl_uni, dec) + design_inf <- oc2S(prior_uni, prior_inf, N, N_ctl_inf, dec) - res_uni <- design_uni(ocRef_uni$pc + ocRef_uni$delta, ocRef_uni$pc) - res_inf <- design_inf(ocRef_inf$pc + ocRef_inf$delta, ocRef_inf$pc) + res_uni <- design_uni(ocRef_uni$pc + ocRef_uni$delta, ocRef_uni$pc) + res_inf <- design_inf(ocRef_inf$pc + ocRef_inf$delta, ocRef_inf$pc) - expect_true(all(abs(100 * (res_uni - ocRef_uni$ref)) < 2.5)) - expect_true(all(abs(100 * (res_inf - ocRef_inf$ref)) < 2.5)) - }) + expect_true(all(abs(100 * (res_uni - ocRef_uni$ref)) < 2.5)) + expect_true(all(abs(100 * (res_inf - ocRef_inf$ref)) < 2.5)) +}) ## some additional, very simple type I error tests and tests for the ## discrete case of correct critical value behavior test_scenario <- function(oc_res, ref) { - resA <- oc_res - ref - expect_true(all(abs(resA) < eps)) + resA <- oc_res - ref + expect_true(all(abs(resA) < eps)) } expect_equal_each <- function(test, expected) { - for(elem in test) { - expect_equal(elem, expected) - } + for (elem in test) { + expect_equal(elem, expected) + } } ## design object, decision function, posterior function must return ## posterior after updatding the prior with the given value; we assume ## that the priors are the same for sample 1 and 2 test_critical_discrete <- function(boundary_design, decision, posterior, y2) { - lower.tail <- attr(decision, "lower.tail") - crit <- boundary_design(y2) - post2 <- posterior(y2) - if(lower.tail) { - expect_equal(decision(posterior(crit-1), post2), 1) - expect_equal(decision(posterior(crit ), post2), 1) - expect_equal(decision(posterior(crit+1), post2), 0) - } else { - expect_equal(decision(posterior(crit-1), post2), 0) - expect_equal(decision(posterior(crit ), post2), 0) - expect_equal(decision(posterior(crit+1), post2), 1) - } + lower.tail <- attr(decision, "lower.tail") + crit <- boundary_design(y2) + post2 <- posterior(y2) + if (lower.tail) { + expect_equal(decision(posterior(crit - 1), post2), 1) + expect_equal(decision(posterior(crit), post2), 1) + expect_equal(decision(posterior(crit + 1), post2), 0) + } else { + expect_equal(decision(posterior(crit - 1), post2), 0) + expect_equal(decision(posterior(crit), post2), 0) + expect_equal(decision(posterior(crit + 1), post2), 1) + } } ## expect results to be 1% exact eps <- 1e-2 alpha <- 0.05 -dec <- decision2S(1-alpha, 0, lower.tail=TRUE) -decB <- decision2S(1-alpha, 0, lower.tail=FALSE) +dec <- decision2S(1 - alpha, 0, lower.tail = TRUE) +decB <- decision2S(1 - alpha, 0, lower.tail = FALSE) ## test binary case beta_prior <- mixbeta(c(1, 1, 1)) -if(!run_on_cran()) { - design_binary <- oc2S(beta_prior, beta_prior, 100, 100, dec) - boundary_design_binary <- decision2S_boundary(beta_prior, beta_prior, 100, 100, dec) - design_binaryB <- oc2S(beta_prior, beta_prior, 100, 100, decB) - boundary_design_binaryB <- decision2S_boundary(beta_prior, beta_prior, 100, 100, decB) +if (!run_on_cran()) { + design_binary <- oc2S(beta_prior, beta_prior, 100, 100, dec) + boundary_design_binary <- decision2S_boundary(beta_prior, beta_prior, 100, 100, dec) + design_binaryB <- oc2S(beta_prior, beta_prior, 100, 100, decB) + boundary_design_binaryB <- decision2S_boundary(beta_prior, beta_prior, 100, 100, decB) } else { - design_binary <- function(...) { return(0.1) } - design_binaryB <- function(...) { return(0.1) } - boundary_design_binary <- function(...) { return(0.1) } - boundary_design_binaryB <- function(...) { return(0.1) } + design_binary <- function(...) { + return(0.1) + } + design_binaryB <- function(...) { + return(0.1) + } + boundary_design_binary <- function(...) { + return(0.1) + } + boundary_design_binaryB <- function(...) { + return(0.1) + } } -posterior_binary <- function(r) postmix(beta_prior, r=r, n=100) +posterior_binary <- function(r) postmix(beta_prior, r = r, n = 100) p_test <- 1:9 / 10 -test_that("Binary type I error rate", { skip_on_cran(); test_scenario(design_binary(p_test, p_test), alpha) }) -test_that("Binary crticial value, lower.tail=TRUE", { skip_on_cran(); test_critical_discrete(boundary_design_binary, dec, posterior_binary, 30) }) -test_that("Binary crticial value, lower.tail=FALSE", { skip_on_cran(); test_critical_discrete(boundary_design_binaryB, decB, posterior_binary, 30) }) -test_that("Binary boundary case, lower.tail=TRUE", { skip_on_cran(); expect_numeric(design_binary( 1, 1), lower=0, upper=1, finite=TRUE, any.missing=FALSE) }) -test_that("Binary boundary case, lower.tail=FALSE", { skip_on_cran(); expect_numeric(design_binaryB(0, 0), lower=0, upper=1, finite=TRUE, any.missing=FALSE) }) +test_that("Binary type I error rate", { + skip_on_cran() + test_scenario(design_binary(p_test, p_test), alpha) +}) +test_that("Binary crticial value, lower.tail=TRUE", { + skip_on_cran() + test_critical_discrete(boundary_design_binary, dec, posterior_binary, 30) +}) +test_that("Binary crticial value, lower.tail=FALSE", { + skip_on_cran() + test_critical_discrete(boundary_design_binaryB, decB, posterior_binary, 30) +}) +test_that("Binary boundary case, lower.tail=TRUE", { + skip_on_cran() + expect_numeric(design_binary(1, 1), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) +}) +test_that("Binary boundary case, lower.tail=FALSE", { + skip_on_cran() + expect_numeric(design_binaryB(0, 0), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) +}) ## check case where decision never changes due to prior being too ## strong -beta_prior1 <- mixbeta(c(1, 0.9, 1000), param="mn") -beta_prior2 <- mixbeta(c(1, 0.1, 1000), param="mn") -design_lower <- oc2S(beta_prior1, beta_prior2, 20, 20, dec) ## always 0 +beta_prior1 <- mixbeta(c(1, 0.9, 1000), param = "mn") +beta_prior2 <- mixbeta(c(1, 0.1, 1000), param = "mn") +design_lower <- oc2S(beta_prior1, beta_prior2, 20, 20, dec) ## always 0 design_upper <- oc2S(beta_prior1, beta_prior2, 20, 20, decB) ## always 1 -boundary_design_lower <- decision2S_boundary(beta_prior1, beta_prior2, 20, 20, dec) ## always 0 +boundary_design_lower <- decision2S_boundary(beta_prior1, beta_prior2, 20, 20, dec) ## always 0 boundary_design_upper <- decision2S_boundary(beta_prior1, beta_prior2, 20, 20, decB) ## always 1 -test_that("Binary case, no decision change, lower.tail=TRUE, critical value", { skip_on_cran(); expect_equal_each(boundary_design_lower(0:20), -1) }) -test_that("Binary case, no decision change, lower.tail=FALSE, critical value", { skip_on_cran(); expect_equal_each(boundary_design_upper(0:20), 21) }) -test_that("Binary case, no decision change, lower.tail=TRUE, frequency=0", { skip_on_cran(); expect_equal_each(design_lower(p_test, p_test), 0.0) }) -test_that("Binary case, no decision change, lower.tail=FALSE, frequency=1", { skip_on_cran(); expect_equal_each(design_upper(p_test, p_test), 1.0) }) +test_that("Binary case, no decision change, lower.tail=TRUE, critical value", { + skip_on_cran() + expect_equal_each(boundary_design_lower(0:20), -1) +}) +test_that("Binary case, no decision change, lower.tail=FALSE, critical value", { + skip_on_cran() + expect_equal_each(boundary_design_upper(0:20), 21) +}) +test_that("Binary case, no decision change, lower.tail=TRUE, frequency=0", { + skip_on_cran() + expect_equal_each(design_lower(p_test, p_test), 0.0) +}) +test_that("Binary case, no decision change, lower.tail=FALSE, frequency=1", { + skip_on_cran() + expect_equal_each(design_upper(p_test, p_test), 1.0) +}) -if(!run_on_cran()) { - design_lower_rev <- oc2S(beta_prior2, beta_prior1, 20, 20, dec) ## always 1 - design_upper_rev <- oc2S(beta_prior2, beta_prior1, 20, 20, decB) ## always 0 - boundary_design_lower_rev <- decision2S_boundary(beta_prior2, beta_prior1, 20, 20, dec) ## always 1 - boundary_design_upper_rev <- decision2S_boundary(beta_prior2, beta_prior1, 20, 20, decB) ## always 0 +if (!run_on_cran()) { + design_lower_rev <- oc2S(beta_prior2, beta_prior1, 20, 20, dec) ## always 1 + design_upper_rev <- oc2S(beta_prior2, beta_prior1, 20, 20, decB) ## always 0 + boundary_design_lower_rev <- decision2S_boundary(beta_prior2, beta_prior1, 20, 20, dec) ## always 1 + boundary_design_upper_rev <- decision2S_boundary(beta_prior2, beta_prior1, 20, 20, decB) ## always 0 } else { - design_lower_rev <- function(...) return(1) - design_upper_rev <- function(...) return(0) - boundary_design_lower_rev <- function(...) return(1) - boundary_design_upper_rev <- function(...) return(0) + design_lower_rev <- function(...) { + return(1) + } + design_upper_rev <- function(...) { + return(0) + } + boundary_design_lower_rev <- function(...) { + return(1) + } + boundary_design_upper_rev <- function(...) { + return(0) + } } -test_that("Binary case, no decision change (reversed), lower.tail=TRUE, critical value", { skip_on_cran(); expect_equal_each(boundary_design_lower_rev(0:20), 20) }) -test_that("Binary case, no decision change (reversed), lower.tail=FALSE, critical value", { skip_on_cran(); expect_equal_each(boundary_design_upper_rev(0:20), -1) }) -test_that("Binary case, no decision change (reversed), lower.tail=TRUE, frequency=0", { skip_on_cran(); expect_equal_each(design_lower_rev(p_test, p_test), 1.0) }) -test_that("Binary case, no decision change (reversed), lower.tail=FALSE, frequency=1", { skip_on_cran(); expect_equal_each(design_upper_rev(p_test, p_test), 0.0) }) +test_that("Binary case, no decision change (reversed), lower.tail=TRUE, critical value", { + skip_on_cran() + expect_equal_each(boundary_design_lower_rev(0:20), 20) +}) +test_that("Binary case, no decision change (reversed), lower.tail=FALSE, critical value", { + skip_on_cran() + expect_equal_each(boundary_design_upper_rev(0:20), -1) +}) +test_that("Binary case, no decision change (reversed), lower.tail=TRUE, frequency=0", { + skip_on_cran() + expect_equal_each(design_lower_rev(p_test, p_test), 1.0) +}) +test_that("Binary case, no decision change (reversed), lower.tail=FALSE, frequency=1", { + skip_on_cran() + expect_equal_each(design_upper_rev(p_test, p_test), 0.0) +}) test_that("Binary case, log-link", { - skip_on_cran() - success <- decision2S(pc=c(0.90, 0.50), qc=c(log(1), log(0.50)), lower.tail=TRUE, link="log") - prior_pbo <- mixbeta(inf1=c(0.60, 19, 29), inf2=c(0.30, 4, 5), rob=c(0.10, 1, 1)) - prior_trt <- mixbeta(c(1, 1/3, 1/3)) - n_trt <- 50 - n_pbo <- 20 - design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success) - theta <- seq(0,1,by=0.1) - expect_numeric(design_suc(theta, theta), lower=0, upper=1, finite=TRUE, any.missing=FALSE) + skip_on_cran() + success <- decision2S(pc = c(0.90, 0.50), qc = c(log(1), log(0.50)), lower.tail = TRUE, link = "log") + prior_pbo <- mixbeta(inf1 = c(0.60, 19, 29), inf2 = c(0.30, 4, 5), rob = c(0.10, 1, 1)) + prior_trt <- mixbeta(c(1, 1 / 3, 1 / 3)) + n_trt <- 50 + n_pbo <- 20 + design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success) + theta <- seq(0, 1, by = 0.1) + expect_numeric(design_suc(theta, theta), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) }) test_that("Binary case, logit-link", { - skip_on_cran() - success <- decision2S(pc=c(0.90, 0.50), qc=c(log(1), log(0.50)), lower.tail=TRUE, link="logit") - prior_pbo <- mixbeta(inf1=c(0.60, 19, 29), inf2=c(0.30, 4, 5), rob=c(0.10, 1, 1)) - prior_trt <- mixbeta(c(1, 1/3, 1/3)) - n_trt <- 50 - n_pbo <- 20 - design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success) - theta <- seq(0,1,by=0.1) - expect_numeric(design_suc(theta, theta), lower=0, upper=1, finite=TRUE, any.missing=FALSE) + skip_on_cran() + success <- decision2S(pc = c(0.90, 0.50), qc = c(log(1), log(0.50)), lower.tail = TRUE, link = "logit") + prior_pbo <- mixbeta(inf1 = c(0.60, 19, 29), inf2 = c(0.30, 4, 5), rob = c(0.10, 1, 1)) + prior_trt <- mixbeta(c(1, 1 / 3, 1 / 3)) + n_trt <- 50 + n_pbo <- 20 + design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success) + theta <- seq(0, 1, by = 0.1) + expect_numeric(design_suc(theta, theta), lower = 0, upper = 1, finite = TRUE, any.missing = FALSE) }) ## check approximate method beta_prior <- mixbeta(c(1, 1, 1)) -design_binary_eps <- oc2S(beta_prior, beta_prior, 100, 100, dec, eps=1E-3) -p_test <- seq(0.1, 0.9, by=0.1) -test_that("Binary type I error rate", { skip_on_cran(); test_scenario(design_binary_eps(p_test, p_test), alpha) }) +design_binary_eps <- oc2S(beta_prior, beta_prior, 100, 100, dec, eps = 1E-3) +p_test <- seq(0.1, 0.9, by = 0.1) +test_that("Binary type I error rate", { + skip_on_cran() + test_scenario(design_binary_eps(p_test, p_test), alpha) +}) ## 22 Nov 2017: disabled test as we trigger always calculation of the ## boundaries as of now. @@ -358,18 +423,27 @@ test_that("Binary type I error rate", { skip_on_cran(); test_scenario(design_bin gamma_prior <- mixgamma(c(1, 2, 2)) -design_poisson <- oc2S(gamma_prior, gamma_prior, 100, 100, dec) +design_poisson <- oc2S(gamma_prior, gamma_prior, 100, 100, dec) design_poissonB <- oc2S(gamma_prior, gamma_prior, 100, 100, decB) -boundary_design_poisson <- decision2S_boundary(gamma_prior, gamma_prior, 100, 100, dec) +boundary_design_poisson <- decision2S_boundary(gamma_prior, gamma_prior, 100, 100, dec) boundary_design_poissonB <- decision2S_boundary(gamma_prior, gamma_prior, 100, 100, decB) -posterior_poisson <- function(m) postmix(gamma_prior, m=m/100, n=100) -lambda_test <- seq(0.5, 1.3, by=0.1) -test_that("Poisson type I error rate", { skip_on_cran(); test_scenario(design_poisson(lambda_test, lambda_test), alpha) }) -test_that("Poisson crticial value, lower.tail=TRUE", { skip_on_cran(); test_critical_discrete(boundary_design_poisson, dec, posterior_poisson, 90) }) -test_that("Poisson crticial value, lower.tail=FALSE", { skip_on_cran(); test_critical_discrete(boundary_design_poissonB, decB, posterior_poisson, 90) }) +posterior_poisson <- function(m) postmix(gamma_prior, m = m / 100, n = 100) +lambda_test <- seq(0.5, 1.3, by = 0.1) +test_that("Poisson type I error rate", { + skip_on_cran() + test_scenario(design_poisson(lambda_test, lambda_test), alpha) +}) +test_that("Poisson crticial value, lower.tail=TRUE", { + skip_on_cran() + test_critical_discrete(boundary_design_poisson, dec, posterior_poisson, 90) +}) +test_that("Poisson crticial value, lower.tail=FALSE", { + skip_on_cran() + test_critical_discrete(boundary_design_poissonB, decB, posterior_poisson, 90) +}) ## 22 Nov 2017: disabled test as we trigger always calculation of the ## boundaries as of now. -##test_that("Poisson results cache expands", { +## test_that("Poisson results cache expands", { ## design_poisson <- oc2S(gamma_prior, gamma_prior, 100, 100, dec) ## design_poisson(theta1=1, theta2=c(0.7,1)) ## expect_true(sum(is.na(design_poisson(y2=70:90)) ) == 4) @@ -378,69 +452,71 @@ test_that("Poisson crticial value, lower.tail=FALSE", { skip_on_cran(); test_cri test_that("Normal OC 2-sample case works for n2=0, crohn-1", { - crohn_sigma <- 88 + crohn_sigma <- 88 - map <- mixnorm(c(0.6,-50,19), c(0.4,-50, 42), sigma=crohn_sigma) + map <- mixnorm(c(0.6, -50, 19), c(0.4, -50, 42), sigma = crohn_sigma) - ## add a 20% non-informative mixture component - map_robust <- robustify(map, weight=0.2, mean=-50, sigma=88) + ## add a 20% non-informative mixture component + map_robust <- robustify(map, weight = 0.2, mean = -50, sigma = 88) - poc <- decision2S(pc=c(0.95,0.5), qc=c(0,-50), lower.tail=TRUE) + poc <- decision2S(pc = c(0.95, 0.5), qc = c(0, -50), lower.tail = TRUE) - weak_prior <- mixnorm(c(1,-50,1), sigma=crohn_sigma, param = 'mn') - n_act <- 40 - ##n_pbo <- 20 + weak_prior <- mixnorm(c(1, -50, 1), sigma = crohn_sigma, param = "mn") + n_act <- 40 + ## n_pbo <- 20 - design_noprior_b <- oc2S(weak_prior, map, n_act, 0, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) + design_noprior_b <- oc2S(weak_prior, map, n_act, 0, poc, + sigma1 = crohn_sigma, sigma2 = crohn_sigma + ) - expect_numeric(design_noprior_b(-20, -30), lower=0, upper=1, any.missing=FALSE) + expect_numeric(design_noprior_b(-20, -30), lower = 0, upper = 1, any.missing = FALSE) }) test_that("Normal OC 2-sample case works for n2=0, crohn-2", { - crohn_sigma <- 88 + crohn_sigma <- 88 - map <- mixnorm(c(1.0,-50,19), sigma=crohn_sigma) + map <- mixnorm(c(1.0, -50, 19), sigma = crohn_sigma) - ## add a 20% non-informative mixture component - map_robust <- robustify(map, weight=0.2, mean=-50, sigma=88) + ## add a 20% non-informative mixture component + map_robust <- robustify(map, weight = 0.2, mean = -50, sigma = 88) - poc <- decision2S(pc=c(0.95,0.5), qc=c(0,-50), lower.tail=TRUE) + poc <- decision2S(pc = c(0.95, 0.5), qc = c(0, -50), lower.tail = TRUE) - weak_prior <- mixnorm(c(1,-50,1), sigma=crohn_sigma, param = 'mn') - n_act <- 40 - ##n_pbo <- 20 + weak_prior <- mixnorm(c(1, -50, 1), sigma = crohn_sigma, param = "mn") + n_act <- 40 + ## n_pbo <- 20 - design_noprior_b <- oc2S(weak_prior, map, n_act, 0, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) + design_noprior_b <- oc2S(weak_prior, map, n_act, 0, poc, + sigma1 = crohn_sigma, sigma2 = crohn_sigma + ) - expect_numeric(design_noprior_b(-20, -30), lower=0, upper=1, any.missing=FALSE) + expect_numeric(design_noprior_b(-20, -30), lower = 0, upper = 1, any.missing = FALSE) }) test_that("Normal OC 2-sample avoids undefined behavior, example 1", { - skip_on_cran() - - sigma_ref <- 3.2 - ##map_ref <- mixnorm(c(0.51, -2.1, 0.39), c(0.42, -2.1, 0.995), c(0.06, -1.99, 2.32), sigma=sigma_ref) - ## chagned so that weights sum to 1 - map_ref <- mixnorm(c(0.52, -2.1, 0.39), c(0.42, -2.1, 0.995), c(0.06, -1.99, 2.32), sigma=sigma_ref) - prior_flat <- mixnorm(c(1, 0, 100), sigma=sigma_ref) - alpha <- 0.05 - dec <- decision2S(1-alpha, 0, lower.tail=FALSE) - n <- 58 - k <- 2 - design_map <- oc2S(prior_flat, map_ref, n, n/k, dec, sigma1=sigma_ref, sigma2=sigma_ref) - design_map_2 <- oc2S(prior_flat, map_ref, n, n/k, dec, sigma1=sigma_ref, sigma2=sigma_ref) - - x <- seq(-2.6, -1.6, by=0.1) - expect_numeric(design_map(x, x), lower=0, upper=1, any.missing=FALSE) - expect_silent(design_map(-3, -4)) - expect_numeric(design_map(-3, -4), lower=0, upper=1, any.missing=FALSE) - expect_numeric(design_map(-3, 4), lower=0, upper=1, any.missing=FALSE) - expect_numeric(design_map(-1.6, -1.6), lower=0, upper=1, any.missing=FALSE) - - expect_numeric(design_map_2(-3, -4), lower=0, upper=1, any.missing=FALSE) - expect_numeric(design_map_2(-3, 4), lower=0, upper=1, any.missing=FALSE) - expect_numeric(design_map_2(-1.6, -1.6), lower=0, upper=1, any.missing=FALSE) - expect_numeric(design_map_2(x, x), lower=0, upper=1, any.missing=FALSE) + skip_on_cran() + + sigma_ref <- 3.2 + ## map_ref <- mixnorm(c(0.51, -2.1, 0.39), c(0.42, -2.1, 0.995), c(0.06, -1.99, 2.32), sigma=sigma_ref) + ## chagned so that weights sum to 1 + map_ref <- mixnorm(c(0.52, -2.1, 0.39), c(0.42, -2.1, 0.995), c(0.06, -1.99, 2.32), sigma = sigma_ref) + prior_flat <- mixnorm(c(1, 0, 100), sigma = sigma_ref) + alpha <- 0.05 + dec <- decision2S(1 - alpha, 0, lower.tail = FALSE) + n <- 58 + k <- 2 + design_map <- oc2S(prior_flat, map_ref, n, n / k, dec, sigma1 = sigma_ref, sigma2 = sigma_ref) + design_map_2 <- oc2S(prior_flat, map_ref, n, n / k, dec, sigma1 = sigma_ref, sigma2 = sigma_ref) + + x <- seq(-2.6, -1.6, by = 0.1) + expect_numeric(design_map(x, x), lower = 0, upper = 1, any.missing = FALSE) + expect_silent(design_map(-3, -4)) + expect_numeric(design_map(-3, -4), lower = 0, upper = 1, any.missing = FALSE) + expect_numeric(design_map(-3, 4), lower = 0, upper = 1, any.missing = FALSE) + expect_numeric(design_map(-1.6, -1.6), lower = 0, upper = 1, any.missing = FALSE) + + expect_numeric(design_map_2(-3, -4), lower = 0, upper = 1, any.missing = FALSE) + expect_numeric(design_map_2(-3, 4), lower = 0, upper = 1, any.missing = FALSE) + expect_numeric(design_map_2(-1.6, -1.6), lower = 0, upper = 1, any.missing = FALSE) + expect_numeric(design_map_2(x, x), lower = 0, upper = 1, any.missing = FALSE) }) diff --git a/tests/testthat/test-pos1S.R b/tests/testthat/test-pos1S.R index 151c469..6a4e9c6 100644 --- a/tests/testthat/test-pos1S.R +++ b/tests/testthat/test-pos1S.R @@ -13,9 +13,9 @@ theta_ni <- 0.4 theta_a <- 0 alpha <- 0.05 -beta <- 0.2 +beta <- 0.2 -za <- qnorm(1-alpha) +za <- qnorm(1 - alpha) n1 <- 155 c1 <- theta_ni - za * s / sqrt(n1) @@ -25,41 +25,49 @@ thetaA <- c(theta_a, theta_ni) ## standard NI design, tests only statistical significance to be ## smaller than theta_ni with 1-alpha certainty -decA <- decision1S(1 - alpha, theta_ni, lower.tail=TRUE) -decAU <- decision1S(1 - alpha, theta_ni, lower.tail=FALSE) +decA <- decision1S(1 - alpha, theta_ni, lower.tail = TRUE) +decAU <- decision1S(1 - alpha, theta_ni, lower.tail = FALSE) -prior <- mixnorm(c(1,0,100), sigma=s) +prior <- mixnorm(c(1, 0, 100), sigma = s) ## let's say we have 40 events at an interim and a HR of 0.9 -ia_dist <- postmix(prior, m=log(0.9), se=s/sqrt(40)) +ia_dist <- postmix(prior, m = log(0.9), se = s / sqrt(40)) test_pos1S <- function(prior, ia_dist, n, dec, decU) { - ## the PoS is the expected value of the condition power integrated - ## over the interim density which is what we check here - cpo_analytic <- oc1S(prior, n, dec) - pos_analytic <- pos1S(prior, n, dec) - samp <- rmix(ia_dist, N_samp) - pos_mc <- mean(cpo_analytic(samp)) - expect_true(all(abs(pos_mc - pos_analytic(ia_dist)) < eps)) - lower.tail <- attr(dec,"lower.tail") - if(lower.tail) { - test_pos1S(prior, ia_dist, n, decU) - } + ## the PoS is the expected value of the condition power integrated + ## over the interim density which is what we check here + cpo_analytic <- oc1S(prior, n, dec) + pos_analytic <- pos1S(prior, n, dec) + samp <- rmix(ia_dist, N_samp) + pos_mc <- mean(cpo_analytic(samp)) + expect_true(all(abs(pos_mc - pos_analytic(ia_dist)) < eps)) + lower.tail <- attr(dec, "lower.tail") + if (lower.tail) { + test_pos1S(prior, ia_dist, n, decU) + } } -test_that("Normal PoS 1 sample function matches MC integration of CPO", { test_pos1S(prior, ia_dist, n1, decA, decAU) }) +test_that("Normal PoS 1 sample function matches MC integration of CPO", { + test_pos1S(prior, ia_dist, n1, decA, decAU) +}) beta_prior <- mixbeta(c(1, 1, 1)) -beta_ia <- postmix(beta_prior, r=20, n=50) -test_that("Binomial PoS 1 sample function matches MC integration of CPO", { test_pos1S(beta_prior, beta_ia, n1, decA, decAU) }) - -gamma_prior <- mixgamma(c(1, 1, 1), param="mn") -dec_count <- decision1S(1-alpha, 1, lower.tail=TRUE) -dec_countU <- decision1S(1-alpha, 1, lower.tail=FALSE) -gamma_ia <- postmix(gamma_prior, m=0.9, n=40) -test_that("Poisson PoS 1 sample function matches MC integration of CPO", { test_pos1S(gamma_prior, gamma_ia, n1, dec_count, dec_countU) }) - -prior_unit_inf <- mixnorm(c(1, 0, 1), sigma=s, param="mn") -post_ia_unit_inf <- postmix(prior_unit_inf, m=-1, n=162) -test_that("Normal PoS 1 sample function matches MC integration of CPO (more extreme case)", { test_pos1S(prior_unit_inf, post_ia_unit_inf, 459-162, decA, decAU) }) +beta_ia <- postmix(beta_prior, r = 20, n = 50) +test_that("Binomial PoS 1 sample function matches MC integration of CPO", { + test_pos1S(beta_prior, beta_ia, n1, decA, decAU) +}) + +gamma_prior <- mixgamma(c(1, 1, 1), param = "mn") +dec_count <- decision1S(1 - alpha, 1, lower.tail = TRUE) +dec_countU <- decision1S(1 - alpha, 1, lower.tail = FALSE) +gamma_ia <- postmix(gamma_prior, m = 0.9, n = 40) +test_that("Poisson PoS 1 sample function matches MC integration of CPO", { + test_pos1S(gamma_prior, gamma_ia, n1, dec_count, dec_countU) +}) + +prior_unit_inf <- mixnorm(c(1, 0, 1), sigma = s, param = "mn") +post_ia_unit_inf <- postmix(prior_unit_inf, m = -1, n = 162) +test_that("Normal PoS 1 sample function matches MC integration of CPO (more extreme case)", { + test_pos1S(prior_unit_inf, post_ia_unit_inf, 459 - 162, decA, decAU) +}) diff --git a/tests/testthat/test-pos2S.R b/tests/testthat/test-pos2S.R index b6eef52..5f57b91 100644 --- a/tests/testthat/test-pos2S.R +++ b/tests/testthat/test-pos2S.R @@ -1,15 +1,14 @@ - ## test the analytical OC function via brute force simulation set.seed(12354) ## expect results to be 1% exact eps <- 1e-2 -prior1 <- mixnorm(c(0.3, -0.2, 2), c(0.7, 0, 50), sigma=1) -prior2 <- mixnorm(c(1.0, 0, 50), sigma=1) +prior1 <- mixnorm(c(0.3, -0.2, 2), c(0.7, 0, 50), sigma = 1) +prior2 <- mixnorm(c(1.0, 0, 50), sigma = 1) -##prior1 <- mixnorm(c(0.3, -0.2, 20), c(0.7, 0, 50), sigma=1) -##prior2 <- mixnorm(c(1.0, 0, 50), sigma=1) +## prior1 <- mixnorm(c(0.3, -0.2, 20), c(0.7, 0, 50), sigma=1) +## prior2 <- mixnorm(c(1.0, 0, 50), sigma=1) N1 <- 30 N2 <- 40 @@ -25,113 +24,118 @@ qcrit <- 0 N_samp <- 1E4 dec <- decision2S(pcrit, qcrit) -decU <- decision2S(pcrit, qcrit, lower.tail=FALSE) +decU <- decision2S(pcrit, qcrit, lower.tail = FALSE) test_pos2S <- function(prior1, prior2, ia_dist1, ia_dist2, n1, n2, dec, decU) { - skip_on_cran() - - ## the PoS is the expected value of the condition power integrated - ## over the interim density which is what we check here - cpo_analytic <- oc2S(prior1, prior2, n1, n2, dec) - pos_analytic <- pos2S(prior1, prior2, n1, n2, dec) - samp1 <- rmix(ia_dist1, N_samp) - samp2 <- rmix(ia_dist2, N_samp) - pos_mc <- mean(cpo_analytic(samp1, samp2)) - ##print(pos_mc) - ##print(pos_analytic(ia_dist1, ia_dist2)) - expect_true(all(abs(pos_mc - pos_analytic(ia_dist1, ia_dist2)) < eps)) - lower.tail <- attr(dec,"lower.tail") - if(lower.tail) { - ##cat("Also testing lower.tail=FALSE\n") - test_pos2S(prior1, prior2, ia_dist1, ia_dist2, n1, n2, decU) - } + skip_on_cran() + + ## the PoS is the expected value of the condition power integrated + ## over the interim density which is what we check here + cpo_analytic <- oc2S(prior1, prior2, n1, n2, dec) + pos_analytic <- pos2S(prior1, prior2, n1, n2, dec) + samp1 <- rmix(ia_dist1, N_samp) + samp2 <- rmix(ia_dist2, N_samp) + pos_mc <- mean(cpo_analytic(samp1, samp2)) + ## print(pos_mc) + ## print(pos_analytic(ia_dist1, ia_dist2)) + expect_true(all(abs(pos_mc - pos_analytic(ia_dist1, ia_dist2)) < eps)) + lower.tail <- attr(dec, "lower.tail") + if (lower.tail) { + ## cat("Also testing lower.tail=FALSE\n") + test_pos2S(prior1, prior2, ia_dist1, ia_dist2, n1, n2, decU) + } } -ia1 <- postmix(prior1, m=0.2, se=s/sqrt(15)) -ia2 <- postmix(prior2, m=0, se=s/sqrt(15)) +ia1 <- postmix(prior1, m = 0.2, se = s / sqrt(15)) +ia2 <- postmix(prior2, m = 0, se = s / sqrt(15)) -test_that("Normal PoS 2 sample function matches MC integration of CPO",{ - test_pos2S(prior1, prior2, - ia1, ia2, - N1, N2, - dec, decU) +test_that("Normal PoS 2 sample function matches MC integration of CPO", { + test_pos2S( + prior1, prior2, + ia1, ia2, + N1, N2, + dec, decU + ) }) ## also run a MC comparison -pos2S_normal_MC <- function(prior1, prior2, N1, N2, dtheta1, dtheta2, pcrit=0.975, qcrit=0) { - skip_on_cran() - - mean_sd1 <- sigma(prior1) / sqrt(N1) - mean_sd2 <- sigma(prior2) / sqrt(N2) - - mean_prior1 <- prior1 - sigma(mean_prior1) <- mean_sd1 - mean_prior2 <- prior2 - sigma(mean_prior2) <- mean_sd2 - - pred_dtheta1 <- preddist(dtheta1, n=N1)##, sigma=mean_sd1) - pred_dtheta2 <- preddist(dtheta2, n=N2)##, sigma=mean_sd1) - - ##mean_samp1 <- rnorm(Nsim, theta1, mean_sd1) - ##mean_samp2 <- rnorm(Nsim, theta2, mean_sd2) - mean_samp1 <- rmix(pred_dtheta1, N_samp) - mean_samp2 <- rmix(pred_dtheta2, N_samp) - - dec <- rep(NA, N_samp) - - for(i in 1:N_samp) { - post1 <- postmix(mean_prior1, m=mean_samp1[i], se=mean_sd1) - post2 <- postmix(mean_prior2, m=mean_samp2[i], se=mean_sd2) - dec[i] <- as.numeric(pmix(RBesT:::mixnormdiff(post1, post2), qcrit) > pcrit) - } - - mean(dec) +pos2S_normal_MC <- function(prior1, prior2, N1, N2, dtheta1, dtheta2, pcrit = 0.975, qcrit = 0) { + skip_on_cran() + + mean_sd1 <- sigma(prior1) / sqrt(N1) + mean_sd2 <- sigma(prior2) / sqrt(N2) + + mean_prior1 <- prior1 + sigma(mean_prior1) <- mean_sd1 + mean_prior2 <- prior2 + sigma(mean_prior2) <- mean_sd2 + + pred_dtheta1 <- preddist(dtheta1, n = N1) ## , sigma=mean_sd1) + pred_dtheta2 <- preddist(dtheta2, n = N2) ## , sigma=mean_sd1) + + ## mean_samp1 <- rnorm(Nsim, theta1, mean_sd1) + ## mean_samp2 <- rnorm(Nsim, theta2, mean_sd2) + mean_samp1 <- rmix(pred_dtheta1, N_samp) + mean_samp2 <- rmix(pred_dtheta2, N_samp) + + dec <- rep(NA, N_samp) + + for (i in 1:N_samp) { + post1 <- postmix(mean_prior1, m = mean_samp1[i], se = mean_sd1) + post2 <- postmix(mean_prior2, m = mean_samp2[i], se = mean_sd2) + dec[i] <- as.numeric(pmix(RBesT:::mixnormdiff(post1, post2), qcrit) > pcrit) + } + + mean(dec) } -test_that("Normal PoS 2 sample function matches MC integration", - { - pos_mc <- pos2S_normal_MC(prior1, prior2, N1, N2, ia1, ia2, pcrit=0.8, qcrit=0) - pos_analytic <- pos2S(prior1, prior2, N1, N2, dec) - expect_true(all(abs(pos_mc - pos_analytic(ia1, ia2)) < eps)) - }) +test_that("Normal PoS 2 sample function matches MC integration", { + pos_mc <- pos2S_normal_MC(prior1, prior2, N1, N2, ia1, ia2, pcrit = 0.8, qcrit = 0) + pos_analytic <- pos2S(prior1, prior2, N1, N2, dec) + expect_true(all(abs(pos_mc - pos_analytic(ia1, ia2)) < eps)) +}) beta_prior <- mixbeta(c(1, 1, 1)) -beta_ia1 <- postmix(beta_prior, r=20, n=50) -beta_ia2 <- postmix(beta_prior, r=30, n=50) +beta_ia1 <- postmix(beta_prior, r = 20, n = 50) +beta_ia2 <- postmix(beta_prior, r = 30, n = 50) test_that("Binomial PoS 2 sample function matches MC integration of CPO", { - test_pos2S(beta_prior, beta_prior, - beta_ia1, beta_ia2, - N1, N2, - dec, decU) + test_pos2S( + beta_prior, beta_prior, + beta_ia1, beta_ia2, + N1, N2, + dec, decU + ) }) -gamma_prior <- mixgamma(c(1, 1, 1), param="mn") +gamma_prior <- mixgamma(c(1, 1, 1), param = "mn") alpha <- 0.05 -dec_count <- decision2S(1-alpha, 0, lower.tail=TRUE) -dec_countU <- decision2S(1-alpha, 0, lower.tail=FALSE) -gamma_ia1 <- postmix(gamma_prior, m=0.7, n=60) -gamma_ia2 <- postmix(gamma_prior, m=1.2, n=60) +dec_count <- decision2S(1 - alpha, 0, lower.tail = TRUE) +dec_countU <- decision2S(1 - alpha, 0, lower.tail = FALSE) +gamma_ia1 <- postmix(gamma_prior, m = 0.7, n = 60) +gamma_ia2 <- postmix(gamma_prior, m = 1.2, n = 60) test_that("Poisson PoS 2 sample function matches MC integration of CPO", { - test_pos2S(gamma_prior, gamma_prior, - gamma_ia1, gamma_ia2, - N1, N2, - dec_count, dec_countU) + test_pos2S( + gamma_prior, gamma_prior, + gamma_ia1, gamma_ia2, + N1, N2, + dec_count, dec_countU + ) }) test_that("Binomial PoS 2 with IA returns results", { - ## reported by user - successCrit <- decision2S(c(0.9), c(0), lower.tail=FALSE) - n0 <- 50 - n <- 100 - n_alt <- 140 - neutr_prior <- mixbeta(c(1,1/3,1/3)) - post_placeboIA <- postmix(neutr_prior, r=13, n=n0) - post_treatIA <- postmix(neutr_prior, r=3, n=n0) - # Criterion for PPoS at IA - pos_final <- pos2S(post_treatIA, post_placeboIA, n-n0, n-n0, successCrit) - pos_final_alt <- pos2S(post_treatIA, post_placeboIA, n_alt-n0, n_alt-n0, successCrit) - #Predictive proba of success at the end - expect_number(pos_final_alt(post_treatIA, post_placeboIA), na.ok=FALSE, lower=0, upper=1, finite=TRUE, null.ok=FALSE) - expect_number(pos_final(post_treatIA, post_placeboIA), na.ok=FALSE, lower=0, upper=1, finite=TRUE, null.ok=FALSE) + ## reported by user + successCrit <- decision2S(c(0.9), c(0), lower.tail = FALSE) + n0 <- 50 + n <- 100 + n_alt <- 140 + neutr_prior <- mixbeta(c(1, 1 / 3, 1 / 3)) + post_placeboIA <- postmix(neutr_prior, r = 13, n = n0) + post_treatIA <- postmix(neutr_prior, r = 3, n = n0) + # Criterion for PPoS at IA + pos_final <- pos2S(post_treatIA, post_placeboIA, n - n0, n - n0, successCrit) + pos_final_alt <- pos2S(post_treatIA, post_placeboIA, n_alt - n0, n_alt - n0, successCrit) + # Predictive proba of success at the end + expect_number(pos_final_alt(post_treatIA, post_placeboIA), na.ok = FALSE, lower = 0, upper = 1, finite = TRUE, null.ok = FALSE) + expect_number(pos_final(post_treatIA, post_placeboIA), na.ok = FALSE, lower = 0, upper = 1, finite = TRUE, null.ok = FALSE) }) diff --git a/tests/testthat/test-postmix.R b/tests/testthat/test-postmix.R index 2492979..ae99f18 100644 --- a/tests/testthat/test-postmix.R +++ b/tests/testthat/test-postmix.R @@ -1,25 +1,24 @@ - -norm <- mixnorm(c(1, 0, 0.5), sigma=1) +norm <- mixnorm(c(1, 0, 0.5), sigma = 1) test_that("Normal mixture reference scale is updated", { - suppressMessages(post_norm <- postmix(norm, m=0, n=100, se=0.1)) - expect_equal(1, RBesT::sigma(post_norm)) - }) + suppressMessages(post_norm <- postmix(norm, m = 0, n = 100, se = 0.1)) + expect_equal(1, RBesT::sigma(post_norm)) +}) test_that("Normal mixture default reference scale is used", { - suppressMessages(post_norm <- postmix(norm, m=0, n=100)) - psd <- sqrt( 1/( (1/sqrt(100))^-2 + (1/2)^-2) ) - expect_lt(abs(summary(post_norm)["sd"] - psd), 1E-7) - }) + suppressMessages(post_norm <- postmix(norm, m = 0, n = 100)) + psd <- sqrt(1 / ((1 / sqrt(100))^-2 + (1 / 2)^-2)) + expect_lt(abs(summary(post_norm)["sd"] - psd), 1E-7) +}) test_that("Normal mixture default reference scale is updated", { - suppressMessages(post_norm <- postmix(norm, m=0, se=1, n=100)) - expect_equal(sigma(post_norm), 10) - }) + suppressMessages(post_norm <- postmix(norm, m = 0, se = 1, n = 100)) + expect_equal(sigma(post_norm), 10) +}) test_that("Gamma mixture is updated for Poisson likelihood", { - gamma_prior <- mixgamma(c(1,10,1), param="mn") - gamma_post <- postmix(gamma_prior, n=20, m=2) - expect_equal(ess(gamma_post), 21) - }) + gamma_prior <- mixgamma(c(1, 10, 1), param = "mn") + gamma_post <- postmix(gamma_prior, n = 20, m = 2) + expect_equal(ess(gamma_post), 21) +}) diff --git a/tests/testthat/test-preddist.R b/tests/testthat/test-preddist.R index 0da4b37..1d98499 100644 --- a/tests/testthat/test-preddist.R +++ b/tests/testthat/test-preddist.R @@ -1,4 +1,3 @@ - ## check that predictive distributions hold what they promise, ## i.e. that they describe the sum of n new data points. @@ -8,7 +7,7 @@ set.seed(42343) eps <- 1e-2 ## percentiles to test for -p_quants <- seq(0.1, 0.9, by=0.1) +p_quants <- seq(0.1, 0.9, by = 0.1) ## number of samples used for sampling method Nsamp <- 1e5 @@ -18,63 +17,75 @@ beta <- mixbeta(c(1, 11, 4)) betaMix <- mixbeta(c(0.8, 11, 4), c(0.2, 1, 1)) gamma <- mixgamma(c(1, 65, 50)) -gammaMix <- mixgamma(rob=c(0.5, 8, 0.5), inf=c(0.5, 9, 2), param="ms") +gammaMix <- mixgamma(rob = c(0.5, 8, 0.5), inf = c(0.5, 9, 2), param = "ms") -norm <- mixnorm(c(1, 0, 0.5), sigma=1) -normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 1), sigma=1) +norm <- mixnorm(c(1, 0, 0.5), sigma = 1) +normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 1), sigma = 1) n <- 25 -preddist_cmp <- function(mix, n, n_rng, N=Nsamp, qntls=p_quants, stat=c("sum", "mean"), Teps=eps) { - skip_on_cran() - - ## sample for each draw a single hyper-parameter which is then - ## used n times in the rng function to return n samples from the - ## sampling distribution - stat <- match.arg(stat) - test <- replicate(N, n_rng(rmix(mix, 1))) - if(stat=="sum") test_stat <- colSums( test) - if(stat=="mean") test_stat <- colMeans(test) - - quants_stest <- quantile(test_stat, qntls) - ## note: in particular for the discrete/counting distributions, - ## sampling gives better estimates - quants_sref <- qmix(preddist(mix, n=n), qntls) - res_sum <- abs(quants_sref-quants_stest) - ## note: errors are accumulating with n, hence to check the mean, - ## we scale eps with n - if(stat=="sum") expect_true(all(res_sum < n * Teps)) - if(stat=="mean") expect_true(all(res_sum < Teps)) - - quants_test <- quantile(test[1,], qntls) - quants_ref <- qmix(preddist(mix, n=1), qntls) - res <- abs(quants_ref-quants_test) - expect_true(all(res < Teps)) - - if(inherits(mix, "betaMix")) { - ## specifically test BetaBinomial (which is from Stan) - predmix <- preddist(mix, n=30) - dens <- dmix(predmix, 0:30) - cdens <- cumsum(dens) - pc <- pmix(predmix, 0:30) - upc <- pmix(predmix, 0:30, FALSE) - expect_true(all(abs(cdens - pc) < Teps)) - expect_true(all(abs(1-cdens - upc) < Teps)) - } - - ## test that output length of the predictive is the same as the - ## input data vector, even for negative values for values outside - ## the valid support of the postive only distribtions - cprob_ltest <- pmix(preddist(mix, n=1), c(-1, quants_ref)) - expect_true(length(cprob_ltest) == length(c(-1, quants_ref))) +preddist_cmp <- function(mix, n, n_rng, N = Nsamp, qntls = p_quants, stat = c("sum", "mean"), Teps = eps) { + skip_on_cran() + + ## sample for each draw a single hyper-parameter which is then + ## used n times in the rng function to return n samples from the + ## sampling distribution + stat <- match.arg(stat) + test <- replicate(N, n_rng(rmix(mix, 1))) + if (stat == "sum") test_stat <- colSums(test) + if (stat == "mean") test_stat <- colMeans(test) + + quants_stest <- quantile(test_stat, qntls) + ## note: in particular for the discrete/counting distributions, + ## sampling gives better estimates + quants_sref <- qmix(preddist(mix, n = n), qntls) + res_sum <- abs(quants_sref - quants_stest) + ## note: errors are accumulating with n, hence to check the mean, + ## we scale eps with n + if (stat == "sum") expect_true(all(res_sum < n * Teps)) + if (stat == "mean") expect_true(all(res_sum < Teps)) + + quants_test <- quantile(test[1, ], qntls) + quants_ref <- qmix(preddist(mix, n = 1), qntls) + res <- abs(quants_ref - quants_test) + expect_true(all(res < Teps)) + + if (inherits(mix, "betaMix")) { + ## specifically test BetaBinomial (which is from Stan) + predmix <- preddist(mix, n = 30) + dens <- dmix(predmix, 0:30) + cdens <- cumsum(dens) + pc <- pmix(predmix, 0:30) + upc <- pmix(predmix, 0:30, FALSE) + expect_true(all(abs(cdens - pc) < Teps)) + expect_true(all(abs(1 - cdens - upc) < Teps)) + } + + ## test that output length of the predictive is the same as the + ## input data vector, even for negative values for values outside + ## the valid support of the postive only distribtions + cprob_ltest <- pmix(preddist(mix, n = 1), c(-1, quants_ref)) + expect_true(length(cprob_ltest) == length(c(-1, quants_ref))) } -test_that("Predictive for a beta evaluates correctly (binary)", { preddist_cmp(beta, n, Curry(rbinom, n=n, size=1)) }) -test_that("Predictive for a beta mixture evaluates correctly (binary)", { preddist_cmp(betaMix, n, Curry(rbinom, n=n, size=1)) }) - -test_that("Predictive for a gamma evaluates correctly (poisson)", { preddist_cmp(gamma, n, Curry(rpois, n=n)) }) -test_that("Predictive for a gamma mixture evaluates correctly (poisson)", { preddist_cmp(gammaMix, n, Curry(rpois, n=n), Teps=1E-1) }) - -test_that("Predictive for a normal evaluates correctly (normal)", { preddist_cmp(norm, n, Curry(rnorm, n=n, sd=sigma(norm)), stat="mean") }) -test_that("Predictive for a normal mixture evaluates correctly (normal)", { preddist_cmp(normMix, n, Curry(rnorm, n=n, sd=sigma(normMix)), stat="mean", Teps=1E-1) }) +test_that("Predictive for a beta evaluates correctly (binary)", { + preddist_cmp(beta, n, Curry(rbinom, n = n, size = 1)) +}) +test_that("Predictive for a beta mixture evaluates correctly (binary)", { + preddist_cmp(betaMix, n, Curry(rbinom, n = n, size = 1)) +}) + +test_that("Predictive for a gamma evaluates correctly (poisson)", { + preddist_cmp(gamma, n, Curry(rpois, n = n)) +}) +test_that("Predictive for a gamma mixture evaluates correctly (poisson)", { + preddist_cmp(gammaMix, n, Curry(rpois, n = n), Teps = 1E-1) +}) + +test_that("Predictive for a normal evaluates correctly (normal)", { + preddist_cmp(norm, n, Curry(rnorm, n = n, sd = sigma(norm)), stat = "mean") +}) +test_that("Predictive for a normal mixture evaluates correctly (normal)", { + preddist_cmp(normMix, n, Curry(rnorm, n = n, sd = sigma(normMix)), stat = "mean", Teps = 1E-1) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 81ea59e..493b963 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,317 +1,481 @@ - ## run the example from predict.gMAP source_example("predict_gMAP.R") ## check that we got for each input data item a prediction -test_that("correct # of predictions are generated", { expect_equal(nrow(map$data), ncol(samp)) }) +test_that("correct # of predictions are generated", { + expect_equal(nrow(map$data), ncol(samp)) +}) ## check that the predictive distribution has a variance which is ## larger in accordance to the betwee-trial heterogeniety (needs to be ## done on the link scale) test_that("variances have correct ordering", { - pred_cov_link <- predict(map, type="link") - within_var <- (summary(pred_cov_link)[,"sd"])^2 + pred_cov_link <- predict(map, type = "link") + within_var <- (summary(pred_cov_link)[, "sd"])^2 - pred_cov_link_pred <- predict(map, trans_cov, type="link") - pred_var_pred <- summary(pred_cov_link_pred)[,"sd"] - tau_est <- summary(map)$tau[,"mean"] + pred_cov_link_pred <- predict(map, trans_cov, type = "link") + pred_var_pred <- summary(pred_cov_link_pred)[, "sd"] + tau_est <- summary(map)$tau[, "mean"] - ## the predictive must include between and within; as such it is - ## larger than within - expect_true(all(pred_var_pred > tau_est)) + ## the predictive must include between and within; as such it is + ## larger than within + expect_true(all(pred_var_pred > tau_est)) - ## ensure that predictive has larger variance than the model estimate - expect_true(all(summary(pred_cov_link_pred)[,"sd"] > summary(pred_cov_link)[,"sd"])) - }) + ## ensure that predictive has larger variance than the model estimate + expect_true(all(summary(pred_cov_link_pred)[, "sd"] > summary(pred_cov_link)[, "sd"])) +}) ## new prediction was done for a single data item -test_that("correct # of new predictions are generated", { expect_equal(ncol(pred_new), 1) } ) +test_that("correct # of new predictions are generated", { + expect_equal(ncol(pred_new), 1) +}) ## must have larger sd than between-trial alone (on link scale) -test_that("predictive variances have correct ordering",{ - pred_new_link <- predict(map, data.frame(country="CH", study=11), type="link") - tau_est <- summary(map)$tau[,"mean"] - expect_true(summary(pred_new_link)[,"sd"] > tau_est) - }) +test_that("predictive variances have correct ordering", { + pred_new_link <- predict(map, data.frame(country = "CH", study = 11), type = "link") + tau_est <- summary(map)$tau[, "mean"] + expect_true(summary(pred_new_link)[, "sd"] > tau_est) +}) ## whenever the same study/covariate combination is requested, then ## the MAP must be numerically exactly the same. This ensures that per ## study the random effect is sampled just once in each iteration. test_that("predictive distributions for the same study & covariate must match exactly", { - trans_cov_new <- data.frame(study="new", n=50, r=0, country=levels(trans_cov$country)[c(1,1)]) - post_trans <- as.matrix(predict(map, newdata=trans_cov_new)) - expect_equal(post_trans[,1], post_trans[,2]) + trans_cov_new <- data.frame(study = "new", n = 50, r = 0, country = levels(trans_cov$country)[c(1, 1)]) + post_trans <- as.matrix(predict(map, newdata = trans_cov_new)) + expect_equal(post_trans[, 1], post_trans[, 2]) }) test_that("automixfit attempts K=4 different models and returns best fitting", { - auto_map <- automixfit(map, Nc=1:4, k=6) - models <- attr(auto_map, "models") - expect_equal(length(models), 4) - perf <- sapply(models, AIC, k=6) - ## ensure that performance is decreasing - expect_true(all(diff(perf) > 0)) - expect_true("betaMix" %in% class(auto_map)) - }) + auto_map <- automixfit(map, Nc = 1:4, k = 6) + models <- attr(auto_map, "models") + expect_equal(length(models), 4) + perf <- sapply(models, AIC, k = 6) + ## ensure that performance is decreasing + expect_true(all(diff(perf) > 0)) + expect_true("betaMix" %in% class(auto_map)) +}) test_that("mixfit for prediction handles response and link scale", { - pred_map <- mixfit(pred_new, Nc=2) + pred_map <- mixfit(pred_new, Nc = 2) - expect_true(is.list(pred_map)) - expect_true("betaMix" %in% class(pred_map[[1]])) - expect_equal(ncol(pred_map[[1]]), 2) + expect_true(is.list(pred_map)) + expect_true("betaMix" %in% class(pred_map[[1]])) + expect_equal(ncol(pred_map[[1]]), 2) - pred_new_link <- predict(map, data.frame(country="CH", study=11), type="link") - pred_map_link <- mixfit(pred_new_link, Nc=2) + pred_new_link <- predict(map, data.frame(country = "CH", study = 11), type = "link") + pred_map_link <- mixfit(pred_new_link, Nc = 2) - expect_true(is.list(pred_map_link)) - expect_true("normMix" %in% class(pred_map_link[[1]])) - expect_equal(ncol(pred_map_link[[1]]), 2) - }) + expect_true(is.list(pred_map_link)) + expect_true("normMix" %in% class(pred_map_link[[1]])) + expect_equal(ncol(pred_map_link[[1]]), 2) +}) source_example("mixcombine.R") test_that("combination of mixtures", { - m1 <- mixcombine(bm, unif, weight=c(9, 1)) - m2 <- mixcombine(bm, unif, unif, weight=c(8, 1, 1)) - expect_equal(m1[1,], c(bm[1,] - 0.1/2, 0.1), ignore_attr=TRUE) - expect_equal(m1[2:3,1:2], bm[2:3,1:2], ignore_attr=TRUE) - expect_equal(m2[2:3,1:2], bm[2:3,1:2], ignore_attr=TRUE) - }) + m1 <- mixcombine(bm, unif, weight = c(9, 1)) + m2 <- mixcombine(bm, unif, unif, weight = c(8, 1, 1)) + expect_equal(m1[1, ], c(bm[1, ] - 0.1 / 2, 0.1), ignore_attr = TRUE) + expect_equal(m1[2:3, 1:2], bm[2:3, 1:2], ignore_attr = TRUE) + expect_equal(m2[2:3, 1:2], bm[2:3, 1:2], ignore_attr = TRUE) +}) test_that("throws an error if more weights than mixtures given", { - ## giving 3 weights but only 2 mixtures must not work - expect_error(mixcombine(bm, unif, weight=c(8, 1, 1)), "length(weight) not equal to length(comp)", fixed=TRUE) - }) + ## giving 3 weights but only 2 mixtures must not work + expect_error(mixcombine(bm, unif, weight = c(8, 1, 1)), "length(weight) not equal to length(comp)", fixed = TRUE) +}) test_that("combination of normal mixtures without default sigma works", { - norm_ui <- mixnorm(c(1, 0, 2)) - norm_ui_mix <- mixcombine(norm_ui, norm_ui, weight=c(0.5,0.5)) - expect_true(ncol(norm_ui_mix) == 2) - }) + norm_ui <- mixnorm(c(1, 0, 2)) + norm_ui_mix <- mixcombine(norm_ui, norm_ui, weight = c(0.5, 0.5)) + expect_true(ncol(norm_ui_mix) == 2) +}) source_example("robustify.R") test_that("beta mixture is robustified with Beta(1,1)", { - expect_equal(ncol(bmix)+1, ncol(rbmix)) - expect_equal(rbmix[,ncol(rbmix)], c(0.1, 1, 1), ignore_attr=TRUE) - }) + expect_equal(ncol(bmix) + 1, ncol(rbmix)) + expect_equal(rbmix[, ncol(rbmix)], c(0.1, 1, 1), ignore_attr = TRUE) +}) test_that("beta mixture is robustified with Beta(0.5,0.5)", { - rbmix2 <- robustify(bmix, w=0.1, n=0, mean=0.5) - expect_equal(ncol(bmix)+1, ncol(rbmix2)) - expect_equal(rbmix2[,ncol(rbmix2)], c(0.1, 0.5, 0.5), ignore_attr=TRUE) - }) + rbmix2 <- robustify(bmix, w = 0.1, n = 0, mean = 0.5) + expect_equal(ncol(bmix) + 1, ncol(rbmix2)) + expect_equal(rbmix2[, ncol(rbmix2)], c(0.1, 0.5, 0.5), ignore_attr = TRUE) +}) test_that("gamma mixture is robustified with n=1 equivalent prior", { - m <- summary(gmnMix)["mean"] - nr <- ncol(rgmnMix) - expect_equal(rgmnMix[[nr, rescale=TRUE]], mixgamma(c(1, m, 1), param="mn"), ignore_attr=TRUE) - expect_equal(rgmnMix[1,nr], 0.1) - }) + m <- summary(gmnMix)["mean"] + nr <- ncol(rgmnMix) + expect_equal(rgmnMix[[nr, rescale = TRUE]], mixgamma(c(1, m, 1), param = "mn"), ignore_attr = TRUE) + expect_equal(rgmnMix[1, nr], 0.1) +}) test_that("gamma mixture is robustified with n=5 equivalent prior", { - m <- summary(gmnMix)["mean"] - rgmnMix2 <- robustify(gmnMix, w=0.1, n=5, mean=2) - nr <- ncol(rgmnMix2) - expect_equal(rgmnMix2[[nr, rescale=TRUE]], mixgamma(c(1, m, 5), param="mn"), ignore_attr=TRUE) - expect_equal(rgmnMix2[1,nr], 0.1) - }) + m <- summary(gmnMix)["mean"] + rgmnMix2 <- robustify(gmnMix, w = 0.1, n = 5, mean = 2) + nr <- ncol(rgmnMix2) + expect_equal(rgmnMix2[[nr, rescale = TRUE]], mixgamma(c(1, m, 5), param = "mn"), ignore_attr = TRUE) + expect_equal(rgmnMix2[1, nr], 0.1) +}) test_that("normal mixture is robustified with n=1 equivalent prior", { - nr <- ncol(rnMix) - expect_equal(rnMix[[nr, rescale=TRUE]], mixnorm(c(1, 0, 1), param="mn", sigma=sigma(nm)), ignore_attr=TRUE) - expect_equal(rnMix[1,nr], 0.1) - }) + nr <- ncol(rnMix) + expect_equal(rnMix[[nr, rescale = TRUE]], mixnorm(c(1, 0, 1), param = "mn", sigma = sigma(nm)), ignore_attr = TRUE) + expect_equal(rnMix[1, nr], 0.1) +}) test_that("normal mixture is robustified with n=5 equivalent prior", { - rnMix2 <- robustify(nm, w=0.1, mean=0, n=5, sigma=sigma(nm)) - nr <- ncol(rnMix2) - expect_equal(rnMix2[[nr, rescale=TRUE]], mixnorm(c(1, 0, 5), param="mn", sigma=sigma(nm)), ignore_attr=TRUE) - expect_equal(rnMix2[1,nr], 0.1) - }) + rnMix2 <- robustify(nm, w = 0.1, mean = 0, n = 5, sigma = sigma(nm)) + nr <- ncol(rnMix2) + expect_equal(rnMix2[[nr, rescale = TRUE]], mixnorm(c(1, 0, 5), param = "mn", sigma = sigma(nm)), ignore_attr = TRUE) + expect_equal(rnMix2[1, nr], 0.1) +}) test_that("plotting of normal mixtures without default sigma works", { - norm_ui <- mixnorm(c(1, 0, 2)) - norm_mix_ui <- mixcombine(norm_ui, norm_ui, weight=c(0.5,0.5)) - pl <- plot(norm_mix_ui) - expect_true(inherits(pl, "ggplot")) - }) + norm_ui <- mixnorm(c(1, 0, 2)) + norm_mix_ui <- mixcombine(norm_ui, norm_ui, weight = c(0.5, 0.5)) + pl <- plot(norm_mix_ui) + expect_true(inherits(pl, "ggplot")) +}) source_example("ess.R") test_that("conjugate beta case matches canonical formula", { - expect_equal(a+b, ess(prior, "moment")) - expect_equal(a+b, round(ess(prior, "morita"))) - expect_equal(a+b, ess(prior, "elir")) - }) + expect_equal(a + b, ess(prior, "moment")) + expect_equal(a + b, round(ess(prior, "morita"))) + expect_equal(a + b, ess(prior, "elir")) +}) test_that("ess elir for beta mixtures gives a warning for a<1 & b<1 densities", { - unconstrain1 <- mixbeta(c(0.95, 10, 5), c(0.05, 0.9, 2)) - unconstrain2 <- mixbeta(c(0.95, 10, 5), c(0.05, 2, 0.9)) + unconstrain1 <- mixbeta(c(0.95, 10, 5), c(0.05, 0.9, 2)) + unconstrain2 <- mixbeta(c(0.95, 10, 5), c(0.05, 2, 0.9)) + + expect_error(ess(unconstrain1, "elir"), "At least one parameter of the beta mixtures is less than 1") + expect_error(ess(unconstrain2, "elir"), "At least one parameter of the beta mixtures is less than 1") - expect_error(ess(unconstrain1, "elir"), "At least one parameter of the beta mixtures is less than 1") - expect_error(ess(unconstrain2, "elir"), "At least one parameter of the beta mixtures is less than 1") + ## this one can trigger errors if the integration is not setup properly + constrained <- mixbeta(c(0.48, 1, 11), c(0.34, 6.9, 173), c(0.18, 1.0, 1.13)) + expect_numeric(ess(constrained, "elir"), lower = 0, finite = TRUE, any.missing = FALSE, len = 1) +}) - ## this one can trigger errors if the integration is not setup properly - constrained <- mixbeta(c(0.48, 1, 11), c(0.34, 6.9, 173), c(0.18, 1.0, 1.13)) - expect_numeric(ess(constrained, "elir"), lower=0, finite=TRUE, any.missing=FALSE, len=1) +test_that("conjugate normal case matches canonical formula", { + s <- 2 + sigma_data <- 4 + nprior <- mixnorm(c(1, -1, s), sigma = sigma_data) + nprior_ess <- sigma_data^2/s^2 + expect_equal(ess(nprior, "moment", sigma = sigma_data), nprior_ess) + expect_equal(ess(nprior, "morita", sigma = sigma_data, s=Inf), nprior_ess) + expect_equal(ess(nprior, "elir", sigma = sigma_data), nprior_ess) }) test_that("ess elir for normal mixtures returns correct values", { - mix <- mixnorm( inf1=c(0.5026,-191.1869,127.4207),inf2=c(0.2647,-187.5895,31.6130),inf3=c(0.2326,-184.7445,345.3849), sigma=270.4877) - expect_gt(ess(mix, sigma=270.4877), 0) + mix <- mixnorm(inf1 = c(0.5026, -191.1869, 127.4207), inf2 = c(0.2647, -187.5895, 31.6130), inf3 = c(0.2326, -184.7445, 345.3849), sigma = 270.4877) + expect_gt(ess(mix, sigma = 270.4877), 0) }) test_that("moment matching for beta mixtures is correct", { - expect_equal(ess(bmix, method="moment"), sum(ab_matched)) - }) + expect_equal(ess(bmix, method = "moment"), sum(ab_matched)) +}) test_that("normal mixtures have reference scale used correctly", { - nmix_sigma_small <- nmix - sigma_large <- RBesT::sigma(nmix) - sigma(nmix_sigma_small) <- sigma_large/sqrt(2) - suppressMessages(e1m <- ess(nmix, "moment")) - suppressMessages(e2m <- ess(nmix_sigma_small, "moment")) - expect_gt(e1m, e2m) - expect_equal(floor(abs(e2m - e1m/2)), 0) - - suppressMessages(e1b <- ess(nmix, "morita")) - suppressMessages(e2b <- ess(nmix_sigma_small, "morita")) - expect_gt(e1b, e2b) - expect_equal(floor(abs(e2b - e1b/2)), 0) - - suppressMessages(e1r <- ess(nmix, "elir")) - suppressMessages(e2r <- ess(nmix_sigma_small, "elir")) - expect_gt(e1r, e2r) - expect_equal(floor(abs(e2r - e1r/2)), 0) - }) + nmix_sigma_small <- nmix + nmix_sigma_large <- nmix + sigma_large <- 2 * summary(nmix_sigma_large)["sd"] + sigma(nmix_sigma_large) <- sigma_large + sigma(nmix_sigma_small) <- sigma_large / sqrt(2) + suppressMessages(e1m <- ess(nmix_sigma_large, "moment")) + suppressMessages(e2m <- ess(nmix_sigma_small, "moment")) + expect_gt(e1m, e2m) + expect_equal(floor(abs(e2m - e1m / 2)), 0) + + suppressMessages(e1b <- ess(nmix_sigma_large, "morita")) + suppressMessages(e2b <- ess(nmix_sigma_small, "morita")) + expect_gt(e1b, e2b) + expect_equal(floor(abs(e2b - e1b / 2)), 0) + + suppressMessages(e1r <- ess(nmix_sigma_large, "elir")) + suppressMessages(e2r <- ess(nmix_sigma_small, "elir")) + expect_gt(e1r, e2r) + expect_equal(floor(abs(e2r - e1r / 2)), 0) +}) test_that("gamma mixtures have likelihood property respected", { - gmix1 <- gmix - likelihood(gmix1) <- "poisson" - gmix2 <- gmix - likelihood(gmix2) <- "exp" - e1m <- ess(gmix1, "moment") - e2m <- ess(gmix2, "moment") - expect_true(e1m != e2m) - - e1b <- ess(gmix1, "morita") - e2b <- ess(gmix2, "morita") - expect_true(e1b != e2b) - - e1r <- ess(gmix1, "morita") - e2r <- ess(gmix2, "morita") - expect_true(e1r != e2r) - }) + gmix1 <- gmix + likelihood(gmix1) <- "poisson" + gmix2 <- gmix + likelihood(gmix2) <- "exp" + e1m <- ess(gmix1, "moment") + e2m <- ess(gmix2, "moment") + expect_true(e1m != e2m) + + e1b <- ess(gmix1, "morita") + e2b <- ess(gmix2, "morita") + expect_true(e1b != e2b) + + e1r <- ess(gmix1, "morita") + e2r <- ess(gmix2, "morita") + expect_true(e1r != e2r) +}) test_that("gamma 1-component density gives canonical results", { - guni1 <- gmix[[1, rescale=TRUE]] - likelihood(guni1) <- "poisson" - guni2 <- gmix[[1, rescale=TRUE]] - likelihood(guni2) <- "exp" - - e1m <- ess(guni1, "moment") - e2m <- ess(guni2, "moment") - expect_true(e1m != e2m) - expect_equal(guni1[3,1], e1m) - expect_equal(guni2[2,1], e2m) - - e1b <- round(ess(guni1, "morita")) - e2b <- round(ess(guni2, "morita")) - expect_true(e1b != e2b) - expect_equal(guni1[3,1], e1b) - expect_equal(guni2[2,1], e2b) - - e1r <- ess(guni1, "elir") - e2r <- ess(guni2, "elir") - expect_true(e1r != e2r) - expect_true(abs(guni1[3,1] - e1r) < 1E-4) - ## ELIR gives a-1 as ESS - expect_true(abs(guni2[2,1] - (e2r+1)) < 1E-4) - }) + guni1 <- gmix[[1, rescale = TRUE]] + likelihood(guni1) <- "poisson" + guni2 <- gmix[[1, rescale = TRUE]] + likelihood(guni2) <- "exp" + + e1m <- ess(guni1, "moment") + e2m <- ess(guni2, "moment") + expect_true(e1m != e2m) + expect_equal(guni1[3, 1], e1m) + expect_equal(guni2[2, 1], e2m) + + e1b <- round(ess(guni1, "morita")) + e2b <- round(ess(guni2, "morita")) + expect_true(e1b != e2b) + expect_equal(guni1[3, 1], e1b) + expect_equal(guni2[2, 1], e2b) + + e1r <- ess(guni1, "elir") + e2r <- ess(guni2, "elir") + expect_true(e1r != e2r) + expect_true(abs(guni1[3, 1] - e1r) < 1E-4) + ## ELIR gives a-1 as ESS + expect_true(abs(guni2[2, 1] - (e2r + 1)) < 1E-4) +}) ## check predictive consistency of ELIR -elir_predictive_consistent <- function(dens, m, Nsim, seed, stat, ...) { - ## simulated from predictve which is m events equivalent to - suppressMessages(pdens <- preddist(dens, n=m)) - set.seed(seed) - psamp <- rmix(pdens, Nsim) - - if(inherits(dens, "gammaMix")) - psamp <- psamp / m - - posterior_ess <- function(mix, method, stat, ...) { - args <- c(list(priormix=mix, stat=0), list(...)) - names(args)[2] <- stat - fn <- function(x) { - args[[stat]] <- x - suppressMessages(res <- ess(do.call(postmix, args), method=method)) - res - } - Vectorize(fn) +elir_predictive_consistent <- function(dens, m, Nsim, seed, stat, ...) { + ## simulated from predictve which is m events equivalent to + suppressMessages(pdens <- preddist(dens, n = m)) + set.seed(seed) + psamp <- rmix(pdens, Nsim) + + if (inherits(dens, "gammaMix")) { + psamp <- psamp / m + } + + posterior_ess <- function(mix, method, stat, ...) { + args <- c(list(priormix = mix, stat = 0), list(...)) + names(args)[2] <- stat + fn <- function(x) { + args[[stat]] <- x + suppressMessages(res <- ess(do.call(postmix, args), method = method)) + res } + Vectorize(fn) + } - ## obtain ess of each posterior - pred_ess <- posterior_ess(dens, "elir", stat, ...) - ess_psamp <- pred_ess(psamp) + ## obtain ess of each posterior + pred_ess <- posterior_ess(dens, "elir", stat, ...) + ess_psamp <- pred_ess(psamp) - suppressMessages(elir_prior <- ess(dens, "elir")) - ## the average over the predicitve of the posterior ESS must match - ## the the elir value taken directly (when m is subtracted, of - ## course) - elir_pred <- mean(ess_psamp) - m + suppressMessages(elir_prior <- ess(dens, "elir")) + ## the average over the predicitve of the posterior ESS must match + ## the the elir value taken directly (when m is subtracted, of + ## course) + elir_pred <- mean(ess_psamp) - m - expect_true(abs(elir_prior - elir_pred) < 0.75) + expect_true(abs(elir_prior - elir_pred) < 0.75) } test_that("ESS elir is predictively consistent for normal mixtures", { - skip_on_cran() - nmix <- mixnorm(rob=c(0.5, 0, 2), inf=c(0.5, 3, 4), sigma=10) - elir_predictive_consistent(nmix, m=3E2, Nsim=1E3, seed=3435, stat="m", se=10/sqrt(3E2)) + skip_on_cran() + nmix <- mixnorm(rob = c(0.5, 0, 2), inf = c(0.5, 3, 4), sigma = 10) + elir_predictive_consistent(nmix, m = 3E2, Nsim = 1E3, seed = 3435, stat = "m", se = 10 / sqrt(3E2)) }) test_that("ESS elir is predictively consistent for beta mixtures", { - skip_on_cran() - bmix <- mixbeta(rob=c(0.2, 1, 1), inf=c(0.8, 10, 2)) - elir_predictive_consistent(bmix, m=1E2, Nsim=1E3, seed=355435, stat="r", n=1E2) + skip_on_cran() + bmix <- mixbeta(rob = c(0.2, 1, 1), inf = c(0.8, 10, 2)) + elir_predictive_consistent(bmix, m = 1E2, Nsim = 1E3, seed = 355435, stat = "r", n = 1E2) }) test_that("ESS elir is predictively consistent for gamma mixtures (Poisson likelihood)", { - skip_on_cran() - gmixP <- mixgamma(rob=c(0.3, 20, 4), inf=c(0.7, 50, 10), likelihood="poisson") - elir_predictive_consistent(gmixP, m=1E2, Nsim=1E3, seed=355435, stat="m", n=1E2) + skip_on_cran() + gmixP <- mixgamma(rob = c(0.3, 20, 4), inf = c(0.7, 50, 10), likelihood = "poisson") + elir_predictive_consistent(gmixP, m = 1E2, Nsim = 1E3, seed = 355435, stat = "m", n = 1E2) }) test_that("ess elir for problematic beta mixtures gives correct result 1", { - ## by user reported beta mixture density which triggers this erros - ## with RBesT 1.7.2 & 1.7.3 (others not tested): - ## Error in if (all(dgl < 0) || all(dgl > 0)) { : - ## missing value where TRUE/FALSE needed + ## by user reported beta mixture density which triggers this erros + ## with RBesT 1.7.2 & 1.7.3 (others not tested): + ## Error in if (all(dgl < 0) || all(dgl > 0)) { : + ## missing value where TRUE/FALSE needed - mixmat <- matrix(c(0.06429517, 0.03301215, 0.00269268, 0.90000000, - 437.32302999, 64.04211307, 5.92543558, 1.00000000, - 10.71709277, 2.14157953, 1.00000001, 1.00000000), byrow=TRUE, ncol=4) + mixmat <- matrix(c( + 0.06429517, 0.03301215, 0.00269268, 0.90000000, + 437.32302999, 64.04211307, 5.92543558, 1.00000000, + 10.71709277, 2.14157953, 1.00000001, 1.00000000 + ), byrow = TRUE, ncol = 4) - mixb <- do.call(mixbeta, apply(mixmat,2,c,simplify=FALSE)) + mixb <- do.call(mixbeta, apply(mixmat, 2, c, simplify = FALSE)) - expect_double(ess(mixb), lower=0, finite=TRUE, any.missing=FALSE, len=1) + expect_double(ess(mixb), lower = 0, finite = TRUE, any.missing = FALSE, len = 1) }) - + test_that("ess elir for problematic beta mixtures gives correct result 2", { - mixmat <- matrix(c(0.7237396, 0.1665037, 0.1097567, - 53.3721902, 44.3894573, 9.8097062, - 1.4301638, 4.3842200, 1.8492197 - ), byrow=TRUE, ncol=3) + mixmat <- matrix(c( + 0.7237396, 0.1665037, 0.1097567, + 53.3721902, 44.3894573, 9.8097062, + 1.4301638, 4.3842200, 1.8492197 + ), byrow = TRUE, ncol = 3) + + mixb <- do.call(mixbeta, apply(mixmat, 2, c, simplify = FALSE)) + + expect_double(ess(robustify(mixb, 0.05, 0.5)), lower = 0, finite = TRUE, any.missing = FALSE, len = 1) + expect_double(ess(robustify(mixb, 0.95, 0.5)), lower = 0, finite = TRUE, any.missing = FALSE, len = 1) +}) + + +test_that("ess elir for problematic beta mixtures gives warning", { + mixmat1 <- matrix(c( + 0.6092774, 0.2337629, 0.1569597, + 1.0000000, 1.2672179, 3.3856153, + 11.8465288, 1.2389927, 7.0191159 + ), byrow = TRUE, ncol = 3) + + + mixb1 <- do.call(mixbeta, apply(mixmat1, 2, c, simplify = FALSE)) + + ## in case one of the coefficients of a and b is 1, then we can + ## get negative results... which are unreliable to the user hopefully + expect_warning(ess(mixb1)) + expect_double(suppressWarnings(ess(mixb1)), finite = TRUE, + any.missing = FALSE, len = 1) + + mixmat2 <- matrix(c( + 0.6051804, 0.2324492, 0.1623704, + 1.0210697, 1.1955047, 3.1342298, + 11.5485831, 1.0831573, 6.7636286 + ), byrow = TRUE, ncol = 3) + + mixb2 <- do.call(mixbeta, apply(mixmat2, 2, c, simplify = FALSE)) + + expect_double(ess(mixb2), lower = 0, finite = TRUE, any.missing = FALSE, + len = 1) +}) + +test_that("BinaryExactCI has correct boundary behavior", { + expect_equal(unname(BinaryExactCI(0, 10, 0.05)[1]), 0) + expect_equal(unname(BinaryExactCI(10, 10, 0.05)[2]), 1) +}) + + +test_that("ess for a normal density with binomial family under a logit link gives correct results", { + ## the ess elir for a normal density prior with mean m and + ## standard deviation s given to a logit transformed response rate + ## is: i(p(eta)) = 1/s^2 and i_F(eta) = exp(eta) / (1 + + ## exp(eta))^2 => r(eta) = i(p(eta)) / i_F(eta) the ess ELIR + ## integral then involves terms as integral exp(eta) p(eta|m,s) + ## d(eta) = exp(m + s^2/2) and integral exp(-eta) p(eta|m,s) d(eta) + ## = exp(-m + s^2/2). The analyical result is then + ## ess_elir = 1/s^2 * [ 2 + exp(-m + s^/2) + exp(m + s^/2) ] + + ## since the information of a normal is just 1/s^2 and thus a + ## constant, the moment based approach gives the same result as + ## the elir method. The morita method differs though as it + ## evaluates at the mode of the prior. + + ess_elir_binomial_logit <- function(m, s) { + s2 <- s * s + (2 + exp(-m + s2 / 2) + exp(m + s2 / 2)) / s2 + } + + fisher_binomial_logit <- function(l) { + exp(l) / (1 + exp(l))^2 + } + + ## Pennello and Thomson ESS for a binomial logit case corresponds + ## to the Morita ESS whenever the scale s for the flattened prior + ## is Infinity + pe_ess_binomial_logit <- function(m, s) { + 1 / s^2 / fisher_binomial_logit(m) + } + + m1 <- 0 + s1 <- 2 / sqrt(10) + prior_norm1 <- mixnorm(c(1, m1, s1), sigma = 2) + expect_equal(ess(prior_norm1, "elir", family = binomial, sigma = 2), ess_elir_binomial_logit(m1, s1), tolerance = 1E-4) + expect_equal(ess(prior_norm1, "moment", family = binomial, sigma = 2), ess_elir_binomial_logit(m1, s1), tolerance = 1E-4) + expect_equal(ess(prior_norm1, "morita", family = binomial, sigma = 2, s = Inf), pe_ess_binomial_logit(m1, s1), tolerance = 1E-4) + + m2 <- 2 + s2 <- 2 / sqrt(100) + prior_norm2a <- mixnorm(c(1, m2, s2), sigma = 2) + expect_equal(ess(prior_norm2a, "elir", family = binomial, sigma = 2), ess_elir_binomial_logit(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2a, "moment", family = binomial, sigma = 2), ess_elir_binomial_logit(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2a, "morita", family = binomial, sigma = 2, s = Inf), pe_ess_binomial_logit(m2, s2), tolerance = 1E-4) + + ## sigma does not play a role here + prior_norm2b <- mixnorm(c(1, m2, s2), sigma = 4) + expect_equal(ess(prior_norm2b, "elir", family = binomial, sigma = 4), ess_elir_binomial_logit(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2b, "moment", family = binomial, sigma = 4), ess_elir_binomial_logit(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2b, "morita", family = binomial, sigma = 4, s = Inf), pe_ess_binomial_logit(m2, s2), tolerance = 1E-4) +}) + + +test_that("ess for a normal density with poisson family under a log link gives correct results", { + ## the ess elir for a normal density prior with mean m and + ## standard deviation s given to a log transformed count rate + ## is: i(p(eta)) = 1/s^2 and i_F(eta) = exp(eta) => r(eta) = i(p(eta)) / i_F(eta) the ess ELIR + ## integral then involves terms as integral exp(-eta) p(eta|m,s) + ## d(eta) = exp(-m + s^2/2). The analyical result is then + ## ess_elir = 1/s^2 * exp(-m + s^/2) + + ## since the information of a normal is just 1/s^2 and thus a + ## constant, the moment based approach gives the same result as + ## the elir method. The morita method differs though as it + ## evaluates at the mode of the prior. + + ess_elir_poisson_log <- function(m, s) { + s2 <- s * s + exp(-m + s2 / 2) / s2 + } + + fisher_poisson_log <- function(l) { + exp(l) + } + + ## Pennello and Thomson ESS for a binomial logit case corresponds + ## to the Morita ESS whenever the scale s for the flattened prior + ## is Infinity + pe_ess_poisson_log <- function(m, s) { + 1 / s^2 / fisher_poisson_log(m) + } + + m1 <- 0 + s1 <- 2 / sqrt(10) + prior_norm1 <- mixnorm(c(1, m1, s1), sigma = 2) + expect_equal(ess(prior_norm1, "elir", family = poisson, sigma = 2), ess_elir_poisson_log(m1, s1), tolerance = 1E-4) + expect_equal(ess(prior_norm1, "moment", family = poisson, sigma = 2), ess_elir_poisson_log(m1, s1), tolerance = 1E-4) + expect_equal(ess(prior_norm1, "morita", family = poisson, sigma = 2, s = Inf), pe_ess_poisson_log(m1, s1), tolerance = 1E-4) + + m2 <- 2 + s2 <- 2 / sqrt(100) + prior_norm2a <- mixnorm(c(1, m2, s2), sigma = 2) + expect_equal(ess(prior_norm2a, "elir", family = poisson, sigma = 2), ess_elir_poisson_log(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2a, "moment", family = poisson, sigma = 2), ess_elir_poisson_log(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2a, "morita", family = poisson, sigma = 2, s = Inf), pe_ess_poisson_log(m2, s2), tolerance = 1E-4) + + ## sigma does not play a role here + prior_norm2b <- mixnorm(c(1, m2, s2), sigma = 4) + expect_equal(ess(prior_norm2b, "elir", family = poisson, sigma = 4), ess_elir_poisson_log(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2b, "moment", family = poisson, sigma = 4), ess_elir_poisson_log(m2, s2), tolerance = 1E-4) + expect_equal(ess(prior_norm2b, "morita", family = poisson, sigma = 4, s = Inf), pe_ess_poisson_log(m2, s2), tolerance = 1E-4) +}) + +test_that("ess for a beta mixture errors if a family is specified", { + expect_error(ess(mixbeta(c(1, 5, 15)), family = binomial)) +}) - mixb <- do.call(mixbeta, apply(mixmat,2,c,simplify=FALSE)) - - expect_double(ess(robustify(mixb, 0.05, 0.5)), lower=0, finite=TRUE, any.missing=FALSE, len=1) - expect_double(ess(robustify(mixb, 0.95, 0.5)), lower=0, finite=TRUE, any.missing=FALSE, len=1) +test_that("ess for a gamma mixture errors if a family is specified", { + expect_error(ess(mixgamma(rob = c(0.3, 20, 4), inf = c(0.7, 50, 10)), family = poisson)) }) - diff --git a/tools/make-ds.R b/tools/make-ds.R index 9fd1a33..e261788 100644 --- a/tools/make-ds.R +++ b/tools/make-ds.R @@ -43,7 +43,7 @@ make_internal_ds <- function() { calibration_meta["MD5"] <- vals["MD5"] pkg_create_date <- Sys.time() - pkg_sha <- "896a402" + pkg_sha <- "3437e3d" if (gsub("\\$", "", pkg_sha) == "Format:%h") { pkg_sha <- system("git rev-parse --short HEAD", intern=TRUE) diff --git a/vignettes/articles/PoS_codata.Rmd b/vignettes/articles/PoS_codata.Rmd index 32b99a9..30e4a50 100644 --- a/vignettes/articles/PoS_codata.Rmd +++ b/vignettes/articles/PoS_codata.Rmd @@ -136,16 +136,17 @@ ratio used for the design of the trial is $0.8$. Example data: ```{r} -trials <- data.frame(study = c("PoC", "PhII", "PhIII_A", "PhIII_B"), - deaths = c( 8, 85, 162, 150), - HR = c( 0.7, 0.75, 0.83, 0.78), - stringsAsFactors = FALSE - ) +trials <- data.frame( + study = c("PoC", "PhII", "PhIII_A", "PhIII_B"), + deaths = c(8, 85, 162, 150), + HR = c(0.7, 0.75, 0.83, 0.78), + stringsAsFactors = FALSE +) ## under the normal approximation of the log-HR, the sampling sd is 2 ## such that the standard errors are sqrt(4/events) trials <- trials %>% - mutate(logHR=log(HR), sem=sqrt(4/deaths)) -kable(trials, digits=2) + mutate(logHR = log(HR), sem = sqrt(4 / deaths)) +kable(trials, digits = 2) ``` The remaining outline of the vignette is to first evaluate the design @@ -198,16 +199,16 @@ Here we use the unit information prior as non-informative prior and define it using the mean & effective sample size (ESS) specification: ```{r} -unit_inf <- mixnorm(c(1, 0, 1), sigma=2, param="mn") +unit_inf <- mixnorm(c(1, 0, 1), sigma = 2, param = "mn") unit_inf ``` Define conditional power for the overall trial: ```{r} -success_crit <- decision1S(1-alpha, 0) +success_crit <- decision1S(1 - alpha, 0) ## let's print the defined criterion success_crit -design <- oc1S(unit_inf, Nev, success_crit, sigma=2) +design <- oc1S(unit_inf, Nev, success_crit, sigma = 2) ``` Under the alternative these design choices result in 80% power @@ -220,20 +221,21 @@ The impact of the unit-information prior is minimal which can be seen by comparing to the frequentist calculation: ```{r} -power.t.test(n=Nev, delta=-1*alt_logHR, sd=2, type="one.sample", sig.level=0.025, alternative="one.sided") +power.t.test(n = Nev, delta = -1 * alt_logHR, sd = 2, type = "one.sample", sig.level = 0.025, alternative = "one.sided") ``` With RBesT we can explore the conditional power for a range of alternatives: ```{r} -ggplot(data.frame(HR=c(0.5, 1.2)), aes(HR)) + - stat_function(fun=compose(design, log)) + - vline_at(c(alt_HR, 1.0), linetype=I(2)) + - scale_y_continuous(breaks=seq(0,1,by=0.1)) + - scale_x_continuous(breaks=c(alt_HR, seq(0,1.2,by=0.2))) + - ylab(NULL) + xlab(expression(theta[a])) + - ggtitle(paste("Power for N =", Nev, "events")) +ggplot(data.frame(HR = c(0.5, 1.2)), aes(HR)) + + stat_function(fun = compose(design, log)) + + vline_at(c(alt_HR, 1.0), linetype = I(2)) + + scale_y_continuous(breaks = seq(0, 1, by = 0.1)) + + scale_x_continuous(breaks = c(alt_HR, seq(0, 1.2, by = 0.2))) + + ylab(NULL) + + xlab(expression(theta[a])) + + ggtitle(paste("Power for N =", Nev, "events")) ``` @@ -243,7 +245,7 @@ The critical value determines at which observed logHR we *just* conclude that the success criterion is fulfilled. ```{r} -design_crit <- decision1S_boundary(unit_inf, Nev, success_crit, sigma=2) +design_crit <- decision1S_boundary(unit_inf, Nev, success_crit, sigma = 2) design_crit exp(design_crit) @@ -252,7 +254,7 @@ exp(design_crit) We can check this: ```{r} -success_crit(postmix(unit_inf, m=design_crit, n=379)) +success_crit(postmix(unit_inf, m = design_crit, n = 379)) ``` Ok, when observing the critical value, we get a success. @@ -260,7 +262,7 @@ Ok, when observing the critical value, we get a success. Now, what if we observe a 1% worse result? ```{r} -success_crit(postmix(unit_inf, m=design_crit+log(1.01), n=379)) +success_crit(postmix(unit_inf, m = design_crit + log(1.01), n = 379)) ``` No success then $\Rightarrow$ this is the critical boundary value. @@ -273,7 +275,7 @@ Posterior of treatment effect at interim. The trial uses a non-informative prior for the treatment effect: ```{r} -interim_A <- postmix(unit_inf, m=trials$logHR[3], se=trials$sem[3]) +interim_A <- postmix(unit_inf, m = trials$logHR[3], se = trials$sem[3]) interim_A ``` @@ -282,7 +284,7 @@ use for the analysis of the second half is given by the data collected so far. ```{r} -interim_pos_A <- pos1S(interim_A, Nev-trials$deaths[3], success_crit, sigma=2) +interim_pos_A <- pos1S(interim_A, Nev - trials$deaths[3], success_crit, sigma = 2) ``` The returned function can now calculate the PoS assuming any @@ -306,7 +308,7 @@ power which is conditional on the observed data, $CP_{N-n_I}(\theta|y_{n_I})$: ```{r} -interim_oc_A <- oc1S(interim_A, Nev-trials$deaths[3], success_crit, sigma=2) +interim_oc_A <- oc1S(interim_A, Nev - trials$deaths[3], success_crit, sigma = 2) ``` The conditional power assuming the alternative is true (a HR of 0.75): @@ -325,8 +327,8 @@ interim_pos_A(mixnorm(c(1, alt_logHR, 1E-4))) For trial B the calculation is: ```{r} -interim_B <- postmix(unit_inf, m=trials$logHR[4], se=trials$sem[4]) -interim_pos_B <- pos1S(interim_B, Nev-trials$deaths[4], success_crit, sigma=2) +interim_B <- postmix(unit_inf, m = trials$logHR[4], se = trials$sem[4]) +interim_pos_B <- pos1S(interim_B, Nev - trials$deaths[4], success_crit, sigma = 2) interim_pos_B(interim_B) ``` @@ -340,17 +342,18 @@ trial. We now derive from these a MAP prior; recall that the MAP prior is the prediction of the log-hazard ratio of a future trial: ```{r} -base <- trials[1:2,] +base <- trials[1:2, ] set.seed(342345) base_map_mc <- gMAP(cbind(logHR, sem) ~ 1 | study, - family=gaussian, - data=base, - weights=deaths, - tau.dist="HalfNormal", tau.prior=0.5, - beta.prior=cbind(0, 2)) + family = gaussian, + data = base, + weights = deaths, + tau.dist = "HalfNormal", tau.prior = 0.5, + beta.prior = cbind(0, 2) +) -forest_plot(base_map_mc, est="MAP") +forest_plot(base_map_mc, est = "MAP") base_map <- automixfit(base_map_mc) @@ -364,7 +367,7 @@ effect through the interim data itself which we can include into the MAP prior: ```{r} -interim_A_combined <- postmix(base_map, m=trials$logHR[3], se=trials$sem[3]) +interim_A_combined <- postmix(base_map, m = trials$logHR[3], se = trials$sem[3]) ``` The PoS for this posterior at interim (representing historical @@ -379,7 +382,7 @@ the final analysis will use a non-informative prior. For trial B the calculation is: ```{r} -interim_B_combined <- postmix(base_map, m=trials$logHR[4], se=trials$sem[4]) +interim_B_combined <- postmix(base_map, m = trials$logHR[4], se = trials$sem[4]) interim_pos_B(interim_B_combined) ``` @@ -389,12 +392,12 @@ However, there is even more information which can be used here, since the phase III result of trial B is also available: ```{r} -interim_map_mc <- update(base_map_mc, data=trials) +interim_map_mc <- update(base_map_mc, data = trials) ``` Now the trial B specific posterior at interim is ```{r} -kable(fitted(interim_map_mc), digits=3) +kable(fitted(interim_map_mc), digits = 3) ``` which we can extract as: @@ -403,17 +406,17 @@ which we can extract as: 1. obtain posterior (which we restrict to the first 4 columns) ```{r} -interim_map_post <- as.matrix(interim_map_mc)[,1:4] +interim_map_post <- as.matrix(interim_map_mc)[, 1:4] dim(interim_map_post) # posterior is given as matrix: iteration x parameter -head(interim_map_post, n=3) +head(interim_map_post, n = 3) ``` 2. turn MCMC posterior sample into parametric mixture ```{r} -interim_A_allcombined <- automixfit(interim_map_post[,"theta[3]"]) +interim_A_allcombined <- automixfit(interim_map_post[, "theta[3]"]) ``` 3. and finally evaluate the PoS @@ -429,7 +432,7 @@ exchangeability. For trial B computations are: ```{r} -interim_B_allcombined <- automixfit(interim_map_post[,"theta[4]"]) +interim_B_allcombined <- automixfit(interim_map_post[, "theta[4]"]) interim_pos_B(interim_B_allcombined) ``` @@ -442,23 +445,24 @@ the historical data in comparison to the twin phase III trials. Assign data to historical (2) and concurrent data strata (1): ```{r} -trials <- trials %>% mutate(stratum=c(2, 2, 1, 1)) +trials <- trials %>% mutate(stratum = c(2, 2, 1, 1)) -kable(trials, digits=2) +kable(trials, digits = 2) set.seed(435345) interim_diff_map_mc <- gMAP(cbind(logHR, sem) ~ 1 | study, - tau.strata=stratum, - family=gaussian, - data=trials, - weights=deaths, - tau.dist="HalfNormal", tau.prior=c(0.5, 1), - beta.prior=cbind(0, 2)) + tau.strata = stratum, + family = gaussian, + data = trials, + weights = deaths, + tau.dist = "HalfNormal", tau.prior = c(0.5, 1), + beta.prior = cbind(0, 2) +) -interim_diff_map_post <- as.matrix(interim_diff_map_mc)[,1:4] +interim_diff_map_post <- as.matrix(interim_diff_map_mc)[, 1:4] -interim_A_diff_allcombined <- automixfit(interim_diff_map_post[,"theta[3]"]) -interim_B_diff_allcombined <- automixfit(interim_diff_map_post[,"theta[4]"]) +interim_A_diff_allcombined <- automixfit(interim_diff_map_post[, "theta[3]"]) +interim_B_diff_allcombined <- automixfit(interim_diff_map_post[, "theta[4]"]) interim_pos_A(interim_A_diff_allcombined) interim_pos_B(interim_B_diff_allcombined) @@ -482,7 +486,7 @@ interim_pos_A(interim_A) As explained, the conditional power is the operating characerstic of a design when conditioning on the already observed data: ```{r} -interim_oc_A <- oc1S(interim_A, Nev-trials$deaths[3], success_crit, sigma=2) +interim_oc_A <- oc1S(interim_A, Nev - trials$deaths[3], success_crit, sigma = 2) ``` The PoS is then the integral of the conditional power over the @@ -520,13 +524,13 @@ $$ Thus we need to also get the conditional power for trial B at interim... ```{r} -interim_oc_B <- oc1S(interim_B, Nev-trials$deaths[4], success_crit, sigma=2) +interim_oc_B <- oc1S(interim_B, Nev - trials$deaths[4], success_crit, sigma = 2) ``` ...and integrate over the posterior samples (differential discounting case) ```{r} -mean(interim_oc_A(interim_diff_map_post[,"theta[3]"]) * interim_oc_B(interim_diff_map_post[,"theta[4]"])) +mean(interim_oc_A(interim_diff_map_post[, "theta[3]"]) * interim_oc_B(interim_diff_map_post[, "theta[4]"])) ``` which is slightly larger than assuming independence: @@ -536,12 +540,12 @@ interim_pos_A(interim_A) * interim_pos_B(interim_B) This is due to dependence of the posteriors ```{r} -cor(interim_diff_map_post[,c("theta[3]", "theta[4]")]) +cor(interim_diff_map_post[, c("theta[3]", "theta[4]")]) ``` For the full exchangeability case we have ```{r} -mean(interim_oc_A(interim_map_post[,"theta[3]"]) * interim_oc_B(interim_map_post[,"theta[4]"])) +mean(interim_oc_A(interim_map_post[, "theta[3]"]) * interim_oc_B(interim_map_post[, "theta[4]"])) ``` @@ -557,7 +561,7 @@ our preceding calculations. Phase III trial A: ```{r} -## only interim data of trial A +## only interim data of trial A interim_pos_A(interim_A) ## in addition with prior historical data PoC & phase II data interim_pos_A(interim_A_combined) @@ -600,19 +604,20 @@ chains) to get a very high precision. ```{r} base_map_mc_2 <- gMAP(cbind(logHR, sem) ~ 1 | study, - family=gaussian, - data=base, - weights=deaths, - tau.dist="HalfNormal", tau.prior=0.5, - beta.prior=cbind(0, 2), - chains=ifelse(is_CRAN, 2, 20)) + family = gaussian, + data = base, + weights = deaths, + tau.dist = "HalfNormal", tau.prior = 0.5, + beta.prior = cbind(0, 2), + chains = ifelse(is_CRAN, 2, 20) +) ``` Force an accurate fit with 5 components: ```{r} -base_map_2 <- mixfit(base_map_mc_2, Nc=5) +base_map_2 <- mixfit(base_map_mc_2, Nc = 5) base_map_2 ``` @@ -620,7 +625,7 @@ Now, combine the MAP prior (representing historical knowledge) with the interim data of trial A: ```{r} -interim_A_combined_2 <- postmix(base_map_2, m=trials$logHR[3], se=trials$sem[3]) +interim_A_combined_2 <- postmix(base_map_2, m = trials$logHR[3], se = trials$sem[3]) ``` @@ -628,15 +633,15 @@ interim_A_combined_2 <- postmix(base_map_2, m=trials$logHR[3], se=trials$sem[3]) phase III A trial, but excluding the phase III B data): ```{r} -interim_map_mc_2 <- update(base_map_mc_2, data=trials[-4,]) +interim_map_mc_2 <- update(base_map_mc_2, data = trials[-4, ]) -interim_map_post_2 <- as.matrix(interim_map_mc_2)[,1:3] +interim_map_post_2 <- as.matrix(interim_map_mc_2)[, 1:3] ``` 2. turn MCMC posterior sample into parametric mixture ```{r} -interim_A_allcombined_2 <- mixfit(interim_map_post_2[,"theta[3]"], Nc=5) +interim_A_allcombined_2 <- mixfit(interim_map_post_2[, "theta[3]"], Nc = 5) interim_A_allcombined_2 ``` @@ -645,11 +650,11 @@ interim_A_allcombined_2 Now let's overlay the two posterior's ```{r} -ggplot(data.frame(logHR=c(-0.8,0.25)), aes(logHR)) + - stat_function(fun=dmix, args=list(mix=interim_A_combined_2), aes(linetype="MAP")) + - stat_function(fun=dmix, args=list(mix=interim_A_allcombined_2), aes(linetype="MAC")) + - scale_linetype_discrete("Analysis") + - ggtitle("Posterior log hazard of phase III A trial at interim") +ggplot(data.frame(logHR = c(-0.8, 0.25)), aes(logHR)) + + stat_function(fun = dmix, args = list(mix = interim_A_combined_2), aes(linetype = "MAP")) + + stat_function(fun = dmix, args = list(mix = interim_A_allcombined_2), aes(linetype = "MAC")) + + scale_linetype_discrete("Analysis") + + ggtitle("Posterior log hazard of phase III A trial at interim") ``` diff --git a/vignettes/articles/PoS_interim.Rmd b/vignettes/articles/PoS_interim.Rmd index e3dbdc2..cc11974 100644 --- a/vignettes/articles/PoS_interim.Rmd +++ b/vignettes/articles/PoS_interim.Rmd @@ -38,21 +38,23 @@ upon treatment is considered improvement in the patients. Below is the summary statistics of this primary endpoint by group at the interim. ```{r ia data summary} -ia <- data.frame(n=c(12, 14), - median_count=c(20.5, 21), - mean_count=c(23.3, 27), - mean_log=c(2.96, 3.03), - sd_log=c(0.67, 0.774), - row.names=c("active", "placebo")) %>% - transform(se_log=round(sd_log/sqrt(n), 3)) -sd_log_pooled <- with(ia, sqrt(sum(sd_log^2*(n-1))/(sum(n)-2))) +ia <- data.frame( + n = c(12, 14), + median_count = c(20.5, 21), + mean_count = c(23.3, 27), + mean_log = c(2.96, 3.03), + sd_log = c(0.67, 0.774), + row.names = c("active", "placebo") +) %>% + transform(se_log = round(sd_log / sqrt(n), 3)) +sd_log_pooled <- with(ia, sqrt(sum(sd_log^2 * (n - 1)) / (sum(n) - 2))) kable(ia) ``` The predefined dual PoC criteria is as follows, ```{r rules, eval=TRUE} n <- 21 # planned total n per arm -rules <- decision2S(c(0.9, 0.5), c(0,-0.357), lower.tail = TRUE) +rules <- decision2S(c(0.9, 0.5), c(0, -0.357), lower.tail = TRUE) print(rules) ``` @@ -68,12 +70,12 @@ treatment over placebo numerically. The variability of this endpoint is higher than what was assumed for study sample size calculation. ```{r ia} -priorP <- priorT <- mixnorm(c(1, log(20), 1), sigma = 0.47, param = 'mn') +priorP <- priorT <- mixnorm(c(1, log(20), 1), sigma = 0.47, param = "mn") ## posterior at IA data -postT_interim <- postmix(priorT, m=ia["active","mean_log"], se=ia["active","se_log"]) -postP_interim <- postmix(priorP, m=ia["placebo","mean_log"], se=ia["placebo","se_log"]) +postT_interim <- postmix(priorT, m = ia["active", "mean_log"], se = ia["active", "se_log"]) +postP_interim <- postmix(priorP, m = ia["placebo", "mean_log"], se = ia["placebo", "se_log"]) pmixdiff(postT_interim, postP_interim, 0) -pmixdiff(postT_interim, postP_interim,-0.357) +pmixdiff(postT_interim, postP_interim, -0.357) ``` The probability of success at the final analysis, i.e. the probability @@ -87,12 +89,12 @@ would be used. pos_final <- pos2S( postT_interim, postP_interim, - n - ia["active","n"], - n - ia["placebo","n"], + n - ia["active", "n"], + n - ia["placebo", "n"], rules, sigma1 = sd_log_pooled, sigma2 = sd_log_pooled - ) +) ``` The function constructed by **`pos2S()`** can produce the predictive @@ -108,34 +110,37 @@ One can also use **`oc2S()`** to compute conditional power for any given treatment effect. ```{r oc, fig.height=4,fig.width=4*1.62} ia_oc <- oc2S( - postT_interim, - postP_interim, - n - ia["active","n"], - n - ia["placebo","n"], - rules, - sigma1 = sd_log_pooled, - sigma2 = sd_log_pooled - ) - -delta <- seq(0, 0.9, 0.01) #pct diff from pbo -pbomean <- ia["placebo","mean_log"] -y1 <- log(exp(pbomean) * (1 - delta)) #active -y2 <- log(exp(pbomean) * (1 - 0 * delta)) #placebo - + postT_interim, + postP_interim, + n - ia["active", "n"], + n - ia["placebo", "n"], + rules, + sigma1 = sd_log_pooled, + sigma2 = sd_log_pooled +) + +delta <- seq(0, 0.9, 0.01) # pct diff from pbo +pbomean <- ia["placebo", "mean_log"] +y1 <- log(exp(pbomean) * (1 - delta)) # active +y2 <- log(exp(pbomean) * (1 - 0 * delta)) # placebo + out <- - data.frame( - diff_pct = delta, - diff = round(y1 - y2, 2), - y_act = y1, - y_pbo = y2, - cp = ia_oc(y1, y2) - ) - -ggplot(data = out, aes(x = diff_pct, y = cp)) + geom_line() + - scale_x_continuous(labels = scales::percent) + - labs(y = 'Conditional power', - x = 'True percentage difference from placebo in lesion count', - title = 'Conditional power at interim for success at final analysis') + data.frame( + diff_pct = delta, + diff = round(y1 - y2, 2), + y_act = y1, + y_pbo = y2, + cp = ia_oc(y1, y2) + ) + +ggplot(data = out, aes(x = diff_pct, y = cp)) + + geom_line() + + scale_x_continuous(labels = scales::percent) + + labs( + y = "Conditional power", + x = "True percentage difference from placebo in lesion count", + title = "Conditional power at interim for success at final analysis" + ) ``` diff --git a/vignettes/articles/customizing_plots.Rmd b/vignettes/articles/customizing_plots.Rmd index 502f876..4d90199 100644 --- a/vignettes/articles/customizing_plots.Rmd +++ b/vignettes/articles/customizing_plots.Rmd @@ -39,16 +39,17 @@ library(bayesplot) # Default settings for bayesplot color_scheme_set("blue") -theme_set(theme_default(base_size=12)) +theme_set(theme_default(base_size = 12)) # Load example gMAP object set.seed(546346) map_crohn <- gMAP(cbind(y, y.se) ~ 1 | study, - family=gaussian, - data=transform(crohn, y.se=88/sqrt(n)), - weights=n, - tau.dist="HalfNormal", tau.prior=44, - beta.prior=cbind(0,88)) + family = gaussian, + data = transform(crohn, y.se = 88 / sqrt(n)), + weights = n, + tau.dist = "HalfNormal", tau.prior = 44, + beta.prior = cbind(0, 88) +) print(map_crohn) ``` @@ -67,7 +68,7 @@ We can also include the model-based estimates for each study, and add a legend to explain the different linetypes. ```{r} -forest_plot(map_crohn, model="both") + legend_move("right") +forest_plot(map_crohn, model = "both") + legend_move("right") ``` We can modify the color scheme as follows (refer to @@ -77,7 +78,7 @@ We can modify the color scheme as follows (refer to # preview a color scheme color_scheme_view("mix-blue-red") # and now let's use it -color_scheme_set("mix-blue-red") +color_scheme_set("mix-blue-red") forest_plot(map_crohn) color_scheme_set("gray") forest_plot(map_crohn) @@ -87,7 +88,7 @@ The point size can be modified and the vertical line removed: ```{r} color_scheme_set("blue") -forest_plot(map_crohn, size=0.5, alpha=0) +forest_plot(map_crohn, size = 0.5, alpha = 0) ``` ## Presentation-ready plots @@ -101,10 +102,12 @@ this purpose. ```{r, fig.width=10, fig.height=6} # adjust the base font size -theme_set(theme_default(base_size=16)) -forest_plot(map_crohn, model="both", est="MAP", size=1) + legend_move("right") + - labs(title="Forest plot", subtitle="Results of Meta-Analytic-Predictive (MAP) analysis", - caption="Plot shows point estimates (posterior medians) with 95% intervals") +theme_set(theme_default(base_size = 16)) +forest_plot(map_crohn, model = "both", est = "MAP", size = 1) + legend_move("right") + + labs( + title = "Forest plot", subtitle = "Results of Meta-Analytic-Predictive (MAP) analysis", + caption = "Plot shows point estimates (posterior medians) with 95% intervals" + ) ``` We also recommend saving plots explicitly with the `ggsave` function, @@ -117,8 +120,8 @@ pleasing axis ratio. Png is the recommended image file type for presentations and study documents. ```{r, eval=FALSE} -ggsave("plot1.png", last_plot(), width=1.62*2.78, height=2.78, unit="in") # too small for the chosen font size -ggsave("plot2.png", last_plot(), width=1.62*5.56, height=5.56, unit="in") # fits a single ppt slide quite well +ggsave("plot1.png", last_plot(), width = 1.62 * 2.78, height = 2.78, unit = "in") # too small for the chosen font size +ggsave("plot2.png", last_plot(), width = 1.62 * 5.56, height = 5.56, unit = "in") # fits a single ppt slide quite well ``` # Advanced topics @@ -132,8 +135,8 @@ this object and create a graph from scratch using `ggplot` functions. Recall the original forest plot: ```{r, echo=FALSE} -theme_set(theme_default(base_size=12)) -forest_plot(map_crohn) + labs(title="Original forest plot") +theme_set(theme_default(base_size = 12)) +forest_plot(map_crohn) + labs(title = "Original forest plot") ``` Suppose we wish to use different symbols for the meta/stratified point @@ -143,15 +146,17 @@ plot can be created as follows. ```{r} # Extract the data from the returned object fp_data <- forest_plot(map_crohn)$data -print(fp_data, digits=2) +print(fp_data, digits = 2) # Use a two-component map mixture to compute the vertical line location -map_mix <- mixfit(map_crohn, Nc=2) +map_mix <- mixfit(map_crohn, Nc = 2) # Finally compose a ggplot call for the desired graph -ggplot(fp_data, aes(x=study, y=median, ymin=low, ymax=up, linetype=model, shape=model)) + - geom_pointrange(size=0.7, position=position_dodge(width=0.5)) + - geom_hline(yintercept=qmix(map_mix, 0.5), linetype=3, alpha=0.5) + - coord_flip() + theme_bw(base_size=12) + theme(legend.position="None") + - labs(x="", y="Response", title="Modified forest plot") +ggplot(fp_data, aes(x = study, y = median, ymin = low, ymax = up, linetype = model, shape = model)) + + geom_pointrange(size = 0.7, position = position_dodge(width = 0.5)) + + geom_hline(yintercept = qmix(map_mix, 0.5), linetype = 3, alpha = 0.5) + + coord_flip() + + theme_bw(base_size = 12) + + theme(legend.position = "None") + + labs(x = "", y = "Response", title = "Modified forest plot") ``` ## Design plots a clinical trial @@ -179,36 +184,38 @@ combination of outcomes on the two treatment arms. ```{r} # Define prior distributions -prior_pbo <- mixbeta(inf1=c(0.60, 19, 29), inf2=c(0.30, 4, 5), rob=c(0.10, 1, 1)) -prior_trt <- mixbeta(c(1, 1/3, 1/3)) +prior_pbo <- mixbeta(inf1 = c(0.60, 19, 29), inf2 = c(0.30, 4, 5), rob = c(0.10, 1, 1)) +prior_trt <- mixbeta(c(1, 1 / 3, 1 / 3)) # Study sample size n_trt <- 50 n_pbo <- 20 # Create decision rules and designs to represent success and futility -success <- decision2S(pc=c(0.90, 0.50), qc=c(log(1), log(0.50)), lower.tail=TRUE, link="log") -futility <- decision2S(pc=c(0.10, 0.50), qc=c(log(1), log(0.50)), lower.tail=FALSE, link="log") +success <- decision2S(pc = c(0.90, 0.50), qc = c(log(1), log(0.50)), lower.tail = TRUE, link = "log") +futility <- decision2S(pc = c(0.10, 0.50), qc = c(log(1), log(0.50)), lower.tail = FALSE, link = "log") design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success) design_fut <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, futility) crit_suc <- decision2S_boundary(prior_trt, prior_pbo, n_trt, n_pbo, success) crit_fut <- decision2S_boundary(prior_trt, prior_pbo, n_trt, n_pbo, futility) -# Create a data frame that holds the outcomes for y1 (treatment) that define success and futility, +# Create a data frame that holds the outcomes for y1 (treatment) that define success and futility, # conditional on the number of events on y2 (placebo) -outcomes <- data.frame(y2=c(0:n_pbo), suc=crit_suc(0:n_pbo), fut=crit_fut(0:n_pbo), max=n_trt) -outcomes$suc <- with(outcomes, ifelse(suc<0, 0, suc)) # don't allow negative number of events +outcomes <- data.frame(y2 = c(0:n_pbo), suc = crit_suc(0:n_pbo), fut = crit_fut(0:n_pbo), max = n_trt) +outcomes$suc <- with(outcomes, ifelse(suc < 0, 0, suc)) # don't allow negative number of events -# Finally put it all together in a plot. +# Finally put it all together in a plot. o <- 0.5 # offset -ggplot(outcomes, aes(x=y2, ymin=-o, ymax=suc+o)) + geom_linerange(size=4, colour="green", alpha=0.6) + - geom_linerange(aes(ymin=suc+o, ymax=fut+o), colour="orange", size=4, alpha=0.6) + - geom_linerange(aes(ymin=fut+o, ymax=max+o), colour="red", size=4, alpha=0.6) + - annotate("text", x=c(2,14), y=c(36,8), label=c("STOP", "GO"), size=10) + - scale_x_continuous(breaks=seq(0,n_pbo,by=2)) + - scale_y_continuous(breaks=seq(0,n_trt,by=4)) + - labs(x="Events on placebo", y="Events on treatment", title="Study outcomes") + - coord_flip() + theme_bw(base_size=12) +ggplot(outcomes, aes(x = y2, ymin = -o, ymax = suc + o)) + + geom_linerange(size = 4, colour = "green", alpha = 0.6) + + geom_linerange(aes(ymin = suc + o, ymax = fut + o), colour = "orange", size = 4, alpha = 0.6) + + geom_linerange(aes(ymin = fut + o, ymax = max + o), colour = "red", size = 4, alpha = 0.6) + + annotate("text", x = c(2, 14), y = c(36, 8), label = c("STOP", "GO"), size = 10) + + scale_x_continuous(breaks = seq(0, n_pbo, by = 2)) + + scale_y_continuous(breaks = seq(0, n_trt, by = 4)) + + labs(x = "Events on placebo", y = "Events on treatment", title = "Study outcomes") + + coord_flip() + + theme_bw(base_size = 12) ``` We can also use the design functions that were already derived @@ -216,30 +223,31 @@ We can also use the design functions that were already derived ```{r, fig.width=8.5, fig.height=5.5} # Define the grid of true event rates for which to evaluate OC -p_trt <- seq(0, 0.5, length=200) +p_trt <- seq(0, 0.5, length = 200) p_pbo <- c(0.35, 0.40, 0.45, 0.50) -# Loop through the values for placebo and compute outcome probabilities +# Loop through the values for placebo and compute outcome probabilities oc_list <- lapply(p_pbo, function(x) { p_go <- design_suc(p_trt, x) p_stop <- design_fut(p_trt, x) - data.frame(p_trt, p_pbo=x, Go=p_go, Stop=p_stop, Indeterminate=1-p_go-p_stop) + data.frame(p_trt, p_pbo = x, Go = p_go, Stop = p_stop, Indeterminate = 1 - p_go - p_stop) }) # The above returns a list, so we bind the elements together into one data frame -oc <- bind_rows(oc_list) +oc <- bind_rows(oc_list) # And convert from wide to long format oc <- gather(oc, "Outcome", "Probability", 3:5) -oc$facet_text <- as.factor(paste("True placebo rate = ", oc$p_pbo, sep="")) +oc$facet_text <- as.factor(paste("True placebo rate = ", oc$p_pbo, sep = "")) # Finally we are ready to plot -ggplot(oc, aes(x=p_trt, y=Probability, colour=Outcome, linetype=Outcome)) + - facet_wrap(~facet_text) + geom_line(size=1) + - scale_colour_manual(values=c("green", "orange", "red"), name="Outcome") + - scale_linetype(guide=FALSE) + - geom_hline(yintercept=c(0.1, 0.8), linetype=3) + - scale_y_continuous(breaks=seq(0, 1, by=0.2)) + - labs(x="True event rate for treatment", y="Probability", title="Operating Characteristics") + - theme_bw(base_size=12) +ggplot(oc, aes(x = p_trt, y = Probability, colour = Outcome, linetype = Outcome)) + + facet_wrap(~facet_text) + + geom_line(size = 1) + + scale_colour_manual(values = c("green", "orange", "red"), name = "Outcome") + + scale_linetype(guide = FALSE) + + geom_hline(yintercept = c(0.1, 0.8), linetype = 3) + + scale_y_continuous(breaks = seq(0, 1, by = 0.2)) + + labs(x = "True event rate for treatment", y = "Probability", title = "Operating Characteristics") + + theme_bw(base_size = 12) ``` ```{r} diff --git a/vignettes/articles/introduction_normal.Rmd b/vignettes/articles/introduction_normal.Rmd index b102d97..c085c70 100644 --- a/vignettes/articles/introduction_normal.Rmd +++ b/vignettes/articles/introduction_normal.Rmd @@ -45,11 +45,11 @@ standard errors of the effect estimates. ```{r data} dat <- crohn crohn_sigma <- 88 -dat$y.se <- crohn_sigma/sqrt(dat$n) +dat$y.se <- crohn_sigma / sqrt(dat$n) ``` ```{r dataprint,results="asis",echo=FALSE} -kable(dat, digits=2) +kable(dat, digits = 2) ``` @@ -72,11 +72,12 @@ exactly reproducible. ```{r gMAP} library(RBesT) set.seed(689654) -map_mcmc <- gMAP(cbind(y, y.se) ~ 1 | study, - weights=n,data=dat, - family=gaussian, - beta.prior=cbind(0, crohn_sigma), - tau.dist="HalfNormal",tau.prior=cbind(0,crohn_sigma/2)) +map_mcmc <- gMAP(cbind(y, y.se) ~ 1 | study, + weights = n, data = dat, + family = gaussian, + beta.prior = cbind(0, crohn_sigma), + tau.dist = "HalfNormal", tau.prior = cbind(0, crohn_sigma / 2) +) print(map_mcmc) ## a graphical representation is also available @@ -120,9 +121,9 @@ conservative moment-based ESS of 20 was used to reduce the planned sample size of the control group. ```{r ESS} -round(ess(map)) ## default elir method -round(ess(map, method="morita")) -round(ess(map, method="moment")) +round(ess(map)) ## default elir method +round(ess(map, method = "morita")) +round(ess(map, method = "moment")) ``` ## Robustification of MAP Prior @@ -142,9 +143,9 @@ decreases the ESS. ```{r ROBUST} ## add a 20% non-informative mixture component -map_robust <- robustify(map, weight=0.2, mean=-50) +map_robust <- robustify(map, weight = 0.2, mean = -50) print(map_robust) -round(ess(map_robust)) +round(ess(map_robust)) ``` @@ -181,7 +182,7 @@ change from baseline in CDAI corresponds to improvement. ```{r rules} ## dual decision criteria ## pay attention to "lower.tail" argument and the order of active and pbo -poc <- decision2S(pc=c(0.95,0.5), qc=c(0,-50), lower.tail=TRUE) +poc <- decision2S(pc = c(0.95, 0.5), qc = c(0, -50), lower.tail = TRUE) print(poc) ``` @@ -194,21 +195,25 @@ choices of control prior and different sizes of control group. ```{r design_options} ## set up prior for active group -weak_prior <- mixnorm(c(1,-50,1), sigma=crohn_sigma, param = 'mn') +weak_prior <- mixnorm(c(1, -50, 1), sigma = crohn_sigma, param = "mn") n_act <- 40 n_pbo <- 20 ## four designs ## "b" means a balanced design, 1:1 ## "ub" means 40 in active and 20 in placebo -design_noprior_b <- oc2S(weak_prior, weak_prior, n_act, n_act, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) +design_noprior_b <- oc2S(weak_prior, weak_prior, n_act, n_act, poc, + sigma1 = crohn_sigma, sigma2 = crohn_sigma +) design_noprior_ub <- oc2S(weak_prior, weak_prior, n_act, n_pbo, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) -design_nonrob_ub <- oc2S(weak_prior, map, n_act, n_pbo, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) -design_rob_ub <- oc2S(weak_prior, map_robust, n_act, n_pbo, poc, - sigma1=crohn_sigma, sigma2=crohn_sigma) + sigma1 = crohn_sigma, sigma2 = crohn_sigma +) +design_nonrob_ub <- oc2S(weak_prior, map, n_act, n_pbo, poc, + sigma1 = crohn_sigma, sigma2 = crohn_sigma +) +design_rob_ub <- oc2S(weak_prior, map_robust, n_act, n_pbo, poc, + sigma1 = crohn_sigma, sigma2 = crohn_sigma +) ``` @@ -221,29 +226,38 @@ case to a lower level. ```{r typeI} # the range for true values -cfb_truth <- seq(-120, -40, by=1) +cfb_truth <- seq(-120, -40, by = 1) typeI1 <- design_noprior_b(cfb_truth, cfb_truth) typeI2 <- design_noprior_ub(cfb_truth, cfb_truth) typeI3 <- design_nonrob_ub(cfb_truth, cfb_truth) typeI4 <- design_rob_ub(cfb_truth, cfb_truth) -ocI <- rbind(data.frame(cfb_truth=cfb_truth, typeI=typeI1, - design="40:40 with non-informative priors"), - data.frame(cfb_truth=cfb_truth, typeI=typeI2, - design="40:20 with non-informative priors"), - data.frame(cfb_truth=cfb_truth, typeI=typeI3, - design="40:20 with non-robust prior for placebo"), - data.frame(cfb_truth=cfb_truth, typeI=typeI4, - design="40:20 with robust prior for placebo") +ocI <- rbind( + data.frame( + cfb_truth = cfb_truth, typeI = typeI1, + design = "40:40 with non-informative priors" + ), + data.frame( + cfb_truth = cfb_truth, typeI = typeI2, + design = "40:20 with non-informative priors" + ), + data.frame( + cfb_truth = cfb_truth, typeI = typeI3, + design = "40:20 with non-robust prior for placebo" + ), + data.frame( + cfb_truth = cfb_truth, typeI = typeI4, + design = "40:20 with robust prior for placebo" + ) ) -ggplot(ocI, aes(cfb_truth, typeI, colour=design)) + - geom_line() + - ggtitle("Type I Error") + - xlab(expression(paste('True value of change from baseline ', mu[act] == mu[pbo]))) + - ylab('Type I error') + - coord_cartesian(ylim=c(0,0.2)) + - theme(legend.justification=c(1,1),legend.position=c(0.95,0.85)) +ggplot(ocI, aes(cfb_truth, typeI, colour = design)) + + geom_line() + + ggtitle("Type I Error") + + xlab(expression(paste("True value of change from baseline ", mu[act] == mu[pbo]))) + + ylab("Type I error") + + coord_cartesian(ylim = c(0, 0.2)) + + theme(legend.justification = c(1, 1), legend.position = c(0.95, 0.85)) ``` @@ -255,38 +269,49 @@ with weakly informative priors for both arms or the balanced design. ```{r power} -delta <- seq(-80,0,by=1) +delta <- seq(-80, 0, by = 1) m <- summary(map)["mean"] -cfb_truth1 <- m + delta # active for 1 -cfb_truth2 <- m + 0*delta # pbo for 2 +cfb_truth1 <- m + delta # active for 1 +cfb_truth2 <- m + 0 * delta # pbo for 2 power1 <- design_noprior_b(cfb_truth1, cfb_truth2) power2 <- design_noprior_ub(cfb_truth1, cfb_truth2) power3 <- design_nonrob_ub(cfb_truth1, cfb_truth2) power4 <- design_rob_ub(cfb_truth1, cfb_truth2) -ocP <- rbind(data.frame(cfb_truth1=cfb_truth1, cfb_truth2=cfb_truth2, - delta=delta, power=power1, - design="40:40 with non-informative priors"), - data.frame(cfb_truth1=cfb_truth1, cfb_truth2=cfb_truth2, - delta=delta, power=power2, - design="40:20 with non-informative priors"), - data.frame(cfb_truth1=cfb_truth1, cfb_truth2=cfb_truth2, - delta=delta, power=power3, - design="40:20 with non-robust prior for placebo"), - data.frame(cfb_truth1=cfb_truth1, cfb_truth2=cfb_truth2, - delta=delta, power=power4, - design="40:20 with robust prior for placebo")) - -ggplot(ocP, aes(delta, power, colour=design)) + - geom_line() + - ggtitle("Power") + - xlab('True value of difference (act - pbo)')+ ylab('Power') + - scale_y_continuous(breaks=c(seq(0,1,0.2),0.9)) + - scale_x_continuous(breaks=c(seq(-80,0,20),-70)) + - geom_hline(yintercept=0.9,linetype=2) + - geom_vline(xintercept=-70,linetype=2) + - theme(legend.justification=c(1,1),legend.position=c(0.95,0.85)) +ocP <- rbind( + data.frame( + cfb_truth1 = cfb_truth1, cfb_truth2 = cfb_truth2, + delta = delta, power = power1, + design = "40:40 with non-informative priors" + ), + data.frame( + cfb_truth1 = cfb_truth1, cfb_truth2 = cfb_truth2, + delta = delta, power = power2, + design = "40:20 with non-informative priors" + ), + data.frame( + cfb_truth1 = cfb_truth1, cfb_truth2 = cfb_truth2, + delta = delta, power = power3, + design = "40:20 with non-robust prior for placebo" + ), + data.frame( + cfb_truth1 = cfb_truth1, cfb_truth2 = cfb_truth2, + delta = delta, power = power4, + design = "40:20 with robust prior for placebo" + ) +) + +ggplot(ocP, aes(delta, power, colour = design)) + + geom_line() + + ggtitle("Power") + + xlab("True value of difference (act - pbo)") + + ylab("Power") + + scale_y_continuous(breaks = c(seq(0, 1, 0.2), 0.9)) + + scale_x_continuous(breaks = c(seq(-80, 0, 20), -70)) + + geom_hline(yintercept = 0.9, linetype = 2) + + geom_vline(xintercept = -70, linetype = 2) + + theme(legend.justification = c(1, 1), legend.position = c(0.95, 0.85)) ``` @@ -310,19 +335,20 @@ y.pbo.se <- 13.9 n.pbo <- 20 ## first obtain posterior distributions -post_act <- postmix(weak_prior, m=y.act, se=y.act.se) -post_pbo <- postmix(map_robust, m=y.pbo, se=y.pbo.se) +post_act <- postmix(weak_prior, m = y.act, se = y.act.se) +post_pbo <- postmix(map_robust, m = y.pbo, se = y.pbo.se) ## then calculate probability for the dual criteria ## and compare to the predefined threshold values -p1 <- pmixdiff(post_act, post_pbo, 0); print(p1) -p2 <- pmixdiff(post_act, post_pbo, -50); print(p2) +p1 <- pmixdiff(post_act, post_pbo, 0) +print(p1) +p2 <- pmixdiff(post_act, post_pbo, -50) +print(p2) -print(p1>0.95 & p2>0.5) +print(p1 > 0.95 & p2 > 0.5) ## or we can use the decision function poc(post_act, post_pbo) - ``` ### References diff --git a/vignettes/articles/variances_MAP.Rmd b/vignettes/articles/variances_MAP.Rmd index a166226..4ba0d8e 100644 --- a/vignettes/articles/variances_MAP.Rmd +++ b/vignettes/articles/variances_MAP.Rmd @@ -69,11 +69,12 @@ In the following we reanalyze the main example of reference [1] which is shown in table 2: ```{r,results="asis",echo=FALSE} -hdata <- data.frame(study=1:6, - sd=c(12.11, 10.97, 10.94, 9.41, 10.97, 10.95), - df=c(597, 60, 548, 307, 906, 903) - ) -kable(hdata, digits=2) +hdata <- data.frame( + study = 1:6, + sd = c(12.11, 10.97, 10.94, 9.41, 10.97, 10.95), + df = c(597, 60, 548, 307, 906, 903) +) +kable(hdata, digits = 2) ``` Using the above equations (and using plug-in estimates for $\sigma_j$) @@ -82,14 +83,15 @@ variance as: ```{r} hdata <- mutate(hdata, - alpha=df/2, - beta=alpha/sd^2, - logvar_mean=log(sd^2 * alpha) - digamma(alpha), - logvar_var=psigamma(alpha,1)) + alpha = df / 2, + beta = alpha / sd^2, + logvar_mean = log(sd^2 * alpha) - digamma(alpha), + logvar_var = psigamma(alpha, 1) +) ``` ```{r,results="asis",echo=FALSE} -kable(hdata, digits=4) +kable(hdata, digits = 4) ``` @@ -104,9 +106,11 @@ case. For the intercept $\beta$ a very wide prior is used with a standard deviation of $100$ which is in line with reference [1]: ```{r} -map_mc <- gMAP(cbind(logvar_mean, sqrt(logvar_var)) ~ 1 | study, data=hdata, - tau.dist="HalfNormal", tau.prior=sqrt(2)/2, - beta.prior=cbind(4.8, 100)) +map_mc <- gMAP(cbind(logvar_mean, sqrt(logvar_var)) ~ 1 | study, + data = hdata, + tau.dist = "HalfNormal", tau.prior = sqrt(2) / 2, + beta.prior = cbind(4.8, 100) +) map_mc @@ -133,10 +137,10 @@ using `RBesT` as: ```{r} map_mc_post <- as.matrix(map_mc) sd_trans <- compose(sqrt, exp) -mcmc_intervals(map_mc_post, regex_pars="theta", transformation=sd_trans) +mcmc_intervals(map_mc_post, regex_pars = "theta", transformation = sd_trans) -map_sigma_mc <- sd_trans(map_mc_post[,c("theta_pred")]) -map_sigma <- automixfit(map_sigma_mc, type="gamma") +map_sigma_mc <- sd_trans(map_mc_post[, c("theta_pred")]) +map_sigma <- automixfit(map_sigma_mc, type = "gamma") plot(map_sigma)$mix @@ -166,27 +170,26 @@ A short simulation demonstrates the above results: gamma_dist <- mixgamma(c(1, 18, 6)) ## logGamma density -dlogGamma <- function(z, a, b, log=FALSE) { - n <- exp(z) - if(!log) { - return(dgamma(n, a, b) * n) - } else { - return(dgamma(n, a, b, log=TRUE) + z) - } +dlogGamma <- function(z, a, b, log = FALSE) { + n <- exp(z) + if (!log) { + return(dgamma(n, a, b) * n) + } else { + return(dgamma(n, a, b, log = TRUE) + z) + } } -a <- gamma_dist[2,1] -b <- gamma_dist[3,1] +a <- gamma_dist[2, 1] +b <- gamma_dist[3, 1] m <- digamma(a) - log(b) -v <- psigamma(a,1) +v <- psigamma(a, 1) ## compare simulated histogram of log transformed Gamma variates to ## analytic density and approximate normal sim <- rmix(gamma_dist, 1E5) -mcmc_hist(data.frame(logGamma=log(sim)), freq=FALSE, binwidth=0.1) + - overlay_function(fun=dlogGamma, args=list(a=a,b=b), aes(linetype="LogGamma")) + - overlay_function(fun=dnorm, args=list(mean=m, sd=sqrt(v)), aes(linetype="NormalApprox")) - +mcmc_hist(data.frame(logGamma = log(sim)), freq = FALSE, binwidth = 0.1) + + overlay_function(fun = dlogGamma, args = list(a = a, b = b), aes(linetype = "LogGamma")) + + overlay_function(fun = dnorm, args = list(mean = m, sd = sqrt(v)), aes(linetype = "NormalApprox")) ``` We see that for $\nu=9$ only, the approximation with a normal density @@ -200,51 +203,51 @@ for two different $\sigma$ values: ```{r,echo=FALSE} qgammaLog <- function(p, a, b) { - log(qgamma(p, a, b)) + log(qgamma(p, a, b)) } VqgammaLog <- Vectorize(qgammaLog) var2gamma <- function(nu, sigma) { - c(a=nu/2, b=nu/(2*sigma^2)) + c(a = nu / 2, b = nu / (2 * sigma^2)) } var2logNormal <- function(nu, sigma) { - gamma <- var2gamma(nu, sigma) - res <- c(mu=digamma(gamma["a"]) - log(gamma["b"]), sigma=sqrt(psigamma(gamma["a"],1))) - names(res) <- c("mu", "sigma") - res + gamma <- var2gamma(nu, sigma) + res <- c(mu = digamma(gamma["a"]) - log(gamma["b"]), sigma = sqrt(psigamma(gamma["a"], 1))) + names(res) <- c("mu", "sigma") + res } -dlogvar <- function(z, nu, sigma, log=FALSE) { - ga <- var2gamma(nu, sigma) - dlogGamma(z, ga["a"], ga["b"], log=log) +dlogvar <- function(z, nu, sigma, log = FALSE) { + ga <- var2gamma(nu, sigma) + dlogGamma(z, ga["a"], ga["b"], log = log) } qlogvar <- function(p, nu, sigma) { - ga <- var2gamma(nu, sigma) - VqgammaLog(p, ga["a"], ga["b"]) + ga <- var2gamma(nu, sigma) + VqgammaLog(p, ga["a"], ga["b"]) } Vqlogvar <- Vectorize(qlogvar) qlogvarApprox <- function(p, nu, sigma) { - ga <- var2logNormal(nu, sigma) - qnorm(p, ga["mu"], ga["sigma"]) + ga <- var2logNormal(nu, sigma) + qnorm(p, ga["mu"], ga["sigma"]) } VqlogvarApprox <- Vectorize(qlogvarApprox) compare_quantiles <- function(nuLow, nuHigh, sigma, quants) { - q1 <- quants[1] - yv <- c(Vqlogvar(quants, nuHigh, sigma), Vqlogvar(quants, nuLow, sigma)) - ymax <- max(yv) - ymin <- min(yv) - qtext <- paste("quantiles:", paste(quants, collapse=", ")) - curve(Vqlogvar(q1, x, sigma), nuLow, nuHigh, ylim=c(ymin, ymax), ylab="log(sigma^2)", xlab="Sample Size nu") - curve(VqlogvarApprox(q1, x, sigma), add=TRUE, lty=2) - for(q in quants[-1]) { - curve(Vqlogvar(q, x, sigma), add=TRUE) - curve(VqlogvarApprox(q, x, sigma), add=TRUE, lty=2) - } - title(paste0("Log-Gamma (solid) vs Normal Approx (dashed)\nsigma=", sigma, "; ", qtext)) + q1 <- quants[1] + yv <- c(Vqlogvar(quants, nuHigh, sigma), Vqlogvar(quants, nuLow, sigma)) + ymax <- max(yv) + ymin <- min(yv) + qtext <- paste("quantiles:", paste(quants, collapse = ", ")) + curve(Vqlogvar(q1, x, sigma), nuLow, nuHigh, ylim = c(ymin, ymax), ylab = "log(sigma^2)", xlab = "Sample Size nu") + curve(VqlogvarApprox(q1, x, sigma), add = TRUE, lty = 2) + for (q in quants[-1]) { + curve(Vqlogvar(q, x, sigma), add = TRUE) + curve(VqlogvarApprox(q, x, sigma), add = TRUE, lty = 2) + } + title(paste0("Log-Gamma (solid) vs Normal Approx (dashed)\nsigma=", sigma, "; ", qtext)) } compare_quantiles(10, 100, 1, c(0.025, 0.5, 0.975)) @@ -253,28 +256,30 @@ compare_quantiles(10, 100, 10, c(0.025, 0.5, 0.975)) ## calculate the KL distance of the approximation to the exact ## distribution using quadrature integration kl_distance <- function(nu, sigma) { - ln <- var2logNormal(nu, sigma) - ga <- var2gamma(nu, sigma) - lims <- log(qgamma(c(1E-5, 1-1E-5), ga["a"], ga["b"])) - kl <- integrate(function(z) dlogvar(z, nu, sigma) * (dlogvar(z, nu, sigma, log=TRUE) - dnorm(z, ln["mu"], ln["sigma"], log=TRUE)), lims[1], lims[2])$value - ## this transform is needed to let the scale represent in a - ## physical sense distance, see PC priors paper from Daniel - ## Simpson et al. - sqrt(2 * kl) + ln <- var2logNormal(nu, sigma) + ga <- var2gamma(nu, sigma) + lims <- log(qgamma(c(1E-5, 1 - 1E-5), ga["a"], ga["b"])) + kl <- integrate(function(z) dlogvar(z, nu, sigma) * (dlogvar(z, nu, sigma, log = TRUE) - dnorm(z, ln["mu"], ln["sigma"], log = TRUE)), lims[1], lims[2])$value + ## this transform is needed to let the scale represent in a + ## physical sense distance, see PC priors paper from Daniel + ## Simpson et al. + sqrt(2 * kl) } Vkl_distance <- Vectorize(kl_distance) compare_densities <- function(nu, sigma) { - ln <- var2logNormal(nu, sigma) - low <- qnorm(1E-5, ln["mu"], ln["sigma"]) - high <- qnorm(1-1E-5, ln["mu"], ln["sigma"]) - ##curve(dlogvar(x, nu, sigma), low, high, axes=FALSE, frame.plot=TRUE, xlab="", ylab="", xaxt='n', yaxt='n') - ##curve(dnorm(x, ln["mu"], ln["sigma"]), add=TRUE, lty=2) - ##title(paste0("LogGamma (solid) vs Normal Approx (dashed)\nsigma=", sigma, ", nu=", nu)) - ggplot(data.frame(x=c(low,high)), aes(x)) + - stat_function(fun=dlogvar, args=list(nu=nu, sigma=sigma), linetype=1) + - stat_function(fun=dnorm, args=list(mean=ln["mu"], sd=ln["sigma"]), linetype=2) + - ggtitle(paste0("sigma=", sigma, ", nu=", nu), "Log-Gamma (solid) vs Normal Approx (dashed)") + xlab(NULL) + ylab(NULL) + ln <- var2logNormal(nu, sigma) + low <- qnorm(1E-5, ln["mu"], ln["sigma"]) + high <- qnorm(1 - 1E-5, ln["mu"], ln["sigma"]) + ## curve(dlogvar(x, nu, sigma), low, high, axes=FALSE, frame.plot=TRUE, xlab="", ylab="", xaxt='n', yaxt='n') + ## curve(dnorm(x, ln["mu"], ln["sigma"]), add=TRUE, lty=2) + ## title(paste0("LogGamma (solid) vs Normal Approx (dashed)\nsigma=", sigma, ", nu=", nu)) + ggplot(data.frame(x = c(low, high)), aes(x)) + + stat_function(fun = dlogvar, args = list(nu = nu, sigma = sigma), linetype = 1) + + stat_function(fun = dnorm, args = list(mean = ln["mu"], sd = ln["sigma"]), linetype = 2) + + ggtitle(paste0("sigma=", sigma, ", nu=", nu), "Log-Gamma (solid) vs Normal Approx (dashed)") + + xlab(NULL) + + ylab(NULL) } @@ -284,12 +289,11 @@ pl3 <- compare_densities(10, 10) pl4 <- compare_densities(20, 10) bayesplot_grid(pl1, pl2, pl3, pl4) -ggplot(data.frame(nu=c(10, 100)), aes(nu)) + - stat_function(fun=Vkl_distance, args=list(sigma=1)) + - ylab("KLD(LogGamma||NormalApprox)") + - ggtitle("KL Distance of approximate to exact distribution") + - scale_y_continuous(breaks=seq(0.05,0.25,by=0.025)) - +ggplot(data.frame(nu = c(10, 100)), aes(nu)) + + stat_function(fun = Vkl_distance, args = list(sigma = 1)) + + ylab("KLD(LogGamma||NormalApprox)") + + ggtitle("KL Distance of approximate to exact distribution") + + scale_y_continuous(breaks = seq(0.05, 0.25, by = 0.025)) ``` ## Acknowledgements diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 5e6cbf9..ec64138 100644 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -107,12 +107,13 @@ library(ggplot2) theme_set(theme_bw()) # sets up plotting theme set.seed(34563) -map_mcmc <- gMAP(cbind(r, n-r) ~ 1 | study, - data=AS, - tau.dist="HalfNormal", - tau.prior=1, - beta.prior=2, - family=binomial) +map_mcmc <- gMAP(cbind(r, n - r) ~ 1 | study, + data = AS, + tau.dist = "HalfNormal", + tau.prior = 1, + beta.prior = 2, + family = binomial +) print(map_mcmc) ## a graphical representation of model checks is available @@ -135,7 +136,7 @@ arguments of **`gMAP`**: ```{r} set.seed(36546) -map_mcmc_sens <- update(map_mcmc, tau.prior=1/2) +map_mcmc_sens <- update(map_mcmc, tau.prior = 1 / 2) print(map_mcmc_sens) ``` @@ -172,9 +173,9 @@ approach leads to conservative (small) ESS estimates while the Morita with mixtures: ```{r} -round(ess(map, method="elir")) ## default method -round(ess(map, method="moment")) -round(ess(map, method="morita")) +round(ess(map, method = "elir")) ## default method +round(ess(map, method = "moment")) +round(ess(map, method = "morita")) ``` The Morita approach uses the curvature of the prior at the mode and has been found to be sensitive to a large number of mixture @@ -190,7 +191,7 @@ i.e. if the future trial data strongly deviate from the historical control information. ```{r} ## add a 20% non-informative mixture component -map_robust <- robustify(map, weight=0.2, mean=1/2) +map_robust <- robustify(map, weight = 0.2, mean = 1 / 2) print(map_robust) round(ess(map_robust)) @@ -206,18 +207,24 @@ helpful to graphically illustrate the relationship of the prior ESS as a function of the robust mixture component weight: ```{r} -ess_weight <- data.frame(weight=seq(0.05, 0.95, by=0.05), ess=NA) -for(i in seq_along(ess_weight$weight)) { - ess_weight$ess[i] <- ess(robustify(map, ess_weight$weight[i], 0.5)) +ess_weight <- data.frame(weight = seq(0.05, 0.95, by = 0.05), ess = NA) +for (i in seq_along(ess_weight$weight)) { + ess_weight$ess[i] <- ess(robustify(map, ess_weight$weight[i], 0.5)) } -ess_weight <- rbind(ess_weight, - data.frame(weight=c(0, 1), - ess=c(ess(map), ess(mixbeta(c(1,1,1)))))) - -ggplot(ess_weight, aes(weight, ess)) + geom_point() + geom_line() + - ggtitle("ESS of robust MAP for varying weight of robust component") + - scale_x_continuous(breaks=seq(0, 1, by=0.1)) + - scale_y_continuous(breaks=seq(0, 40, by=5)) +ess_weight <- rbind( + ess_weight, + data.frame( + weight = c(0, 1), + ess = c(ess(map), ess(mixbeta(c(1, 1, 1)))) + ) +) + +ggplot(ess_weight, aes(weight, ess)) + + geom_point() + + geom_line() + + ggtitle("ESS of robust MAP for varying weight of robust component") + + scale_x_continuous(breaks = seq(0, 1, by = 0.1)) + + scale_y_continuous(breaks = seq(0, 40, by = 5)) ``` # Design Evaluation @@ -268,29 +275,32 @@ case of a conflict between the trial data and the prior. Note, that in this example the MAP prior has a 95% interval of about 0.1 to 0.5. ```{r} -theta <- seq(0.1,0.95,by=0.01) -uniform_prior <- mixbeta(c(1,1,1)) -treat_prior <- mixbeta(c(1,0.5,1)) # prior for treatment used in trial -lancet_prior <- mixbeta(c(1,11,32)) # prior for control used in trial -decision <- decision2S(0.95, 0, lower.tail=FALSE) - -design_uniform <- oc2S(uniform_prior, uniform_prior, 24, 6, decision) -design_classic <- oc2S(uniform_prior, uniform_prior, 24, 24, decision) -design_nonrobust <- oc2S(treat_prior, map , 24, 6, decision) -design_robust <- oc2S(treat_prior, map_robust , 24, 6, decision) - -typeI_uniform <- design_uniform( theta, theta) -typeI_classic <- design_classic( theta, theta) +theta <- seq(0.1, 0.95, by = 0.01) +uniform_prior <- mixbeta(c(1, 1, 1)) +treat_prior <- mixbeta(c(1, 0.5, 1)) # prior for treatment used in trial +lancet_prior <- mixbeta(c(1, 11, 32)) # prior for control used in trial +decision <- decision2S(0.95, 0, lower.tail = FALSE) + +design_uniform <- oc2S(uniform_prior, uniform_prior, 24, 6, decision) +design_classic <- oc2S(uniform_prior, uniform_prior, 24, 24, decision) +design_nonrobust <- oc2S(treat_prior, map, 24, 6, decision) +design_robust <- oc2S(treat_prior, map_robust, 24, 6, decision) + +typeI_uniform <- design_uniform(theta, theta) +typeI_classic <- design_classic(theta, theta) typeI_nonrobust <- design_nonrobust(theta, theta) -typeI_robust <- design_robust( theta, theta) - -ocI <- rbind(data.frame(theta=theta, typeI=typeI_robust, prior="robust"), - data.frame(theta=theta, typeI=typeI_nonrobust, prior="non-robust"), - data.frame(theta=theta, typeI=typeI_uniform, prior="uniform"), - data.frame(theta=theta, typeI=typeI_classic, prior="uniform 24:24") - ) - -ggplot(ocI, aes(theta, typeI, colour=prior)) + geom_line() + ggtitle("Type I Error") +typeI_robust <- design_robust(theta, theta) + +ocI <- rbind( + data.frame(theta = theta, typeI = typeI_robust, prior = "robust"), + data.frame(theta = theta, typeI = typeI_nonrobust, prior = "non-robust"), + data.frame(theta = theta, typeI = typeI_uniform, prior = "uniform"), + data.frame(theta = theta, typeI = typeI_classic, prior = "uniform 24:24") +) + +ggplot(ocI, aes(theta, typeI, colour = prior)) + + geom_line() + + ggtitle("Type I Error") ``` Note that observing response rates greater that 50% is highly @@ -304,9 +314,10 @@ Hence, it is resonable to restrict the response rates $\theta$ for which we evaluate the type I error to a a range of plausible values: ```{r} -ggplot(ocI, aes(theta, typeI, colour=prior)) + geom_line() + - ggtitle("Type I Error - response rate restricted to plausible range") + - coord_cartesian(xlim=c(0, 0.5)) +ggplot(ocI, aes(theta, typeI, colour = prior)) + + geom_line() + + ggtitle("Type I Error - response rate restricted to plausible range") + + coord_cartesian(xlim = c(0, 0.5)) ``` ### Power @@ -316,25 +327,26 @@ i.e. 80% power is reached for smaller $\delta$ values in comparison to a design with non-informative priors for both arms. ```{r} -delta <- seq(0,0.7,by=0.01) +delta <- seq(0, 0.7, by = 0.01) mean_control <- summary(map)["mean"] -theta_active <- mean_control + delta -theta_control <- mean_control + 0*delta +theta_active <- mean_control + delta +theta_control <- mean_control + 0 * delta -power_uniform <- design_uniform( theta_active, theta_control) -power_classic <- design_classic( theta_active, theta_control) +power_uniform <- design_uniform(theta_active, theta_control) +power_classic <- design_classic(theta_active, theta_control) power_nonrobust <- design_nonrobust(theta_active, theta_control) -power_robust <- design_robust( theta_active, theta_control) - -ocP <- rbind(data.frame(theta_active, theta_control, delta=delta, power=power_robust, prior="robust"), - data.frame(theta_active, theta_control, delta=delta, power=power_nonrobust, prior="non-robust"), - data.frame(theta_active, theta_control, delta=delta, power=power_uniform, prior="uniform"), - data.frame(theta_active, theta_control, delta=delta, power=power_classic, prior="uniform 24:24") - ) - -ggplot(ocP, aes(delta, power, colour=prior)) + geom_line() + - ggtitle("Power") - +power_robust <- design_robust(theta_active, theta_control) + +ocP <- rbind( + data.frame(theta_active, theta_control, delta = delta, power = power_robust, prior = "robust"), + data.frame(theta_active, theta_control, delta = delta, power = power_nonrobust, prior = "non-robust"), + data.frame(theta_active, theta_control, delta = delta, power = power_uniform, prior = "uniform"), + data.frame(theta_active, theta_control, delta = delta, power = power_classic, prior = "uniform 24:24") +) + +ggplot(ocP, aes(delta, power, colour = prior)) + + geom_line() + + ggtitle("Power") ``` We see that with the MAP prior one reaches greater power at smaller @@ -343,17 +355,25 @@ for which 80% power is reached can be found with: ```{r} find_delta <- function(design, theta_control, target_power) { - uniroot(function(delta) { design(theta_control + delta, theta_control) - target_power }, - interval=c(0, 1-theta_control))$root + uniroot( + function(delta) { + design(theta_control + delta, theta_control) - target_power + }, + interval = c(0, 1 - theta_control) + )$root } -target_effect <- data.frame(delta=c(find_delta(design_nonrobust, mean_control, 0.8), - find_delta(design_classic, mean_control, 0.8), - find_delta(design_robust, mean_control, 0.8), - find_delta(design_uniform, mean_control, 0.8)), - prior=c("non-robust", "uniform 24:24", "robust", "uniform")) - -knitr::kable(target_effect, digits=3) +target_effect <- data.frame( + delta = c( + find_delta(design_nonrobust, mean_control, 0.8), + find_delta(design_classic, mean_control, 0.8), + find_delta(design_robust, mean_control, 0.8), + find_delta(design_uniform, mean_control, 0.8) + ), + prior = c("non-robust", "uniform 24:24", "robust", "uniform") +) + +knitr::kable(target_effect, digits = 3) ``` ### Data Scenarios @@ -369,18 +389,21 @@ are the critical values at which the decision criterion flips. In the ## Critical values at which the decision flips are given conditional ## on the outcome of the second read-out; as we like to have this as a ## function of the treatment group outcome, we flip label 1 and 2 -decision_flipped <- decision2S(0.95, 0, lower.tail=TRUE) -crit_uniform <- decision2S_boundary(uniform_prior, uniform_prior, 6, 24, decision_flipped) -crit_nonrobust <- decision2S_boundary(map , treat_prior , 6, 24, decision_flipped) -crit_robust <- decision2S_boundary(map_robust , treat_prior , 6, 24, decision_flipped) +decision_flipped <- decision2S(0.95, 0, lower.tail = TRUE) +crit_uniform <- decision2S_boundary(uniform_prior, uniform_prior, 6, 24, decision_flipped) +crit_nonrobust <- decision2S_boundary(map, treat_prior, 6, 24, decision_flipped) +crit_robust <- decision2S_boundary(map_robust, treat_prior, 6, 24, decision_flipped) treat_y2 <- 0:24 ## Note that -1 is returned to indicated that the decision is never 1 -ocC <- rbind(data.frame(y2=treat_y2, y1_crit=crit_robust(treat_y2), prior="robust"), - data.frame(y2=treat_y2, y1_crit=crit_nonrobust(treat_y2), prior="non-robust"), - data.frame(y2=treat_y2, y1_crit=crit_uniform(treat_y2), prior="uniform") - ) - -ggplot(ocC, aes(y2, y1_crit, colour=prior)) + geom_step() + ggtitle("Critical values y1(y2)") +ocC <- rbind( + data.frame(y2 = treat_y2, y1_crit = crit_robust(treat_y2), prior = "robust"), + data.frame(y2 = treat_y2, y1_crit = crit_nonrobust(treat_y2), prior = "non-robust"), + data.frame(y2 = treat_y2, y1_crit = crit_uniform(treat_y2), prior = "uniform") +) + +ggplot(ocC, aes(y2, y1_crit, colour = prior)) + + geom_step() + + ggtitle("Critical values y1(y2)") ``` The graph shows that the decision will always be negative if there are @@ -391,9 +414,9 @@ result, we can directly evaluate the decision function: ```{r} ## just positive -decision(postmix(treat_prior, n=24, r=15), postmix(map, n=6, r=3)) +decision(postmix(treat_prior, n = 24, r = 15), postmix(map, n = 6, r = 3)) ## negative -decision(postmix(treat_prior, n=24, r=14), postmix(map, n=6, r=4)) +decision(postmix(treat_prior, n = 24, r = 14), postmix(map, n = 6, r = 4)) ``` @@ -406,15 +429,15 @@ setting. ```{r} r_placebo <- 1 -r_treat <- 14 +r_treat <- 14 ## first obtain posterior distributions... -post_placebo <- postmix(map_robust, r=r_placebo, n=6) -post_treat <- postmix(treat_prior, r=r_treat , n=24) +post_placebo <- postmix(map_robust, r = r_placebo, n = 6) +post_treat <- postmix(treat_prior, r = r_treat, n = 24) ## ...then calculate probability that the difference is smaller than ## zero -prob_smaller <- pmixdiff(post_treat, post_placebo, 0, lower.tail=FALSE) +prob_smaller <- pmixdiff(post_treat, post_placebo, 0, lower.tail = FALSE) prob_smaller