backward_step.R

library(tidyr)
library(dplyr)
library(stringr)

min_sd_fctr_grp <- function(model, replace_table) {
  # replace_table は src に 変数名レベル、tgtに変数名を持つdf
  min_sd <- as.data.frame(VarCorr(model)) %>%
    filter(is.na(var2) & var1 != "(Intercept)") %>%
    select(c(grp, var1, sdcor)) %>%
    arrange(sdcor) %>%
    head(1)
  min_var_factor <- min_sd$var
  for (i in 1:nrow(replace_table)) {
    min_var_factor <- str_replace_all(
      min_var_factor,
      replace_table[i, "src"],
      replace_table[i, "tgt"]
    )
  }
  return(list(fctr = min_var_factor, grp = min_sd$grp))
}

contextual_removal <- function(call_i, rm_factor, context) {
  # いったん||や|を置き換えてから処理
  call_i %>%
    str_replace_all("\\|\\|", "DUB_BAR") %>%
    str_replace_all("\\|", "SIN_BAR") %>%
    str_replace_all(
      sprintf("SIN_BAR *%s", context),
      sprintf("- %s SIN_BAR %s", rm_factor, context)
    ) %>%
    str_replace_all(
      sprintf("DUB_BAR *%s", context),
      sprintf("- %s DUB_BAR %s", rm_factor, context)
    ) %>%
    str_replace_all("DUB_BAR", "\\|\\|") %>%
    str_replace_all("SIN_BAR", "\\|") %>%
    return()
}

get_replace_table <- function(data) {
  # src に 変数名レベル、tgtに変数名を持つdf を返す
  # variablelevel のようなものを修正しないとならない
  data <- data %>% as.data.frame() # tibble だと失敗する
  df_cats <- data[, !sapply(data, is.numeric), drop = FALSE]
  col_cats <- colnames(df_cats)
  src <- c()
  tgt <- c()
  for (i in 1:length(col_cats)) {
    src_tmp <- unique(paste0(col_cats[i], unique(df_cats[, i])))
    src <- c(src, src_tmp)
    tgt <- c(tgt, rep(col_cats[i], length(src_tmp)))
  }
  return(as.data.frame(list(src = src, tgt = tgt)))
}


# backward elimination 用の関数
backward_step <- function(model, formula, data, models = c(), steps = c(), ...) {
  model_i <- model(formula, data, ...)
  models <- c(models, model_i) # append
  replace_table <- get_replace_table(data)
  min_sd_fctr <- unlist(min_sd_fctr_grp(model_i, replace_table)[["fctr"]])
  min_sd_grp <- unlist(min_sd_fctr_grp(model_i, replace_table)[["grp"]])
  steps <- c(steps, sprintf("%s | %s ->", min_sd_fctr, min_sd_grp))
  if (length(min_sd_fctr) == 0) {
    return(list(models = models, steps = c(steps, "NA")))
  }
  rhs <- contextual_removal(as.character(formula)[3], min_sd_fctr, min_sd_grp)
  formula_next <- as.formula(paste(as.character(formula)[2], as.character(formula)[1], rhs))
  backward_step(model, formula_next, data, models, steps, ...)
}

# How to use
# 0. load this snippet
# source("https://gist.githubusercontent.com/kishiyamat/e06cb97a098043a2754a58b2b4f64e76/raw")

# 1. make models and steps
# models_steps <- backward_step(
#   model = lmer,
#   formula =
#    Dependent ~ Independent +
#       (Independent | Item) +
#       (Independent | Subj),
#   data = yourdata
# )

# 2. check models ans steps
# for (i in 1:length(models_steps[["steps"]])) {
#   print(sprintf("model %s", i))
#   print(paste("To be eliminated:", models_steps[["steps"]][[i]]))
#   print(summary(models_steps[["models"]][[i]]))
# }

# 3. anova
# AICの小さい順にならんでいる. 各モデルの変更による改善に意味があるかを検証している
# do.call(anova, c(models_steps[["models"]], refit = FALSE))

• https://www.r-bloggers.com/2013/08/a-new-r-trick-for-me-at-least/ を使えば lmer以外でも容易に渡せる
• model と model を作る call が変数名からはわかりづらい
• VarCorr(model) がモデルで成り立つことを前提としている