R/utils.R

In singmann/afex: Analysis of Factorial Experiments

check_contrasts <- function(data, factors, 
                            check_contrasts, type, 
                            warn = TRUE) {
  if (check_contrasts) {
    data <- droplevels(data)
    resetted <- NULL
    for (i in factors) {
      if (is.character(data[,i])) {
        data[,i] <- factor(data[,i])
      }
      if (is.factor(data[,i])) {
        if (is.null(attr(data[,i], "contrasts")) & 
            (options("contrasts")[[1]][1] != "contr.sum")) {
          contrasts(data[,i]) <- "contr.sum"
          resetted  <- c(resetted, i)
        }
        else if (!is.null(attr(data[,i], "contrasts")) && 
                 attr(data[,i], "contrasts") != "contr.sum") {
          contrasts(data[,i]) <- "contr.sum"
          resetted  <- c(resetted, i)
        }
      }
    }
    if (!is.null(resetted)) 
      message(paste0("Contrasts set to contr.sum for the following variables: ", 
                     paste0(resetted, collapse=", ")))
  } else if (warn) {
    non_sum_contrast <- c()
    for (i in factors) {
      if (is.factor(data[,i])) {
        if (is.null(attr(data[,i], "contrasts")) & 
            (options("contrasts")[[1]][1] != "contr.sum")) {
          non_sum_contrast <- c(non_sum_contrast, i)
        }
        else if (!is.null(attr(data[,i], "contrasts")) && 
                 attr(data[,i], "contrasts") != "contr.sum") {
          non_sum_contrast <- c(non_sum_contrast, i)
        }
      }
    }
    if((type == 3 | type == "III") && (length(non_sum_contrast)>0)) 
      warning(
        paste0("Calculating Type 3 sums with contrasts != 'contr.sum' for: ", 
               paste0(non_sum_contrast, collapse=", "), 
               "\n  Results likely bogus or not interpretable!\n",
               "You probably want check_contrasts = TRUE or ", 
               "options(contrasts=c('contr.sum','contr.poly'))"), 
        call. = FALSE)
  }
  return(data)
}

## paste function that can replace stringr::str_c and differs from the way 
# paste handles NULL arguments as last arguments. 
# It checks whether the first or last char of the string is equal to sep and 
# removes it in this case.
mypaste <- function(..., sep) {
  tmp <- paste(..., sep = sep)
  if (substr(tmp, nchar(tmp), nchar(tmp)) == sep) {
    tmp <- substr(tmp, 1, nchar(tmp)-1)
  }
  if (substr(tmp, 1, 1) == sep) {
    tmp <- substr(tmp, 2, nchar(tmp))
  }
  tmp
}

escape_vars <- function(names) {
  if (length(names) == 0)
    return(names)
  names <- vapply(names, function(name) {
    if (make.names(name) != name) {
      name <- gsub('\\', '\\\\', name, fixed=TRUE)
      name <- gsub('`',  '\\`',  name, fixed=TRUE)
      name <- paste0('`', name, '`')
    }
    name
  }, FUN.VALUE='', USE.NAMES=FALSE)
  names
}

# decompose functions from jmvcore

decomposeTerm <- function(term) {

    chars <- strsplit(term, '')[[1]]
    components <- character()
    componentChars <- character()
    inQuote <- FALSE

    i <- 1
    n <- length(chars)

    while (i <= n) {
        char <- chars[i]
        if (char == '`') {
            inQuote <- ! inQuote
        }
        else if (char == '\\') {
            i <- i + 1
            char <- chars[i]
            componentChars <- c(componentChars, char)
        }
        else if (char == ':' && inQuote == FALSE) {
            component <- paste0(componentChars, collapse='')
            components <- c(components, component)
            componentChars <- character()
        }
        else {
            componentChars <- c(componentChars, char)
        }
        i <- i + 1
    }

    component <- paste0(componentChars, collapse='')
    components <- c(components, component)

    components
}


print_legend <- function(x) {
  sig_symbols <- as.character(attr(x, "sig_symbols"))
  if(length(sig_symbols) > 0 & !all(sig_symbols == rep("", 4))) {
    sleg <- attr(stats::symnum(0, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), 
                               symbols = rev(c(" " , trimws(sig_symbols)))), "legend")
    width <- getOption("width")
    
    if(width < nchar(sleg)) {
      sleg <- strwrap(sleg, width = width - 2, prefix = "  ")
    } 
    
    cat("---\nSignif. codes:  ", sleg, sep = "", fill = getOption("width") + 4 + max(nchar(sleg, "bytes") - nchar(sleg)))
  }
}