R/hypothesis_latex.R

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

#' @rdname hypothesis_latex
#' @title Latex Hypothesis
#' @aliases lhypo
#' @description Creates a data frame for a test hypothesis with various columns:
#' * `h0.left` left value of the null hypothesis, usually `\mu` or `\pi`   
#' * `h0.operator` operator of the null hypothesis, one of the following: `eq`, `ne`, `lt`, `le`, `gt`, or `ge` 
#' * `h0.right` right value of the null hypothesis, usually `\mu_0`, `\pi_0`, or a hypothetical value
#' * `h1.left` left value of the alternative hypothesis, usually `\mu` or `\pi`   
#' * `h1.operator` operator of the alternative hypothesis, one of the following: `eq`, `ne`, `lt`, `le`, `gt`, or `ge` 
#' * `h1.right` right value of the alternative hypothesis, usually `\mu_0`, `\pi_0`, or a hypothetical value
#' * `H0` latex representation of the null hypothesis
#' * `H1` latex representation of the alternative hypothesis
#' * `match.left` do the left value in the null and the alternative hypothesis match?
#' * `match.right`  do the right value in the null and the alternative hypothesis match?
#' * `match.operator` do the operators in the null and the alternative hypothesis cover all real numbers?
#' * `match.right`  do the right value in the null and alternative hypothesis match?
#' * `match.type` either `wrong`, `left.sided`, `right.sided`, `two.sided`, `greater`, or `less`.
#' 
#' If \code{null} is not given then it is determined from \code{alternative}. Otherwise hypotheses pairs are generated by
#' all combinations from `alternative` and `null`.
#' Valid values for `alternative`and `null` are `two.sided`, `greater`, `less`,  `eq`, `ne`, `lt`, `le`, `gt`, or `ge`.
#' 
#' @param left character: symbol, for example \code{"\\mu"} or \code{"\\pi"}
#' @param alternative character: alternative hypotheses
#' @param null character: null hypotheses (default: \code{NULL})
#' @param right character: a symbol (default: \code{paste0(left, "_0")})
#'
#' @return A data frame with hypothesis pairs.
#' @export
#'
#' @examples
#' # Create one hypotheses pair
#' hypothesis_latex("\\mu")
#' hypothesis_latex("\\pi")
#' hypothesis_latex("\\mu", alternative="two.sided")
#' hypothesis_latex("\\mu", alternative="two.sided", null="lt")
#' hypothesis_latex("\\mu", alternative="ne", null="eq")
# create several hypotheses pairs
#' hypothesis_latex("\\mu", right=c(0,1))
#' hypothesis_latex("\\mu", alternative=c("eq", "ne", "lt", "le", "gt", "ge"))
#' hypothesis_latex("\\mu", alternative=c("eq", "ne", "lt", "le", "gt", "ge"), 
#'                          null=c("eq", "ne", "lt", "le", "gt", "ge"))
hypothesis_latex <- function(left, alternative = NULL, null = NULL, right = paste0(left, "_0")) {
  inverse_hypothesis <- function(h) {
    ret <- rep(NA_character_, length(h))
    ret[h=='ne'] <- 'eq'
    ret[h=='eq'] <- 'ne'
    ret[h=='le'] <- 'gt'
    ret[h=='lt'] <- 'ge'
    ret[h=='ge'] <- 'lt'
    ret[h=='gt'] <- 'le'
    ret
  }
  #
  cond <- c("two.sided", "less", "greater", "lt", "le", "eq", "ne", "gt", "ge")
  if (is.null(alternative)) alternative <- 'ne'
  pos <- match(alternative, cond)
  napos <- which(is.na(pos))
  if (any(napos)) stop(paste("Unknown hypothesis:", toString(alternative[napos])))
  alternative <- cond[pos]
  alternative[alternative=="two.sided"] <- 'ne'
  alternative[alternative=="less"]      <- 'lt'
  alternative[alternative=="greater"]   <- 'gt'
  if (is.null(null)) { # no null hypothesis given
    null <- inverse_hypothesis(alternative)
    reti <- gapply(list, h0.left=left, h0.right=right, h1.left=left, h1.right=right)
    ret  <- NULL
    for (i in 1:length(alternative)) {
      ret <- rbind(ret, cbind(reti, h0.operator=rep(null[i], nrow(reti)), h1.operator=rep(alternative[i], nrow(reti))))
    }
  } else {
    pos  <- match(null, cond)
    napos <- which(is.na(pos))
    if (length(napos)) stop(paste("Unknown hypothesis:", toString(null[napos])))
    null <- cond[pos]
    null[null=="two.sided"] <- 'eq'
    null[null=="less"]      <- 'ge'
    null[null=="greater"]   <- 'le'
    ret <- gapply(list, h0.left=left, h0.operator=null, h0.right=right, h1.left=left, h1.operator=alternative, h1.right=right)
  }
  latex  <- c('eq' = '=', 'ne'= '\\neq', 'gt'='>', 'ge'='\\geq', 'lt'='<', 'le'='\\leq')    
  ret$H0 <- paste(ret$h0.left, latex[ret$h0.operator], ret$h0.right)
  ret$H1 <- paste(ret$h1.left, latex[ret$h1.operator], ret$h1.right)
  ret$match.left  <- ret$h0.left==ret$h1.left
  ret$match.right <- ret$h0.right==ret$h1.right
  ret$match.operator <- ret$h0.operator==inverse_hypothesis(ret$h1.operator)
  ret$type <- rep("wrong", nrow(ret))
  ret$type[ret$match.left & ret$match.right & ret$match.operator & ret$h1.operator=='ne'] <- "two.sided"
  ret$type[ret$match.left & ret$match.right & ret$match.operator & ret$h1.operator=='gt'] <- "greater"
  ret$type[ret$match.left & ret$match.right & ret$match.operator & ret$h1.operator=='lt'] <- "less"
  ret$type[ret$match.left & ret$match.right & ret$h0.operator=='eq' & ret$h1.operator=='lt'] <- "left.sided"
  ret$type[ret$match.left & ret$match.right & ret$h0.operator=='eq' & ret$h1.operator=='lt'] <- "right.sided"
  unique(ret) 
}

#hypothesis_latex <- function (left, alternative=c("two.sided", "less", "greater"), null=NULL,
#                              right=paste0(left, "_0")) {
#  hyp <- list()
#  hyp[["two.sided"]] <- c("=", "\\neq")
#  hyp[["less"]]      <- c("\\geq", "<")
#  hyp[["greater"]]   <- c("\\leq", ">")
#  hyp[["ne"]] <- c("\\neq", "\\neq") 
#  hyp[["gt"]] <- c(">", ">") 
#  hyp[["lt"]] <- c("<", "<") 
#  hyp[["le"]] <- c("\\leq", "\\leq")
#  hyp[["ge"]] <- c("\\geq", "\\geq")
#  hyp[["eq"]] <- c("=", "=")
#  h0 <- sapply(hyp, "[", 1)
#  h1 <- sapply(hyp, "[", 2)
#  if (is.null(null)) null <- alternative
#  h0 <- h0[null]
#  h1 <- h1[alternative]
#  stopifnot(length(h0)==length(h1))
#  less      <- (h0=="\\geq") & (h1=="<")
#  greater   <- (h0=="\\leq") & (h1==">")
#  two.sided <- (h0=="=") & (h1=="\\neq")
#  ret <- cbind(paste(left, h0, right), paste(left, h1, right))
#  colnames(ret)  <- c("H0", "H1")
#  row.names(ret) <- sprintf("wrong%0.f", 1:nrow(ret))
#  if (any(less)) row.names(ret)[which(less)] <- "less"
#  if (any(greater)) row.names(ret)[which(greater)] <- "greater"  
#  if (any(two.sided)) row.names(ret)[which(two.sided)] <- "two.sided"    
#  if (anyDuplicated(ret)) warning ("duplicate hypothesis pairs")
#  as.data.frame(ret)
#}

#' @rdname hypothesis_latex
#' @export
# lhypo <- function(...){
#  hypothesis_latex(...)}
lhypo <- hypothesis_latex