├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── ISSUE_TEMPLATE.md ├── NAMESPACE ├── NEWS.md ├── R ├── binomial.R ├── defaults.R ├── doFit.R ├── doSim.R ├── doTest.R ├── extend.R ├── extendWithin.R ├── getData.R ├── graphics.R ├── lmerTest.R ├── maybe.R ├── modify.R ├── new.R ├── oops.R ├── options.R ├── powerCurve.R ├── powerPlot.R ├── powerSim.R ├── print.R ├── progress.R ├── simr.R └── testLibrary.R ├── README.md ├── appveyor.yml ├── build └── make_simdata.r ├── data └── simdata.rda ├── inst └── CITATION ├── man ├── doFit.Rd ├── doSim.Rd ├── doTest.Rd ├── extend.Rd ├── getData.Rd ├── lastResult.Rd ├── makeGlmer.Rd ├── modify.Rd ├── powerCurve.Rd ├── powerSim.Rd ├── print.powerSim.Rd ├── simdata.Rd ├── simr-package.Rd ├── simrOptions.Rd └── tests.Rd ├── simr.Rproj ├── tests ├── test-all.R └── testthat │ ├── helper_setup.R │ ├── test_aaa.R │ ├── test_binomial.R │ ├── test_contrasts.R │ ├── test_extend.r │ ├── test_fixef.r │ ├── test_function.R │ ├── test_getData.R │ ├── test_graphics.R │ ├── test_lm.r │ ├── test_logResponse.R │ ├── test_logging.R │ ├── test_modify.R │ ├── test_new.R │ ├── test_observed.R │ ├── test_options.R │ ├── test_powerCurve.R │ ├── test_powerSim.R │ ├── test_testLibrary.R │ └── test_zzz.r └── vignettes ├── examples.Rmd └── fromscratch.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^appveyor\.yml$ 5 | ISSUE_TEMPLATE.md 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: simr 2 | Type: Package 3 | Title: Power Analysis for Generalised Linear Mixed Models by Simulation 4 | Description: Calculate power for generalised linear mixed models, using 5 | simulation. Designed to work with models fit using the 'lme4' package. 6 | Described in Green and MacLeod, 2016 . 7 | Version: 1.0.7-1 8 | Authors@R: c( 9 | person("Peter", "Green", role=c("aut", "cre"), email="simr.peter@gmail.com", 10 | comment=c(ORCID="0000-0002-0238-9852")), 11 | person("Catriona", "MacLeod", role="aut"), 12 | person("Phillip", "Alday", role="ctb")) 13 | URL: https://github.com/pitakakariki/simr 14 | BugReports: https://github.com/pitakakariki/simr/issues 15 | License: GPL (>=2) 16 | Depends: 17 | lme4 (>= 1.1-16) 18 | Imports: 19 | binom,iterators,pbkrtest,plotrix,plyr,RLRsim,stringr,stats,methods,utils,graphics,grDevices,car,lmerTest (>= 3.0-0) 20 | Suggests: 21 | testthat,knitr,rmarkdown 22 | LazyData: true 23 | RoxygenNote: 7.2.3 24 | VignetteBuilder: knitr 25 | Encoding: UTF-8 26 | -------------------------------------------------------------------------------- /ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 2 | Please note that this issue tracker is for reporting bugs in the `simr` package. 3 | 4 | 5 | Due to time constraints I can no longer provide support for any statistical aspects of your power analysis. 6 | 7 | However, do note that unclear usage or unhelpful documentation in `simr` is still a "bug". 8 | 9 | 10 | 11 | If you have found a coding bug, please provide a reproducible example to help me isolate the problem. 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("coef<-",default) 4 | S3method("coef<-",glm) 5 | S3method("getData<-",default) 6 | S3method("getData<-",lm) 7 | S3method("sigma<-",glm) 8 | S3method("sigma<-",lm) 9 | S3method("sigma<-",merMod) 10 | S3method(confint,powerCurve) 11 | S3method(confint,powerSim) 12 | S3method(doFit,"function") 13 | S3method(doFit,default) 14 | S3method(doSim,"function") 15 | S3method(doSim,default) 16 | S3method(doSim,iter) 17 | S3method(doSim,merMod) 18 | S3method(doTest,default) 19 | S3method(extend,data.frame) 20 | S3method(extend,default) 21 | S3method(extend,lm) 22 | S3method(plot,powerCurve) 23 | S3method(plot,powerSim) 24 | S3method(print,powerCurve) 25 | S3method(print,powerSim) 26 | S3method(print,test) 27 | S3method(sigma,lm) 28 | S3method(summary,powerCurve) 29 | S3method(summary,powerSim) 30 | export("VarCorr<-") 31 | export("coef<-") 32 | export("fixef<-") 33 | export("getData<-") 34 | export("scale<-") 35 | export("sigma<-") 36 | export(compare) 37 | export(doFit) 38 | export(doSim) 39 | export(doTest) 40 | export(extend) 41 | export(fcompare) 42 | export(fixed) 43 | export(getData) 44 | export(getSimrOption) 45 | export(lastResult) 46 | export(makeGlmer) 47 | export(makeLmer) 48 | export(powerCurve) 49 | export(powerSim) 50 | export(random) 51 | export(rcompare) 52 | export(simrOptions) 53 | import(RLRsim) 54 | import(binom) 55 | import(car) 56 | import(grDevices) 57 | import(graphics) 58 | import(iterators) 59 | import(lme4) 60 | import(methods) 61 | import(pbkrtest) 62 | import(plotrix) 63 | import(plyr) 64 | import(stats) 65 | import(stringr) 66 | import(utils) 67 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ### simr 1.0.7 2 | 3 | - compatibility update for R 4.3.0 (Martyn Plummer) 4 | 5 | - bugfix for `compare` with complicated models (Tobias R. Rebholz) 6 | 7 | ### simr 1.0.6 8 | 9 | - reduce dependence on orphaned plyr. 10 | 11 | - fixed given/family name order in DESCRIPTION 12 | 13 | ### simr 1.0.5 14 | 15 | - fixed a unit test that was causing problems for lme4 downstream checks. 16 | 17 | - minor improvements 18 | - include `nrow` in `summary.powerCurve`. 19 | 20 | ### simr 1.0.4 21 | 22 | - compatibility updates for `lmerTest` version 3.0-0. 23 | 24 | - bugfixes 25 | - contrast attributes are no longer dropped by `extend`. 26 | - more bugfixes and unit tests for binomial responses. 27 | - warnings for non-uniform weights, which aren't supported yet. 28 | 29 | ### simr 1.0.3 30 | 31 | - update maintainer email address. 32 | 33 | ### simr 1.0.2 34 | 35 | - `print`, `summary`, and `confint` methods for easier access to results. 36 | - `log(y)` type responses now work. 37 | - added unit tests. 38 | 39 | ### simr 1.0.1 40 | 41 | - added citation info. 42 | - added vignette building instructions. 43 | - bugfixes 44 | - binomial responses. 45 | - lm/glm simulation. 46 | - subsetted data arguments. 47 | 48 | ### simr 1.0.0 49 | 50 | - Initial CRAN release. 51 | -------------------------------------------------------------------------------- /R/binomial.R: -------------------------------------------------------------------------------- 1 | # 2 | # Binomial models with cbind responses need special treatment 3 | # 4 | 5 | # does the model have a cbind response? 6 | cbindResponse <- function(object) { 7 | 8 | family(object)$family=="binomial" && is.matrix(model.response(object@frame)) 9 | } 10 | 11 | 12 | -------------------------------------------------------------------------------- /R/defaults.R: -------------------------------------------------------------------------------- 1 | getDefaultXname <- function(obj) { 2 | 3 | rhs <- formula(obj)[[3]] 4 | 5 | a <- all.vars(rhs)[[1]] 6 | b <- str_trim(str_split(deparse(rhs), stringr::fixed("+"))[[1]][1]) 7 | 8 | if(a != b) stop("Couldn't automatically determine a default fixed effect for this model.") 9 | 10 | return(a) 11 | } 12 | 13 | -------------------------------------------------------------------------------- /R/doFit.R: -------------------------------------------------------------------------------- 1 | #' Fit model to a new response. 2 | #' 3 | #' This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 4 | #' 5 | #' @param y new values for the response variable (vector or matrix depending on the model). 6 | #' @param fit a previously fitted model object. 7 | #' @param subset boolean vector specifying how much of the data to use. If missing, the model is fit to all 8 | #' the data. This argument needs to be implemented for \code{\link{powerCurve}} to work. 9 | #' @param ... additional options. 10 | #' 11 | #' @return a fitted model object. 12 | #' 13 | #' @export 14 | doFit <- function(y, fit, subset, ...) UseMethod('doFit', fit) 15 | 16 | #' @export 17 | doFit.default <- function(y, fit, subset, ...) { 18 | 19 | ## nb: `responseName` might be e.g. log(z) or cbind(z, 10-z) 20 | ## in this case, need a gensym using make.names 21 | ## a) in newData 22 | ## b) replacing the response in fit's formula 23 | 24 | responseName <- formula(fit)[[2]] 25 | 26 | # cbind response for binomial 27 | if(as.character(responseName)[1] == "cbind") { 28 | 29 | responseForm <- responseName 30 | 31 | responseName <- responseName[[2]] 32 | if(is.matrix(y)) y <- y[, 1] 33 | 34 | } else { 35 | 36 | if(!is.character(responseName)) responseName <- deparse(responseName) 37 | responseName <- make.names(responseName) 38 | 39 | responseForm <- as.symbol(responseName) 40 | } 41 | 42 | newData <- getData(fit) 43 | newData[[responseName]] <- y 44 | 45 | newData <- newData[subset, ] 46 | 47 | newCall <- getCall(fit) 48 | newCall[["formula"]][[2]] <- responseForm 49 | newCall[["data"]] <- quote(newData) 50 | 51 | if("weights" %in% names(newCall)) { 52 | 53 | N <- nrow(getData(fit)) 54 | w <- weights(fit) 55 | if(length(w) != N) { 56 | 57 | if(length(unique(w)) != 1) stop("Non-uniform weights are not supported") 58 | w <- rep(w[1], N) 59 | } 60 | 61 | w <- w[subset] 62 | 63 | newCall[["weights"]] <- w 64 | } 65 | 66 | opts <- list(...) 67 | newCall[names(opts)] <- opts 68 | 69 | e <- new.env(parent=environment(formula(newCall))) 70 | attr(newCall$formula, ".Environment") <- e 71 | assign("newData", newData, envir=e) 72 | 73 | rval <- eval(newCall) 74 | 75 | return(rval) 76 | } 77 | 78 | #' @export 79 | doFit.function <- function(y, fit, subset, ...) { 80 | 81 | ss <- "subset" %in% names(formals(fit)) 82 | 83 | if(!ss & !missing(subset)) stop("The supplied function has no subset argument") 84 | 85 | if(!ss) { 86 | 87 | fit(y, ...) 88 | 89 | } else { 90 | 91 | fit(y, subset=subset, ...) 92 | } 93 | } 94 | -------------------------------------------------------------------------------- /R/doSim.R: -------------------------------------------------------------------------------- 1 | #' Generate simulated response variables. 2 | #' 3 | #' This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 4 | #' 5 | #' @param object an object to simulate from, usually a fitted model. 6 | #' @param ... additional options. 7 | #' 8 | #' @return a vector containing simulated response values (or, for models with a multivariate response such as 9 | #' binomial gl(m)m's, a matrix of simulated response values). Suitable as input for \code{\link{doFit}}. 10 | #' 11 | #' @export 12 | doSim <- function(object, ...) UseMethod("doSim", object) 13 | 14 | #' @export 15 | doSim.default <- function(object, ...) { 16 | 17 | simulate(object, ...)[[1]] 18 | } 19 | 20 | #' @export 21 | doSim.iter <- function(object, ...) { 22 | 23 | nextElem(object, ...) 24 | } 25 | 26 | #' @export 27 | doSim.merMod <- function(object, ...) { 28 | 29 | simParams <- list( 30 | 31 | beta = fixef(object), 32 | theta = getME(object, "theta"), 33 | sigma = sigma(object) 34 | ) 35 | 36 | useSc <- object@devcomp$dims["useSc"] 37 | if(!useSc) simParams$sigma <- NULL 38 | 39 | simData <- getData(object) 40 | 41 | # check weights 42 | w <- weights(object) 43 | if(!is.null(w)) if(length(w) != nrow(simData)) { 44 | 45 | if(length(unique(w)) != 1) { 46 | 47 | if(cbindResponse(object)) { 48 | 49 | w <- NULL 50 | 51 | } else { 52 | 53 | stop("Non-uniform weights are not supported yet.") 54 | } 55 | 56 | } else { 57 | 58 | w <- rep(w[1], nrow(simData)) 59 | } 60 | } 61 | 62 | simulate( 63 | formula(object), 64 | newparams=simParams, 65 | newdata=simData, 66 | family=family(object), 67 | weights=w, ...)[[1]] 68 | } 69 | 70 | #' @export 71 | doSim.function <- function(object, ...) object(...) 72 | 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /R/doTest.R: -------------------------------------------------------------------------------- 1 | #' Apply a hypothesis test to a fitted model. 2 | #' 3 | #' This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 4 | #' 5 | #' @param object an object to apply a statistical test to, usually a fitted model. 6 | #' @param test a test function, see \link{tests}. 7 | #' @param ... additional options. 8 | #' 9 | #' @return a p-value with attributes describing the test. 10 | #' 11 | #' @export 12 | doTest <- function(object, test, ...) UseMethod('doTest', object) 13 | 14 | #' @export 15 | doTest.default <- function(object, test=fixed(getDefaultXname(object)), ...) { 16 | 17 | opts <- simrOptions(...) 18 | on.exit(simrOptions(opts)) 19 | 20 | test <- wrapTest(test) 21 | 22 | pval <- test(object) 23 | 24 | if(!is.numeric(pval) || length(pval)!= 1 || is.na(pval)) stop("Test did not return a p-value") 25 | 26 | rval <- structure(pval, 27 | 28 | text = str_c("p-value", substring(attr(test, "text")(object, object), 6)), 29 | description = attr(test, "description")(object, object) 30 | ) 31 | 32 | class(rval) <- "test" 33 | 34 | return(rval) 35 | } 36 | 37 | #' @export 38 | print.test <- function(x, ...) { 39 | 40 | cat(attr(x, "text"), ": ", x, "\n", sep="") 41 | 42 | cat(" --------------------\n") 43 | 44 | pad <- "Test: " 45 | for(text in attr(x, "description")) { 46 | cat(pad); pad <- " " 47 | cat(text) 48 | cat("\n") 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /R/extend.R: -------------------------------------------------------------------------------- 1 | #' Extend a longitudinal model. 2 | #' 3 | #' This method increases the sample size for a model. 4 | #' 5 | #' @param object a fitted model object to extend. 6 | #' @param along the name of an explanatory variable. This variable will have its number of levels extended. 7 | #' @param within names of grouping variables, separated by "+" or ",". Each combination of groups will be 8 | #' extended to \code{n} rows. 9 | #' @param n number of levels: the levels of the explanatory variable will be replaced by \code{1,2,3,..,n} for a 10 | #' continuous variable or \code{a,b,c,...,n} for a factor. 11 | #' @param values alternatively, you can specify a new set of levels for the explanatory variable. 12 | #' 13 | #' @details 14 | #' 15 | #' \code{extend} takes "slices" through the data for each unique value of the extended variable. 16 | #' An extended dataset is built from \code{n} slices, with slices duplicated if necessary. 17 | #' 18 | #' @return 19 | #' 20 | #' A copy of \code{object} suitable for \code{\link{doSim}} with an extended dataset attached as 21 | #' an attribute named \code{newData}. 22 | #' 23 | #' @examples 24 | #' fm <- lmer(y ~ x + (1|g), data=simdata) 25 | #' nrow(example) 26 | #' fmx1 <- extend(fm, along="x", n=20) 27 | #' nrow(getData(fmx1)) 28 | #' fmx2 <- extend(fm, along="x", values=c(1,2,4,8,16)) 29 | #' nrow(getData(fmx2)) 30 | #' 31 | #' @export 32 | extend <- function(object, along, within, n, values) UseMethod("extend", object) 33 | 34 | #' @export 35 | extend.data.frame <- function(object, along, within, n, values) { 36 | 37 | if(missing(n) && missing(values)) stop("Extended values not specified.") 38 | 39 | if(!missing(along) && !missing(within)) stop("Only one of along and within may be used.") 40 | 41 | if(!missing(within)) { 42 | 43 | object <- addReplicateIndex(object, within) 44 | along <- ".simr_repl" 45 | } 46 | 47 | a <- is.factor(object[[along]]) 48 | b <- along %in% all.vars(nobars(formula(object)[[length(formula(object))]])) 49 | 50 | if(missing(values)) { 51 | 52 | if(a) { 53 | 54 | values <- character(n) 55 | suppressWarnings(values[] <- letters) 56 | values <- make.unique(values) 57 | 58 | } else { 59 | 60 | values <- seq_len(n) 61 | 62 | } 63 | } 64 | 65 | ## NB this is where the extension logic gets defined 66 | ## e.g. if values=c("a", "b", "c"), and unique(along)=c(1, 2) 67 | ## then oldvalues=c(1, 2, 1) 68 | 69 | # repeat unique `along` values, length(values) times. 70 | oldValues <- values 71 | suppressWarnings(oldValues[] <- as.character(unique(object[[along]]))) 72 | 73 | # repeat N times 74 | f <- function(value, oldValue) { 75 | 76 | #one_X <- reduce(object, along, oldValue) 77 | one_X <- object[(object[[along]] == oldValue), , drop=FALSE] 78 | if(a) levels(one_X[[along]]) <- values 79 | 80 | one_X[[along]][] <- value 81 | return(one_X) 82 | } 83 | 84 | X <- do.call(rbind, mapply(f, values, oldValues, SIMPLIFY=FALSE)) 85 | 86 | # cleanup 87 | X$.simr_repl <- NULL 88 | 89 | # copy contrast attributes 90 | for(j in seq_along(X)) { 91 | 92 | C <- attr(object[[j]], "contrasts") 93 | 94 | if(!is.null(C)) contrasts(X[[j]]) <- C 95 | } 96 | 97 | return(X) 98 | 99 | } 100 | 101 | #' @export 102 | extend.default <- function(object, along, within, n, values) { 103 | 104 | # Sanity checks 105 | 106 | if(length(unique(weights(object))) > 1 && !cbindResponse(object)) { 107 | 108 | warning("Non-uniform weights are not supported") 109 | } 110 | 111 | if(missing(n) && missing(values)) { 112 | 113 | stop("Extended values not specified.") 114 | } 115 | 116 | if(missing(within)) { 117 | 118 | if(missing(along)) along <- getDefaultXname(object) 119 | 120 | a <- is.factor(getData(object)[[along]]) 121 | b <- along %in% all.vars(nobars(formula(object)[[length(formula(object))]])) 122 | 123 | if(a && b) stop("Cannot extend along a fixed factor.") 124 | } 125 | 126 | # Attach an extended data.frame 127 | 128 | newData <- extend(getData(object), along, within, n, values) 129 | 130 | getData(object) <- newData 131 | 132 | return(object) 133 | } 134 | 135 | #' @export 136 | extend.lm <- function(object, along, within, n, values) { 137 | 138 | newData <- extend(getData(object), along, within, n, values) 139 | 140 | newCall <- getCall(object) 141 | newCall$data <- quote(newData) 142 | 143 | newObject <- eval(newCall) 144 | 145 | # beta and sigma 146 | coef(newObject) <- coef(object) 147 | suppressWarnings( 148 | sigma(newObject) <- sigma(object) 149 | ) # In summary.lm(object) : essentially perfect fit: summary may be unreliable 150 | 151 | # less likely to have problems if the data's kept here? 152 | # attr(newObject, 'newData') <- newData 153 | 154 | return(newObject) 155 | } 156 | 157 | 158 | -------------------------------------------------------------------------------- /R/extendWithin.R: -------------------------------------------------------------------------------- 1 | # adds a .simr_repl variable to a data.frame 2 | 3 | addReplicateIndex <- function(data, factors) { 4 | 5 | factors <- str_split(factors, "[\\+,]")[[1]] 6 | factors <- str_trim(factors) 7 | 8 | #f <- eval(substitute(with(data, interaction(...)))) 9 | x <- lapply(factors, get, data) 10 | f <- do.call(interaction, x) 11 | repl <- lapply(table(f), seq_len) 12 | 13 | data$.simr_repl <- 0 14 | for(i in levels(f)) { 15 | 16 | data$.simr_repl[f==i] <- repl[[i]] 17 | } 18 | 19 | return(data) 20 | } -------------------------------------------------------------------------------- /R/getData.R: -------------------------------------------------------------------------------- 1 | #' Get an object's data. 2 | #' 3 | #' Get the data associated with a model object. 4 | #' 5 | #' @param object a fitted model object (e.g. an object of class \code{merMod} or \code{lm}). 6 | #' @param value a new \code{data.frame} to replace the old one. 7 | #' The new data will be stored in the \code{newData} attribute. 8 | #' 9 | #' @details 10 | #' 11 | #' Looks for data in the following order: 12 | #' 13 | #' \enumerate{ 14 | #' \item{The object's \code{newData} attribute, if it has been set by \code{simr}.} 15 | #' \item{The \code{data} argument of \code{getCall(object)}, in the environment of \code{formula(object)}.} 16 | #' } 17 | #' 18 | #' @return 19 | #' 20 | #' A \code{data.frame} with the required data. 21 | #' 22 | #' @examples 23 | #' 24 | #' lm1 <- lmer(y ~ x + (1|g), data=simdata) 25 | #' X <- getData(lm1) 26 | #' 27 | #' @export 28 | getData <- function(object) { 29 | 30 | # 31 | # 1st choice: has simr set a `newData` attribute? 32 | # 33 | 34 | newData <- attr(object, "newData") 35 | if(!is.null(newData)) return(newData) 36 | 37 | # 38 | # 2nd choice: @frame for merMod, $model for lm. 39 | # 40 | 41 | # not clever enough? Breaks e.g. binomial? 42 | 43 | #if(is(object, "merMod")) return(object@frame) 44 | #if(is(object, "lm")) return(object$model) 45 | 46 | # 47 | # @nd choice: doFit inserts a whole data.frame into the call 48 | # 49 | 50 | dataCall <- maybe(getCall)(object)$value$data 51 | if(is(dataCall, "data.frame")) return(dataCall) 52 | 53 | # 54 | # 3rd choice: evaluate the `data` argument 55 | # 56 | 57 | #dataName <- as.character(dataCall) 58 | if(length(dataCall) > 0) return(eval(dataCall, envir=environment(formula(object)))) 59 | 60 | # 61 | # If none of the above worked: 62 | # 63 | 64 | stop("Couldn't find object's data.") 65 | } 66 | 67 | #' @rdname getData 68 | #' @export 69 | `getData<-` <- function(object, value) UseMethod("getData<-", object) 70 | 71 | #' @export 72 | `getData<-.default` <- function(object, value) { 73 | 74 | attr(object, "newData") <- value 75 | return(object) 76 | } 77 | 78 | #' @export 79 | `getData<-.lm` <- function(object, value) { 80 | 81 | newData <- value 82 | 83 | newCall <- getCall(object) 84 | newCall$data <- quote(newData) 85 | 86 | newObject <- eval(newCall) 87 | 88 | # beta and sigma 89 | coef(newObject) <- coef(object) 90 | suppressWarnings( 91 | sigma(newObject) <- sigma(object) 92 | ) # In summary.lm(object) : essentially perfect fit: summary may be unreliable 93 | 94 | # less likely to have problems if the data's kept here? 95 | # attr(newObject, 'newData') <- newData 96 | 97 | return(newObject) 98 | } 99 | -------------------------------------------------------------------------------- /R/graphics.R: -------------------------------------------------------------------------------- 1 | alpha <- function(x, alpha=1) { 2 | 3 | alpha0 <- col2rgb(x, alpha=TRUE)[4] 4 | 5 | rgb(t(col2rgb(x)), alpha=alpha0*alpha, maxColorValue=255) 6 | } 7 | 8 | lighten <- Vectorize(function(col) { 9 | 10 | rgb <- col2rgb(col) 11 | 12 | # lighten 13 | f <- 150 14 | rgb <- f + (1 - f/255) * rgb 15 | 16 | r <- rgb[[1]] 17 | g <- rgb[[2]] 18 | b <- rgb[[3]] 19 | 20 | rgb(r, g, b, max=255) 21 | }) 22 | 23 | ci_abline <- function( 24 | fit, 25 | col = 'palevioletred', 26 | alpha = 0.5, 27 | npts = 1000) { 28 | 29 | xrange <- range(fit$model$x) 30 | x <- seq(xrange[1], xrange[2], length=npts) 31 | 32 | pred <- predict(fit, newdata=data.frame(x=x), interval='confidence') 33 | 34 | polygon(c(x, rev(x)), c(pred[,2], rev(pred[,3])), col=alpha(col, alpha), border=NA) 35 | lines(x, pred[,2], col=col, lwd=2) 36 | lines(x, pred[,3], col=col, lwd=2) 37 | 38 | lines(x, pred[,1], col=col, lwd=3) 39 | } 40 | 41 | lcrgreen <- '#639441' 42 | lcrlightgreen <- '#EBF1E5' 43 | lcrblue <- '#008FC5' 44 | lcrlightblue <- '#E2E9F3' 45 | lcrbrown <- '#767662' 46 | lcrlightbrown <- '#EFF0EB' 47 | 48 | plotpal <- function(n=length(x), x=getPalette(n)) { 49 | 50 | plot(seq_along(x), rep(1, n), col=x, bg=lighten(x), pch=21, cex=10, xlim=c(0, n+1), lwd=3) 51 | 52 | invisible(x) 53 | } 54 | 55 | getPalette <- function(n) { 56 | 57 | start <- c(lcrblue, lcrgreen, lcrbrown) 58 | 59 | if(n <= 3) return(start[seq_len(n)]) 60 | 61 | return(c(start, seq_len(n-3))) 62 | } 63 | -------------------------------------------------------------------------------- /R/lmerTest.R: -------------------------------------------------------------------------------- 1 | 2 | lmerTest_anova <- function(object, ...) { 3 | 4 | # Produce lmerTest-anova table for lmer-model fits (lme4 or lmerTest) with new lmerTest package. 5 | pkg_version <- "3.0-0" 6 | 7 | if(requireNamespace("lmerTest", quietly=TRUE) && packageVersion("lmerTest") < pkg_version) { 8 | 9 | stop("lmerTest versions < 3.0-0 are not supported.") 10 | } 11 | 12 | if(requireNamespace("lmerTest", quietly=TRUE) && packageVersion("lmerTest") >= pkg_version) { 13 | 14 | return(anova(lmerTest::as_lmerModLmerTest(object), ...)) # lme4 object 15 | } 16 | 17 | stop("The lmerTest package is required for this test.") 18 | } 19 | 20 | lmerTest_summary <- function(object, ...) { 21 | 22 | # Produce lmerTest-summary for lmer-model fits (lme4 or lmerTest) with new lmerTest package. 23 | pkg_version <- "3.0-0" 24 | 25 | if(requireNamespace("lmerTest", quietly=TRUE) && packageVersion("lmerTest") < pkg_version) { 26 | 27 | stop("lmerTest versions < 3.0-0 are not supported.") 28 | } 29 | 30 | if(requireNamespace("lmerTest", quietly=TRUE) && packageVersion("lmerTest") >= pkg_version) { 31 | 32 | return(summary(lmerTest::as_lmerModLmerTest(object), ...)) # lme4 object 33 | } 34 | 35 | stop("The lmerTest package is required for this test.") 36 | } 37 | 38 | is_lmerTest <- function(object) { 39 | 40 | # Check if an object is of class merModLmerTest or lmerModLmerTest 41 | # Bridges across versions of lmerTest 42 | inherits(object, "merModLmerTest") || inherits(object, "lmerModLmerTest") 43 | } 44 | -------------------------------------------------------------------------------- /R/maybe.R: -------------------------------------------------------------------------------- 1 | # 2 | # Add a tag to any warnings or errors thrown when evaluating "thing". 3 | # 4 | tag <- function(thing, tag="") { 5 | 6 | tryCatch( 7 | 8 | withCallingHandlers(eval.parent(thing), 9 | 10 | warning=function(w) { 11 | 12 | w$tag <- tag 13 | warning(w) 14 | invokeRestart("muffleWarning") 15 | }), 16 | 17 | error=function(e) { 18 | 19 | e$tag <- tag 20 | stop(e) 21 | } 22 | ) 23 | 24 | invisible(NULL) 25 | } 26 | 27 | maybe <- function(f) { 28 | 29 | function(...) { 30 | 31 | returnValue <- NULL 32 | warningValue <- NULL 33 | warningTag <- NULL 34 | errorValue <- NULL 35 | errorTag <- NULL 36 | 37 | returnValue <- tryCatch( 38 | 39 | withCallingHandlers(f(...), 40 | 41 | warning=function(w) { 42 | 43 | warningValue <<- append(warningValue, w$message) 44 | wtag <- if(is.null(w$tag)) "" else w$tag 45 | warningTag <<- append(warningTag, wtag) 46 | invokeRestart("muffleWarning") 47 | }), 48 | 49 | error=function(e) { 50 | 51 | errorValue <<- e$message 52 | errorTag <<- if(is.null(e$tag)) "" else e$tag 53 | return(NULL) 54 | } 55 | ) 56 | 57 | rval <- list() 58 | class(rval) <- "Maybe" 59 | 60 | rval["value"] <- list(returnValue) # nb returnValue might be NULL 61 | rval["warning"] <- list(warningValue) 62 | rval["warningtag"] <- list(warningTag) 63 | rval["error"] <- list(errorValue) 64 | rval["errortag"] <- list(errorTag) 65 | 66 | return(rval) 67 | } 68 | } 69 | 70 | list2maybe <- function(x) { 71 | 72 | rval <- list() 73 | 74 | rval $ value <- as.list(x) 75 | 76 | rval $ warnings <- maybeFrame() 77 | rval $ errors <- maybeFrame() 78 | 79 | class(rval) <- "maybeList" 80 | 81 | return(rval) 82 | } 83 | 84 | maybeFrame <- function() { 85 | 86 | data.frame(stage=character(), index=integer(), message=character(), stringsAsFactors=FALSE) 87 | } 88 | 89 | maybe_llply <- function(.data, .fun, .text="", ..., .progress=progress_simr(.text), .extract=FALSE) { 90 | 91 | if(!is(.data, "maybeList")) { 92 | 93 | .data <- list2maybe(.data) 94 | } 95 | 96 | maybenot <- seq_along(.data$value) %in% .data$errors$index 97 | 98 | z <- list() 99 | z[maybenot] <- llply(.data$errormessage[maybenot], function(e) maybe(stop(e))()) 100 | z[!maybenot] <- not_llply(.data$value[!maybenot], maybe(.fun), ..., .progress=.progress) 101 | 102 | # $value 103 | rval <- list() 104 | rval $ value <- llply(z, `[[`, "value") 105 | 106 | # extract warnings and errors from $value? 107 | extractWarnings <- if(.extract) do.call(rbind, llply(rval$value, `[[`, "warnings")) else maybeFrame() 108 | extractErrors <- if(.extract) do.call(rbind, llply(rval$value, `[[`, "errors")) else maybeFrame() 109 | 110 | # $warnings 111 | warnings <- llply(z, `[[`, "warning") 112 | wtags <- llply(z, `[[`, "warningtag") 113 | index <- rep(seq_along(warnings), laply(warnings, length)) 114 | #stage <- rep(.text, length(index)) 115 | message <- unlist(warnings) 116 | stage <- unlist(wtags) 117 | 118 | rval $ warnings <- rbind( 119 | .data$warnings, 120 | extractWarnings, 121 | data.frame(stage, index, message, stringsAsFactors=FALSE) 122 | ) 123 | 124 | # $errors 125 | errors <- llply(z, `[[`, "error") 126 | etags <- llply(z, `[[`, "errortag") 127 | index <- which(!laply(errors, is.null)) 128 | #stage <- rep(.text, length(index)) 129 | message <- unlist(errors) 130 | stage <- unlist(etags) 131 | 132 | rval $ errors <- rbind( 133 | .data$errors, 134 | extractErrors, 135 | data.frame(stage, index, message, stringsAsFactors=FALSE) 136 | ) 137 | 138 | class(rval) <- "maybeList" 139 | 140 | return(rval) 141 | } 142 | 143 | 144 | list_to_atomic <- function(x) { 145 | 146 | # must be a list of length one things, with maybe some zeroes 147 | if(any(laply(x, length) > 1)) stop("vectors longer than one found") 148 | 149 | # they should probably be atomic too 150 | if(any(laply(x, is.recursive))) stop("recursive elements found") 151 | 152 | # nb NULL -> NA 153 | unlist(ifelse(laply(x, is.null), NA, x)) 154 | } 155 | 156 | maybe_laply <- function(...) { 157 | 158 | # do maybe_llply stuff 159 | rval <- maybe_llply(...) 160 | 161 | # simplify and return 162 | rval $ value <- list_to_atomic(rval $ value) 163 | 164 | return(rval) 165 | } 166 | 167 | maybe_raply <- function(.N, .thing, ...) { 168 | 169 | maybe_laply(seq_len(.N), eval.parent(substitute(function(.) .thing)), ...) 170 | } 171 | 172 | maybe_rlply <- function(.N, .thing, ...) { 173 | 174 | maybe_llply(seq_len(.N), eval.parent(substitute(function(.) .thing)), ...) 175 | } 176 | 177 | sometimes <- function(x, p=0.01, emsg="x8x", pw=NA, wmsg="boo!", lambda=NA) { 178 | 179 | if(!is.na(pw)) { 180 | 181 | if(runif(1) < pw) { 182 | 183 | nmsg <- if(is.na(lambda)) 1 else rpois(1, lambda) 184 | 185 | for(i in seq_len(nmsg)) { 186 | 187 | warning(sample(wmsg, 1)) 188 | } 189 | } 190 | } 191 | 192 | if(runif(1) < p) test_error(emsg) 193 | 194 | x 195 | } 196 | 197 | test_error <- function(e) stop(e) 198 | 199 | # temporary replacement until I can get progress bars to work with purrr 200 | not_llply <- function(.data, .fun, .progress) { 201 | 202 | rval <- list() 203 | 204 | N <- length(.data) 205 | .progress$init(N) 206 | 207 | for(i in seq_len(N)) { 208 | 209 | rval[[i]] <- .fun(.data[[i]]) 210 | 211 | .progress$step() 212 | } 213 | 214 | .progress$term() 215 | 216 | return(rval) 217 | } 218 | 219 | 220 | 221 | 222 | 223 | -------------------------------------------------------------------------------- /R/modify.R: -------------------------------------------------------------------------------- 1 | #' Modifying model parameters. 2 | #' 3 | #' These functions can be used to change the size of a model's fixed effects, 4 | #' its random effect variance/covariance matrices, or its residual variance. 5 | #' This gives you more control over simulations from the model. 6 | #' 7 | #' @name modify 8 | #' @rdname modify 9 | #' 10 | #' @param object a fitted model object. 11 | #' @param value new parameter values. 12 | #' 13 | #' @details 14 | #' 15 | #' New values for \code{VarCorr} are interpreted as variances and covariances, not standard deviations and 16 | #' correlations. New values for \code{sigma} and \code{scale} are interpreted on the standard deviation scale. 17 | #' This means that both \code{VarCorr(object)<-VarCorr(object)} and \code{sigma(object)<-sigma(object)} 18 | #' leave \code{object} unchanged, as you would expect. 19 | #' 20 | #' \code{sigma<-} will only change the residual standard deviation, 21 | #' whereas \code{scale<-} will affect both \code{sigma} and \code{VarCorr}. 22 | #' 23 | #' These functions can be used to change the value of individual parameters, such as 24 | #' a single fixed effect coefficient, using standard R subsetting commands. 25 | #' 26 | #' @examples 27 | #' fm <- lmer(y ~ x + (1|g), data=simdata) 28 | #' fixef(fm) 29 | #' fixef(fm)["x"] <- -0.1 30 | #' fixef(fm) 31 | #' 32 | #' @seealso \code{\link{getData}} if you want to modify the model's data. 33 | #' 34 | NULL 35 | 36 | #' @rdname modify 37 | #' @export 38 | `fixef<-` <- function(object, value) { 39 | 40 | fixefNames <- colnames(getME(object, 'X')) 41 | nameTest <- setdiff(names(value), fixefNames) 42 | 43 | if(length(nameTest) != 0) { 44 | 45 | stop(str_c(nameTest[[1]], " is not the name of a fixed effect.")) 46 | } 47 | 48 | object @ beta <- unname(value) 49 | 50 | simrTag(object) <- TRUE 51 | 52 | return(object) 53 | } 54 | 55 | #' @rdname modify 56 | #' @export 57 | `coef<-` <- function(object, value) UseMethod("coef<-", object) 58 | 59 | #' @export 60 | `coef<-.default` <- function(object, value) { 61 | 62 | object $ coefficients <- value 63 | object $ fitted.values <- predict(object, type="response") 64 | 65 | simrTag(object) <- TRUE 66 | 67 | return(object) 68 | } 69 | 70 | #' @export 71 | `coef<-.glm` <- function(object, value) { 72 | 73 | object $ coefficients <- value 74 | object $ linear.predictors <- predict.lm(object, type="response") 75 | object $ fitted.values <- family(object)$linkinv(object $ linear.predictors) 76 | 77 | simrTag(object) <- TRUE 78 | 79 | return(object) 80 | } 81 | 82 | # VarCorr -> theta for a single group 83 | calcTheta1 <- function(V, sigma=1) { 84 | 85 | L <- suppressWarnings(chol(V, pivot=TRUE)) 86 | p <- order(attr(L, "pivot")) 87 | L <- t(L[p, p]) 88 | 89 | L[lower.tri(L, diag=TRUE)] / sigma 90 | } 91 | 92 | # All the thetas 93 | calcTheta <- function(V, sigma) { 94 | 95 | if(missing(sigma)) sigma <- attr(V, "sc") 96 | if(is.null(sigma)) sigma <- 1 97 | 98 | if(!is.list(V)) V <- list(V) 99 | 100 | theta <- llply(V, calcTheta1, sigma) 101 | 102 | unname(unlist(theta)) 103 | } 104 | 105 | #' @rdname modify 106 | #' @export 107 | `VarCorr<-` <- function(object, value) { 108 | 109 | object.useSc <- isTRUE(attr(VarCorr(object), "useSc")) 110 | value.useSc <- isTRUE(attr(value, "useSc")) 111 | 112 | if(object.useSc && value.useSc) s <- sigma(object) <- attr(value, "sc") 113 | if(object.useSc && !value.useSc) s <- sigma(object) 114 | if(!object.useSc && value.useSc) s <- attr(value, "sc") 115 | if(!object.useSc && !value.useSc) s <- 1 116 | 117 | object@theta <- calcTheta(value, s) 118 | 119 | simrTag(object) <- TRUE 120 | 121 | return(object) 122 | } 123 | 124 | #' @rdname modify 125 | #' @export 126 | `sigma<-` <- function(object, value) UseMethod("sigma<-", object) 127 | 128 | #' @export 129 | `sigma<-.merMod` <- function(object, value) { 130 | 131 | useSc <- object@devcomp$dims[["useSc"]] 132 | REML <- object@devcomp$dims[["REML"]] 133 | 134 | if(!useSc && !identical(value, 1)) stop("sigma is not applicable for this model.") 135 | 136 | V <- VarCorr(object) 137 | 138 | sigmaName <- if(REML) "sigmaREML" else "sigmaML" 139 | object@devcomp$cmp[[sigmaName]] <- value 140 | object@theta <- calcTheta(V, value) 141 | 142 | simrTag(object) <- TRUE 143 | 144 | return(object) 145 | } 146 | 147 | #' @export 148 | `sigma<-.glm` <- function(object, value) { 149 | 150 | if(is.null(value)) return(object) 151 | 152 | stop("sigma is not applicable for this model.") 153 | } 154 | 155 | #' @export 156 | `sigma<-.lm` <- function(object, value) { 157 | 158 | old.sigma <- sigma(object) 159 | new.sigma <- value 160 | 161 | if(is.null(old.sigma)) { 162 | 163 | if(is.null(value)) return(object) 164 | 165 | stop("sigma is not applicable for this model.") 166 | } 167 | 168 | object$residuals <- object$residuals * new.sigma / old.sigma 169 | 170 | simrTag(object) <- TRUE 171 | 172 | return(object) 173 | } 174 | 175 | #' @export 176 | sigma.lm <- function(object, ...) summary(object)$sigma 177 | 178 | #' @rdname modify 179 | #' @export 180 | `scale<-` <- function(object, value) { 181 | 182 | useSc <- object@devcomp$dims[["useSc"]] 183 | REML <- object@devcomp$dims[["REML"]] 184 | 185 | if(!useSc) stop("scale is not applicable for this model.") 186 | 187 | sigmaName <- if(REML) "sigmaREML" else "sigmaML" 188 | object@devcomp$cmp[[sigmaName]] <- value 189 | 190 | simrTag(object) <- TRUE 191 | 192 | return(object) 193 | } 194 | 195 | # Unmodified objects suggest post hoc power analysis. 196 | 197 | simrTag <- function(object) { 198 | 199 | isTRUE(attr(object, "simrTag")) 200 | } 201 | 202 | `simrTag<-` <- function(object, value) { 203 | 204 | attr(object, "simrTag") <- value 205 | 206 | return(object) 207 | } 208 | 209 | observedPowerWarning <- function(sim) { 210 | 211 | if(simrTag(sim)) return(FALSE) 212 | 213 | if(is.function(sim)) return(FALSE) 214 | 215 | if(is(sim, "iter")) return(FALSE) 216 | 217 | if(!getSimrOption("observedPowerWarning")) return(FALSE) 218 | 219 | warning("This appears to be an \"observed power\" calculation") 220 | 221 | return(TRUE) 222 | } 223 | -------------------------------------------------------------------------------- /R/new.R: -------------------------------------------------------------------------------- 1 | # 2 | # TO-DO 3 | # 4 | 5 | # 6 | # document 7 | # 8 | # check for errors in inputs and give meaningful messages 9 | # - e.g. sigma missing for lmer 10 | # 11 | 12 | makeMer <- function(formula, family, fixef, VarCorr, sigma, data, dataName) { 13 | 14 | if(length(formula) < 3) stop("Formula must have left and right hand side") 15 | 16 | lhs <- make.names(deparse(formula[[2]])); formula[[2]] <- as.name(lhs) 17 | rhs <- formula[-2] 18 | 19 | p <- list(beta=fixef, theta=calcTheta(VarCorr)) 20 | if(!missing(sigma)) p$sigma <- sigma 21 | 22 | if(!(lhs %in% names(data))) { 23 | 24 | suppressMessages( 25 | y <- simulate(rhs, nsim=1, family=family, newparams=p, newdata=data)[[1]] 26 | ) 27 | 28 | data[[lhs]] <- y 29 | } 30 | 31 | environment(formula) <- environment() # https://github.com/lme4/lme4/issues/177 32 | 33 | theta <- calcTheta(VarCorr, sigma) 34 | 35 | suppressWarnings( 36 | if(identical(family, "gaussian")) { 37 | 38 | rval <- lmer(formula, data=data, control=lmerSet(theta)) 39 | 40 | } else { 41 | 42 | rval <- glmer(formula, family=family, data=data, control=glmerSet(theta)) 43 | rval@call$family <- rval@resp$family$family 44 | } 45 | ) 46 | 47 | fixef(rval) <- fixef 48 | VarCorr(rval) <- VarCorr 49 | if(!missing(sigma)) sigma(rval) <- sigma 50 | 51 | attr(rval, "newData") <- data 52 | rval@call$data <- parse(text=dataName)[[1]] 53 | 54 | rval@call$control <- NULL 55 | 56 | attr(rval, "simrTag") <- TRUE 57 | 58 | if(dataName=="rval") { 59 | 60 | .rval <- rval 61 | assign(dataName, data) 62 | return(.rval) 63 | 64 | } else { 65 | 66 | assign(dataName, data) 67 | return(rval) 68 | } 69 | } 70 | 71 | 72 | #' Create an artificial mixed model object 73 | #' 74 | #' Make a \code{\link[lme4]{merMod}} object with the specified structure and parameters. 75 | #' 76 | #' @param formula a formula describing the model (see \code{\link[lme4]{glmer}}). 77 | #' @param family type of response variable (see \code{\link{family}}). 78 | #' @param fixef vector of fixed effects 79 | #' @param VarCorr variance and covariances for random effects. 80 | #' If there are multiple random effects, supply their parameters as a list. 81 | #' @param sigma residual standard deviation. 82 | #' @param data \code{data.frame} of explanatory variables. 83 | #' 84 | #' @export 85 | makeGlmer <- function(formula, family, fixef, VarCorr, data) { 86 | 87 | makeMer(formula, family, fixef, VarCorr, , data, deparse(substitute(data))) 88 | } 89 | 90 | #' @rdname makeGlmer 91 | #' @export 92 | makeLmer <- function(formula, fixef, VarCorr, sigma, data) { 93 | 94 | makeMer(formula, "gaussian", fixef, VarCorr, sigma, data, deparse(substitute(data))) 95 | } 96 | 97 | 98 | # 99 | # We need to make merMod objects but we don't need to fit them because we're supplying the parameters 100 | # 101 | nullOpt <- function(fn, par, lower, upper, control) { 102 | 103 | theta <- control$theta 104 | if(is.null(theta)) theta <- rep(1, length(par)) 105 | 106 | rval <- list( 107 | fval = fn(theta), 108 | par = theta, 109 | convergence = 0, 110 | message = "No optimisation", 111 | control = list() 112 | ) 113 | 114 | # calling the deviance function updates its environment 115 | rval$fval <- fn(rval$par) 116 | 117 | return(rval) 118 | } 119 | 120 | lmerSet <- function(theta) lmerControl( 121 | 122 | optimizer=nullOpt, 123 | optCtrl=list(theta=theta), 124 | restart_edge=FALSE, 125 | boundary.tol=0, 126 | calc.derivs=FALSE 127 | ) 128 | 129 | glmerSet <- function(theta) glmerControl( 130 | 131 | optimizer=nullOpt, 132 | optCtrl=list(theta=theta), 133 | restart_edge=FALSE, 134 | boundary.tol=0, 135 | calc.derivs=FALSE 136 | ) 137 | 138 | # logic from stats::glm 139 | as.family <- function(family) { 140 | 141 | if(is.character(family)) { 142 | 143 | family <- get(family, mode = "function", envir = parent.frame(2)) 144 | family <- family() 145 | } 146 | 147 | if(is.function(family)) { 148 | 149 | family <- family() 150 | } 151 | 152 | if(is.null(family$family)) { 153 | 154 | stop("'family' not recognized") 155 | } 156 | 157 | return(family) 158 | } 159 | -------------------------------------------------------------------------------- /R/oops.R: -------------------------------------------------------------------------------- 1 | #' Recover an unsaved simulation 2 | #' 3 | #' Simulations can take a non-trivial time to run. If the user forgets to assign 4 | #' the result to a variable this method can recover it. 5 | #' 6 | #' @examples 7 | #' fm1 <- lmer(y ~ x + (1|g), data=simdata) 8 | #' powerSim(fm1, nsim=10) 9 | #' ps1 <- lastResult() 10 | #' 11 | #' @seealso \code{\link[base]{.Last.value}} 12 | #' 13 | #' @export 14 | lastResult <- function() { 15 | 16 | if(exists("lastResult", envir=.simrLastResult)) return(get("lastResult", envir=.simrLastResult)) 17 | 18 | stop("No result available to recover.") 19 | } 20 | 21 | .simrLastResult <- new.env(parent=emptyenv()) 22 | 23 | -------------------------------------------------------------------------------- /R/options.R: -------------------------------------------------------------------------------- 1 | # 2 | # Default settings. 3 | # 4 | 5 | .simrOptions <- new.env(parent=emptyenv()) 6 | 7 | .simrOptions $ nsim <- 1000 8 | .simrOptions $ alpha <- 0.05 9 | .simrOptions $ progress <- TRUE 10 | .simrOptions $ binom <- "exact" 11 | .simrOptions $ pbnsim <- 100 12 | .simrOptions $ pcmin <- 3 13 | .simrOptions $ pcmax <- 10 14 | .simrOptions $ observedPowerWarning <- TRUE 15 | .simrOptions $ carTestType <- "II" 16 | .simrOptions $ lmerTestDdf <- "Satterthwaite" 17 | .simrOptions $ lmerTestType <- 2 18 | 19 | #' Options Settings for \code{simr} 20 | #' 21 | #' Control the default behaviour of \code{simr} analyses. 22 | #' 23 | #' @param ... a list of names to get options, or a named list of new values to set options. 24 | #' @param opt option name (character string). 25 | #' 26 | #' @return 27 | #' 28 | #' \code{getSimrOption} returns the current value for the option \code{x}. 29 | #' 30 | #' \code{simrOptions} returns 31 | #' 32 | #' \enumerate{ 33 | #' \item a named list of all options, if no arguments are given. 34 | #' \item a named list of specified options, if a list of option names is given. 35 | #' \item (invisibly) a named list of changed options with their previous values, if options are set. 36 | #' } 37 | #' 38 | #' @section Options in \code{simr}: 39 | #' 40 | #' Options that can be set with this method (and their default values). 41 | #' 42 | #' \describe{ 43 | #' \item{\code{nsim}}{default number of simulations (\code{1000}).} 44 | #' \item{\code{alpha}}{default confidence level (\code{0.05}).} 45 | #' \item{\code{progress}}{use progress bars during calculations (\code{TRUE}).} 46 | #' \item{\code{binom}}{method for calculating confidence intervals (\code{"exact"}).} 47 | #' \item{\code{pbnsim}}{number of simulations for parametric bootstrap tests using \code{pbkrtest} (\code{100}).} 48 | #' \item{\code{pcmin}}{minimum number of levels for the smallest point on a \code{\link{powerCurve}} (3).} 49 | #' \item{\code{pcmax}}{maximum number of points on the default \code{\link{powerCurve}} (10).} 50 | #' \item{\code{observedPowerWarning}}{warn if an unmodified fitted model is used (TRUE).} 51 | #' \item{\code{carTestType}}{ type of test, i.e. type of sum of squares, for tests performed with \code{\link[=Anova]{car::Anova}} (\code{"II"}).} 52 | #' \item{\code{lmerTestDdf}}{ approximation to use for denominator degrees of 53 | #' freedom for tests performed with 54 | #' \code{\link[lmerTest:lmer]{lmerTest}} 55 | #' (\code{"Satterthwaite"}). Note that setting this 56 | #' option to \code{"lme4"} will reduce the 57 | #' \code{lmerTest} model to an \code{lme4} model and 58 | #' break functionality based on \code{lmerTest}.} 59 | #' \item{\code{lmerTestType}}{ type of test, i.e. type of sum of squares, for 60 | #' F-tests performed with 61 | #' \code{\link[lmerTest:anova.lmerModLmerTest]{lmerTest::anova.lmerModLmerTest}} 62 | #' (\code{2}). Note that unlike the tests performed 63 | #' with \code{car::Anova}, the test type must be 64 | #' given as a number and not a character.} 65 | #' 66 | #' } 67 | #' 68 | #' @examples 69 | #' 70 | #' getSimrOption("nsim") 71 | #' oldopts <- simrOptions(nsim=5) 72 | #' getSimrOption("nsim") 73 | #' simrOptions(oldopts) 74 | #' getSimrOption("nsim") 75 | #' 76 | #' @export 77 | simrOptions <- function(...) { 78 | 79 | args <- list(...) 80 | 81 | # Case 1: empty list; return all options. 82 | if(length(args) == 0) return(as.list(.simrOptions)) 83 | 84 | # Case 2: unnamed list ... 85 | if(is.null(names(args))) { 86 | 87 | # Case 2a: single argument which is a list; use do.call. 88 | if(length(args) == 1 && is.list(args[[1]])) return(do.call(simrOptions, args[[1]])) 89 | 90 | # Case 2b: must be a list of characters; return specified options. 91 | optNames <- unlist(args) 92 | if(!is.character(optNames)) stop("not a list of option names") 93 | for(n in optNames) if(!(n %in% ls(.simrOptions))) stop(str_c("no option to get named ", n)) 94 | return(mget(optNames, envir=.simrOptions)) 95 | } 96 | 97 | # must be either unnamed or fully named 98 | if(any(nchar(names(args))==0)) stop("cannot get and set options at the same time") 99 | 100 | # Case 3: named list; set options. 101 | for(n in names(args)) if(!n %in% ls(.simrOptions)) stop(str_c("no option to set named ", n)) 102 | 103 | oldOptions <- mget(names(args), envir=.simrOptions) 104 | mapply(assign, names(args), args, MoreArgs=list(envir=.simrOptions)) 105 | invisible(oldOptions) 106 | } 107 | 108 | #' @export 109 | #' @rdname simrOptions 110 | getSimrOption <- function(opt) simrOptions(opt)[[1]] 111 | 112 | -------------------------------------------------------------------------------- /R/powerCurve.R: -------------------------------------------------------------------------------- 1 | #' Estimate power at a range of sample sizes. 2 | #' 3 | #' This function runs \code{\link{powerSim}} over a range of sample sizes. 4 | #' 5 | #' @param fit a fitted model object (see \code{\link{doFit}}). 6 | #' @param test specify the test to perform. By default, the first fixed effect in \code{fit} will be tested. 7 | #' (see: \link{tests}). 8 | #' @param sim an object to simulate from. By default this is the same as \code{fit} (see \code{\link{doSim}}). 9 | #' @param along the name of an explanatory variable. This variable will have its number of levels varied. 10 | #' @param within names of grouping variables, separated by "+" or ",". Each combination of groups will be 11 | #' extended to \code{n} rows. 12 | #' @param breaks number of levels of the variable specified by \code{along} at each point on the power curve. 13 | #' @param seed specify a random number generator seed, for reproducible results. 14 | #' @param fitOpts extra arguments for \code{\link{doFit}}. 15 | #' @param testOpts extra arguments for \code{\link{doTest}}. 16 | #' @param simOpts extra arguments for \code{\link{doSim}}. 17 | #' @param ... any additional arguments are passed on to \code{\link{simrOptions}}. Common options include: 18 | #' \describe{ 19 | #' \item{\code{nsim}:}{the number of simulations to run (default is \code{1000}).} 20 | #' \item{\code{alpha}:}{the significance level for the statistical test (default is \code{0.05}).} 21 | #' \item{\code{progress}:}{use progress bars during calculations (default is \code{TRUE}).} 22 | #' } 23 | #' 24 | #' @examples 25 | #' \dontrun{ 26 | #' fm <- lmer(y ~ x + (1|g), data=simdata) 27 | #' pc1 <- powerCurve(fm) 28 | #' pc2 <- powerCurve(fm, breaks=c(4,6,8,10)) 29 | #' print(pc2) 30 | #' plot(pc2) 31 | #' } 32 | #' 33 | #' @seealso \code{\link{print.powerCurve}}, \code{\link{summary.powerCurve}}, \code{\link{confint.powerCurve}} 34 | #' 35 | #' @export 36 | powerCurve <- function( 37 | 38 | fit, 39 | test = fixed(getDefaultXname(fit)), 40 | sim = fit, 41 | 42 | along = getDefaultXname(fit), 43 | within, 44 | breaks, 45 | 46 | seed, 47 | 48 | fitOpts = list(), 49 | testOpts = list(), 50 | simOpts = list(), 51 | 52 | ... 53 | 54 | ) { 55 | 56 | opts <- simrOptions(...) 57 | on.exit(simrOptions(opts)) 58 | 59 | # START TIMING 60 | start <- proc.time() 61 | 62 | nsim <- getSimrOption("nsim") 63 | if(!missing(seed)) set.seed(seed) 64 | 65 | # auto subsetting 66 | 67 | data <- getData(sim) 68 | 69 | if(!missing(along) && !missing(within)) stop("Only one of along and within may be used.") 70 | 71 | if(!missing(within)) { 72 | 73 | data <- addReplicateIndex(data, within) 74 | along <- ".simr_repl" 75 | } 76 | 77 | x <- with(data, get(along)) 78 | targets <- sort(unique(x)) 79 | 80 | # refactor into new function? 81 | if(along == ".simr_repl") { 82 | 83 | xlab <- str_c("number of observations within ", within) 84 | xval <- seq_along(targets) 85 | 86 | } else { 87 | 88 | if(is.factor(x)) { 89 | 90 | xlab <- str_c("number of levels in ", along) 91 | xval <- seq_along(targets) 92 | 93 | } else { 94 | 95 | xlab <- str_c("largest value of ", along) 96 | xval <- targets 97 | } 98 | } 99 | 100 | if(missing(breaks)) { 101 | 102 | breaks <- tidySeq(getSimrOption("pcmin"), length(targets), getSimrOption("pcmax")) 103 | } 104 | xval <- xval[breaks] 105 | 106 | ss_list <- llply(breaks, function(z) x %in% head(targets, z)) 107 | 108 | msg <- if(along==".simr_repl") { 109 | str_c("Calculating power at ", length(ss_list), " sample sizes within ", within) 110 | } else str_c("Calculating power at ", length(ss_list), " sample sizes along ", along) 111 | 112 | if(getSimrOption("progress")) message(msg) 113 | 114 | simulations <- maybe_llply(seq_len(nsim), function(.) doSim(sim), .text="Simulating") 115 | 116 | psF <- function(ss) { 117 | 118 | powerSim( 119 | fit=fit, 120 | test=test, 121 | sim=iter(simulations$value), 122 | fitOpts=c(list(subset=ss), fitOpts), 123 | testOpts=testOpts, simOpts=simOpts 124 | ) 125 | } 126 | 127 | psList <- maybe_llply(ss_list, psF, .progress=counter_simr(), .text="powerCurve", .extract=TRUE) 128 | 129 | # END TIMING 130 | timing <- proc.time() - start 131 | 132 | z <- list( 133 | ps = psList$value, 134 | alpha = getSimrOption("alpha"), 135 | text = attr(test, "text")(fit, sim), 136 | along = along, 137 | warnings = psList$warnings, 138 | errors = psList$errors, 139 | nlevels = breaks, 140 | simrTag = observedPowerWarning(sim), 141 | xlab = xlab, 142 | xval = xval, 143 | timing = timing 144 | ) 145 | 146 | rval <- structure(z, class="powerCurve") 147 | 148 | .simrLastResult $ lastResult <- rval 149 | 150 | return(rval) 151 | } 152 | 153 | # 154 | # Function to calculate tidy subset breaks 155 | # 156 | 157 | tidySeq <- function(from=getSimrOption("pcmin"), to, maxLength=getSimrOption("pcmax")) { 158 | 159 | if(to < from) return(to) 160 | 161 | if(to - from + 1 <= maxLength) return(seq(from, to)) 162 | 163 | round(seq(from, to, length=maxLength)) 164 | } 165 | -------------------------------------------------------------------------------- /R/powerPlot.R: -------------------------------------------------------------------------------- 1 | 2 | powerPlot <- function(z, x, n, col=lcrblue, bg=lighten(col), add=FALSE, join=TRUE, xlab) { 3 | 4 | # Confidence intervals 5 | ci <- binom.confint(x, n, 0.95, "logit") 6 | 7 | # Plot 8 | plotx <- z $ xval 9 | ploty <- x/n 10 | 11 | plotCI(plotx, ploty, ylim=c(0,1), ui=ci$upper, li=ci$lower, 12 | xlab=xlab, 13 | ylab="power", 14 | yaxt="n", yaxs="i", 15 | col=col, pch=21, add=add, cex.lab=1) 16 | 17 | axisy <- seq(0, 1, 0.2) 18 | axis(2, at=axisy, labels=str_c(pretty(axisy) * 100, '%'), las=TRUE, cex.lab=2) 19 | 20 | #abline(h=0) 21 | #abline(h=1) 22 | 23 | # Decoration 24 | if(join) lines(plotx, ploty, col=alpha(col, 0.75), lwd=2, lty=4) 25 | points(plotx, ploty, col=col, bg=bg, pch=21, xpd=TRUE) 26 | 27 | } 28 | 29 | 30 | #' @export 31 | plot.powerCurve <- function(x, alpha=x$alpha, power=0.80, xlab=x$xlab, ...) { 32 | 33 | pal <- getPalette(length(alpha)) 34 | 35 | for(i in seq_along(alpha)) { 36 | 37 | y <- sapply(x$ps, function(ps) sum(ps$pval < alpha[[i]], na.rm=TRUE)) 38 | n <- sapply(x$ps, "[[", "n") 39 | 40 | powerPlot(x, y, n, add=(i!=1), col=pal[[i]], xlab=xlab, ...) 41 | } 42 | 43 | if(is.numeric(power)) abline(h=power, lty=2) 44 | if(length(alpha) > 1) legend('topleft', col=pal, pt.bg=lighten(pal), pch=21, legend=alpha, bg='white') 45 | } 46 | -------------------------------------------------------------------------------- /R/powerSim.R: -------------------------------------------------------------------------------- 1 | #' Estimate power by simulation. 2 | #' 3 | #' Perform a power analysis for a mixed model. 4 | #' 5 | #' @param fit a fitted model object (see \code{\link{doFit}}). 6 | #' @param test specify the test to perform. By default, the first fixed effect in \code{fit} will be tested. 7 | #' (see: \link{tests}). 8 | #' @param sim an object to simulate from. By default this is the same as \code{fit} (see \code{\link{doSim}}). 9 | #' @param seed specify a random number generator seed, for reproducible results. 10 | #' @param fitOpts extra arguments for \code{\link{doFit}}. 11 | #' @param testOpts extra arguments for \code{\link{doTest}}. 12 | #' @param simOpts extra arguments for \code{\link{doSim}}. 13 | #' @param ... any additional arguments are passed on to \code{\link{simrOptions}}. Common options include: 14 | #' \describe{ 15 | #' \item{\code{nsim}:}{the number of simulations to run (default is \code{1000}).} 16 | #' \item{\code{alpha}:}{the significance level for the statistical test (default is \code{0.05}).} 17 | #' \item{\code{progress}:}{use progress bars during calculations (default is \code{TRUE}).} 18 | #' } 19 | #' @examples 20 | #' fm1 <- lmer(y ~ x + (1|g), data=simdata) 21 | #' powerSim(fm1, nsim=10) 22 | #' 23 | #' @seealso \code{\link{print.powerSim}}, \code{\link{summary.powerSim}}, \code{\link{confint.powerSim}} 24 | #' @export 25 | powerSim <- function( 26 | 27 | fit, 28 | test = fixed(getDefaultXname(fit)), 29 | sim = fit, 30 | 31 | fitOpts = list(), 32 | testOpts = list(), 33 | simOpts = list(), 34 | 35 | seed, 36 | 37 | ... 38 | 39 | ) { 40 | 41 | opts <- simrOptions(...) 42 | on.exit(simrOptions(opts)) 43 | 44 | nsim <- getSimrOption("nsim") 45 | alpha <- getSimrOption("alpha") 46 | nrow <- NA 47 | 48 | # START TIMING 49 | start <- proc.time() 50 | 51 | # setup 52 | if(!missing(seed)) set.seed(seed) 53 | 54 | # summarise the fitted models 55 | test <- wrapTest(test) 56 | #p <- maybe_laply(z, test, .text="Testing") 57 | 58 | f <- function() { 59 | 60 | # y <- doSim(sim, [opts]) 61 | tag(y <- do.call(doSim, c(list(sim), simOpts)), tag="Simulating") 62 | 63 | # how many rows? 64 | ss <- fitOpts$subset 65 | nrow <<- length(if(is.null(ss)) y else y[ss]) 66 | 67 | # fit <- doFit(y, fit, [opts]) 68 | tag(z <- do.call(doFit, c(list(y, fit), fitOpts)), tag="Fitting") 69 | 70 | # doTest(fit, test, [opts]) 71 | tag(pval <- do.call(doTest, c(list(z, test), testOpts)), tag="Testing") 72 | 73 | return(pval) 74 | } 75 | 76 | p <- maybe_raply(nsim, f(), .text="Simulating") 77 | 78 | # END TIMING 79 | timing <- proc.time() - start 80 | 81 | # structure the return value 82 | rval <- list() 83 | 84 | rval $ x <- sum(p$value < alpha, na.rm=TRUE) 85 | rval $ n <- nsim 86 | 87 | #rval $ xname <- xname 88 | #rval $ effect <- fixef(sim)[xname] # can't guarantee this is available? 89 | 90 | rval $ text <- attr(test, "text")(fit, sim) 91 | rval $ description <- attr(test, "description")(fit, sim) 92 | 93 | rval $ pval <- p$value 94 | 95 | rval $ alpha <- alpha 96 | rval $ nrow <- nrow 97 | 98 | rval $ warnings <- p$warnings 99 | rval $ errors <- p$errors 100 | 101 | rval $ timing <- timing 102 | rval $ simrTag <- observedPowerWarning(sim) 103 | 104 | class(rval) <- "powerSim" 105 | 106 | .simrLastResult $ lastResult <- rval 107 | 108 | return(rval) 109 | } 110 | 111 | #' @export 112 | plot.powerSim <- function(x, ...) stop("Not yet implemented.") 113 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | # 2 | # print, summary, and confint for powerSim and powerCurve objects 3 | # 4 | # nb: plot function are in powerPlot.R 5 | # 6 | #' Report simulation results 7 | #' 8 | #' Describe and extract power simulation results 9 | #' 10 | #' @param x a \code{\link{powerSim}} or \code{\link{powerCurve}} object 11 | #' @param object a \code{\link{powerSim}} or \code{\link{powerCurve}} object 12 | #' @param parm currently ignored, included for S3 compatibility with \code{\link[=confint]{stats::confint}} 13 | #' @param alpha the significance level for the statistical test (default is that used in the call to \code{powerSim}). 14 | #' @param level confidence level for power estimate 15 | #' @param method method to use for computing binomial confidence intervals (see \code{\link[=binom.confint]{binom::binom.confint()}}) 16 | #' @param ... additional arguments to pass to \code{\link[=binom.confint]{binom::binom.confint()}} 17 | #' 18 | #' \code{alpha} refers to the threshold for an effect being significant and 19 | #' thus directly determines the point estimate for the power calculation. 20 | #' \code{level} is the confidence level that is calculated for this point 21 | #' evidence and determines the width/coverage of the confidence interval for 22 | #' power. 23 | #' @seealso \code{\link[=binom.confint]{binom::binom.confint}}, \code{\link{powerSim}}, \code{\link{powerCurve}} 24 | #' @export 25 | print.powerSim <- function(x, alpha=x$alpha, level=0.95, ...) { 26 | 27 | cat(x$text) 28 | cat(paste0(", (",level*100,"% confidence interval):\n ")) 29 | printerval(x, alpha=alpha, level=level, ...) 30 | cat("\n\n") 31 | 32 | pad <- "Test: " 33 | for(text in x$description) { 34 | cat(pad); pad <- " " 35 | cat(text) 36 | cat("\n") 37 | } 38 | cat("\n") 39 | 40 | #cat(sprintf("Based on %i simulations and effect size %.2f", z$n, z$effect)) 41 | cat(sprintf("Based on %i simulations, ", x$n)) 42 | wn <- length(unique(x$warnings$index)) ; en <- length(unique(x$errors$index)) 43 | wstr <- str_c(wn, " ", if(wn==1) "warning" else "warnings") 44 | estr <- str_c(en, " ", if(en==1) "error" else "errors") 45 | cat(str_c("(", wstr, ", ", estr, ")")) 46 | cat("\n") 47 | 48 | cat("alpha = ", alpha, ", nrow = ", x$nrow, sep="") 49 | cat("\n") 50 | 51 | time <- x$timing['elapsed'] 52 | cat(sprintf("\nTime elapsed: %i h %i m %i s\n", floor(time/60/60), floor(time/60) %% 60, floor(time) %% 60)) 53 | 54 | if(x$simrTag) cat("\nnb: result might be an observed power calculation\n") 55 | } 56 | 57 | #' @rdname print.powerSim 58 | #' @export 59 | print.powerCurve <- function(x, ...) { 60 | 61 | cat(x$text) 62 | cat(", (95% confidence interval),\n") 63 | 64 | #l_ply(x$pa, function(x) {printerval(x);cat("\n")}) 65 | cat("by ", x$xlab, ":\n", sep="") 66 | for(i in seq_along(x$ps)) { 67 | 68 | cat(sprintf("%7s: ", x$xval[i])) 69 | printerval(x$ps[[i]], ...) 70 | cat(" -", x$ps[[i]]$nrow, "rows") 71 | cat("\n") 72 | } 73 | 74 | time <- x$timing['elapsed'] 75 | cat(sprintf("\nTime elapsed: %i h %i m %i s\n", floor(time/60/60), floor(time/60) %% 60, floor(time) %% 60)) 76 | } 77 | 78 | #' @rdname print.powerSim 79 | #' @export 80 | summary.powerSim <- function(object, alpha=object$alpha, level=0.95, method=getSimrOption("binom"), ...) { 81 | 82 | x <- sum(object$pval < alpha, na.rm=TRUE) 83 | n <- object$n 84 | 85 | power <- binom.confint(x, n, conf.level=level, methods=method, ...)[c("mean", "lower", "upper")] 86 | 87 | rval <- cbind(successes=x, trials=n, power) 88 | 89 | class(rval) <- c("summary.powerSim", class(rval)) 90 | 91 | return(rval) 92 | } 93 | 94 | #' @rdname print.powerSim 95 | #' @export 96 | summary.powerCurve <- function(object, alpha=object$alpha, level=0.95, method=getSimrOption("binom"), ...) { 97 | 98 | rval <- ldply(object$ps, summary, alpha=alpha, level=level, method=method) 99 | rval <- cbind(nrow=sapply(object$ps, `[[`, "nrow"), nlevels=object$nlevels, rval) 100 | 101 | class(rval) <- c("summary.powerCurve", class(rval)) 102 | 103 | return(rval) 104 | } 105 | 106 | #' @rdname print.powerSim 107 | #' @export 108 | confint.powerSim <- function(object, parm, level=0.95, method=getSimrOption("binom"), alpha=object$alpha, ...) { 109 | 110 | x <- sum(object$pval < alpha, na.rm=TRUE) 111 | n <- object$n 112 | 113 | rval <- binom.confint(x, n, conf.level=level, methods=method, ...)[c("lower", "upper")] 114 | 115 | rval <- as.matrix(rval) 116 | levelNames <- paste(format(100 * c((1-level)/2, 1-(1-level)/2), trim=TRUE, scientific=FALSE, digits=3), "%") 117 | dimnames(rval) <- list("power", levelNames) 118 | 119 | return(rval) 120 | } 121 | 122 | #' @rdname print.powerSim 123 | #' @export 124 | confint.powerCurve <- function(object, parm, level=0.95, method=getSimrOption("binom"), ...) { 125 | 126 | rval <- do.call(rbind, lapply(object$ps, confint, ...)) 127 | row.names(rval) <- object$xval 128 | 129 | return(rval) 130 | } 131 | 132 | printerval <- function(object, alpha=object$alpha, level=0.95, method=getSimrOption("binom"), ...) { 133 | 134 | x <- sum(object$pval < alpha, na.rm=TRUE) 135 | n <- object$n 136 | 137 | # check for NA 138 | if(is.na(x) || is.na(n) || (n==0)) { 139 | 140 | cat("") 141 | return() 142 | } 143 | 144 | interval <- binom.confint(x, n, level, method, ...)[c("mean", "lower", "upper")] 145 | cat(as.percentage(interval)) 146 | } 147 | 148 | # vectorised, w/ % sign 149 | as.percentage1 <- function(x) ifelse(is.na(x), "", ifelse(x==1, "100.0%", sprintf("%5.2f%%", 100*x))) 150 | 151 | # vecorised, no % sign 152 | as.percentage2 <- function(x) ifelse(is.na(x), "", ifelse(x==1, "100.0", sprintf("%5.2f", 100*x))) 153 | 154 | # vectorised x.xx% (x.xx, x.xx) 155 | as.percentage3 <- function(x, y, z) str_c(as.percentage1(x), " (", as.percentage2(y), ", ", as.percentage2(z), ")") 156 | 157 | # 158 | as.percentage <- function(x) as.percentage3(x[1], x[2], x[3]) 159 | -------------------------------------------------------------------------------- /R/progress.R: -------------------------------------------------------------------------------- 1 | .simrCounter <- new.env(parent=emptyenv()) 2 | 3 | progress_simr <- function (text="", ...) { 4 | 5 | set <- function(x) { 6 | 7 | .simrCounter $ xp <- x 8 | updateProgress() 9 | } 10 | 11 | list( 12 | 13 | init = function(N) { 14 | 15 | .simrCounter $ Np <- N 16 | .simrCounter $ text <- text 17 | 18 | set(0) 19 | }, 20 | 21 | step = function() { 22 | 23 | x <- .simrCounter $ xp 24 | N <- .simrCounter $ Np 25 | 26 | set(min(x+1, N)) 27 | }, 28 | 29 | term = function() { 30 | 31 | rm(xp, Np, text, envir=.simrCounter) 32 | 33 | if(exists("xc", .simrCounter)) updateProgress() else done() 34 | } 35 | ) 36 | } 37 | 38 | 39 | counter_simr <- function() { 40 | 41 | set <- function(n) { 42 | 43 | .simrCounter $ xc <- n 44 | updateProgress() 45 | } 46 | 47 | list( 48 | 49 | init = function(N) { 50 | 51 | .simrCounter $ Nc <- N 52 | set(1) 53 | }, 54 | 55 | step = function() { 56 | 57 | x <- .simrCounter $ xc 58 | N <- .simrCounter $ Nc 59 | 60 | set(min(x+1, N)) 61 | }, 62 | 63 | term = function() { 64 | 65 | rm(xc, Nc, envir=.simrCounter) 66 | 67 | done() 68 | } 69 | ) 70 | } 71 | 72 | updateProgress <- function() { 73 | 74 | sc <- .simrCounter 75 | 76 | # build "(xc/Nc)" 77 | counter <- if(exists("xc", sc)) { 78 | 79 | str_c("(", str_pad(sc$xc, str_length(sc$Nc)), "/", sc$Nc, ") ") 80 | 81 | } else "" 82 | 83 | # build "Text: |=== |" 84 | progress <- if(exists("xp", sc)) { 85 | 86 | title <- if(sc$text == "") "" else str_c(sc$text, ": ") 87 | 88 | fullwidth <- getOption("width") 89 | width <- fullwidth - str_length(counter) - str_length(title) - 2L 90 | nbar <- trunc(sc$xp * width / sc$Np) 91 | 92 | str_c(title, "|", str_dup("=", nbar), str_dup(" ", width-nbar), "|") 93 | 94 | } else "" 95 | 96 | # combine 97 | newcounter <- str_c(counter, progress) 98 | 99 | # print 100 | 101 | if(!exists("oldcounter", sc)) { 102 | 103 | maybecat(newcounter) 104 | flush.console() 105 | } 106 | 107 | if(exists("oldcounter", sc) && newcounter != sc$oldcounter) { 108 | 109 | maybecat(str_dup("\b", str_length(sc$oldcounter))) 110 | maybecat(newcounter) 111 | flush.console() 112 | } 113 | 114 | sc $ oldcounter <- newcounter 115 | } 116 | 117 | maybecat <- function(...) if(getSimrOption("progress")) cat(..., sep="") 118 | 119 | done <- function() { 120 | 121 | maybecat(str_dup("\b", str_length(.simrCounter $ oldcounter))) 122 | flush.console() 123 | 124 | rm(list=ls(.simrCounter), envir=.simrCounter) 125 | } 126 | -------------------------------------------------------------------------------- /R/simr.R: -------------------------------------------------------------------------------- 1 | #' simr: Simulation-based power calculations for mixed models. 2 | #' 3 | #' \code{simr} is a package that makes it easy to run simulation-based power analyses 4 | #' with \code{lme4}. 5 | #' 6 | #' @docType package 7 | #' @name simr-package 8 | NULL 9 | 10 | #' @import lme4 11 | #' @import binom 12 | #' @import iterators 13 | #' @import pbkrtest 14 | #' @import plotrix 15 | #' @import plyr 16 | #' @import RLRsim 17 | #' @import stringr 18 | #' @import stats 19 | #' @import methods 20 | #' @import utils 21 | #' @import graphics 22 | #' @import grDevices 23 | #' @import car 24 | NULL 25 | 26 | #' Example dataset. 27 | #' 28 | #' A simple artificial data set used in the tutorial. There are two response variables, 29 | #' a Poisson count \code{z} and a Gaussian response \code{y}. There is a continuous predictor 30 | #' \code{x} with ten values \code{\{1,2,...,10\}} and a categorical predictor \code{g} with 31 | #' three levels \code{\{a, b, c\}}. 32 | #' 33 | #' @name simdata 34 | #' @docType data 35 | NULL 36 | 37 | # suppress weird R CMD check NOTEs 38 | if(getRversion() >= "2.15.1") globalVariables(c("xc", "Nc", "xp", "Np"), package="simr") 39 | -------------------------------------------------------------------------------- /R/testLibrary.R: -------------------------------------------------------------------------------- 1 | #' Specify a statistical test to apply 2 | #' 3 | #' @name tests 4 | #' @rdname tests 5 | #' 6 | #' @param xname an explanatory variable to test (character). 7 | #' @param model a null model for comparison (formula). 8 | #' @param method the type of test to apply (see Details). 9 | #' 10 | #' @details 11 | #' 12 | #' \describe{ 13 | #' \item{\code{fixed}:}{ 14 | #' Test a single fixed effect, specified by \code{xname}.} 15 | #' \item{\code{compare}:}{ 16 | #' Compare the current model to a smaller one specified by the formula \code{model}.} 17 | #' \item{\code{fcompare}, \code{rcompare}:}{ 18 | #' Similar to \code{compare}, but only the fixed/random part of the formula needs to be supplied.} 19 | #' \item{\code{random}:}{ 20 | #' Test the significance of a single random effect.} 21 | #' } 22 | #' 23 | #' @section Methods: 24 | #' 25 | #' The \code{method} argument can be used to specify one of the following tests. 26 | #' Note that \code{"z"} is an asymptotic approximation for models not fitted 27 | #' with \code{\link[lme4]{glmer}} and \code{"kr"} will only work with models 28 | #' fitted with \code{\link[lme4]{lmer}}. 29 | #' 30 | #' \describe{ 31 | #' \item{\code{z}:}{ 32 | #' Z-test for models fitted with \code{\link[lme4]{glmer}} (or \code{\link{glm}}), 33 | #' using the p-value from \code{\link[=summary.merMod]{summary}}. 34 | #' For models fitted with \code{\link[lme4]{lmer}}, this test can be used to 35 | #' treat the t-values from \code{\link[=summary.merMod]{summary}} as 36 | #' z-values, which is equivalent to assuming infinite degrees of freedom. 37 | #' This asymptotic approximation seems to perform well for even medium-sized 38 | #' data sets, as the denominator degrees of freedom are already quite large 39 | #' (cf. Baayen et al. 2008) even if calculating their exact value is 40 | #' analytically unsolved and computationally difficult (e.g. with 41 | #' Satterthwaite or Kenward-Roger approximations). Setting 42 | #' \code{alpha=0.045} is roughly equal to the t=2 threshold suggested by 43 | #' Baayen et al. (2008) and helps compensate for the slightly 44 | #' anti-conservative approximation.} 45 | #' \item{\code{t}:}{ 46 | #' T-test for models fitted with \code{\link{lm}}. Also available for mixed models 47 | #' when \code{\link[lmerTest]{lmerTest}} is installed, using the p-value calculated 48 | #' using the Satterthwaite approximation for the denominator degrees of 49 | #' freedom by default. This can be changed by setting \code{lmerTestDdf}, 50 | #' see \code{\link{simrOptions}}.} 51 | #' \item{\code{lr}:}{Likelihood ratio test, using \code{\link[=anova.merMod]{anova}}.} 52 | #' \item{\code{f}:}{ 53 | #' Wald F-test, using \code{\link[=Anova]{car::Anova}}. 54 | #' Useful for examining categorical terms. For models fitted with 55 | #' \code{\link[lme4]{lmer}}, this should yield equivalent results to 56 | #' \code{method='kr'}. Uses Type-II tests by default, this can be changed 57 | #' by setting \code{carTestType}, see \code{\link{simrOptions}}.} 58 | #' \item{\code{chisq}:}{ 59 | #' Wald Chi-Square test, using \code{\link[=Anova]{car::Anova}}. 60 | #' Please note that while this is much faster than the F-test computed with 61 | #' Kenward-Roger, it is also known to be anti-conservative, especially for 62 | #' small samples. Uses Type-II tests by default, this can be changed by 63 | #' setting \code{carTestType}, see \code{\link{simrOptions}}.} 64 | #' \item{\code{anova}:}{ 65 | #' ANOVA-style F-test, using \code{\link{anova}} and 66 | #' \code{\link[lmerTest:anova.lmerModLmerTest]{lmerTest::anova.lmerModLmerTest}}. 67 | #' For `lm`, this yields a Type-I (sequential) test (see \code{\link[=anova.lm]{anova}}); 68 | #' to use other test types, use the F-tests provided by \code{car::Anova()} 69 | #' (see above). For \code{lmer}, this generates Type-II tests with 70 | #' Satterthwaite denominator degrees of freedom by default, this can be 71 | #' changed by setting \code{lmerTestDdf} and \code{lmerTestType}, see 72 | #' \code{\link{simrOptions}}.} 73 | #' \item{\code{kr}:}{ 74 | #' Kenward-Roger test, using \code{\link[pbkrtest]{KRmodcomp}}. 75 | #' This only applies to models fitted with \code{\link[lme4]{lmer}}, and compares models with 76 | #' different fixed effect specifications but equivalent random effects.} 77 | #' \item{\code{pb}:}{ 78 | #' Parametric bootstrap test, using \code{\link[pbkrtest]{PBmodcomp}}. 79 | #' This test will be very accurate, but is also very computationally expensive.} 80 | #' } 81 | #' 82 | #' Tests using \code{random} for a single random effect call \code{\link[RLRsim]{exactRLRT}}. 83 | #' 84 | #' @return 85 | #' 86 | #' A function which takes a fitted model as an argument and returns a single p-value. 87 | #' 88 | #' @examples 89 | #' lm1 <- lmer(y ~ x + (x|g), data=simdata) 90 | #' lm0 <- lmer(y ~ x + (1|g), data=simdata) 91 | #' anova(lm1, lm0) 92 | #' compare(. ~ x + (1|g))(lm1) 93 | #' rcompare(~ (1|g))(lm1) 94 | #' \dontrun{powerSim(fm1, compare(. ~ x + (1|g)))} 95 | #' 96 | #' @references 97 | #' Baayen, R. H., Davidson, D. J., and Bates, D. M. (2008). Mixed-effects modeling 98 | #' with crossed random effects for subjects and items. Journal of Memory and Language, 59, 390--412. 99 | #' 100 | NULL 101 | 102 | ## ---------- 103 | ## 104 | ## User-visible test definition functions. These are suitable for test= arguments. 105 | ## 106 | ## ---------- 107 | 108 | # 109 | # Test a fixed effect 110 | # 111 | #' @rdname tests 112 | #' @export 113 | fixed <- function(xname, method=c("z", "t", "f", "chisq", "anova", "lr", "sa", "kr", "pb")) { 114 | 115 | method <- if(missing(method)) "default" else match.arg(method) 116 | 117 | test <- switch(method, 118 | default = defaulttest, 119 | z = ztest, 120 | t = ttest, 121 | f = waldftest, 122 | lr = lrtest, 123 | chisq = waldchisqtest, 124 | anova = anovatest, 125 | kr = krtest, 126 | sa = satest, 127 | pb = pbtest 128 | ) 129 | 130 | descriptionText <- switch(method, 131 | default = "default", 132 | z = "z-test", 133 | t = "t-test", 134 | f = paste0("Type-",getSimrOption("carTestType"), " F-test (package car)"), 135 | lr = "Likelihood ratio", 136 | chisq = paste0("Type-",getSimrOption("carTestType"), " Chi-Square-test (package car)"), 137 | anova = "F-test", 138 | kr = "Kenward Roger (package pbkrtest)", 139 | sa = "Satterthwait (package lmerTest)", 140 | pb = "Parametric bootstrap (package pbkrtest)" 141 | ) 142 | 143 | description <- fixeddesc(descriptionText, xname) 144 | 145 | rval <- function(.) test(., xname) 146 | 147 | wrapTest(rval, str_c("for predictor '", removeSquiggle(xname), "'"), description) 148 | } 149 | 150 | fixeddesc <- function(text, xname) { 151 | 152 | function(fit, sim) { 153 | 154 | if(text %in% c("t-test") & inherits(fit,"merMod")){ 155 | text <- paste(text,"with",getSimrOption("lmerTestDdf"), 156 | "degrees of freedom (package lmerTest)") 157 | }else if(text %in% c("F-test")){ 158 | if(inherits(fit,"merMod")){ 159 | text <- paste0("Type-", getSimrOption("lmerTestType")," ", text, 160 | " with ",getSimrOption("lmerTestDdf")," degrees of freedom (package lmerTest)") 161 | }else{ 162 | text <- paste("Type-I",text) 163 | } 164 | } 165 | 166 | # test used 167 | rval <- if(text=="default") defaultdesc(fit, xname) else text 168 | 169 | # effect size 170 | fe <- maybe(fixef)(sim)$value 171 | if(!is.null(fe) && xname %in% names(fe)) { 172 | 173 | rval[2] <- sprintf("Effect size for %s is %#.2g", xname, fe[[xname]]) 174 | } 175 | 176 | return(rval) 177 | } 178 | } 179 | 180 | # default fixed effect test 181 | # lm - ttest 182 | # glm - ztest 183 | # lmer - krtest 184 | # glmer - ztest 185 | defaulttest <- function(fit, xname) { 186 | 187 | x <- getData(fit)[[xname]] 188 | 189 | if(is.factor(x) || is.character(x)) { 190 | 191 | return(lrtest(fit, xname)) 192 | } 193 | 194 | switch(class(fit)[1], 195 | 196 | lm = ttest(fit, xname), 197 | glm = ztest(fit, xname), 198 | lmerMod = krtest(fit, xname), 199 | glmerMod = ztest(fit, xname), 200 | stop(str_c("No default test for ", class(fit)[1])) 201 | ) 202 | } 203 | 204 | checkInteractions <- function(fit, xname) { 205 | 206 | ts <- terms(fit) 207 | 208 | order <- attr(ts, "order") 209 | label <- attr(ts, "term.labels") 210 | 211 | xname %in% unlist(str_split(label[order > 1], stringr::fixed(":"))) 212 | } 213 | 214 | defaultdesc <- function(fit, xname) { 215 | 216 | if(is.factor(getData(fit)[[xname]])) return("Likelihood ratio") 217 | 218 | switch(class(fit)[1], 219 | 220 | lm = "t-test", 221 | glm = "z-test", 222 | lmerMod = "Kenward Roger (package pbkrtest)", 223 | glmerMod = "z-test", 224 | "unknown test" 225 | ) 226 | } 227 | 228 | # 229 | # Compare two models 230 | # 231 | #' @rdname tests 232 | #' @export 233 | compare <- function(model, method=c("lr", "pb")) { 234 | 235 | method <- match.arg(method) 236 | 237 | test <- switch(method, 238 | lr = lrcompare, 239 | pb = pbcompare 240 | ) 241 | 242 | description <- switch(method, 243 | lr = "Likelihood ratio", 244 | pb = "Parametric bootstrap (package pbkrtest)" 245 | ) 246 | 247 | rval <- function(fit1) { 248 | 249 | fit2 <- update(fit1, formula(model), evaluate=FALSE) 250 | fit2 <- eval(fit2, envir=environment(formula(fit1))) 251 | 252 | test(fit1, fit2) 253 | } 254 | 255 | description[2] <- str_c("Comparison to ", deparse1(formula(model))) 256 | 257 | wrapTest(rval, "for model comparison", description) 258 | } 259 | 260 | 261 | #' @rdname tests 262 | #' @export 263 | fcompare <- function(model, method=c("lr", "kr", "pb")) { 264 | 265 | method <- match.arg(method) 266 | 267 | test <- switch(method, 268 | lr = lrcompare, 269 | kr = krcompare, 270 | pb = pbcompare 271 | ) 272 | 273 | description <- switch(method, 274 | lr = "Likelihood ratio", 275 | kr = "Kenward-Roger (package pbkrtest)", 276 | pb = "Parametric bootstrap (package pbkrtest)" 277 | ) 278 | 279 | rval <- function(fit1) { 280 | 281 | fe.part <- deparse1(nobars(formula(model))) 282 | re.part <- do.call(str_c, c(llply(findbars(formula(fit1)), function(.) str_c("(", deparse1(.), ")")), sep=" + ")) 283 | 284 | new.formula <- str_c(fe.part, " + ", re.part) 285 | 286 | fit2 <- update(fit1, as.formula(new.formula), evaluate=FALSE) 287 | fit2 <- eval(fit2, envir=environment(formula(fit1))) 288 | 289 | test(fit1, fit2) 290 | } 291 | 292 | description[2] <- str_c("Comparison to ", deparse1(formula(model)), " + [re]") 293 | 294 | wrapTest(rval, "for model comparison", description) 295 | } 296 | 297 | #' @rdname tests 298 | #' @export 299 | rcompare <- function(model, method=c("lr", "pb")) { 300 | 301 | method <- match.arg(method) 302 | 303 | test <- switch(method, 304 | lr = lrcompare, 305 | pb = pbcompare 306 | ) 307 | 308 | description <- switch(method, 309 | lr = "Likelihood ratio", 310 | pb = "Parametric bootstrap (package pbkrtest)" 311 | ) 312 | 313 | rval <- function(fit1) { 314 | 315 | fe.part <- deparse1(nobars(formula(fit1))) 316 | re.part <- laply(findbars(formula(model)), function(.) str_c("(", deparse1(.), ")")) 317 | 318 | new.formula <- str_c(fe.part, " + ", re.part) 319 | 320 | fit2 <- update(fit1, as.formula(new.formula), evaluate=FALSE) 321 | fit2 <- eval(fit2, envir=environment(formula(fit1))) 322 | 323 | test(fit1, fit2) 324 | } 325 | 326 | description[2] <- str_c("Comparison to [fe] + ", deparse1(formula(model))) 327 | 328 | wrapTest(rval, "for model comparison", description) 329 | } 330 | 331 | # 332 | # Single random effects via RLRsim 333 | # 334 | #' @rdname tests 335 | #' @export 336 | random <- function() { 337 | 338 | rval <- function(.) exactRLRT(.)$p.value 339 | rval <- wrapTest(rval, "for a single random effect", "Exact restricted LRT (package RLRsim)") 340 | 341 | return(rval) 342 | } 343 | 344 | ## ---------- 345 | ## 346 | ## Helper functions 347 | ## 348 | ## ---------- 349 | 350 | wrapTest <- function(test, text="[user defined]", description="[user defined function]") { 351 | 352 | if(is.character(text)) { 353 | 354 | this.text <- str_c("Power ", text) 355 | text <- function(...) this.text 356 | } 357 | 358 | if(is.character(description)) { 359 | 360 | this.description <- description 361 | description <- function(...) this.description 362 | } 363 | 364 | if(is.null(attr(test, "text"))) attr(test, "text") <- text 365 | if(is.null(attr(test, "description"))) attr(test, "description") <- description 366 | 367 | return(test) 368 | } 369 | 370 | addSquiggle <- function(x) { 371 | 372 | if(inherits(x, "formula")) return(x) 373 | 374 | if(inherits(x, "character")) { 375 | 376 | return(formula(str_c("~", x))) 377 | } 378 | 379 | stop(str_c("Can't interpret a fixed effect name with class ", class(x)[[1]])) 380 | } 381 | 382 | removeSquiggle <- function(x) { 383 | 384 | if(inherits(x, "character")) return(x) 385 | 386 | if(inherits(x, "formula")) { 387 | 388 | return(deparse1(x[[length(x)]])) 389 | } 390 | 391 | stop(str_c("Can't interpret a fixed effect name with class ", class(x)[[1]])) 392 | } 393 | 394 | ## ---------- 395 | ## 396 | ## Building blocks for fixed effects tests 397 | ## 398 | ## ---------- 399 | 400 | # 401 | # simplest test --- just grab the p-value from the model's summary. 402 | # nb: This will be a z-test (Wald) for glmerMod and glm objects, 403 | # t-test for lm, not available for lmerMod 404 | 405 | ztest <- function(fit, xname) { 406 | 407 | xname <- removeSquiggle(xname) 408 | 409 | if(is_lmerTest(fit)) { 410 | 411 | # block costly ddf calculations for lmerTest fits since we're using 412 | # the asymptotic approximation anyway 413 | a <- lmerTest_summary(fit, ddf="lme4")$coefficients 414 | 415 | } else { 416 | 417 | a <- summary(fit)$coefficients 418 | } 419 | 420 | if(inherits(fit, "lmerMod")) { 421 | 422 | # multiple by 2 for two-tailed test (which is what we want on coefs) 423 | # and we need the absolute value for symmetry 424 | rval <- pnorm(abs(a[xname, "t value"]), lower.tail=FALSE)*2 425 | 426 | } else { 427 | 428 | rval <- a[xname, "Pr(>|z|)"] 429 | } 430 | 431 | return(rval) 432 | } 433 | 434 | ttest <- function(fit, xname) { 435 | 436 | xname <- removeSquiggle(xname) 437 | 438 | if(inherits(fit, "merMod")){ 439 | 440 | if(requireNamespace("lmerTest", quietly=TRUE)) { 441 | 442 | a <- lmerTest_summary(fit, ddf=getSimrOption("lmerTestDdf"))$coefficients 443 | 444 | } else { 445 | 446 | stop("t-tests for lmer models require the lmerTest package") 447 | } 448 | 449 | } else { 450 | 451 | a <- summary(fit)$coefficients 452 | } 453 | 454 | rval <- a[xname, "Pr(>|t|)"] 455 | return(rval) 456 | } 457 | 458 | # 459 | # Wald tests for linear hypotheses using car::Anova() 460 | # 461 | waldftest <- function(fit, xname) { 462 | 463 | if(checkInteractions(fit, xname)) warning("Main effect (", xname, ") was tested but there were interactions.") 464 | 465 | xname <- removeSquiggle(xname) 466 | 467 | if(inherits(fit, "merMod") & !isREML(fit)) { 468 | 469 | warning("F test available only for linear mixed model fit by REML: refitting model with REML.") 470 | fit <- update(fit, REML=TRUE) 471 | } 472 | 473 | a <- Anova(fit,test.statistic="F", type=getSimrOption("carTestType")) 474 | rval <- a[xname, "Pr(>F)"] 475 | 476 | return(rval) 477 | } 478 | 479 | waldchisqtest <- function(fit, xname) { 480 | 481 | if(checkInteractions(fit, xname)) warning("Main effect (", xname, ") was tested but there were interactions.") 482 | 483 | xname <- removeSquiggle(xname) 484 | 485 | a <- Anova(fit, test.statistic="Chisq", type=getSimrOption("carTestType")) 486 | rval <- a[xname, "Pr(>Chisq)"] 487 | 488 | return(rval) 489 | } 490 | 491 | # 492 | # F-tests using anova() and lmerTest::anova() 493 | # 494 | 495 | anovatest <- function(fit, xname){ 496 | 497 | if(checkInteractions(fit, xname)) warning("Main effect (", xname, ") was tested but there were interactions.") 498 | 499 | xname <- removeSquiggle(xname) 500 | 501 | if(inherits(fit,"merMod")) { 502 | 503 | if(is_lmerTest(fit)) { 504 | 505 | # we assume that lmerTest is present, if we have an object of class lmerTest 506 | # no typecast necessary here 507 | a <- lmerTest_anova(fit, ddf=getSimrOption("lmerTestDdf"), type=getSimrOption("lmerTestType")) 508 | 509 | } else { 510 | 511 | if(requireNamespace("lmerTest", quietly=TRUE)) { 512 | 513 | #warning(paste("Using",getSimrOption("lmerTestDdf"),"approximation from lmerTest (casting merMod to merModLmerTest)")) 514 | a <- lmerTest_anova(fit, ddf=getSimrOption("lmerTestDdf"), type=getSimrOption("lmerTestType")) 515 | 516 | } else { 517 | 518 | stop("anova-tests for lmer-fitted models require the lmerTest package") 519 | } 520 | } 521 | 522 | } else { 523 | 524 | a <- anova(fit) 525 | } 526 | 527 | rval <- a[xname, "Pr(>F)"] 528 | 529 | return(rval) 530 | } 531 | 532 | # 533 | # basic likelihood ratio test using drop1 534 | # 535 | 536 | lrtest <- function(fit, xname) { 537 | 538 | if(checkInteractions(fit, xname)) warning("Main effect (", xname, ") was tested but there were interactions.") 539 | 540 | dropname <- addSquiggle(xname) 541 | xname <- removeSquiggle(xname) 542 | 543 | test <- if(inherits(fit, "lm") && family(fit)$family == "gaussian") "F" else "Chisq" 544 | 545 | a <- drop1(fit, dropname, test=test) 546 | testname <- grep("Pr\\(", colnames(a), value=TRUE) 547 | rval <- a[xname, testname] 548 | 549 | return(rval) 550 | } 551 | 552 | 553 | # 554 | # test using drop1 --- use this to build krtest and pbtest 555 | # 556 | drop1test <- function(fit, xname, fun, ...) { 557 | 558 | # formula for dropped variable 559 | dropname <- addSquiggle(xname) 560 | xname <- removeSquiggle(xname) 561 | 562 | a <- drop1(fit, dropname, test="user", sumFun=fun, ...) 563 | rval <- a[xname, "p.value"] 564 | 565 | return(rval) 566 | } 567 | 568 | # from ?drop1.merMod in lme4 569 | krWrap <- function(object, objectDrop, ...) { 570 | 571 | krnames <- c("ndf", "ddf", "Fstat", "p.value", "F.scaling") 572 | 573 | if(missing(objectDrop)) return(setNames(rep(NA, length(krnames)), krnames)) 574 | 575 | krtest <- suppressMessages(KRmodcomp(object, objectDrop)) # suppress S4 note for `kronecker` 576 | rval <- unlist(krtest$stats[krnames]) 577 | 578 | return(rval) 579 | } 580 | 581 | krtest <- function(fit, xname) { 582 | 583 | if(checkInteractions(fit, xname)) warning("Main effect (", xname, ") was tested but there were interactions.") 584 | 585 | drop1test(fit, xname, krWrap) 586 | } 587 | 588 | pbWrap <- function(object, objectDrop, ...) { 589 | 590 | pbnames <- c("stat", "df", "p.value") 591 | 592 | if(missing(objectDrop)) return(setNames(rep(NA, length(pbnames)), pbnames)) 593 | 594 | pbtest <- PBmodcomp(object, objectDrop, nsim=getSimrOption("pbnsim")) 595 | rval <- unlist(pbtest$test["PBtest", pbnames]) 596 | 597 | return(rval) 598 | } 599 | 600 | pbtest <- function(fit, xname) drop1test(fit, xname, pbWrap) 601 | 602 | satest <- function(fit, xname) { 603 | 604 | xname <- removeSquiggle(xname) 605 | 606 | a <- lmerTest_summary(fit, ddf="Satterthwaite")$coefficients 607 | 608 | rval <- a[xname, "Pr(>|t|)"] 609 | return(rval) 610 | } 611 | 612 | ## ---------- 613 | ## 614 | ## Comparison based tests. 615 | ## 616 | ## ---------- 617 | 618 | krcompare <- function(model1, model2) { 619 | 620 | suppressMessages(KRmodcomp(model1, model2)$stats$p.value) # suppress S4 note for `kronecker` 621 | } 622 | 623 | pbcompare <- function(model1, model2) { 624 | 625 | PBmodcomp(model1, model2, nsim=getSimrOption("pbnsim"))$test["PBtest", "p.value"] 626 | } 627 | 628 | lrcompare <- function(model1, model2) { 629 | 630 | suppressMessages(anova(model1, model2, test="Chisq")$Pr[2]) # supress ML refit messages 631 | } 632 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # simr 2 | 3 | [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/pitakakariki/simr?branch=master&svg=true)](https://ci.appveyor.com/project/pitakakariki/simr) 4 | [![Coverage Status](https://codecov.io/gh/pitakakariki/simr/branch/master/graph/badge.svg)](https://codecov.io/github/pitakakariki/simr?branch=master) 5 | 6 | Power Analysis for Generalised Linear Mixed Models by Simulation. 7 | 8 | ## Getting Started 9 | 10 | A tutorial has been published in [Methods in Ecology and Evolution](https://doi.org/10.1111/2041-210X.12504). 11 | 12 | 13 | ## Old RLRsim Binaries 14 | 15 | If you get the following error, try reinstalling RLRsim. 16 | 17 | > library(simr) 18 | Loading required package: lme4 19 | Loading required package: Matrix 20 | Error : object ‘sigma’ is not exported by 'namespace:lme4' 21 | Error: package or namespace load failed for ‘simr’ 22 | 23 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | # Download script file from GitHub 4 | init: 5 | ps: | 6 | $ErrorActionPreference = "Stop" 7 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 8 | Import-Module '..\appveyor-tool.ps1' 9 | 10 | install: 11 | ps: Bootstrap 12 | 13 | # Adapt as necessary starting from here 14 | 15 | build_script: 16 | - travis-tool.sh install_deps 17 | 18 | test_script: 19 | - travis-tool.sh run_tests 20 | 21 | on_failure: 22 | - 7z a failure.zip *.Rcheck\* 23 | - appveyor PushArtifact failure.zip 24 | 25 | artifacts: 26 | - path: '*.Rcheck\**\*.log' 27 | name: Logs 28 | 29 | - path: '*.Rcheck\**\*.out' 30 | name: Logs 31 | 32 | - path: '*.Rcheck\**\*.fail' 33 | name: Logs 34 | 35 | - path: '*.Rcheck\**\*.Rout' 36 | name: Logs 37 | 38 | - path: '\*_*.tar.gz' 39 | name: Bits 40 | 41 | - path: '\*_*.zip' 42 | name: Bits 43 | -------------------------------------------------------------------------------- /build/make_simdata.r: -------------------------------------------------------------------------------- 1 | # reproducible: 2 | set.seed(123) 3 | 4 | # cts and categorical predictors: 5 | x <- rep(1:10, times=3) 6 | g <- as.factor(rep(c('a', 'b', 'c'), each=10)) 7 | 8 | # parameters 9 | a <- 10 10 | b <- -0.25 11 | s <- 1 12 | r <- 3 13 | 14 | # random effects: 15 | re <- rnorm(nlevels(g), 0, r) 16 | names(re) <- levels(g) 17 | 18 | # linear response 19 | y <- a + b*x + re[g] + rnorm(length(x), 0, s) 20 | 21 | # poisson response: 22 | lambda <- exp((a + b*x + re[g])/10) 23 | z <- rpois(length(x), lambda) 24 | 25 | 26 | 27 | 28 | 29 | simdata <- data.frame(y=y, x=x, g=g, z=z) 30 | save(simdata, file='data/simdata.rda') 31 | 32 | -------------------------------------------------------------------------------- /data/simdata.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pitakakariki/simr/23e6090e9cb13dbb9a0e959505990aa401dcc0b5/data/simdata.rda -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "Article", 2 | title = "simr: an R package for power analysis of generalised linear mixed models by simulation", 3 | author = c(person("Peter", "Green"), person(c("Catriona", "J."), "MacLeod")), 4 | journal = "Methods in Ecology and Evolution", 5 | volume = "7", 6 | number = "4", 7 | pages = "493--498", 8 | year = "2016", 9 | doi = "10.1111/2041-210X.12504", 10 | url = "https://CRAN.R-project.org/package=simr" 11 | ) 12 | -------------------------------------------------------------------------------- /man/doFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/doFit.R 3 | \name{doFit} 4 | \alias{doFit} 5 | \title{Fit model to a new response.} 6 | \usage{ 7 | doFit(y, fit, subset, ...) 8 | } 9 | \arguments{ 10 | \item{y}{new values for the response variable (vector or matrix depending on the model).} 11 | 12 | \item{fit}{a previously fitted model object.} 13 | 14 | \item{subset}{boolean vector specifying how much of the data to use. If missing, the model is fit to all 15 | the data. This argument needs to be implemented for \code{\link{powerCurve}} to work.} 16 | 17 | \item{...}{additional options.} 18 | } 19 | \value{ 20 | a fitted model object. 21 | } 22 | \description{ 23 | This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 24 | } 25 | -------------------------------------------------------------------------------- /man/doSim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/doSim.R 3 | \name{doSim} 4 | \alias{doSim} 5 | \title{Generate simulated response variables.} 6 | \usage{ 7 | doSim(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{an object to simulate from, usually a fitted model.} 11 | 12 | \item{...}{additional options.} 13 | } 14 | \value{ 15 | a vector containing simulated response values (or, for models with a multivariate response such as 16 | binomial gl(m)m's, a matrix of simulated response values). Suitable as input for \code{\link{doFit}}. 17 | } 18 | \description{ 19 | This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 20 | } 21 | -------------------------------------------------------------------------------- /man/doTest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/doTest.R 3 | \name{doTest} 4 | \alias{doTest} 5 | \title{Apply a hypothesis test to a fitted model.} 6 | \usage{ 7 | doTest(object, test, ...) 8 | } 9 | \arguments{ 10 | \item{object}{an object to apply a statistical test to, usually a fitted model.} 11 | 12 | \item{test}{a test function, see \link{tests}.} 13 | 14 | \item{...}{additional options.} 15 | } 16 | \value{ 17 | a p-value with attributes describing the test. 18 | } 19 | \description{ 20 | This is normally an internal function, but it can be overloaded to extend \code{simr} to other packages. 21 | } 22 | -------------------------------------------------------------------------------- /man/extend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/extend.R 3 | \name{extend} 4 | \alias{extend} 5 | \title{Extend a longitudinal model.} 6 | \usage{ 7 | extend(object, along, within, n, values) 8 | } 9 | \arguments{ 10 | \item{object}{a fitted model object to extend.} 11 | 12 | \item{along}{the name of an explanatory variable. This variable will have its number of levels extended.} 13 | 14 | \item{within}{names of grouping variables, separated by "+" or ",". Each combination of groups will be 15 | extended to \code{n} rows.} 16 | 17 | \item{n}{number of levels: the levels of the explanatory variable will be replaced by \code{1,2,3,..,n} for a 18 | continuous variable or \code{a,b,c,...,n} for a factor.} 19 | 20 | \item{values}{alternatively, you can specify a new set of levels for the explanatory variable.} 21 | } 22 | \value{ 23 | A copy of \code{object} suitable for \code{\link{doSim}} with an extended dataset attached as 24 | an attribute named \code{newData}. 25 | } 26 | \description{ 27 | This method increases the sample size for a model. 28 | } 29 | \details{ 30 | \code{extend} takes "slices" through the data for each unique value of the extended variable. 31 | An extended dataset is built from \code{n} slices, with slices duplicated if necessary. 32 | } 33 | \examples{ 34 | fm <- lmer(y ~ x + (1|g), data=simdata) 35 | nrow(example) 36 | fmx1 <- extend(fm, along="x", n=20) 37 | nrow(getData(fmx1)) 38 | fmx2 <- extend(fm, along="x", values=c(1,2,4,8,16)) 39 | nrow(getData(fmx2)) 40 | 41 | } 42 | -------------------------------------------------------------------------------- /man/getData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getData.R 3 | \name{getData} 4 | \alias{getData} 5 | \alias{getData<-} 6 | \title{Get an object's data.} 7 | \usage{ 8 | getData(object) 9 | 10 | getData(object) <- value 11 | } 12 | \arguments{ 13 | \item{object}{a fitted model object (e.g. an object of class \code{merMod} or \code{lm}).} 14 | 15 | \item{value}{a new \code{data.frame} to replace the old one. 16 | The new data will be stored in the \code{newData} attribute.} 17 | } 18 | \value{ 19 | A \code{data.frame} with the required data. 20 | } 21 | \description{ 22 | Get the data associated with a model object. 23 | } 24 | \details{ 25 | Looks for data in the following order: 26 | 27 | \enumerate{ 28 | \item{The object's \code{newData} attribute, if it has been set by \code{simr}.} 29 | \item{The \code{data} argument of \code{getCall(object)}, in the environment of \code{formula(object)}.} 30 | } 31 | } 32 | \examples{ 33 | 34 | lm1 <- lmer(y ~ x + (1|g), data=simdata) 35 | X <- getData(lm1) 36 | 37 | } 38 | -------------------------------------------------------------------------------- /man/lastResult.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/oops.R 3 | \name{lastResult} 4 | \alias{lastResult} 5 | \title{Recover an unsaved simulation} 6 | \usage{ 7 | lastResult() 8 | } 9 | \description{ 10 | Simulations can take a non-trivial time to run. If the user forgets to assign 11 | the result to a variable this method can recover it. 12 | } 13 | \examples{ 14 | fm1 <- lmer(y ~ x + (1|g), data=simdata) 15 | powerSim(fm1, nsim=10) 16 | ps1 <- lastResult() 17 | 18 | } 19 | \seealso{ 20 | \code{\link[base]{.Last.value}} 21 | } 22 | -------------------------------------------------------------------------------- /man/makeGlmer.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/new.R 3 | \name{makeGlmer} 4 | \alias{makeGlmer} 5 | \alias{makeLmer} 6 | \title{Create an artificial mixed model object} 7 | \usage{ 8 | makeGlmer(formula, family, fixef, VarCorr, data) 9 | 10 | makeLmer(formula, fixef, VarCorr, sigma, data) 11 | } 12 | \arguments{ 13 | \item{formula}{a formula describing the model (see \code{\link[lme4]{glmer}}).} 14 | 15 | \item{family}{type of response variable (see \code{\link{family}}).} 16 | 17 | \item{fixef}{vector of fixed effects} 18 | 19 | \item{VarCorr}{variance and covariances for random effects. 20 | If there are multiple random effects, supply their parameters as a list.} 21 | 22 | \item{data}{\code{data.frame} of explanatory variables.} 23 | 24 | \item{sigma}{residual standard deviation.} 25 | } 26 | \description{ 27 | Make a \code{\link[lme4]{merMod}} object with the specified structure and parameters. 28 | } 29 | -------------------------------------------------------------------------------- /man/modify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/modify.R 3 | \name{modify} 4 | \alias{modify} 5 | \alias{fixef<-} 6 | \alias{coef<-} 7 | \alias{VarCorr<-} 8 | \alias{sigma<-} 9 | \alias{scale<-} 10 | \title{Modifying model parameters.} 11 | \usage{ 12 | fixef(object) <- value 13 | 14 | coef(object) <- value 15 | 16 | VarCorr(object) <- value 17 | 18 | sigma(object) <- value 19 | 20 | scale(object) <- value 21 | } 22 | \arguments{ 23 | \item{object}{a fitted model object.} 24 | 25 | \item{value}{new parameter values.} 26 | } 27 | \description{ 28 | These functions can be used to change the size of a model's fixed effects, 29 | its random effect variance/covariance matrices, or its residual variance. 30 | This gives you more control over simulations from the model. 31 | } 32 | \details{ 33 | New values for \code{VarCorr} are interpreted as variances and covariances, not standard deviations and 34 | correlations. New values for \code{sigma} and \code{scale} are interpreted on the standard deviation scale. 35 | This means that both \code{VarCorr(object)<-VarCorr(object)} and \code{sigma(object)<-sigma(object)} 36 | leave \code{object} unchanged, as you would expect. 37 | 38 | \code{sigma<-} will only change the residual standard deviation, 39 | whereas \code{scale<-} will affect both \code{sigma} and \code{VarCorr}. 40 | 41 | These functions can be used to change the value of individual parameters, such as 42 | a single fixed effect coefficient, using standard R subsetting commands. 43 | } 44 | \examples{ 45 | fm <- lmer(y ~ x + (1|g), data=simdata) 46 | fixef(fm) 47 | fixef(fm)["x"] <- -0.1 48 | fixef(fm) 49 | 50 | } 51 | \seealso{ 52 | \code{\link{getData}} if you want to modify the model's data. 53 | } 54 | -------------------------------------------------------------------------------- /man/powerCurve.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerCurve.R 3 | \name{powerCurve} 4 | \alias{powerCurve} 5 | \title{Estimate power at a range of sample sizes.} 6 | \usage{ 7 | powerCurve( 8 | fit, 9 | test = fixed(getDefaultXname(fit)), 10 | sim = fit, 11 | along = getDefaultXname(fit), 12 | within, 13 | breaks, 14 | seed, 15 | fitOpts = list(), 16 | testOpts = list(), 17 | simOpts = list(), 18 | ... 19 | ) 20 | } 21 | \arguments{ 22 | \item{fit}{a fitted model object (see \code{\link{doFit}}).} 23 | 24 | \item{test}{specify the test to perform. By default, the first fixed effect in \code{fit} will be tested. 25 | (see: \link{tests}).} 26 | 27 | \item{sim}{an object to simulate from. By default this is the same as \code{fit} (see \code{\link{doSim}}).} 28 | 29 | \item{along}{the name of an explanatory variable. This variable will have its number of levels varied.} 30 | 31 | \item{within}{names of grouping variables, separated by "+" or ",". Each combination of groups will be 32 | extended to \code{n} rows.} 33 | 34 | \item{breaks}{number of levels of the variable specified by \code{along} at each point on the power curve.} 35 | 36 | \item{seed}{specify a random number generator seed, for reproducible results.} 37 | 38 | \item{fitOpts}{extra arguments for \code{\link{doFit}}.} 39 | 40 | \item{testOpts}{extra arguments for \code{\link{doTest}}.} 41 | 42 | \item{simOpts}{extra arguments for \code{\link{doSim}}.} 43 | 44 | \item{...}{any additional arguments are passed on to \code{\link{simrOptions}}. Common options include: 45 | \describe{ 46 | \item{\code{nsim}:}{the number of simulations to run (default is \code{1000}).} 47 | \item{\code{alpha}:}{the significance level for the statistical test (default is \code{0.05}).} 48 | \item{\code{progress}:}{use progress bars during calculations (default is \code{TRUE}).} 49 | }} 50 | } 51 | \description{ 52 | This function runs \code{\link{powerSim}} over a range of sample sizes. 53 | } 54 | \examples{ 55 | \dontrun{ 56 | fm <- lmer(y ~ x + (1|g), data=simdata) 57 | pc1 <- powerCurve(fm) 58 | pc2 <- powerCurve(fm, breaks=c(4,6,8,10)) 59 | print(pc2) 60 | plot(pc2) 61 | } 62 | 63 | } 64 | \seealso{ 65 | \code{\link{print.powerCurve}}, \code{\link{summary.powerCurve}}, \code{\link{confint.powerCurve}} 66 | } 67 | -------------------------------------------------------------------------------- /man/powerSim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerSim.R 3 | \name{powerSim} 4 | \alias{powerSim} 5 | \title{Estimate power by simulation.} 6 | \usage{ 7 | powerSim( 8 | fit, 9 | test = fixed(getDefaultXname(fit)), 10 | sim = fit, 11 | fitOpts = list(), 12 | testOpts = list(), 13 | simOpts = list(), 14 | seed, 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{fit}{a fitted model object (see \code{\link{doFit}}).} 20 | 21 | \item{test}{specify the test to perform. By default, the first fixed effect in \code{fit} will be tested. 22 | (see: \link{tests}).} 23 | 24 | \item{sim}{an object to simulate from. By default this is the same as \code{fit} (see \code{\link{doSim}}).} 25 | 26 | \item{fitOpts}{extra arguments for \code{\link{doFit}}.} 27 | 28 | \item{testOpts}{extra arguments for \code{\link{doTest}}.} 29 | 30 | \item{simOpts}{extra arguments for \code{\link{doSim}}.} 31 | 32 | \item{seed}{specify a random number generator seed, for reproducible results.} 33 | 34 | \item{...}{any additional arguments are passed on to \code{\link{simrOptions}}. Common options include: 35 | \describe{ 36 | \item{\code{nsim}:}{the number of simulations to run (default is \code{1000}).} 37 | \item{\code{alpha}:}{the significance level for the statistical test (default is \code{0.05}).} 38 | \item{\code{progress}:}{use progress bars during calculations (default is \code{TRUE}).} 39 | }} 40 | } 41 | \description{ 42 | Perform a power analysis for a mixed model. 43 | } 44 | \examples{ 45 | fm1 <- lmer(y ~ x + (1|g), data=simdata) 46 | powerSim(fm1, nsim=10) 47 | 48 | } 49 | \seealso{ 50 | \code{\link{print.powerSim}}, \code{\link{summary.powerSim}}, \code{\link{confint.powerSim}} 51 | } 52 | -------------------------------------------------------------------------------- /man/print.powerSim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.R 3 | \name{print.powerSim} 4 | \alias{print.powerSim} 5 | \alias{print.powerCurve} 6 | \alias{summary.powerSim} 7 | \alias{summary.powerCurve} 8 | \alias{confint.powerSim} 9 | \alias{confint.powerCurve} 10 | \title{Report simulation results} 11 | \usage{ 12 | \method{print}{powerSim}(x, alpha = x$alpha, level = 0.95, ...) 13 | 14 | \method{print}{powerCurve}(x, ...) 15 | 16 | \method{summary}{powerSim}( 17 | object, 18 | alpha = object$alpha, 19 | level = 0.95, 20 | method = getSimrOption("binom"), 21 | ... 22 | ) 23 | 24 | \method{summary}{powerCurve}( 25 | object, 26 | alpha = object$alpha, 27 | level = 0.95, 28 | method = getSimrOption("binom"), 29 | ... 30 | ) 31 | 32 | \method{confint}{powerSim}( 33 | object, 34 | parm, 35 | level = 0.95, 36 | method = getSimrOption("binom"), 37 | alpha = object$alpha, 38 | ... 39 | ) 40 | 41 | \method{confint}{powerCurve}(object, parm, level = 0.95, method = getSimrOption("binom"), ...) 42 | } 43 | \arguments{ 44 | \item{x}{a \code{\link{powerSim}} or \code{\link{powerCurve}} object} 45 | 46 | \item{alpha}{the significance level for the statistical test (default is that used in the call to \code{powerSim}).} 47 | 48 | \item{level}{confidence level for power estimate} 49 | 50 | \item{...}{additional arguments to pass to \code{\link[=binom.confint]{binom::binom.confint()}} 51 | 52 | \code{alpha} refers to the threshold for an effect being significant and 53 | thus directly determines the point estimate for the power calculation. 54 | \code{level} is the confidence level that is calculated for this point 55 | evidence and determines the width/coverage of the confidence interval for 56 | power.} 57 | 58 | \item{object}{a \code{\link{powerSim}} or \code{\link{powerCurve}} object} 59 | 60 | \item{method}{method to use for computing binomial confidence intervals (see \code{\link[=binom.confint]{binom::binom.confint()}})} 61 | 62 | \item{parm}{currently ignored, included for S3 compatibility with \code{\link[=confint]{stats::confint}}} 63 | } 64 | \description{ 65 | Describe and extract power simulation results 66 | } 67 | \seealso{ 68 | \code{\link[=binom.confint]{binom::binom.confint}}, \code{\link{powerSim}}, \code{\link{powerCurve}} 69 | } 70 | -------------------------------------------------------------------------------- /man/simdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simr.R 3 | \docType{data} 4 | \name{simdata} 5 | \alias{simdata} 6 | \title{Example dataset.} 7 | \description{ 8 | A simple artificial data set used in the tutorial. There are two response variables, 9 | a Poisson count \code{z} and a Gaussian response \code{y}. There is a continuous predictor 10 | \code{x} with ten values \code{\{1,2,...,10\}} and a categorical predictor \code{g} with 11 | three levels \code{\{a, b, c\}}. 12 | } 13 | -------------------------------------------------------------------------------- /man/simr-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simr.R 3 | \docType{package} 4 | \name{simr-package} 5 | \alias{simr-package} 6 | \title{simr: Simulation-based power calculations for mixed models.} 7 | \description{ 8 | \code{simr} is a package that makes it easy to run simulation-based power analyses 9 | with \code{lme4}. 10 | } 11 | -------------------------------------------------------------------------------- /man/simrOptions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/options.R 3 | \name{simrOptions} 4 | \alias{simrOptions} 5 | \alias{getSimrOption} 6 | \title{Options Settings for \code{simr}} 7 | \usage{ 8 | simrOptions(...) 9 | 10 | getSimrOption(opt) 11 | } 12 | \arguments{ 13 | \item{...}{a list of names to get options, or a named list of new values to set options.} 14 | 15 | \item{opt}{option name (character string).} 16 | } 17 | \value{ 18 | \code{getSimrOption} returns the current value for the option \code{x}. 19 | 20 | \code{simrOptions} returns 21 | 22 | \enumerate{ 23 | \item a named list of all options, if no arguments are given. 24 | \item a named list of specified options, if a list of option names is given. 25 | \item (invisibly) a named list of changed options with their previous values, if options are set. 26 | } 27 | } 28 | \description{ 29 | Control the default behaviour of \code{simr} analyses. 30 | } 31 | \section{Options in \code{simr}}{ 32 | 33 | 34 | Options that can be set with this method (and their default values). 35 | 36 | \describe{ 37 | \item{\code{nsim}}{default number of simulations (\code{1000}).} 38 | \item{\code{alpha}}{default confidence level (\code{0.05}).} 39 | \item{\code{progress}}{use progress bars during calculations (\code{TRUE}).} 40 | \item{\code{binom}}{method for calculating confidence intervals (\code{"exact"}).} 41 | \item{\code{pbnsim}}{number of simulations for parametric bootstrap tests using \code{pbkrtest} (\code{100}).} 42 | \item{\code{pcmin}}{minimum number of levels for the smallest point on a \code{\link{powerCurve}} (3).} 43 | \item{\code{pcmax}}{maximum number of points on the default \code{\link{powerCurve}} (10).} 44 | \item{\code{observedPowerWarning}}{warn if an unmodified fitted model is used (TRUE).} 45 | \item{\code{carTestType}}{ type of test, i.e. type of sum of squares, for tests performed with \code{\link[=Anova]{car::Anova}} (\code{"II"}).} 46 | \item{\code{lmerTestDdf}}{ approximation to use for denominator degrees of 47 | freedom for tests performed with 48 | \code{\link[lmerTest:lmer]{lmerTest}} 49 | (\code{"Satterthwaite"}). Note that setting this 50 | option to \code{"lme4"} will reduce the 51 | \code{lmerTest} model to an \code{lme4} model and 52 | break functionality based on \code{lmerTest}.} 53 | \item{\code{lmerTestType}}{ type of test, i.e. type of sum of squares, for 54 | F-tests performed with 55 | \code{\link[lmerTest:anova.lmerModLmerTest]{lmerTest::anova.lmerModLmerTest}} 56 | (\code{2}). Note that unlike the tests performed 57 | with \code{car::Anova}, the test type must be 58 | given as a number and not a character.} 59 | 60 | } 61 | } 62 | 63 | \examples{ 64 | 65 | getSimrOption("nsim") 66 | oldopts <- simrOptions(nsim=5) 67 | getSimrOption("nsim") 68 | simrOptions(oldopts) 69 | getSimrOption("nsim") 70 | 71 | } 72 | -------------------------------------------------------------------------------- /man/tests.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/testLibrary.R 3 | \name{tests} 4 | \alias{tests} 5 | \alias{fixed} 6 | \alias{compare} 7 | \alias{fcompare} 8 | \alias{rcompare} 9 | \alias{random} 10 | \title{Specify a statistical test to apply} 11 | \usage{ 12 | fixed( 13 | xname, 14 | method = c("z", "t", "f", "chisq", "anova", "lr", "sa", "kr", "pb") 15 | ) 16 | 17 | compare(model, method = c("lr", "pb")) 18 | 19 | fcompare(model, method = c("lr", "kr", "pb")) 20 | 21 | rcompare(model, method = c("lr", "pb")) 22 | 23 | random() 24 | } 25 | \arguments{ 26 | \item{xname}{an explanatory variable to test (character).} 27 | 28 | \item{method}{the type of test to apply (see Details).} 29 | 30 | \item{model}{a null model for comparison (formula).} 31 | } 32 | \value{ 33 | A function which takes a fitted model as an argument and returns a single p-value. 34 | } 35 | \description{ 36 | Specify a statistical test to apply 37 | } 38 | \details{ 39 | \describe{ 40 | \item{\code{fixed}:}{ 41 | Test a single fixed effect, specified by \code{xname}.} 42 | \item{\code{compare}:}{ 43 | Compare the current model to a smaller one specified by the formula \code{model}.} 44 | \item{\code{fcompare}, \code{rcompare}:}{ 45 | Similar to \code{compare}, but only the fixed/random part of the formula needs to be supplied.} 46 | \item{\code{random}:}{ 47 | Test the significance of a single random effect.} 48 | } 49 | } 50 | \section{Methods}{ 51 | 52 | 53 | The \code{method} argument can be used to specify one of the following tests. 54 | Note that \code{"z"} is an asymptotic approximation for models not fitted 55 | with \code{\link[lme4]{glmer}} and \code{"kr"} will only work with models 56 | fitted with \code{\link[lme4]{lmer}}. 57 | 58 | \describe{ 59 | \item{\code{z}:}{ 60 | Z-test for models fitted with \code{\link[lme4]{glmer}} (or \code{\link{glm}}), 61 | using the p-value from \code{\link[=summary.merMod]{summary}}. 62 | For models fitted with \code{\link[lme4]{lmer}}, this test can be used to 63 | treat the t-values from \code{\link[=summary.merMod]{summary}} as 64 | z-values, which is equivalent to assuming infinite degrees of freedom. 65 | This asymptotic approximation seems to perform well for even medium-sized 66 | data sets, as the denominator degrees of freedom are already quite large 67 | (cf. Baayen et al. 2008) even if calculating their exact value is 68 | analytically unsolved and computationally difficult (e.g. with 69 | Satterthwaite or Kenward-Roger approximations). Setting 70 | \code{alpha=0.045} is roughly equal to the t=2 threshold suggested by 71 | Baayen et al. (2008) and helps compensate for the slightly 72 | anti-conservative approximation.} 73 | \item{\code{t}:}{ 74 | T-test for models fitted with \code{\link{lm}}. Also available for mixed models 75 | when \code{\link[lmerTest]{lmerTest}} is installed, using the p-value calculated 76 | using the Satterthwaite approximation for the denominator degrees of 77 | freedom by default. This can be changed by setting \code{lmerTestDdf}, 78 | see \code{\link{simrOptions}}.} 79 | \item{\code{lr}:}{Likelihood ratio test, using \code{\link[=anova.merMod]{anova}}.} 80 | \item{\code{f}:}{ 81 | Wald F-test, using \code{\link[=Anova]{car::Anova}}. 82 | Useful for examining categorical terms. For models fitted with 83 | \code{\link[lme4]{lmer}}, this should yield equivalent results to 84 | \code{method='kr'}. Uses Type-II tests by default, this can be changed 85 | by setting \code{carTestType}, see \code{\link{simrOptions}}.} 86 | \item{\code{chisq}:}{ 87 | Wald Chi-Square test, using \code{\link[=Anova]{car::Anova}}. 88 | Please note that while this is much faster than the F-test computed with 89 | Kenward-Roger, it is also known to be anti-conservative, especially for 90 | small samples. Uses Type-II tests by default, this can be changed by 91 | setting \code{carTestType}, see \code{\link{simrOptions}}.} 92 | \item{\code{anova}:}{ 93 | ANOVA-style F-test, using \code{\link{anova}} and 94 | \code{\link[lmerTest:anova.lmerModLmerTest]{lmerTest::anova.lmerModLmerTest}}. 95 | For `lm`, this yields a Type-I (sequential) test (see \code{\link[=anova.lm]{anova}}); 96 | to use other test types, use the F-tests provided by \code{car::Anova()} 97 | (see above). For \code{lmer}, this generates Type-II tests with 98 | Satterthwaite denominator degrees of freedom by default, this can be 99 | changed by setting \code{lmerTestDdf} and \code{lmerTestType}, see 100 | \code{\link{simrOptions}}.} 101 | \item{\code{kr}:}{ 102 | Kenward-Roger test, using \code{\link[pbkrtest]{KRmodcomp}}. 103 | This only applies to models fitted with \code{\link[lme4]{lmer}}, and compares models with 104 | different fixed effect specifications but equivalent random effects.} 105 | \item{\code{pb}:}{ 106 | Parametric bootstrap test, using \code{\link[pbkrtest]{PBmodcomp}}. 107 | This test will be very accurate, but is also very computationally expensive.} 108 | } 109 | 110 | Tests using \code{random} for a single random effect call \code{\link[RLRsim]{exactRLRT}}. 111 | } 112 | 113 | \examples{ 114 | lm1 <- lmer(y ~ x + (x|g), data=simdata) 115 | lm0 <- lmer(y ~ x + (1|g), data=simdata) 116 | anova(lm1, lm0) 117 | compare(. ~ x + (1|g))(lm1) 118 | rcompare(~ (1|g))(lm1) 119 | \dontrun{powerSim(fm1, compare(. ~ x + (1|g)))} 120 | 121 | } 122 | \references{ 123 | Baayen, R. H., Davidson, D. J., and Bates, D. M. (2008). Mixed-effects modeling 124 | with crossed random effects for subjects and items. Journal of Memory and Language, 59, 390--412. 125 | } 126 | -------------------------------------------------------------------------------- /simr.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 4 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageRoxygenize: rd,collate,namespace 21 | -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | if(require(testthat)) { 2 | 3 | test_check("simr") 4 | } -------------------------------------------------------------------------------- /tests/testthat/helper_setup.R: -------------------------------------------------------------------------------- 1 | # 2 | # Tests should be quick and clean. 3 | # 4 | 5 | # nb: move this to test_aaa.R for now? 6 | helperopts <- simrOptions(nsim=10, progress=FALSE, pbnsim=5) 7 | simrOptions(helperopts) # b/c helpers are not called by load_all 8 | 9 | # 10 | # Useful to have some example models. 11 | # 12 | 13 | fm1 <- lmer(y ~ x + (1|g), data=simdata, control=lmerControl(optimizer="bobyqa")) 14 | fixef(fm1) <- fixef(fm1) 15 | 16 | fm2 <- glmer(z ~ x + (1|g), family=poisson, data=simdata); fixef(fm2) <- fixef(fm2) 17 | fm3 <- glmer(z ~ x + (x|g), family=poisson, data=simdata); fixef(fm3) <- fixef(fm3) 18 | 19 | flm <- lm(y ~ x + g, data=simdata); coef(flm) <- coef(flm) 20 | fglm <- glm(z ~ x + g, family=poisson, data=simdata); coef(fglm) <- coef(fglm) 21 | 22 | -------------------------------------------------------------------------------- /tests/testthat/test_aaa.R: -------------------------------------------------------------------------------- 1 | # 2 | # Tests should be quick and clean. 3 | # 4 | 5 | # temporarily here until devtools is fixed 6 | 7 | helperopts <- simrOptions(nsim=10, progress=FALSE, pbnsim=5) 8 | 9 | # 10 | # NB: test lastResult here b/c this needs to be run before any simulations are done 11 | # 12 | 13 | context("lastResult") 14 | 15 | test_that("lastResult works", { 16 | 17 | expect_error(lastResult(), "No result available to recover.") 18 | 19 | ps <- powerSim(fm1, nsim=1) 20 | 21 | expect_identical(lastResult(), ps) 22 | 23 | }) 24 | -------------------------------------------------------------------------------- /tests/testthat/test_binomial.R: -------------------------------------------------------------------------------- 1 | context("Binomial") 2 | 3 | ## binary response 4 | 5 | zbin <- with(simdata, z < 3) 6 | glm_bin1 <- glm(zbin ~ x + g, family="binomial", data=simdata) 7 | glmm_bin1 <- glmer(zbin ~ x + (1|g), family="binomial", data=simdata) 8 | 9 | test_that("binomial with binary response works", { 10 | 11 | y <- doSim(glm_bin1) 12 | expect_true(all(y * (1-y) == 0)) 13 | 14 | temp <- doTest(doFit(doSim(glm_bin1), glm_bin1)) 15 | 16 | 17 | y <- doSim(glmm_bin1) 18 | expect_true(all(y * (1-y) == 0)) 19 | 20 | temp <- doTest(doFit(doSim(glmm_bin1), glmm_bin1)) 21 | 22 | }) 23 | 24 | ## cbind response 25 | 26 | # note the weird number of trials - z+10, z successes and 10 failures 27 | 28 | glm_bin2 <- glm(cbind(z, 10) ~ x + g, family="binomial", data=simdata) 29 | glmm_bin2 <- glmer(cbind(z, 10) ~ x + (1|g), family="binomial", data=simdata) 30 | 31 | test_that("binomial with cbind response works", { 32 | 33 | y <- doSim(glm_bin2) 34 | expect_identical(dim(y), c(30L, 2L)) 35 | 36 | temp <- doTest(doFit(doSim(glm_bin2), glm_bin2)) 37 | 38 | y <- doSim(glmm_bin2) 39 | expect_identical(dim(y), c(30L, 2L)) 40 | 41 | temp <- doTest(doFit(doSim(glmm_bin2), glmm_bin2)) 42 | 43 | }) 44 | 45 | ## proportion response 46 | 47 | zweight <- rep(10, nrow(simdata)) 48 | zprop <- with(simdata, z/zweight) 49 | 50 | glm_bin3 <- glm(zprop ~ x + g, family="binomial", data=simdata, weights=zweight) 51 | glmm_bin3 <- glmer(zprop ~ x + (1|g), family="binomial", data=simdata, weights=zweight) 52 | 53 | zweight_b <- zweight + c(0,1) 54 | zprop_b <- with(simdata, z/zweight_b) 55 | 56 | glmm_bin3b <- glmer(zprop_b ~ x + (1|g), family="binomial", data=simdata, weights=zweight_b) 57 | 58 | test_that("binomial with proportion response works", { 59 | 60 | y <- doSim(glm_bin3) 61 | expect_equal(zweight*y, round(zweight*y)) 62 | expect_true(!all(y %in% c(0, 1))) 63 | 64 | temp <- doTest(doFit(doSim(glm_bin2), glm_bin2)) 65 | 66 | y <- doSim(glmm_bin3) 67 | expect_equal(zweight*y, round(zweight*y)) 68 | expect_true(!all(y %in% c(0, 1))) 69 | 70 | temp <- doTest(doFit(doSim(glmm_bin3), glmm_bin3)) 71 | 72 | expect_warning(xm_bin3 <- extend(glmm_bin3b, along="g", n=5), "not supported") 73 | 74 | }) 75 | 76 | ## Mixing Poisson and binomial 77 | -------------------------------------------------------------------------------- /tests/testthat/test_contrasts.R: -------------------------------------------------------------------------------- 1 | context("Contrasts") 2 | 3 | set.seed(76) 4 | 5 | simdata_con <- within(simdata, { 6 | 7 | f <- as.factor(sample(letters[1:3], nrow(simdata), TRUE)) 8 | contrasts(f) <- contr.sum(3) 9 | }) 10 | 11 | fm_con <- lmer(y ~ f + (1|g), data=simdata_con) 12 | fixef(fm_con) <- fixef(fm_con) 13 | xm_con <- extend(fm_con, along="g", n=6) 14 | 15 | test_that("Contrasts work", { 16 | 17 | temp <- powerSim(xm_con) 18 | 19 | expect_equal(nrow(temp$errors), 0) 20 | }) -------------------------------------------------------------------------------- /tests/testthat/test_extend.r: -------------------------------------------------------------------------------- 1 | context("extend") 2 | 3 | test_that("extended model has correct dimensions", { 4 | 5 | x1 <- extend(fm1, along="x", n=20) 6 | 7 | expect_equal(nrow(getData(x1)), 2*nrow(getData(fm1))) 8 | 9 | 10 | x2 <- extend(fm1, along="g", n=15) 11 | 12 | expect_equal(nrow(getData(x2)), 5*nrow(getData(fm1))) 13 | 14 | 15 | x3 <- extend(fm1, within="x+g", n=3) 16 | 17 | expect_equal(nrow(getData(x3)), 3*nrow(getData(fm1))) 18 | 19 | 20 | x4 <- extend(flm, along="x", n=20) 21 | 22 | expect_equal(nrow(getData(x4)), 2*nrow(getData(flm))) 23 | }) 24 | 25 | test_that("extend works with a single column data frame", { 26 | 27 | X5 <- data.frame(x=1:5) 28 | X10 <- data.frame(x=1:10) 29 | 30 | expect_equivalent(extend(X5, along="x", n=10), X10) 31 | }) 32 | 33 | -------------------------------------------------------------------------------- /tests/testthat/test_fixef.r: -------------------------------------------------------------------------------- 1 | #context('fixef') 2 | 3 | 4 | ### simpler test model. kiwifruit e.g. too slow? 5 | 6 | 7 | #a <- lmer(Carbon ~ Year + (Year | Cluster), kiwifruit) 8 | 9 | #test_that('single fixef coefs can be replaced', { 10 | 11 | # .a <- a 12 | 13 | # test replacement 14 | # fixef(a)['Year'] <- -0.13 15 | # expect_that(fixef(a)['Year'], equals( c(Year=-0.13) )) 16 | 17 | # test reversibility 18 | # fixef(a)['Year'] <- fixef(.a)['Year'] 19 | # expect_that(a, is_identical_to(.a)) 20 | #}) -------------------------------------------------------------------------------- /tests/testthat/test_function.R: -------------------------------------------------------------------------------- 1 | context("User supplied functions") 2 | 3 | test_that("doFit works for a function", { 4 | 5 | 6 | f <- function(yy) lmer(yy ~ x + (1|g), data=simdata) 7 | 8 | ps <- powerSim(fit=f, sim=fm1, test=fixed("x", "z")) 9 | expect_equal(nrow(ps$errors), 0) 10 | 11 | g <- function(yy, subset) lmer(yy ~ x + (1|g), data=simdata, subset=subset) 12 | 13 | pc <- powerCurve(fit=g, sim=fm1, test=fixed("x", "z"), along="x") 14 | expect_equal(nrow(pc$errors), 0) 15 | }) 16 | -------------------------------------------------------------------------------- /tests/testthat/test_getData.R: -------------------------------------------------------------------------------- 1 | context("getData") 2 | 3 | test_that("error thrown", { 4 | 5 | expect_error(getData(1), "Couldn't find object's data.") 6 | }) 7 | -------------------------------------------------------------------------------- /tests/testthat/test_graphics.R: -------------------------------------------------------------------------------- 1 | # 2 | # To-do: work out how to test graphics in R 3 | # 4 | 5 | context("Graphics (NYI)") 6 | 7 | test_that("Not yet implemented", { 8 | 9 | ps <- powerSim(fm1, nsim=1) 10 | expect_error(plot(ps), "Not yet implemented.") 11 | }) -------------------------------------------------------------------------------- /tests/testthat/test_lm.r: -------------------------------------------------------------------------------- 1 | context("Base lm/glm") 2 | 3 | set.seed(123) 4 | 5 | test_that("simr works with lm", { 6 | 7 | temp <- powerSim(flm) 8 | 9 | expect_is(temp, "powerSim") 10 | 11 | expect_equal(nrow(temp$warnings), 0) 12 | expect_equal(nrow(temp$errors), 0) 13 | }) 14 | 15 | test_that("simr can combine lm and lmer", { 16 | 17 | temp <- powerSim(fit=flm, sim=fm1) 18 | 19 | expect_is(temp, "powerSim") 20 | 21 | expect_equal(nrow(temp$warnings), 0) 22 | expect_equal(nrow(temp$errors), 0) 23 | }) 24 | 25 | test_that("simr works with glm", { 26 | 27 | temp <- powerSim(fglm) 28 | 29 | expect_is(temp, "powerSim") 30 | 31 | expect_equal(nrow(temp$warnings), 0) 32 | expect_equal(nrow(temp$errors), 0) 33 | }) 34 | -------------------------------------------------------------------------------- /tests/testthat/test_logResponse.R: -------------------------------------------------------------------------------- 1 | # 2 | # models with (e.g.) a log response 3 | # -------------------------------------------------------------------------------- /tests/testthat/test_logging.R: -------------------------------------------------------------------------------- 1 | context("Logging") 2 | 3 | test_that("warnings and errors are logged by powerSim", { 4 | 5 | simf <- function() sometimes(doSim(fm1), p=0.2, pw=0.3, lambda=5) 6 | 7 | ps <- powerSim(fm1, sim=simf, nsim=10, seed=12345) 8 | 9 | expect_equal(ps$warnings$index, c(rep(4,7),6,10,10)) 10 | expect_equal(ps$errors$index, c(3,10)) 11 | 12 | expect_identical(ps, lastResult()) 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/test_modify.R: -------------------------------------------------------------------------------- 1 | context("modify") 2 | 3 | test_that("errors are thrown", { 4 | 5 | expect_error(fixef(fm1)["z"] <- 3, " is not the name of a fixed effect.") 6 | 7 | expect_error(sigma(fm2) <- 8, "sigma is not applicable for this model.") 8 | expect_error(sigma(fm2) <- 1, NA) 9 | 10 | expect_error(scale(fm2) <- 5, "scale is not applicable for this model.") 11 | 12 | expect_error(sigma(fglm) <- 8, "sigma is not applicable for this model.") 13 | expect_error(sigma(fglm) <- NULL, NA) 14 | }) 15 | 16 | test_that("scale<- modifies VarCorr", { 17 | 18 | scale(fm1) <- 2 19 | 20 | expect_equal(attr(VarCorr(fm1), "sc"), 2) 21 | }) -------------------------------------------------------------------------------- /tests/testthat/test_new.R: -------------------------------------------------------------------------------- 1 | context("From scratch") 2 | 3 | x <- rep(1:10) 4 | g <- c('a', 'b', 'c') 5 | 6 | X <- expand.grid(x=x, g=g) 7 | 8 | b <- c(2, -0.1) # fixed intercept and slope 9 | V1 <- 0.5 # random intercept variance 10 | V2 <- matrix(c(0.5,0.05,0.05,0.1), 2) # random intercept and slope variance-covariance matrix 11 | s <- 1 # residual variance 12 | 13 | test_that("makeLmer works", { 14 | 15 | model1 <- makeLmer(y ~ x + (1|g), fixef=b, VarCorr=V1, sigma=s, data=X) 16 | 17 | expect_equivalent(fixef(model1), b) 18 | expect_equivalent(sigma(model1), s) 19 | 20 | expect_equal(c(VarCorr(model1)$g), V1) 21 | 22 | ps <- powerSim(model1, nsim=1) 23 | expect_equal(nrow(ps$warnings), 0) 24 | expect_equal(nrow(ps$errors), 0) 25 | }) 26 | 27 | test_that("makeGlmer works", { 28 | 29 | model2 <- makeGlmer(z ~ x + (x|g), family="poisson", fixef=b, VarCorr=V2, data=X) 30 | 31 | expect_equivalent(fixef(model2), b) 32 | 33 | expect_equal(c(VarCorr(model2)$g), c(V2)) 34 | 35 | ps <- powerSim(model2, nsim=1) 36 | expect_equal(nrow(ps$warnings), 0) 37 | expect_equal(nrow(ps$errors), 0) 38 | 39 | rval <- X 40 | model3 <- makeGlmer(z ~ x + (x|g), family="poisson", fixef=b, VarCorr=V2, data=rval) 41 | 42 | expect_error(getData(model3), NA) 43 | 44 | model4 <- makeGlmer(cbind(z, 12) ~ x + (x|g), family="poisson", fixef=b, VarCorr=V2, data=X) 45 | 46 | expect_error(getData(model4), NA) 47 | 48 | }) 49 | -------------------------------------------------------------------------------- /tests/testthat/test_observed.R: -------------------------------------------------------------------------------- 1 | context("Observed power warning") 2 | 3 | test_that("observed power warning is thrown", { 4 | 5 | set.seed(23) 6 | 7 | fm <- lmer(y ~ x + (1|g), data=subset(simdata, x < 8)) 8 | 9 | expect_warning(temp <- powerSim(fm), 'This appears to be an "observed power" calculation') 10 | 11 | expect_is(temp, "powerSim") 12 | expect_equal(temp$x, 8) 13 | expect_equal(temp$n, 10) 14 | 15 | expect_output(print(temp), "observed power calculation") 16 | }) -------------------------------------------------------------------------------- /tests/testthat/test_options.R: -------------------------------------------------------------------------------- 1 | context("Options") 2 | 3 | # make sure we return everything to normal after option tests! 4 | original <- simrOptions() 5 | 6 | test_that("getting options works", { 7 | 8 | expect_identical(getSimrOption("nsim"), 10) 9 | 10 | expect_is(simrOptions(), "list") 11 | expect_named(simrOptions()) 12 | 13 | expect_identical(simrOptions("nsim", "progress"), list(nsim=10, progress=FALSE)) 14 | expect_identical(simrOptions(c("nsim", "progress")), list(nsim=10, progress=FALSE)) 15 | expect_identical(simrOptions(list("nsim", "progress")), list(nsim=10, progress=FALSE)) 16 | }) 17 | 18 | test_that("setting options works", { 19 | 20 | newopts <- list(nsim=9, binom="logit") 21 | 22 | # pass as list 23 | expect_false(identical(simrOptions(names(newopts)), newopts)) 24 | oldopts <- simrOptions(newopts) 25 | expect_identical(simrOptions(names(newopts)), newopts) 26 | 27 | simrOptions(oldopts) 28 | 29 | # pass as multiple arguments 30 | expect_false(identical(simrOptions(names(newopts)), newopts)) 31 | oldopts <- do.call(simrOptions, newopts) 32 | expect_identical(simrOptions(names(newopts)), newopts) 33 | }) 34 | 35 | test_that("options are applied", { 36 | 37 | simrOptions(nsim=5) 38 | expect_equal(powerSim(fm1)$n, 5) 39 | }) 40 | 41 | test_that("options are restored", { 42 | 43 | simrOptions(original) 44 | expect_identical(simrOptions(), original) 45 | }) -------------------------------------------------------------------------------- /tests/testthat/test_powerCurve.R: -------------------------------------------------------------------------------- 1 | context("powerCurve") 2 | 3 | test_that("powerCurve works", { 4 | 5 | set.seed(40000) 6 | 7 | pc1 <- powerCurve(fm1, nsim=3) 8 | pc2 <- powerCurve(fm1, along="g", nsim=3) 9 | pc3 <- powerCurve(fm1, within="x+g", nsim=3) 10 | 11 | expect_equal(nrow(pc1$warnings), 0) 12 | expect_equal(nrow(pc2$warnings), 0) 13 | expect_equal(nrow(pc3$warnings), 0) 14 | 15 | expect_equal(nrow(pc1$errors), 0) 16 | expect_equal(nrow(pc2$errors), 0) 17 | expect_equal(nrow(pc3$errors), 0) 18 | 19 | expect_equal(summary(pc1)$successes, c(0,1,1,0,0,2,2,2)) 20 | expect_equal(summary(pc2)$successes, c(3)) 21 | expect_equal(summary(pc3)$successes, c(3)) 22 | 23 | expect_output(print(pc1), "Power for predictor 'x'") 24 | expect_output(print(pc2), "Power for predictor 'x'") 25 | expect_output(print(pc3), "Power for predictor 'x'") 26 | 27 | ci1 <- confint(pc1) 28 | expect_equal(dim(ci1), c(8,2)) 29 | expect_equal(colnames(ci1), c("2.5 %", "97.5 %")) 30 | 31 | }) 32 | 33 | test_that("long and short powerCurves work", { 34 | 35 | fmx <- extend(fm1, along="x", n=20) 36 | 37 | pc18 <- powerCurve(fmx, nsim=1, pcmax=Inf) 38 | expect_equal(length(pc18$ps), 18) 39 | 40 | pc5 <- powerCurve(fmx, nsim=1, pcmax=5) 41 | expect_equal(length(pc5$ps), 5) 42 | }) -------------------------------------------------------------------------------- /tests/testthat/test_powerSim.R: -------------------------------------------------------------------------------- 1 | context("powerSim") 2 | 3 | # Make sure this is replicable. 4 | set.seed(42) 5 | 6 | test_that("Simple powerSim works", { 7 | 8 | ps1 <- powerSim(fm1) 9 | 10 | expect_is(ps1, "powerSim") 11 | expect_equal(ps1$x, 9) 12 | expect_equal(ps1$n, 10) 13 | 14 | expect_equal(ps1$pval, c(0.00116776738713373, 0.0295454542836253, 1.21560063674469e-05, 15 | 0.000498979507405491, 5.92823358089596e-05, 0.00132992922350937, 16 | 4.59434991028126e-06, 0.000667631113289252, 0.187538595459622, 17 | 2.1720438196426e-05), tolerance=1e-7) 18 | 19 | expect_equal(confint(ps1), structure(c(0.554983882971805, 0.997471421455538), .Dim = 1:2, .Dimnames = list( 20 | "power", c("2.5 %", "97.5 %")))) 21 | }) 22 | 23 | test_that("GLMM powerSim works", { 24 | 25 | ps2 <- powerSim(fm2) 26 | 27 | expect_is(ps2, "powerSim") 28 | expect_equal(ps2$x, 9) 29 | expect_equal(ps2$n, 10) 30 | }) 31 | 32 | test_that("nsim=0 doesn't break powerSim", { 33 | 34 | expect_error(ps0 <- powerSim(fm1, nsim=0), NA) 35 | expect_output(print(ps0), "") 36 | }) 37 | 38 | -------------------------------------------------------------------------------- /tests/testthat/test_testLibrary.R: -------------------------------------------------------------------------------- 1 | context("Test Library") 2 | 3 | test_that("tests run", { 4 | 5 | t1 <- doTest(fm1) 6 | expect_equal(c(t1), 0.0007336556, tolerance=1e-5) 7 | expect_output(print(t1), "Kenward Roger \\(package pbkrtest\\)") 8 | 9 | t2 <- doTest(fm1, fixed("x", "lr")) 10 | expect_equal(c(t2), 0.0005147106, tolerance=1e-5) 11 | expect_output(print(t2), "Likelihood ratio") 12 | 13 | t3 <- doTest(fm1, random()) 14 | expect_equal(c(t3), 0, tolerance=1e-5) 15 | expect_output(print(t3), "Exact restricted LRT \\(package RLRsim\\)") 16 | 17 | t4 <- doTest(fm1, compare(~ (1|g))) 18 | expect_equal(c(t4), 0.0005147106, tolerance=1e-5) 19 | expect_output(print(t4), "Likelihood ratio") 20 | 21 | t5 <- doTest(fm1, fcompare(~ 1)) 22 | expect_equal(c(t5), 0.0005147106, tolerance=1e-5) 23 | expect_output(print(t5), "Likelihood ratio") 24 | 25 | t6 <- doTest(fm3, rcompare(~ (1|g))) 26 | expect_equal(c(t6), 0.6029132, tolerance=1e-5) 27 | expect_output(print(t6), "Likelihood ratio") 28 | 29 | set.seed(333) # pb test is random 30 | 31 | t7 <- suppressWarnings(doTest(fm3, rcompare(~ (1|g), "pb"))) 32 | expect_equal(c(t7), 1/3, tolerance=1e-5) 33 | expect_output(print(t7), "Parametric bootstrap \\(package pbkrtest\\)") 34 | 35 | 36 | }) 37 | 38 | test_that("lmer tests work", { 39 | 40 | tst <- doTest(fm1, fixed("x")) 41 | expect_equal(c(tst), 0.0007336556, tolerance=1e-8) 42 | expect_output(print(tst), "Kenward Roger") 43 | 44 | #tst <- doTest(fm1, fixed("x", "z")) 45 | #expect_equal(c(tst), 0.0005147106, tolerance=1e-5) 46 | #expect_output(print(tst), "Likelihood ratio") 47 | 48 | tst <- doTest(fm1, fixed("x", "kr")) 49 | expect_equal(c(tst), 0.0007336556, tolerance=1e-8) 50 | expect_output(print(tst), "Kenward Roger") 51 | 52 | tst <- doTest(fm1, fixed("x", "sa")) 53 | expect_equal(c(tst), 0.0007336547, tolerance=1e-8) 54 | expect_output(print(tst), "Satterthwait") 55 | 56 | }) 57 | -------------------------------------------------------------------------------- /tests/testthat/test_zzz.r: -------------------------------------------------------------------------------- 1 | # 2 | # CLEANUP 3 | # 4 | 5 | # NB: runs last, b/c "zzz". 6 | 7 | simrOptions(helperopts) 8 | 9 | -------------------------------------------------------------------------------- /vignettes/examples.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Test examples" 3 | output: html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Test examples} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | \usepackage[utf8]{inputenc} 8 | --- 9 | 10 | This vignette provides examples of some of the hypothesis tests that can be specified in `simr`. The function `doTest` can be used to apply a test to an input model, which lets you check that the test works before running a power simulation. 11 | 12 | Documentation for the test specification functions can be found in the help system at `?tests`. 13 | 14 | ```{r, message=FALSE, warning=FALSE} 15 | library(simr) 16 | ``` 17 | 18 | ```{r options, echo=FALSE, message=FALSE} 19 | simrOptions(progress=FALSE) 20 | ``` 21 | 22 | ## Binomial GLMM with a categorical predictor 23 | 24 | The first example comes from the help page for `glmer`. The data frame `cbpp` contains data on contagious bovine pleuropneumonia. An observation variable is added to allow for overdispersion. Note that the response is specified using `cbind` --- `simr` expects a binomial model to be in this form. 25 | 26 | ```{r} 27 | cbpp$obs <- 1:nrow(cbpp) 28 | gm1 <- glmer(cbind(incidence, size - incidence) ~ period + (1 | herd) + (1|obs), data=cbpp, 29 | family=binomial) 30 | summary(gm1)$coef 31 | ``` 32 | 33 | Note that `period` is a categorical variable with 4 levels, which enters the model as 3 dummy variables. To test all 3 dummy variables simultaneously, you can use a likelihood ratio test. 34 | 35 | ```{r} 36 | doTest(gm1, fixed("period", "lr")) 37 | ``` 38 | 39 | If you were (for some reason) especially interested in the significance for the dummy variable `period2` you could use a z-test. This test uses the value `Pr(>|z|)` reported in the summary above. 40 | 41 | ```{r} 42 | doTest(gm1, fixed("period2", "z")) 43 | ``` 44 | 45 | Suppose your model also has a continuous predictor. You can use `fixed` to choose which fixed effect to apply tests to. 46 | 47 | ```{r} 48 | gm2 <- glmer(cbind(incidence, size - incidence) ~ period + size + (1 | herd), data=cbpp, 49 | family=binomial) 50 | doTest(gm2, fixed("size", "z")) 51 | ``` 52 | 53 | Once you have chosen your tests, you can run a power analysis by replacing `doTest` with `powerSim`. Don't forget to specify an appropriate effect size. 54 | 55 | ```{r} 56 | fixef(gm2)["size"] <- 0.05 57 | powerSim(gm2, fixed("size", "z"), nsim=50) 58 | ``` 59 | 60 | ## Models with interaction or quadratic terms 61 | 62 | As your models become more complex, it can be easier to explicitly specify your null hypothesis using the `compare` functions. 63 | 64 | ### Cake 65 | 66 | This example uses the `cake` dataset. 67 | 68 | ```{r} 69 | fm1 <- lmer(angle ~ recipe * temp + (1|recipe:replicate), data=cake, REML=FALSE) 70 | ``` 71 | 72 | Main effects should not be tested when they appear in an interaction term. Using the `fcompare` function, we can specify a comparison with a simpler model (without having to re-type the random effects specification). 73 | 74 | ```{r} 75 | doTest(fm1, fcompare(~ recipe + temp)) 76 | ``` 77 | 78 | This also works for polynomial terms: 79 | 80 | ```{r} 81 | fm2 <- lmer(angle ~ recipe + poly(temp, 2) + (1|recipe:replicate), data=cake, REML=FALSE) 82 | summary(fm2)$coef 83 | doTest(fm2, fcompare(~ recipe + temp)) 84 | ``` 85 | 86 | ### Budworms 87 | 88 | We can do similar things with the `budworm` data in the `pbkrtest` package. 89 | 90 | ```{r} 91 | data(budworm, package="pbkrtest") 92 | bw1 <- glm(cbind(ndead, ntotal-ndead) ~ dose*sex, family="binomial", data=budworm) 93 | summary(bw1)$coef 94 | ``` 95 | 96 | Of course we don't want to retype the `cbind` boilerplate: 97 | 98 | ```{r} 99 | doTest(bw1, compare(. ~ dose + sex)) 100 | ``` 101 | 102 | Since `dose` is continous and `sex` is binary we could also use a Z-test on the single interaction term. 103 | 104 | ```{r} 105 | doTest(bw1, fixed("dose:sexmale", "z")) 106 | ``` 107 | 108 | ## Single random effects 109 | 110 | The `random` function gives you access to tests from the `RLRsim` package. No additional arguments are needed for a single random effect. 111 | 112 | ```{r} 113 | re1 <- lmer(Yield ~ 1|Batch, data=Dyestuff) 114 | doTest(re1, random()) 115 | ``` 116 | 117 | ## Multiple random effects 118 | 119 | Where the model has multiple random effects, `compare` can be used to test alternative specifications. 120 | 121 | ```{r} 122 | fm1 <- lmer(Reaction ~ Days + (Days | Subject), data=sleepstudy) 123 | ``` 124 | 125 | ```{r} 126 | doTest(fm1, compare( ~ Days + (1 | Subject))) 127 | ``` 128 | 129 | The LRT is fast but only approximate. In fact, when testing random effects, the test is conservative[^1] because the null hypothesis is at a boundary of the parameter space. This means that you will underestimate power if you use the LRT. For more accurate results you can use `compare` with a parametric bootstrap test from the `pbkrtest` package. These can be quite slow, so you may want to use the LRT to exploring designs, and then double check with the parametric bootstrap. 130 | 131 | ```{r, eval=FALSE} 132 | doTest(fm1, compare( ~ Days + (1 | Subject), "pb")) 133 | ``` 134 | 135 | Note that the shortcut `rcompare` saves you from retyping the fixed effect specification. 136 | 137 | ```{r, eval=FALSE} 138 | doTest(fm1, rcompare( ~ (1 | Subject), "pb")) 139 | ``` 140 | 141 | ## A note about errors during simulation 142 | 143 | During a simulation study, some iterations may fail due to some sort of error. When this happens, `simr` treats that iteration as a failed (i.e. not significant) test. In the following example there are 50 simulations, with 14 successes, 34 failures, and 2 non-results. The power is calculated as 14/50, i.e. 28%: 144 | 145 | ```{r} 146 | binFit <- glm(formula = cbind(z, 10 - z) ~ x + g, family = binomial, data = simdata) 147 | 148 | poisSim <- glm(formula = z ~ x + g, family = poisson, data = simdata) 149 | coef(poisSim)[1:2] <- c(1, -0.05) 150 | 151 | powerSim(binFit, sim=poisSim, nsim=50, seed=1) 152 | ``` 153 | 154 | Rather than interrupting part-way through an analysis, `simr` traps and logs errors and warnings. You can access these logs using `$warnings` and `$errors`. If you didn't assign your analysis to a variable, you can recover it with the `lastResult` function. 155 | 156 | ```{r} 157 | ps <- lastResult() 158 | ps$errors 159 | ``` 160 | 161 | [^1]: See, e.g., Pinheiro, J.C., Bates D.M. (2000) _Mixed-Effects Models in S and S-PLUS_, Springer, New York (p84). -------------------------------------------------------------------------------- /vignettes/fromscratch.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Power analysis from scratch" 3 | output: html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Power analysis from scratch} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | \usepackage[utf8]{inputenc} 8 | --- 9 | 10 | If pilot data is not available, `simr` can be used to create `lme4` objects from scratch as a starting point. This requires more paramters to be specified by the user. Values for these parameters might come from the literature or the user's own knowledge and experience. 11 | 12 | ```{r, message=FALSE, warning=FALSE} 13 | library(simr) 14 | ``` 15 | 16 | ```{r options, echo=FALSE, message=FALSE} 17 | simrOptions(nsim=100, progress=FALSE) 18 | ``` 19 | 20 | ### Covariates and parameters 21 | 22 | First set up some covariates with `expand.grid`. 23 | 24 | ```{r} 25 | x <- 1:10 26 | g <- letters[1:3] 27 | 28 | X <- expand.grid(x=x, g=g) 29 | ``` 30 | 31 | Specify some fixed and random parameters. 32 | 33 | ```{r} 34 | b <- c(2, -0.1) # fixed intercept and slope 35 | V1 <- 0.5 # random intercept variance 36 | V2 <- matrix(c(0.5,0.05,0.05,0.1), 2) # random intercept and slope variance-covariance matrix 37 | s <- 1 # residual standard deviation 38 | ``` 39 | 40 | ### Build a model object 41 | 42 | Use the `makeLmer` or `makeGlmer` function to build an artificial `lme4` object. 43 | 44 | ```{r} 45 | model1 <- makeLmer(y ~ x + (1|g), fixef=b, VarCorr=V1, sigma=s, data=X) 46 | print(model1) 47 | model2 <- makeGlmer(z ~ x + (x|g), family="poisson", fixef=b, VarCorr=V2, data=X) 48 | print(model2) 49 | ``` 50 | 51 | ### Start the power analysis 52 | 53 | Now we have "pilot" models, which can be used with `simr`. 54 | 55 | ```{r} 56 | powerSim(model1, nsim=20) 57 | powerSim(model2, nsim=20) 58 | ``` 59 | --------------------------------------------------------------------------------