R/utils.R

In olsrr: Tools for Building OLS Regression Models

fs <- function() {
  x <- rep("  ")
  return(x)
}

fg <- function(x, w) {
  z <- as.character(x)
  y <- format(z, width = w, justify = "right")
  return(y)
}

fl <- function(x, w) {
  x <- as.character(x)
  ret <- format(x, width = w, justify = "left")
  return(ret)
}

fc <- function(x, w) {
  x <- as.character(x)
  ret <- format(x, width = w, justify = "centre")
  return(ret)
}

fw <- function(x, w) {
  z <- format(as.character(x), width = w, justify = "right")
  return(z)
}

formatter_t <- function(x, w) {
  ret <- format(x, width = w, justify = "centre")
  return(ret)
}

formatter_n <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

format_cil <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

format_ciu <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

formats_t <- function() {
  x <- rep("  ")
  return(x)
}

l <- function(x) {
  x <- as.character(x)
  k <- grep("\\$", x)
  if (length(k) == 1) {
    temp <- strsplit(x, "\\$")
    out <- temp[[1]][2]
  } else {
    out <- x
  }
  return(out)
}

null_model_metrics <- function(model, full_model) {

  output <- summary(model)
  anovam <- anova(model)
  aic    <- ols_aic(model)
  sbc    <- ols_sbc(model)
  sbic   <- ols_sbic(model, full_model)
  n      <- length(anovam$Df)
  ess    <- anovam$`Sum Sq`[n]
  tss    <- sum(anovam$`Sum Sq`)
  rss    <- tss - ess
  rsq    <- output$r.squared
  adjr   <- output$adj.r.squared
  rmse   <- sqrt(mean(model$residuals ^ 2))

  list(adjr = adjr, aic = aic, sbc = sbc,  sbic = sbic, ess = ess,
       rsq = rsq, rss = rss, rmse = rmse)

}

max_nchar <- function(char, val, rn = 3, ns = 3) {
  max(nchar(char), nchar(format(round(val, rn), nsmall = ns)))
}

ols_get_formula <- function(model) {
  formula(model)
}

ols_get_interaction_terms <- function(model) {
  terms <- model$terms
  i <- attr(terms, 'order') > 1
  attr(terms, 'term.labels')[i]
}

ols_get_terms <- function(model) {
  attr(model$terms, 'term.label')
}

ols_get_variables <- function(model) {
  vars  <- names(model$model)
  n     <- length(vars)
  resp  <- vars[1]
  preds <- vars[2:n]
  list(response = resp, predictors = preds)
}

ols_get_data <- function(model) {
  model$model
}

ols_get_df <- function(model) {
  model$df.residual
}

ols_get_intercept <- function(model) {
  model$coefficients[[1]]
}

ols_get_model_matrix <- function(model) {
  model.matrix(model)
}

ols_get_predicted <- function(model) {
  as.numeric(model$fitted.values)
}

ols_get_sigma <- function(model) {
  summary(model)$sigma
}

ols_get_residuals <- function(model) {
  model$residuals
}

ols_get_deviance <- function(model) {
  deviance(model)
}

ols_get_parameters <- function(model) {
  params <- model$coefficients[, 1]
  data.frame(Parameter = names(params), Estimate = unname(params))
}

ols_get_predictors <- function(model) {
  model$model[, -1]
}

ols_get_response <- function(model) {
  model$model[, 1]
}

ols_get_call <- function(model) {
  model$call
}

ols_get_obs <- function(model) {
  nrow(model$model)
}

ols_has_intercept <- function(model) {
  as.logical(attr(model$terms, "intercept"))
}