├── .gitignore ├── LICENSE ├── README.md ├── global.R ├── server.R └── ui.R /.gitignore: -------------------------------------------------------------------------------- 1 | rsconnect 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 jake-westfall 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This page hosts the R code underlying PANGEA. The accompanying working paper can be downloaded here: 2 | 3 | [Westfall, J. (2016). PANGEA: Power ANalysis for GEneral Anova designs.](http://jakewestfall.org/publications/pangea.pdf) 4 | 5 | A live version of PANGEA can be found [here](http://jakewestfall.org/pangea/). 6 | 7 | This code relies on the [Shiny](http://shiny.rstudio.com/) library. To run the app locally, you will need to download the R script files, install the Shiny library, and point Shiny to the R scripts. A nice tutorial can be found [here](http://shiny.rstudio.com/tutorial/lesson1/). 8 | 9 | More docs to follow! -------------------------------------------------------------------------------- /global.R: -------------------------------------------------------------------------------- 1 | textInputMini <- function (inputId, label, value = ""){ 2 | div(style="display:inline-block", 3 | tags$label(label, `for` = inputId), 4 | tags$input(id = inputId, type = "text", value = value, 5 | class = "input-mini", style="width: 100%")) 6 | } 7 | 8 | EMS <- function(design, nested=NULL, random=NULL){ 9 | # modify design formula based on nested factors specified 10 | if(!is.null(nested)){ 11 | terms <- attr(terms(design), "term.labels") 12 | # for each nested, get indices of all terms not involving their interaction 13 | keeps <- lapply(strsplit(nested, "/"), function(x){ 14 | which(apply(sapply(x, grepl, terms), 1, function(x) !all(x))) 15 | }) 16 | terms <- terms[Reduce(intersect, keeps)] 17 | formula <- paste(c(as.character(design)[2:1], paste(terms, collapse="+")), collapse="") 18 | design <- eval(parse(text=formula)) 19 | } 20 | 21 | # build two-way table 22 | mat <- t(attr(terms(design), "factors")) 23 | terms <- tolower(as.character(attr(terms(design), "variables"))[-1]) 24 | 25 | # resolve fixed/random dummies 26 | if (!is.null(random)){ 27 | random <- unlist(strsplit(random,split="")) 28 | mat[,which(colnames(mat) %in% random)][mat[, 29 | which(colnames(mat) %in% random)]==1] <- "" 30 | mat[,which(!colnames(mat) %in% random)][mat[, 31 | which(!colnames(mat) %in% random)]==1] <- "fix" 32 | } 33 | 34 | # insert 1 in nested rows 35 | subs <- strsplit(rownames(mat), split=":") 36 | if(!is.null(nested)){ 37 | nested <- strsplit(nested, split="/") 38 | for(term in nested){ 39 | rows <- unlist(lapply(subs, function(x) term[2] %in% x)) 40 | cols <- colnames(mat)==term[1] 41 | mat[rows,cols] <- "1" 42 | } 43 | } 44 | mat <- rbind(mat, error=rep("1", ncol(mat))) 45 | 46 | # insert numbers of levels for remaining cells 47 | for(row in seq(nrow(mat))){ 48 | mat[row,][mat[row,]=="0"] <- tolower(colnames(mat)[mat[row,]=="0"]) 49 | } 50 | 51 | # construct EMS table 52 | ems <- matrix(nrow=nrow(mat), ncol=nrow(mat), 53 | dimnames=list(Effect=rownames(mat), 54 | VarianceComponent=rev(rownames(mat)))) 55 | # add nesting information to subscripts 56 | if (!is.null(nested)){ 57 | subs <- lapply(subs, function(x){ 58 | new <- x 59 | for (nest in seq(length(nested))){ 60 | if (nested[[nest]][2] %in% x) new <- c(new, nested[[nest]][1]) 61 | } 62 | return(new) 63 | }) 64 | } 65 | subs[["error"]] <- colnames(mat)[-1] 66 | names(subs) <- rownames(mat) 67 | # rename error variable to 'error' invisibly 68 | colnames(mat)[1] <- "error" 69 | # fill in EMS table 70 | for(effect in rownames(ems)){ 71 | for(varcomp in colnames(ems)){ 72 | effectVec <- unlist(strsplit(effect, ":")) 73 | ans <- mat[varcomp,-1*which(colnames(mat) %in% effectVec)] 74 | if ("fix" %in% ans) ans <- "" 75 | if (all(ans=="1")) ans <- "1" 76 | if (("1" %in% ans | "2" %in% ans) & !all(ans=="1")){ 77 | ans <- ans[!ans %in% c("1","2")] 78 | } 79 | varcompVec <- unlist(strsplit(varcomp, ":")) 80 | if (!all(effectVec %in% subs[[varcomp]])) ans <- "" 81 | if (effect=="error" & varcomp=="error") ans <- "1" 82 | ems[effect,varcomp] <- paste(ans, collapse="") 83 | } 84 | } 85 | attr(ems, "terms") <- terms 86 | 87 | # change replicate character to "#" before returning 88 | repChar <- rownames(attr(terms(design), "factors"))[1] 89 | ems <- gsub(repChar, "#", ems) 90 | 91 | # change ':' to 'x' before returning 92 | colnames(ems) <- gsub(":", "*", colnames(ems)) 93 | rownames(ems) <- gsub(":", "*", rownames(ems)) 94 | return(ems) 95 | } 96 | -------------------------------------------------------------------------------- /server.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | shinyServer(function(input, output, session) { 4 | 5 | # declare global variables 6 | ems <- NA 7 | facs <- NA 8 | rands <- NA 9 | nests <- NA 10 | randArg <- NA 11 | fixedFacs <- NA 12 | fixedSimples <- NA 13 | num <- NA 14 | denom <- NA 15 | varLabs <- NA 16 | defaultLabs <- c("Participants", "InkColor", "WordColor", LETTERS[1:10][-9]) 17 | defaultRands <- rep.int(c(TRUE, FALSE), c(1, 11)) 18 | fixNumLabs <- rep(NA, 12) 19 | step2clear <- TRUE 20 | fixContrastPrompts <- rep(NA, 12) 21 | fixContrastMat <- matrix(NA, nrow=12, ncol=12) 22 | labs <- rep(FALSE, 12) 23 | randLabs <- rep(NA, 12) 24 | nestLabs <- rep(NA, 12) 25 | 26 | # define error messages 27 | intError <- "Number of fixed factor levels must be an integer greater than 1." 28 | allRandError <- "There must be at least 1 fixed factor in the design." 29 | dupError <- "At least two factor names have duplicate first letters." 30 | randIntError <- "Number of random factor levels must be an integer greater than 1." 31 | repsError <- "Number of replicates must be an integer greater than 0." 32 | ESerror <- "Effect size (Cohen's d) must be a real number." 33 | sumVPC <- "Variance Partitioning Coefficients (VPCs) must be numbers between 0 and 1, and their sum must be less than or equal to 1 -- see \"Variance component information.\"" 34 | 35 | # define REACTIVE global variables 36 | # start off with 3 factors (2-color Stroop task) 37 | values <- reactiveValues(numFacs = 3, numReps = 1, defaults=NA, 38 | solve=0, step1errors=character(0), step2errors=character(0)) 39 | 40 | # step 1: specify design -------------------------------------------------- 41 | 42 | # initialize "add factor" and "remove factor" buttons 43 | # in separate reactive blocks 44 | observe({ 45 | numFacs <- isolate(values$numFacs) 46 | if(input$addFac > 0){ 47 | if(numFacs < 12) values$numFacs <- numFacs + 1 48 | } 49 | }) 50 | observe({ 51 | numFacs <- isolate(values$numFacs) 52 | if(input$delFac > 0){ 53 | if(numFacs > 1) values$numFacs <- numFacs - 1 54 | } 55 | }) 56 | 57 | # write Labels row -------------------------------------------------------- 58 | 59 | observe({ 60 | # t1 <- Sys.time() 61 | lapply(seq(values$numFacs), function(x){ 62 | lab <- isolate(input[[paste0("f",x,"Lab")]]) 63 | if(!labs[x]){ 64 | output[[paste0("get_f",x,"Lab")]] <- renderUI({ 65 | textInputMini(paste0("f",x,"Lab"), label = NULL, 66 | value=ifelse(is.null(lab), defaultLabs[x], lab)) 67 | }) 68 | labs[x] <<- TRUE 69 | } 70 | }) 71 | lapply(setdiff(1:12, seq(values$numFacs)), function(x){ 72 | if(labs[x]){ 73 | output[[paste0("get_f",x,"Lab")]] <- renderUI(div()) 74 | labs[x] <<- FALSE 75 | } 76 | }) 77 | # print(paste("labels =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 78 | }) 79 | 80 | # write Random row -------------------------------------------------------- 81 | 82 | observe({ 83 | # t1 <- Sys.time() 84 | lapply(seq(values$numFacs), function(x){ 85 | lab <- input[[paste0("f",x,"Lab")]] 86 | if(is.na(randLabs[x]) || randLabs[x] != lab){ 87 | output[[paste0("get_f",x,"Rand")]] <- renderUI({ 88 | checkboxInput(paste0("f",x,"Rand"), 89 | label = ifelse(length(lab) > 0, toupper(substr(lab,1,1)), ""), 90 | value=ifelse(!is.null(lab), 91 | isolate(input[[paste0("f",x,"Rand")]]), 92 | defaultRands[x])) 93 | }) 94 | randLabs[x] <<- ifelse(length(lab) > 0, toupper(substr(lab,1,1)), "") 95 | } 96 | }) 97 | lapply(setdiff(1:12, seq(values$numFacs)), function(x){ 98 | if(!is.na(randLabs[x])){ 99 | output[[paste0("get_f",x,"Rand")]] <- renderUI(div()) 100 | randLabs[x] <<- NA 101 | } 102 | }) 103 | # print(paste("random =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 104 | }) 105 | 106 | # write Nested row -------------------------------------------------------- 107 | 108 | observe({ 109 | # t1 <- Sys.time() 110 | lapply(seq(values$numFacs), function(x){ 111 | lab <- input[[paste0("f",x,"Lab")]] 112 | if(is.na(nestLabs[x]) || nestLabs[x] != lab){ 113 | output[[paste0("get_f",x,"Nest")]] <- renderUI({ 114 | textInputMini(paste0("f",x,"Nest"), 115 | label = ifelse(length(lab) > 0, toupper(substr(lab,1,1)), ""), 116 | value=ifelse(!is.null(lab), isolate(input[[paste0("f",x,"Nest")]]), "")) 117 | }) 118 | nestLabs[x] <<- ifelse(length(lab) > 0, toupper(substr(lab,1,1)), "") 119 | } 120 | }) 121 | lapply(setdiff(1:12, seq(values$numFacs)), function(x){ 122 | lab <- input[[paste0("f",x,"Lab")]] 123 | if(!is.na(nestLabs[x])){ 124 | output[[paste0("get_f",x,"Nest")]] <- renderUI(div()) 125 | nestLabs[x] <<- NA 126 | } 127 | }) 128 | # print(paste("nested =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 129 | }) 130 | 131 | # compute EMSs and store in "ems" object ---------------------------------- 132 | 133 | observe({ 134 | # t1 <- Sys.time() 135 | # t2 <- Sys.time() 136 | # depends on: add/remove factor, label/rand/nest inputs 137 | 138 | facs <<- toupper(substr(lapply(seq(as.numeric(values$numFacs)), function(x){ 139 | tolower(input[[paste0("f",x,"Lab")]]) 140 | }),1,1)) 141 | rands <<- sapply(seq(as.numeric(values$numFacs)), function(x){ 142 | input[[paste0("f",x,"Rand")]] 143 | }) 144 | nests <<- sapply(seq(as.numeric(values$numFacs)), function(x){ 145 | tolower(input[[paste0("f",x,"Nest")]]) 146 | }) 147 | # print(paste("ems.assignGlobals =", round(c(difftime(Sys.time(), t2)*1000)), "ms")) 148 | if(!any(sapply(rands, is.null)) && any(facs %in% LETTERS)){ 149 | # throw error if duplicate factor names 150 | if(length(unique(facs)) < length(facs) && 151 | !dupError %in% isolate(values$step1errors)){ 152 | values$step1errors <- c(isolate(values$step1errors), dupError) 153 | } 154 | # remove error if not duplicate factor names 155 | if(length(unique(facs)) == length(facs) && 156 | dupError %in% isolate(values$step1errors)){ 157 | ind <- match(dupError, isolate(values$step1errors)) 158 | values$step1errors <- isolate(values$step1errors)[-ind] 159 | } 160 | 161 | # t2 <- Sys.time() 162 | # grab input and format arguments for EMS() function 163 | live <- which(facs %in% LETTERS) 164 | repChar <- tolower(tail(setdiff(LETTERS, facs[live]), 1)) 165 | formArg <- paste(repChar,"~",paste(facs[live], collapse="*"), 166 | collapse="") 167 | randArg <<- paste(facs[facs %in% LETTERS & rands], collapse="") 168 | nestArg <- unlist(lapply(live, function(x){ 169 | arg <- toupper(unlist(strsplit(nests[x], split=""))) 170 | arg <- paste0(facs[x], "/", arg[arg %in% facs[live]]) 171 | arg[nchar(arg) > 2] 172 | })) 173 | 174 | # call EMS() function 175 | if(length(nestArg) > 0){ 176 | ems <<- EMS(as.formula(formArg), random=randArg, 177 | nested=nestArg) 178 | } else{ 179 | ems <<- EMS(as.formula(formArg), random=randArg, 180 | nested=NULL) 181 | } 182 | # print(paste("ems.EMSfunction =", round(c(difftime(Sys.time(), t2)*1000)), "ms")) 183 | 184 | # fill in "which effect" power choices if there are fixed facs 185 | # otherwise clear those UIs and throw an error 186 | if(!all(rands)){ 187 | # t2 <- Sys.time() 188 | fixedFacs <<- head(rownames(ems), -1) 189 | if(randArg != ""){ 190 | ind <- sapply(unlist(strsplit(randArg, split="")), function(x){ 191 | !grepl(x, fixedFacs, fixed=TRUE) 192 | }) 193 | fixedFacs <<- fixedFacs[apply(ind, 1, all)] 194 | } 195 | 196 | output$get_which <- renderUI({ 197 | selectInput("which", choices=fixedFacs, 198 | label="Which fixed effect do you want to compute the statistical power to detect?") 199 | }) 200 | # print(paste("ems.getWhich =", round(c(difftime(Sys.time(), t2)*1000)), "ms")) 201 | 202 | # get numbers of fixed factor levels -------------------------------------- 203 | 204 | # t2 <- Sys.time() 205 | # select only simple effects, not interactions 206 | fixedSimples <<- fixedFacs[!grepl("*", fixedFacs, fixed=TRUE)] 207 | 208 | # throw error if input is not an integer >= 2 209 | nonNumerics <- sapply(seq(length(fixedSimples)), function(x){ 210 | fixnum <- input[[paste0("f",x,"FixNum")]] 211 | suppressWarnings(return(is.na(as.numeric(fixnum)) || 212 | as.numeric(fixnum) %% 1 > 0 || 213 | as.numeric(fixnum) < 2)) 214 | }) 215 | # ...but only if no arguments are NULL 216 | if(!any(sapply(nonNumerics, is.na))){ 217 | if(any(nonNumerics) && !intError %in% isolate(values$step1errors)){ 218 | values$step1errors <- c(isolate(values$step1errors), intError) 219 | } else if(!any(nonNumerics) && intError %in% isolate(values$step1errors)){ 220 | ind <- match(intError, isolate(values$step1errors)) 221 | values$step1errors <- isolate(values$step1errors)[-ind] 222 | } 223 | } 224 | 225 | # proceed only if there is no intError 226 | if(!intError %in% isolate(values$step1errors)){ 227 | # write input boxes for each simple effect 228 | # t3 <- Sys.time() 229 | lapply(seq(length(fixedSimples)), function(x){ 230 | fixnum <- isolate(as.numeric(input[[paste0("f",x,"FixNum")]])) 231 | containers <- facs[grep(fixedSimples[x], toupper(nests))] 232 | newLab <- ifelse(length(containers)==0, 233 | paste0(fixedSimples[x]," levels"), 234 | paste0(fixedSimples[x]," levels (per ",paste(containers, sep="*"),")")) 235 | if(is.na(fixNumLabs[x]) || newLab != fixNumLabs[x]){ 236 | output[[paste0("get_f",x,"FixNum")]] <- renderUI({ 237 | textInputMini(paste0("f",x,"FixNum"), label = newLab, 238 | value=ifelse(length(fixnum) > 0, fixnum, 2)) 239 | }) 240 | fixNumLabs[x] <<- newLab 241 | } 242 | }) 243 | # print(paste("ems.getFixNum.writeActive =", round(c(difftime(Sys.time(), t3)*1000)), "ms")) 244 | # t3 <- Sys.time() 245 | # clear the remainder of the 12 UIs 246 | lapply(setdiff(1:12, seq(length(fixedSimples))), function(x){ 247 | if(!is.na(fixNumLabs[x])){ 248 | output[[paste0("f",x,"FixContrastPrompt")]] <- renderUI(div()) 249 | output[[paste0("get_f",x,"FixNum")]] <- renderUI(div()) 250 | fixNumLabs[x] <<- NA 251 | } 252 | }) 253 | # print(paste("ems.getFixNum.writeNonActive =", round(c(difftime(Sys.time(), t3)*1000)), "ms")) 254 | } # end if no intError in step1errors 255 | 256 | # clear no-fixed-factors error if it currently exists 257 | if(allRandError %in% isolate(values$step1errors)){ 258 | ind <- match(allRandError, isolate(values$step1errors)) 259 | values$step1errors <- isolate(values$step1errors)[-ind] 260 | } 261 | # print(paste("ems.getFixNum =", round(c(difftime(Sys.time(), t2)*1000)), "ms")) 262 | } else { # i.e., if all(rands) 263 | # clear UIs that depend on at least 1 fixed factor 264 | output$get_which <- renderUI(div()) 265 | lapply(1:12, function(x){ 266 | output[[paste0("get_f",x,"FixNum")]] <- renderUI(div()) 267 | output[[paste0("f",x,"FixContrastPrompt")]] <- renderUI(div()) 268 | lapply(1:12, function(y){ 269 | output[[paste0("get_f",x,"FixContrast",y)]] <- renderUI(div()) 270 | }) 271 | }) 272 | 273 | # throw error 274 | if(!allRandError %in% isolate(values$step1errors)){ 275 | values$step1errors <- c(isolate(values$step1errors), allRandError) 276 | } 277 | } # end else, i.e., if all(rands) 278 | } # end if any facs in letters 279 | # print(paste("ems =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 280 | }) # end observe 281 | 282 | # get contrasts for fixed factors having >2 levels ------------------------ 283 | 284 | # only if they are specified in input$which 285 | observe({ 286 | t1 <- Sys.time() 287 | if(!intError %in% values$step1errors){ 288 | lapply(1:12, function(f){ 289 | fixnum <- as.numeric(input[[paste0("f",f,"FixNum")]]) 290 | # errors from previous reactive block not registered yet 291 | # so manually check for bad fixnum input 292 | if(length(fixnum) > 0 && !is.na(fixnum) && 293 | !is.null(input$which) && !is.na(fixedSimples[f])){ 294 | # check if current factor interacts with selected effect 295 | if(any(grepl(fixedSimples[f], unlist(strsplit(input$which, split="*", fixed=TRUE))))){ 296 | if(fixnum > 2){ 297 | if(is.na(fixContrastPrompts[f])){ 298 | output[[paste0("f",f,"FixContrastPrompt")]] <- renderUI({ 299 | div("Contrast code values to apply to the levels of ", 300 | strong(fixedSimples[f]),"(must sum to 0!). Note that you",em("only"),"need to specify the single code being tested; you do",em("not"),"need to specify the full set of contrast codes.") 301 | }) 302 | fixContrastPrompts[f] <<- fixedSimples[f] 303 | } 304 | lapply(seq(fixnum), function(x){ 305 | if(is.na(fixContrastMat[f,x])){ 306 | output[[paste0("get_f",f,"FixContrast",x)]] <- renderUI({ 307 | textInputMini(paste0("f",f,"FixContrast",x), 308 | label = NULL, value=1*(x==1) + -1*(x==2)) 309 | }) 310 | } 311 | fixContrastMat[f,x] <<- 1*(x==1) + -1*(x==2) 312 | }) 313 | lapply(setdiff(1:12, seq(fixnum)), function(x){ 314 | if(!is.na(fixContrastMat[f,x])){ 315 | output[[paste0("get_f",f,"FixContrast",x)]] <- renderUI(div()) 316 | } 317 | fixContrastMat[f,x] <<- NA 318 | }) 319 | } 320 | } else { # i.e., if fixed factor NOT in input$which 321 | if(!is.na(fixContrastPrompts[f])){ 322 | output[[paste0("f",f,"FixContrastPrompt")]] <- renderUI(div()) 323 | fixContrastPrompts[f] <<- NA 324 | } 325 | lapply(1:12, function(x){ 326 | if(!is.na(fixContrastMat[f,x])){ 327 | output[[paste0("get_f",f,"FixContrast",x)]] <- renderUI(div()) 328 | fixContrastMat[f,x] <<- NA 329 | } 330 | }) 331 | } # end if fixed factor NOT in input$which 332 | # clear contrasts left over from previous examples 333 | } else if(length(fixnum) > 0 && !is.na(fixnum) && 334 | !is.null(input$which) && is.na(fixedSimples[f])){ 335 | if(!is.na(fixContrastPrompts[f])){ 336 | output[[paste0("f",f,"FixContrastPrompt")]] <- renderUI(div()) 337 | fixContrastPrompts[f] <<- NA 338 | } 339 | lapply(1:12, function(x){ 340 | if(!is.na(fixContrastMat[f,x])){ 341 | output[[paste0("get_f",f,"FixContrast",x)]] <- renderUI(div()) 342 | fixContrastMat[f,x] <<- NA 343 | } 344 | }) 345 | } 346 | }) # end lapply 347 | } # end if no intError in step1errors 348 | # print(paste("getFixContrast =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 349 | }) # end observe 350 | 351 | # drop-down menu examples ------------------------------------------------- 352 | 353 | observe({ 354 | # t1 <- Sys.time() 355 | # clear input$randNums somehow 356 | # or make default randNum values not depend just on not being NULL 357 | 358 | if(substr(input$example,1,1)=="1"){ 359 | updateNumericInput(session, "f2FixNum", value=2) 360 | values$numFacs <- 1 361 | updateTextInput(session, "f1Lab", value="Group") 362 | updateCheckboxInput(session, "f1Rand", value=FALSE) 363 | updateTextInput(session, "f1Nest", value="") 364 | updateSelectInput(session, "which", choices="G") 365 | updateTextInput(session, "f1FixNum", value=2) 366 | } else if(substr(input$example,1,1)=="2"){ 367 | values$numFacs <- 2 368 | updateTextInput(session, "f1Lab", value="Group") 369 | updateTextInput(session, "f2Lab", value="Participant") 370 | updateCheckboxInput(session, "f1Rand", value=FALSE) 371 | updateCheckboxInput(session, "f2Rand", value=TRUE) 372 | updateTextInput(session, "f1Nest", value="P") 373 | updateTextInput(session, "f2Nest", value="") 374 | updateSelectInput(session, "which", choices="G") 375 | updateTextInput(session, "f1FixNum", value=2) 376 | } else if(substr(input$example,1,1)=="3"){ 377 | values$numFacs <- 3 378 | updateTextInput(session, "f1Lab", value="Within") 379 | updateTextInput(session, "f2Lab", value="Between") 380 | updateTextInput(session, "f3Lab", value="Participant") 381 | updateCheckboxInput(session, "f1Rand", value=FALSE) 382 | updateCheckboxInput(session, "f2Rand", value=FALSE) 383 | updateCheckboxInput(session, "f3Rand", value=TRUE) 384 | updateTextInput(session, "f1Nest", value="") 385 | updateTextInput(session, "f2Nest", value="P") 386 | updateTextInput(session, "f3Nest", value="") 387 | updateSelectInput(session, "which", choices=c("W","B","W*B")) 388 | updateTextInput(session, "f1FixNum", value=2) 389 | updateTextInput(session, "f2FixNum", value=3) 390 | } else if(substr(input$example,1,1)=="4"){ 391 | values$numFacs <- 3 392 | updateTextInput(session, "f1Lab", value="Classes") 393 | updateTextInput(session, "f2Lab", value="Schools") 394 | updateTextInput(session, "f3Lab", value="Treatments") 395 | updateCheckboxInput(session, "f1Rand", value=TRUE) 396 | updateCheckboxInput(session, "f2Rand", value=TRUE) 397 | updateCheckboxInput(session, "f3Rand", value=FALSE) 398 | updateTextInput(session, "f1Nest", value="") 399 | updateTextInput(session, "f2Nest", value="C") 400 | updateTextInput(session, "f3Nest", value="C") 401 | updateSelectInput(session, "which", choices="T") 402 | updateTextInput(session, "f1FixNum", value=2) 403 | } else if(substr(input$example,1,1)=="5"){ 404 | values$numFacs <- 3 405 | updateTextInput(session, "f1Lab", value="Participants") 406 | updateTextInput(session, "f2Lab", value="Stimuli") 407 | updateTextInput(session, "f3Lab", value="Treatments") 408 | updateCheckboxInput(session, "f1Rand", value=TRUE) 409 | updateCheckboxInput(session, "f2Rand", value=TRUE) 410 | updateCheckboxInput(session, "f3Rand", value=FALSE) 411 | updateTextInput(session, "f1Nest", value="") 412 | updateTextInput(session, "f2Nest", value="") 413 | updateTextInput(session, "f3Nest", value="S") 414 | updateSelectInput(session, "which", choices="T") 415 | updateTextInput(session, "f1FixNum", value=2) 416 | } else if(substr(input$example,1,1)=="6"){ 417 | values$numFacs <- 4 418 | updateTextInput(session, "f1Lab", value="Participants") 419 | updateTextInput(session, "f2Lab", value="Groups") 420 | updateTextInput(session, "f3Lab", value="Stimuli") 421 | updateTextInput(session, "f4Lab", value="Blocks") 422 | updateCheckboxInput(session, "f1Rand", value=TRUE) 423 | updateCheckboxInput(session, "f2Rand", value=FALSE) 424 | updateCheckboxInput(session, "f3Rand", value=TRUE) 425 | updateCheckboxInput(session, "f4Rand", value=FALSE) 426 | updateTextInput(session, "f1Nest", value="") 427 | updateTextInput(session, "f2Nest", value="P") 428 | updateTextInput(session, "f3Nest", value="") 429 | updateTextInput(session, "f4Nest", value="S") 430 | updateSelectInput(session, "which", choices=c("G","B","G*B")) 431 | updateTextInput(session, "f1FixNum", value=2) 432 | updateTextInput(session, "f2FixNum", value=2) 433 | } 434 | # print(paste("examples =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 435 | }) 436 | 437 | # check for errors in step 1 ---------------------------------------------- 438 | 439 | # only display 'submit' button if no errors found 440 | observe({ 441 | # t1 <- Sys.time() 442 | if(length(values$step1errors) > 0){ 443 | output$submitAndEMS <- renderUI(div()) 444 | output$step1ErrorPrompt <- renderUI({ 445 | h4("The following errors must be corrected before you can continue:", 446 | style = "color:red") 447 | }) 448 | output$step1ErrorBox <- renderUI({ 449 | lapply(values$step1errors, function(x){ 450 | div(x, style = "color:red") 451 | }) 452 | }) 453 | step2clear <<- TRUE 454 | } else { 455 | output$submitAndEMS <- renderUI({ 456 | fluidRow( 457 | column(2, actionButton("submit", strong("Submit Design"))), 458 | column(10, checkboxInput("showEMS", value=FALSE, 459 | label="Advanced: Show expected mean square equations for this design?")) 460 | ) 461 | }) 462 | output$step1ErrorPrompt <- renderUI(div()) 463 | output$step1ErrorBox <- renderUI(div()) 464 | } 465 | # print(paste("step1errors =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 466 | }) 467 | 468 | # step 2: parameters ------------------------------------------------------ 469 | 470 | # write instructions and Solve button, get most basic input 471 | observe({ 472 | # t1 <- Sys.time() 473 | if(length(input$submit) > 0 && input$submit > 0 && 474 | length(values$step1errors)==0){ 475 | # show EMS table if requested 476 | if(isolate(input$showEMS)){ 477 | output$EMSoutput <- renderUI({ 478 | list( 479 | h4("Table of expected mean square equations"), 480 | p("Each row of the table represents one of the expected mean square equations for the specified design. Each mean square equation consists of a sum of",em("variance components"),"multiplied by the numbers of levels of some of the factors in the experiment."), 481 | p("The columns represent the variance components that go into each mean square equation, and the entries in each cell of the table indicate the numbers of factor levels that are multiplied by the corresponding variance component in the corresponding mean square equation. If a cell is blank, it is implicitly equal to 0."), 482 | p("Some more information about expected mean squares can be found at the following links:", 483 | a("[1]", href="http://support.sas.com/documentation/cdl/en/statug/63033/HTML/default/viewer.htm#statug_introanova_a0000000086.htm"),",", 484 | a("[2]", href="http://www.math.unb.ca/~rolf/Courses/07w/3373/notes-ems.pdf"),",", 485 | a("[3]", href="http://www.plantsciences.ucdavis.edu/agr205/Lectures/2011_Transp/T10_MixModels.pdf")), 486 | fluidRow( 487 | column(1, div()), 488 | column(11, div("Columns = Variance components")) 489 | ), 490 | fluidRow( 491 | column(1, div("Rows = Mean squares")), 492 | column(11, tableOutput("EMStable")) 493 | ), 494 | p("The variables representing the numbers of factor levels are the lower-case counterparts of the factor labels (which are printed in upper-case), and represent the number of levels of the corresponding factor. For example, the variable 'a' represents the number of levels of the A factor. The # symbol denotes the number of",em("replicates"),"in the design -- see the \"Replicates information\" section under Step 2."), 495 | p("Importantly, the numbers of factor levels are",em("per each level of any containing factors"),"(i.e., factors that the current factor is nested in). For example, if the factor A is nested in the factor B, then the variable 'a' represents the number of levels of A per each level of B. But if the factor A is not nested in any other factors, then 'a' just represents the total number of levels of A. See the input box labels under Step 2 for some guidance for the random factors.") 496 | ) 497 | }) 498 | output$EMStable <- renderTable(ems) 499 | } else { 500 | output$EMSoutput <- renderUI(div()) 501 | } 502 | 503 | # print instructions and button 504 | step2clear <<- FALSE 505 | output$solveInstrs <- renderUI({ 506 | fluidRow( 507 | column(5, p("Enter the assumed parameters of the study and then click the",strong("Compute Power"),"button at the bottom of this step.")), 508 | column(2, actionButton("display2info", label=strong("Show/hide more information"))) 509 | # p("To compute power estimates, enter an X for the variable you wish to solve for, then click the",strong("Solve for X"),"button.") 510 | ) 511 | }) 512 | 513 | # effect size info 514 | output$step2info <- renderUI({ 515 | conditionalPanel(condition = "(input.display2info % 2) == 1", 516 | p(strong("Effect size information."),"Effect sizes here are on the Cohen's d (standardized mean difference) scale. See the figure below for typical values of Cohen's d based on meta-analytic data. For contrasts consisting of more than 2 levels, PANGEA uses a generalized version of Cohen's d that takes into account the reduction in predictor variance relative to a simple two-group-comparison contrast."), 517 | img(src="http://jakewestfall.org/pangea/d_dist.png"), 518 | p(strong("Replicates information."),"One of the boxes asks for \"# replicates\", or the number of",em("replicates"),"in the study. In traditional ANOVA terminology, replicates refers to the (constant) number of observations in each of the",em("lowest-level"),"cells of the design; lowest-level in the sense that it refers to the crossing of all fixed",em("AND"),"random factors, including e.g. subjects. For example, in a simple pre-test/post-test style design where we measure each subject twice before a treatment and twice after the treatment, the number of replicates would be 2, since there are 2 observations in each Subject*Treatment cell."), 519 | p(strong("Variance component information."),"For most designs involving at least one random factor, PANGEA will ask you to specify the variances of some of the random effects in the design; for example, var(e) for the error variance, or var(S) for the variance of the subject means, if the symbol \"S\" represents the Subject factor in your design. These variance components are entered in a standardized form, specifically, as the",em("proportion of the total random variance"),"due to that effect (i.e., as Variance Partitioning Coefficients or VPCs; see Westfall, Kenny, & Judd, 2014). As such, the variances should be between 0 and 1, and should not sum to more than 1. We have attempted to give these variance components sensible default values that respect the so-called",em("hierarchical ordering principle"),"; again, see Westfall et al. (2014), or also the online discussion",a("HERE", href="http://stats.stackexchange.com/questions/72819/relative-variances-of-higher-order-vs-lower-order-random-terms-in-mixed-models"),". The upshot is that you should be able to get basically reasonable power analysis results without messing around too much with the variance components.") 520 | # p(strong("Standardized vs. unstandardized input."),"As the information above indicates, PANGEA is set up by default to accept",em("standardized"),"input for the experimental parameters; i.e., Cohen's d for the effect to be tested, VPCs for the variances. However, PANGEA can also accept",em("unstandardized"),"parameter input, where the effect is given as a simple mean difference (or, in more general terms, the regression coefficent for the contrast of interest), and the variance components are simply given as variances") 521 | ) 522 | }) 523 | 524 | # get parameters that are always there (power, ES, reps) ------------------ 525 | 526 | output$get_power <- renderUI({ 527 | #textInputMini("power", label="Power", value="X") 528 | }) 529 | output$get_ES <- renderUI({ 530 | textInputMini("ES", label="Effect size (d)", value=.45) 531 | }) 532 | output$get_numReps <- renderUI({ 533 | numReps <- isolate(values$numReps) 534 | textInputMini("numReps", 535 | label=paste0("Replicates (observations per ", 536 | paste(facs[nests==""],collapse="*"),")"), 537 | value=ifelse(length(numReps) > 0, numReps, 1)) 538 | }) 539 | # output$solve <- renderUI({actionButton("solve", strong("Compute Power"))}) 540 | # # create dependence on step2errors 541 | # values$step2errors 542 | 543 | # get numbers of levels for random factors -------------------------------- 544 | 545 | # ONLY if there is at least 1 random factor 546 | if(any(unlist(rands))){ 547 | lapply(seq(nchar(randArg)), function(x){ 548 | containers <- tolower(unlist(strsplit(randArg, split="")))[x] 549 | containers <- facs[grep(containers, nests, fixed=TRUE)] 550 | if(length(containers)==0) containers <- "" 551 | lab <- unlist(strsplit(randArg, split=""))[x] 552 | randnum <- isolate(input[[paste0("f",x,"RandNum")]]) 553 | output[[paste0("get_f",x,"RandNum")]] <- renderUI({ 554 | textInputMini(paste0("f",x,"RandNum"), 555 | label = ifelse(containers[1]=="", 556 | paste0("Number of ",lab,"'s"), 557 | paste0("Number of ",lab,"'s (per ",paste(unlist(strsplit(containers,split="")),collapse="*"),")")), 558 | value=ifelse(is.null(randnum), 30, randnum)) 559 | }) 560 | }) 561 | lapply(setdiff(1:12, seq(nchar(randArg))), function(x){ 562 | output[[paste0("get_f",x,"RandNum")]] <- renderUI(div()) 563 | }) 564 | } # end if any rands 565 | } # end if submit > 0 566 | # print(paste("step2constant =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 567 | }) # end observe 568 | 569 | # get other step 2 inputs ------------------------------------------------- 570 | 571 | observe({ 572 | # t1 <- Sys.time() 573 | if(length(input$submit) > 0 && input$submit > 0 && 574 | length(isolate(values$step1errors))==0 && 575 | isolate(input$which) %in% rownames(ems)){ 576 | if(!is.null(input$numReps)) values$numReps <- input$numReps 577 | num <<- isolate(input$which) 578 | denom <<- ems[num, -c(which(ems[num,]==""), 579 | match(num, colnames(ems)))] 580 | if(length(denom)==1){ 581 | denom <<- c(error="1") 582 | } 583 | 584 | # get random effect variances (as VPCs) ----------------------------------- 585 | # ONLY if there is at least 1 random factor 586 | if(any(unlist(rands))){ 587 | ranefs <- setdiff(head(rownames(ems), -1), fixedFacs) 588 | defaults <- nchar(ranefs) %/% 2 + 1 589 | defaults <- sum(range(defaults)) - defaults 590 | defaults <- c(defaults, max(defaults)+1) 591 | defaults <- defaults/sum(defaults) 592 | names(defaults) <- paste0("var(", c(ranefs, "error"), ")") 593 | varLabs <<- paste0("var(", names(denom), ")") 594 | try(if(as.numeric(values$numReps)==1 & any(denom=="#")){ 595 | defaults <- c(defaults, defaults["var(error)"]+defaults[paste0("var(",names(denom)[denom=="#"],")")]) 596 | varLabs <<- c(paste(varLabs[1], 597 | paste0("var(",names(denom)[denom=="#"],")"), 598 | sep=" + "), 599 | varLabs[-c(1,which(varLabs==paste0("var(",names(denom)[denom=="#"],")")))]) 600 | names(defaults) <- c(head(names(defaults),-1), varLabs[1]) 601 | }, silent=FALSE) 602 | # write input boxes 603 | howmany <- seq(varLabs) 604 | if(any(defaults==1)) howmany <- numeric(0) 605 | values$defaults <- defaults 606 | lapply(howmany, function(x){ 607 | output[[paste0("get_f",x,"Var")]] <- renderUI({ 608 | textInputMini(paste0("f",x,"Var"), label = varLabs[x], 609 | value=round(defaults[varLabs[x]], digits=3)) 610 | }) 611 | }) 612 | lapply(setdiff(1:12, howmany), function(x){ 613 | output[[paste0("get_f",x,"Var")]] <- renderUI(div()) 614 | }) 615 | } # end if any rands 616 | } # end if submit > 0 617 | # print(paste("step2varying =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 618 | }) # end observe 619 | 620 | # check for errors in step 2 ---------------------------------------------- 621 | observe({ 622 | # check that random levels > 1 623 | lapply(1:12, function(x) input[[paste0("f",x,"RandNum")]]) 624 | if(any(unlist(rands))){ 625 | # check conditions 626 | nonNumerics <- sapply(seq(nchar(randArg)), function(x){ 627 | randnum <- input[[paste0("f",x,"RandNum")]] 628 | suppressWarnings(return(is.na(as.numeric(randnum)) || 629 | as.numeric(randnum) %% 1 > 0 || 630 | as.numeric(randnum) < 2)) 631 | }) 632 | # throw error, but only if no arguments are NULL 633 | if(!any(sapply(nonNumerics, is.na))){ 634 | if(any(nonNumerics) && !randIntError %in% isolate(values$step2errors)){ 635 | values$step2errors <- c(isolate(values$step2errors), randIntError) 636 | } else if(!any(nonNumerics) && randIntError %in% isolate(values$step2errors)){ 637 | ind <- match(randIntError, isolate(values$step2errors)) 638 | values$step2errors <- isolate(values$step2errors)[-ind] 639 | } 640 | } # end if no arguments are null 641 | } # end if any rands 642 | 643 | # check that replicates > 0 644 | badReps <- is.na(as.numeric(values$numReps)) || 645 | as.numeric(values$numReps) %% 1 > 0 || as.numeric(values$numReps) < 1 646 | if(badReps && !repsError %in% isolate(values$step2errors)){ 647 | values$step2errors <- c(isolate(values$step2errors), repsError) 648 | } else if(!badReps && repsError %in% isolate(values$step2errors)){ 649 | ind <- match(repsError, isolate(values$step2errors)) 650 | values$step2errors <- isolate(values$step2errors)[-ind] 651 | } 652 | 653 | # check that effect size is numeric 654 | if(length(input$ES) > 0){ 655 | badES <- suppressWarnings(is.na(as.numeric(input$ES))) 656 | if(badES && !ESerror %in% isolate(values$step2errors)){ 657 | values$step2errors <- c(isolate(values$step2errors), ESerror) 658 | } else if(!badES && ESerror %in% isolate(values$step2errors)){ 659 | ind <- match(ESerror, isolate(values$step2errors)) 660 | values$step2errors <- isolate(values$step2errors)[-ind] 661 | } 662 | } 663 | 664 | # check VPCs 665 | lapply(1:12, function(x) input[[paste0("f",x,"Var")]]) 666 | if(any(unlist(rands))){ 667 | # check conditions 668 | checks <- sapply(seq(varLabs), function(x){ 669 | vpc <- input[[paste0("f",x,"Var")]] 670 | suppressWarnings(return(is.na(as.numeric(vpc)) || 671 | as.numeric(vpc) < 0 || 672 | as.numeric(vpc) > 1)) 673 | }) 674 | # throw error, but only if no arguments are NULL 675 | if(!any(sapply(checks, is.na))){ 676 | # only check sum if previous checks all passed 677 | badSum <- FALSE 678 | if(!any(checks)){ 679 | vpcs <- sapply(seq(varLabs), function(x){ 680 | as.numeric(input[[paste0("f",x,"Var")]]) 681 | }) 682 | badSum <- sum(vpcs, na.rm=TRUE) > 1.01 # allow a little tolerance 683 | } 684 | if((any(checks) || badSum) && !sumVPC %in% isolate(values$step2errors)){ 685 | values$step2errors <- c(isolate(values$step2errors), sumVPC) 686 | } else if(!(any(checks) || badSum) && sumVPC %in% isolate(values$step2errors)){ 687 | ind <- match(sumVPC, isolate(values$step2errors)) 688 | values$step2errors <- isolate(values$step2errors)[-ind] 689 | } 690 | } # end if no arguments are null 691 | } # end if any rands 692 | }) # end observe 693 | 694 | # clear step 2 if step 1 modified ----------------------------------------- 695 | 696 | observe({ 697 | # t1 <- Sys.time() 698 | # create dependencies on all step 1 input 699 | values$numFacs 700 | lapply(1:12, function(x) input[[paste0("f",x,"Lab")]]) 701 | lapply(1:12, function(x) input[[paste0("f",x,"Rand")]]) 702 | lapply(1:12, function(x) input[[paste0("f",x,"Nest")]]) 703 | lapply(1:12, function(x) input[[paste0("f",x,"FixNum")]]) 704 | lapply(1:12, function(x) input[[paste0("f",x,"FixContrast")]]) 705 | input$which 706 | values$step1errors 707 | 708 | # if step 2 not already clear... 709 | if(!step2clear){ 710 | # clear step 2 UIs 711 | output$EMSoutput <- renderUI(div()) 712 | output$solveInstrs <- renderUI(div()) 713 | output$solve <- renderUI(div()) 714 | output$step2info <- renderUI(div()) 715 | output$get_power <- renderUI(div()) 716 | output$get_ES <- renderUI(div()) 717 | output$get_numReps <- renderUI(div()) 718 | lapply(1:12, function(x){ 719 | output[[paste0("get_f",x,"RandNum")]] <- renderUI(div()) 720 | }) 721 | lapply(1:12, function(x){ 722 | output[[paste0("get_f",x,"Var")]] <- renderUI(div()) 723 | }) 724 | output$step2ErrorPrompt <- renderUI(div()) 725 | output$step2ErrorBox <- renderUI(div()) 726 | 727 | # set global flag saying it's clear 728 | step2clear <<- TRUE 729 | } 730 | # print(paste("clearStep2 =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 731 | }) 732 | 733 | # only display 'solve' button if no errors found -------------------------- 734 | 735 | observe({ 736 | # t1 <- Sys.time() 737 | # make dependent on submit button 738 | if(length(input$submit) > 0 && input$submit > 0){ 739 | if(length(values$step2errors) > 0){ 740 | output$solve <- renderUI(div()) 741 | output$step2ErrorPrompt <- renderUI({ 742 | h4("The following errors must be corrected before you can continue:", 743 | style = "color:red") 744 | }) 745 | output$step2ErrorBox <- renderUI({ 746 | lapply(values$step2errors, function(x){ 747 | div(x, style = "color:red") 748 | }) 749 | }) 750 | } else if(!is.null(input$numReps)){ 751 | output$solve <- renderUI({actionButton("solve", strong("Compute Power"))}) 752 | output$step2ErrorPrompt <- renderUI(div()) 753 | output$step2ErrorBox <- renderUI(div()) 754 | } 755 | } 756 | # print(paste("displaySubmit =", round(c(difftime(Sys.time(), t1)*1000)), "ms")) 757 | }) 758 | 759 | # step 3: the answer ------------------------------------------------------ 760 | 761 | output$ans <- renderPrint({ 762 | # make answer dependent on Solve button 763 | if(length(input$solve) > 0 && input$solve > 0){ 764 | # get params from step 2 765 | numFacs <- isolate(values$numFacs) 766 | pow <- isolate(input$power) 767 | ES <- as.numeric(isolate(input$ES)) 768 | numReps <- as.numeric(isolate(input$numReps)) 769 | 770 | # compute NCP 771 | numLevs <- rep(NA, numFacs) 772 | numLevs[!rands] <- as.numeric(sapply(seq(sum(!rands)), function(x){ 773 | isolate(as.numeric(input[[paste0("f",x,"FixNum")]])) 774 | })) 775 | if(any(unlist(rands))){ 776 | numLevs[rands] <- as.numeric(sapply(seq(sum(rands)), function(x){ 777 | isolate(input[[paste0("f",x,"RandNum")]]) 778 | })) 779 | } 780 | for(x in seq(numFacs)){ 781 | assign(attr(ems, "terms")[-1][x], numLevs[x]) 782 | } 783 | denomLevs <- strsplit(denom, split="") 784 | denomLevs <- unlist(lapply(denomLevs, paste, collapse="*")) 785 | repChar <- attr(ems, "terms")[1] 786 | denomLevs <- gsub("#", "numReps", denomLevs) 787 | denomLevs <- sapply(denomLevs, function(x) eval(parse(text=x))) 788 | if(numReps==1 & any(denom=="#")){ 789 | denomLevs <- denomLevs[-1] 790 | } 791 | contrasts <- lapply(unlist(strsplit(num, split="*", fixed=TRUE)), function(x){ 792 | if(numLevs[match(x, facs)]==2){ 793 | con <- c(-1,1) 794 | } else { 795 | con <- as.numeric(sapply(seq(numLevs[match(x, facs)]), function(y){ 796 | isolate(input[[paste0("f",match(x, facs[!rands]),"FixContrast",y)]]) 797 | })) 798 | } 799 | return(con) 800 | }) 801 | names(contrasts) <- unlist(strsplit(num, split="*", fixed=TRUE)) 802 | numContrast <- Reduce(kronecker, contrasts) 803 | designFac <- var(numContrast)*(length(numContrast)-1)/length(numContrast) 804 | # add sum of squared contrasts to relevant coefficients in EMS line 805 | denomLevs <- sapply(seq(denomLevs), function(x){ 806 | ind <- match(unlist(strsplit(names(denomLevs[x]), split="*", fixed=TRUE)), names(contrasts)) 807 | if(any(!is.na(ind))){ 808 | return(denomLevs[x] * Reduce(prod, lapply(contrasts[ind[!is.na(ind)]], function(y) sum(y^2)))) 809 | } else { 810 | return(denomLevs[x]) 811 | } 812 | }) 813 | if(any(unlist(rands)) & !any(isolate(values$defaults==1))){ 814 | vars <- as.numeric(sapply(seq(varLabs), function(x){ 815 | isolate(input[[paste0("f",x,"Var")]]) 816 | })) 817 | denomLevLabs <- strsplit(varLabs, split=" + ", fixed=TRUE) 818 | denomLevLabs <- sapply(denomLevLabs, function(x) tail(x,1)) 819 | denomLevLabs <- sapply(denomLevLabs, function(x) substr(x, 5, nchar(x)-1)) 820 | denomValues <- as.vector(t(denomLevs[denomLevLabs]) %*% vars) 821 | ncp <- ES*sqrt(designFac)*sqrt(prod(numReps,numLevs))/ 822 | diff(range(numContrast))/sqrt(denomValues) 823 | } else { 824 | vars <- 1 825 | ncp <- ES*sqrt(designFac)*sqrt(prod(numReps,numLevs))/ 826 | diff(range(numContrast)) 827 | } 828 | 829 | # get DFs for mean squares ------------------------------------------------ 830 | 831 | DFeqs <- sapply(seq(numFacs), function(x){ 832 | tolower(isolate(input[[paste0("f",x,"Nest")]])) 833 | }) 834 | DFeqs <- sapply(seq(DFeqs), function(x){ 835 | containers <- tolower(facs[grepl(tolower(facs[x]), DFeqs, fixed=TRUE)]) 836 | if(length(containers)==0) containers <- "" 837 | paste(paste(tolower(rownames(ems)[x]), 838 | paste(unlist(strsplit(containers, split="")), sep="*"), 839 | sep=ifelse(containers=="","","*")), 840 | "-",ifelse(containers=="","1", 841 | paste(unlist(strsplit(containers, split="")), sep="*"))) 842 | }) 843 | DFsimples <- sapply(DFeqs, function(x) eval(parse(text=tolower(x)))) 844 | names(DFsimples) <- rownames(ems)[seq(numFacs)] 845 | DFints <- rownames(ems)[-c(seq(numFacs),length(rownames(ems)))] 846 | DFints <- sapply(strsplit(DFints, split="*", fixed=TRUE), function(x){ 847 | prod(DFsimples[x]) 848 | }) 849 | names(DFints) <- rownames(ems)[-c(seq(numFacs),length(rownames(ems)))] 850 | DFs <- c(DFsimples, unlist(DFints), 851 | error=prod(numLevs, numReps-1)) 852 | 853 | # get DFs using Satterthwaite 854 | mat <- t(ems[,-match(num, colnames(ems))] != "") 855 | mode(mat) <- "numeric" 856 | beta <- solve(mat[,-match(num, colnames(mat))]) %*% mat[,num] 857 | if(is.null(rownames(beta))) rownames(beta) <- "error" 858 | MSeqs <- ems[rownames(beta)[as.vector(beta) != 0], names(denom), drop=FALSE] 859 | if(numReps==1 & any(denom=="#")){ 860 | MSeqs <- MSeqs[,-match(names(denom)[denom=="#"], colnames(MSeqs)), drop=FALSE] 861 | } 862 | MSlevs <- strsplit(MSeqs, split="") 863 | MSlevs <- unlist(lapply(MSlevs, paste, collapse="*")) 864 | MSlevs <- gsub("#", "numReps", MSlevs) 865 | MSlevs <- sapply(MSlevs, function(x) eval(parse(text=x))) 866 | MSlevs <- sapply(MSlevs, function(x) ifelse(is.null(x),0,x)) 867 | MSlevs <- array(MSlevs, dim=dim(MSeqs)) 868 | if(all(dim(MSlevs) > 0)) MS <- MSlevs %*% vars else MS <- rbind(1) 869 | beta <- beta[beta != 0,,drop=FALSE] 870 | denomDF <- as.vector((t(beta) %*% MS)^2 / 871 | sum((beta^2 * MS^2)/unlist(cbind(DFs[rownames(beta)])))) 872 | 873 | # solve for selected parameter -------------------------------------------- 874 | 875 | pow <- pt(qt(.975, df=denomDF), df=denomDF, ncp=ncp, lower.tail=FALSE) + 876 | pt(qt(.025, df=denomDF), df=denomDF, ncp=ncp, lower.tail=TRUE) 877 | 878 | samps <- sapply(seq(numFacs), function(x){ 879 | tolower(isolate(input[[paste0("f",x,"Nest")]])) 880 | }) 881 | samps <- sapply(seq(samps), function(x){ 882 | containers <- facs[grepl(tolower(facs[x]), samps, fixed=TRUE)] 883 | if(length(containers)==0) containers <- "" 884 | paste(tolower(rownames(ems)[x]), 885 | paste(unlist(strsplit(containers, split="")), collapse="*"), 886 | sep=ifelse(containers=="","","*")) 887 | }) 888 | samps <- sapply(samps, function(x) eval(parse(text=tolower(x)))) 889 | names(samps) <- tolower(facs) 890 | terms <- c("numReps", attr(ems, "terms")[-1]) 891 | nobs <- eval(parse(text=paste(terms, collapse="*"))) 892 | randFacNames <- sapply(which(rands), function(x){ 893 | return(isolate(input[[paste0("f",x,"Lab")]])) 894 | }) 895 | names(samps)[rands] <- randFacNames 896 | samps <- c(samps, replicates=numReps, total_observations=nobs) 897 | sources <- c(head(rownames(ems),-1), "error") 898 | if(length(randFacNames) > 0){ 899 | totalSamps <- samps[c("total_observations",randFacNames,"replicates")] 900 | } else { 901 | totalSamps <- samps[c("total_observations","replicates")] 902 | } 903 | 904 | return(list(total_sample_sizes=totalSamps, 905 | sources_of_variation=noquote(sources), 906 | power_results=c(noncentrality_parameter=round(ncp,2), 907 | degrees_of_freedom=round(denomDF,2), power=round(pow,3)))) 908 | } # end if solve > 0 909 | }) # end assignment to 'ans' 910 | 911 | }) # end call to shinyServer() 912 | -------------------------------------------------------------------------------- /ui.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | shinyUI(fluidPage(title="PANGEA: Power ANalysis for GEneral Anova designs", 4 | h1("PANGEA (v0.2):"), 5 | h2("Power ANalysis for GEneral Anova designs"), 6 | p("PANGEA is the first power analysis program for general ANOVA designs (e.g., Winer, Brown, & Michels, 1991). PANGEA can handle designs with any number of factors, each with any number of levels; any factor can be treated as fixed or random; and any valid pattern of nesting or crossing of the factors is allowed. See the drop-down menu below for specific examples of designs covered by PANGEA."), 7 | p("Download the",a("PANGEA working paper", href="http://jakewestfall.org/publications/pangea.pdf"),"for all the technical info on how PANGEA works. Get the source code",a("here",href="https://github.com/jake-westfall/pangea"),"."), 8 | helpText("Note: when sharing the link to this app, please use the stable redirecting page at", 9 | a("jakewestfall.org/pangea/,", href="http://jakewestfall.org/pangea/"), 10 | "as the app's current URL is possibly subject to change."), 11 | 12 | # step 1 ------------------------------------------------------------------ 13 | 14 | h3("Step 1: Specify the design"), 15 | p("Use the buttons below to load an example design, or use the controls to specify your own design."), 16 | selectInput("example", label=NULL, 17 | choices = c("Custom design", 18 | "1. 2-group between subjects (participants = replicates)", 19 | "2. 2-group between subjects (participants = explicit factor)", 20 | "3. 2*3 mixed (within*between)", 21 | "4. 3-level design: Pupils (replicates)-in-Classrooms-in-Schools)", 22 | "5. Participants crossed w/ random Stimuli-in-Treatments (Clark, 1973)", 23 | "6. Participants crossed w/ random Stimuli, counter-balanced (Kenny & Smith, 1980)")), 24 | 25 | p(strong("How many factors?"), 26 | "Use the buttons below to specify the",em("number of factors")," in the design. The algorithm underlying PANGEA can technically handle any number of factors. The user interface is currently set up to allow up to 12 factors. Practically speaking, the app runs slowly when analyzing designs with more than 8 factors."), 27 | fluidRow( 28 | column(2, actionButton("addFac", "Add factor")), 29 | column(2, actionButton("delFac", "Remove factor")) 30 | ), 31 | p(), 32 | 33 | div(strong("What are they called?"), 34 | "Only the first letter of each name will be used by the rest of the app, so make sure each factor has a unique first letter! Remember that it very often makes sense to represent the Participants as an explicit factor in the design, and in fact is necessary if there is at least one within-subject-varying predictor. As an example, the default inputs describe a simple two-color",a("Stroop task", href="http://en.wikipedia.org/wiki/Stroop_effect")," where the InkColor*WordColor (I*W) interaction represents the Stroop effect; for other examples, see the drop-down menu above."), 35 | do.call(fluidRow, lapply(1:12, function(x){ 36 | column(1, htmlOutput(paste0("get_f",x,"Lab"))) 37 | })), 38 | p(), 39 | 40 | div(strong("Which are random?"), 41 | "For each factor, check the corresponding box if it is a",em("random"),"factor. The fixed vs. random distinction is not always completely unambiguous, but some useful discussion of what it means can be found",a("HERE",href="http://andrewgelman.com/2005/01/25/why_i_dont_use/"),"or",a("HERE",href="http://stats.stackexchange.com/questions/111905/what-is-the-upside-of-treating-a-factor-as-random-in-a-mixed-model"),". Also see the References at the bottom of this page."), 42 | do.call(fluidRow, lapply(1:12, function(x){ 43 | column(1, htmlOutput(paste0("get_f",x,"Rand"))) 44 | })), 45 | p(), 46 | 47 | div(strong("Which are nested in which (if any)?"), 48 | "For each factor, enter the names of the other factors that are",em("nested in")," it. Factors are assumed to be crossed by default unless nesting is explicitly indicated. For example, if the factor in question is Treatments (T), and both the School (S) and Pupil (P) factors are nested in Treatments, then in the box below labeled \"T\" you should enter:",em("SP"),"(or, equivalently, ",em("PS"),"). If all the boxes are left blank, then all factors in the design are fully crossed (as in, e.g., a fully within-subjects design). If this is confusing, studying the example designs from the drop-down menu above may help."), 49 | do.call(fluidRow, lapply(1:12, function(x){ 50 | column(1, htmlOutput(paste0("get_f",x,"Nest"))) 51 | })), 52 | p(), 53 | 54 | p(strong("How many levels of each",em("fixed"),"factor?"), 55 | "We'll worry about the random factors in the next step."), 56 | do.call(fluidRow, lapply(1:12, function(x){ 57 | column(1, htmlOutput(paste0("get_f",x,"FixNum"))) 58 | })), 59 | 60 | conditionalPanel(condition = "input.f1FixNum > 2", 61 | p(), htmlOutput("f1FixContrastPrompt"), 62 | do.call(fluidRow, lapply(1:12, function(x){ 63 | column(1, htmlOutput(paste0("get_f1FixContrast",x))) 64 | }))), 65 | conditionalPanel(condition = "input.f2FixNum > 2", 66 | p(), htmlOutput("f2FixContrastPrompt"), 67 | do.call(fluidRow, lapply(1:12, function(x){ 68 | column(1, htmlOutput(paste0("get_f2FixContrast",x))) 69 | }))), 70 | conditionalPanel(condition = "input.f3FixNum > 2", 71 | p(), htmlOutput("f3FixContrastPrompt"), 72 | do.call(fluidRow, lapply(1:12, function(x){ 73 | column(1, htmlOutput(paste0("get_f3FixContrast",x))) 74 | }))), 75 | conditionalPanel(condition = "input.f4FixNum > 2", 76 | p(), htmlOutput("f4FixContrastPrompt"), 77 | do.call(fluidRow, lapply(1:12, function(x){ 78 | column(1, htmlOutput(paste0("get_f4FixContrast",x))) 79 | }))), 80 | conditionalPanel(condition = "input.f5FixNum > 2", 81 | p(), htmlOutput("f5FixContrastPrompt"), 82 | do.call(fluidRow, lapply(1:12, function(x){ 83 | column(1, htmlOutput(paste0("get_f5FixContrast",x))) 84 | }))), 85 | conditionalPanel(condition = "input.f6FixNum > 2", 86 | p(), htmlOutput("f6FixContrastPrompt"), 87 | do.call(fluidRow, lapply(1:12, function(x){ 88 | column(1, htmlOutput(paste0("get_f6FixContrast",x))) 89 | }))), 90 | conditionalPanel(condition = "input.f7FixNum > 2", 91 | p(), htmlOutput("f7FixContrastPrompt"), 92 | do.call(fluidRow, lapply(1:12, function(x){ 93 | column(1, htmlOutput(paste0("get_f7FixContrast",x))) 94 | }))), 95 | conditionalPanel(condition = "input.f8FixNum > 2", 96 | p(), htmlOutput("f8FixContrastPrompt"), 97 | do.call(fluidRow, lapply(1:12, function(x){ 98 | column(1, htmlOutput(paste0("get_f8FixContrast",x))) 99 | }))), 100 | conditionalPanel(condition = "input.f9FixNum > 2", 101 | p(), htmlOutput("f9FixContrastPrompt"), 102 | do.call(fluidRow, lapply(1:12, function(x){ 103 | column(1, htmlOutput(paste0("get_f9FixContrast",x))) 104 | }))), 105 | conditionalPanel(condition = "input.f10FixNum > 2", 106 | p(), htmlOutput("f10FixContrastPrompt"), 107 | do.call(fluidRow, lapply(1:12, function(x){ 108 | column(1, htmlOutput(paste0("get_f10FixContrast",x))) 109 | }))), 110 | conditionalPanel(condition = "input.f11FixNum > 2", 111 | p(), htmlOutput("f11FixContrastPrompt"), 112 | do.call(fluidRow, lapply(1:12, function(x){ 113 | column(1, htmlOutput(paste0("get_f11FixContrast",x))) 114 | }))), 115 | conditionalPanel(condition = "input.f12FixNum > 2", 116 | p(), htmlOutput("f12FixContrastPrompt"), 117 | do.call(fluidRow, lapply(1:12, function(x){ 118 | column(1, htmlOutput(paste0("get_f12FixContrast",x))) 119 | }))), 120 | p(), 121 | 122 | fluidRow( 123 | column(4, htmlOutput("get_which")) 124 | ), 125 | p(), 126 | 127 | p("When you are finished specifying the design, hit the \"Submit Design\" button below to begin entering the experimental parameters."), 128 | htmlOutput("submitAndEMS"), 129 | 130 | htmlOutput("step1ErrorPrompt"), 131 | htmlOutput("step1ErrorBox"), 132 | 133 | htmlOutput("EMSoutput"), 134 | 135 | # step 2 ------------------------------------------------------------------ 136 | 137 | h3("Step 2: Enter the experimental parameters"), 138 | htmlOutput("solveInstrs"), 139 | htmlOutput("step2info"), 140 | p(), 141 | 142 | fluidRow( 143 | column(2, htmlOutput("get_ES")), 144 | column(6, htmlOutput("get_numReps")) 145 | ), 146 | p(), 147 | do.call(fluidRow, lapply(1:12, function(x){ 148 | column(1, htmlOutput(paste0("get_f",x,"RandNum"))) 149 | })), 150 | p(), 151 | do.call(fluidRow, lapply(1:12, function(x){ 152 | column(1, htmlOutput(paste0("get_f",x,"Var"))) 153 | })), 154 | 155 | p(), 156 | htmlOutput("solve"), 157 | 158 | htmlOutput("step2ErrorPrompt"), 159 | htmlOutput("step2ErrorBox"), 160 | 161 | # step 3 ------------------------------------------------------------------ 162 | 163 | h3("Step 3: Profit!"), 164 | 165 | verbatimTextOutput("ans"), 166 | p("The noncentrality parameter is for a noncentral t distribution. It can be interpreted as the expected value of the t-statistic under the alternative hypothesis (this is technically not exactly true, but very close to true, and easier to remember). Degrees of freedom are computed using the", a("Welch-Satterthwaite equation,",href="http://en.wikipedia.org/wiki/Welch%E2%80%93Satterthwaite_equation"),"and so will often be a non-integer value when there are multiple random factors."), 167 | 168 | h3("References and Contact info"), 169 | p("Clark, H. H. (1973). The language-as-fixed-effect fallacy: A critique of language statistics in psychological research.",em("Journal of verbal learning and verbal behavior, 12"),"(4), 335-359.", 170 | a("[Link to Article PDF]", href="http://acs.ist.psu.edu/papers/clark73.pdf")), 171 | p("Judd, C. M., Westfall, J., & Kenny, D. A. (2012). Treating stimuli as a random factor in social psychology: A new and comprehensive solution to a pervasive but largely ignored problem.",em("Journal of Personality and Social Psychology, 103"),"(1), 54-69.", 172 | a("[Link to Article PDF]", href="http://jakewestfall.org/publications/JWK.pdf")), 173 | p("Judd, C. M., Westfall, J., & Kenny, D. A. (2016). Experiments with more than one random factor: Designs, analytic models, and statistical power.",em("Annual Review of Psychology."), 174 | a("[Link to Article PDF]", href="http://jakewestfall.org/publications/JWK_AnnRev.pdf")), 175 | p("Kenny, D. A., & Smith, E. R. (1980). Note on the analysis of designs in which subjects receive each stimulus only once.",em("Journal of Experimental Social Psychology, 16,"),"497-507.", 176 | a("[Link to Article PDF]", href="http://jakewestfall.org/KennySmithEMS.pdf")), 177 | p("Richard, F. D., Bond Jr, C. F., & Stokes-Zoota, J. J. (2003). One hundred years of social psychology quantitatively described.",em("Review of General Psychology, 7"),"(4), 331-363.", 178 | a("[Link to Article PDF]", href="http://www2.psych.ubc.ca/~schaller/Psyc591Readings/RichardBondStokes-Zoota2003.pdf")), 179 | p("Westfall, J., Judd, C. M., & Kenny, D. A. (2015). Replicating studies in which samples of participants respond to samples of stimuli.",em("Perspectives on Psychological Science, 10"),"(3), 390-399.", 180 | a("[Link to Article PDF]", href="http://jakewestfall.org/publications/WJK2015.pdf")), 181 | p("Westfall, J., Kenny, D. A., & Judd, C. M. (2014). Statistical power and optimal design in experiments in which samples of participants respond to samples of stimuli.",em("Journal of Experimental Psychology: General, 143"),"(5), 2020-2045.", 182 | a("[Link to Article PDF]", href="http://jakewestfall.org/publications/crossed_power_JEPG.pdf")), 183 | p("Winer, B. J., Brown, D. R., & Michels, K. M. (1991). Statistical principles in experimental design (3rd edition). McGraw-Hill, New York."), 184 | p("Contact me with comments/questions/suggestions/bug reports: jake.westfall@utexas.edu"), 185 | p(a("[Back to JakeWestfall.org]", href="http://jakewestfall.org")) 186 | 187 | )) # end call to shinyUI() --------------------------------------------------------------------------------