R/xModel.R

In cwendorf/EASIalt: easiOrigin

# easiOrigin
## Regression Model

### Descriptives

.descModel <- function(x, ...) {
  UseMethod(".descModel")
}

.descModel.default <- function(frame, ...) {
  data <- data.frame(frame)
  columns <- dim(data)[2]
  dataLong <- reshape(data, varying = 1:columns, v.names = "Outcome", timevar = "Factor", idvar = "Subjects", direction = "long")
  dataLong$Subjects <- as.factor(dataLong$Subjects)
  dataLong$Factor <- as.factor(dataLong$Factor)
  object <- lm(Outcome ~ Factor + Subjects, data = dataLong)
  .descModel(object)
}

.descModel.formula <- function(formula, ...) {
  object <- lm(formula, ...)
  .descModel(object)
}

.descModel.lm <- function(object, ...) {
  x <- anova(object)
  total <- cbind(sum(x[2]), sum(x[1]))
  resid <- cbind(tail(x[2], 1), tail(x[1], 1))
  results <- rbind(total - resid, resid)
  results <- cbind(results, results[, 1] / results[, 2])
  rownames(results) <- c("Model", "Residuals")
  colnames(results) <- c("SS", "df", "MS")
  results
}

descModel <- function(..., main = NULL, digits = 3) {
  results <- .descModel(...)
  if (is.null(main)) {
    main <- "Source Table for the Model"
  }
  .formatList(list(results), main = main, digits = digits)
}

### Null Hypothesis Significance Tests

.nhstModel <- function(x, ...) {
  UseMethod(".nhstModel")
}

.nhstModel.default <- function(frame, ...) {
  data <- data.frame(frame)
  columns <- dim(data)[2]
  dataLong <- reshape(data, varying = 1:columns, v.names = "Outcome", timevar = "Factor", idvar = "Subjects", direction = "long")
  dataLong$Subjects <- as.factor(dataLong$Subjects)
  dataLong$Factor <- as.factor(dataLong$Factor)
  object <- lm(Outcome ~ Factor + Subjects, data = dataLong)
  .nhstModel(object)
}

.nhstModel.formula <- function(formula, ...) {
  object <- lm(formula, ...)
  .nhstModel(object)
}

.nhstModel.lm <- function(object, ...) {
  x <- .descModel(object)
  F <- x[1, 3] / x[2, 3]
  df1 <- x[1, 2]
  df2 <- x[2, 2]
  p <- 1 - pf(F, df1, df2)
  results <- cbind(F = F, df1 = df1, df2 = df2, p = p)
  rownames(results) <- c("Model")
  results
}

nhstModel <- function(..., main = NULL, digits = 3) {
  results <- .nhstModel(...)
  if (is.null(main)) {
    main <- "Hypothesis Test for the Model"
  }
  .formatList(list(results), main = main, digits = digits)
}

### Proportion of Variance Accounted For

.pvaModel <- function(x, ...) {
  UseMethod(".pvaModel")
}

.pvaModel.default <- function(frame, ...) {
  data <- data.frame(frame)
  columns <- dim(data)[2]
  dataLong <- reshape(data, varying = 1:columns, v.names = "Outcome", timevar = "Factor", idvar = "Subjects", direction = "long")
  dataLong$Subjects <- as.factor(dataLong$Subjects)
  dataLong$Factor <- as.factor(dataLong$Factor)
  object <- lm(Outcome ~ Factor + Subjects, data = dataLong)
  .pvaModel(object)
}

.pvaModel.formula <- function(formula, ...) {
  object <- lm(formula, ...)
  .pvaModel(object)
}

.pvaModel.lm <- function(object, ...) {
  x <- summary(object)
  results <- cbind(R = sqrt(x$r.squared), RSq = x$r.squared, AdjRSq = x$adj.r.squared)
  rownames(results) <- c("Model")
  results
}

pvaModel <- function(..., main = NULL, digits = 3) {
  results <- .pvaModel(...)
  if (is.null(main)) {
    main <- "Proportion of Variance Accounted for by the Model"
  }
  .formatList(list(results), main = main, digits = digits)
}

### Analyze Meta Function

.analyzeModel <- function(...) {
  pva <- .pvaModel(...)
  nhst <- .nhstModel(...)
  cbind(pva, nhst)
}

analyzeModel <- function(..., main = NULL, digits = 3) {
  results <- .analyzeModel(...)
  if (is.null(main)) {
    main <- "Model Fit"
  }
  .formatList(list(results), main = main, digits = digits)
}