R/models_utils.R

In filippogambarota/filippoR: Personal collection of useful functions

#' leave1out
#'
#' @param data a dataframe
#' @param group_var name of the variable that identify each
#' observation to remove. If \code{NULL} will be removed one
#' dataframe line at time.
#' @return a named list of dataframes
#' @export
#'
leave1out <- function(data, group_var = NULL, keep_full = FALSE){

  if(!is.null(substitute(group_var))){
    group_var <- substitute(group_var)
    group_var_names <- data[[deparse(group_var)]]
    group_var_obj <- as.integer(as.factor(group_var_names))

  }else{
    group_var_obj <- 1:nrow(data) # remove row
    group_var_names <- as.character(group_var_obj)
  }

  # make expression to eval (exclude a level)
  out <- lapply(unique(group_var_obj), function(excl) subset(data, !group_var_obj %in% excl))
  names(out) <- paste0("no_", unique(group_var_names))

  if(keep_full){
    out <- c(list("all" = data), out)
  }

  return(out)
}

#' get_model_formula
#'
#' @param fit a model object
#'
#' @return A character with the model formula
#' @export
#'
get_model_formula <- function(fit){
  deparse(formula(fit))
}

#' conv_problem
#'
#' @param mod a fitted object with \code{lme4::lmer()} or \code{lme4::glmer()}
#'
#' @return logical that indicate convergence problems
#' @export
#'
conv_problem <- function(mod){
  any(grepl("failed to converge",mod@optinfo$conv$lme4$messages))
}

#' singular_problem
#'
#' @inheritParams conv_problem
#'
#' @return logical that indicate singularity problems
#' @export
#'
singular_problem <- function(mod){
  any(grepl("?isSingular", mod@optinfo$conv$lme4$messages))
}