R/proptests.R

In exams.forge: Support for Compiling Examination Tasks using the 'exams' Package

#' @rdname proptests
#' @title Proportion Tests
#' 
#' @description `proptests` runs a bunch of modifications of the input parameters of `proptest` to generate all possible proportion tests. 
#' See under "Details" the detailed parameter values which are used. Note that not giving the parameter `hyperloop` will
#' results in several hundred tests generated. 
#' Only the distinct tests will be returned, with the first element being `proptest`. If only a specific element of a `proptests` is of interest, 
#' provide the name of the element in `elem`. All `proptests` will then be returned where the value of `elem` is different.
#' 
#' @param proptest proptest: the base result from a valid t-test generated by [proptest_num()]
#' @param elem character: element to extract (default: `NULL`)
#' @param hyperloop named list: parameter values to run over (default: see above)
#'
#' @details The default `hyperloop` is:
#' ```
#' list(x           = c(proptest$x, proptest$n-proptest$x)
#'      pi0         = c(proptest$pi0, 1-proptest$pi0, proptest$x/proptest$n, 1-proptest$x/proptest$n)
#'      alpha       = unique(c(proptest$alpha, 0.01, 0.05, 0.1)),
#'      alternative = c("two.sided", "greater", "less")
#'    )
#' ````
#'
#' @return list of `proptest` objects is returned 
#' @export
#' @md
#'
#' @examples
#' basetest  <- proptest_num(x=3, n=8, alternative="greater")
#' # vary the number of observations
#' hyperloop <- list(pi0 = c(basetest$pi0, 1-basetest$pi0, 
#'                           basetest$x/basetest$n, 1-basetest$x/basetest$n))
#' # return all different tests
#' tts       <- proptests(basetest, hyperloop=hyperloop)
#' # return all different random sampling functions
#' proptests(basetest, "X", hyperloop)
proptests <- function(proptest, elem=NULL, hyperloop=NULL) {
  if (is.null(hyperloop)) {
    hyperloop  <- list(x           = c(proptest$x, proptest$n-proptest$x),
                       pi0         = c(proptest$pi0, 1-proptest$pi0, proptest$x/proptest$n, 1-proptest$x/proptest$n),
                       alpha       = unique(c(proptest$alpha, 0.01, 0.05, 0.1)),
                       alternative = c("two.sided", "greater", "less")
                       )
  }
  hyperindex <- lapply(hyperloop, function(e){seq(e)} )
  loop       <- expand.grid(hyperindex)
  #1
  ret        <- vector("list", 1+nrow(loop))
  ret[[1]]   <- proptest
  keep       <- rep(NA_character_, 1+nrow(loop))
  keep[[1]]  <- toString(serialize(proptest, NULL))
  # All others
  loopname   <- names(hyperloop)
  for (i in 1:nrow(loop)) {
    ltest <- proptest  
    for (name in loopname) {
      j             <- loop[[name]][i]
      ltest[[name]] <- hyperloop[[name]][j]
    }
    ltest       <- try(proptest_num(arglist=ltest), silent=TRUE)
    if ("try-error" %in% class(ltest)) {
      ret[[i+1]]  <- ret[[1]]
      keep[[i+1]] <- toString(serialize(ret[[1]], NULL))      
    } else {
      ret[[i+1]]  <- ltest 
      keep[[i+1]] <- toString(serialize(ltest, NULL))      
    }
  } 
  # Clean up 
  keep <- !duplicated(keep) 
  ret  <- ret[keep]
  if (is.null(elem)) return(ret)
  keep <- sapply(ret, function(e) { toString(serialize(e[[elem]], NULL))})   
  keep <- !duplicated(keep)
  ret[keep]
}