R/q_functions_helpers.R

In manymome: Mediation, Moderation and Moderated-Mediation After Model Fitting

# Functions developed for q_* functions.

#' @noRd
# Check if all variables in a model is in the dataset.
# Input:
# - A character vector of formulas presented as strings.
# - A data frame.
# Output:
# - Logical. Whether all variables are in the dataset.

check_vars_lm <- function(formulas,
                          data) {
  my_call <- match.call()
  # Some lines adapted from lmhelprs::many_lm()
  all_vars <- sapply(formulas,
                     function(x) {
                        all.vars(stats::as.formula(x))
                     },
                     USE.NAMES = FALSE,
                     simplify = FALSE)
  all_vars <- unique(unlist(all_vars))
  data_to_use <- eval(my_call$data,
                      envir = parent.frame())
  data_vars <- colnames(data_to_use)
  if (all(all_vars %in% data_vars)) {
    return(TRUE)
  } else {
    out <- FALSE
    not_found <- setdiff(all_vars, data_vars)
    attr(out, "not_in_data") <- not_found
    return(out)
  }
}

#' @noRd
# Do listwise selection based on the
# variables used in a model.
# Input:
# - A character vector of formulas presented as strings.
# - A data frame.
# Output:
# - An integer vector to cases to remove. If no case removed,
#   it ia a zero-length integer vector

lm_listwise <- function(formulas,
                        data) {
  my_call <- match.call()
  # Some lines adapted from lmhelprs::many_lm()
  all_vars <- sapply(formulas,
                     function(x) {
                        all.vars(stats::as.formula(x))
                     },
                     USE.NAMES = FALSE,
                     simplify = FALSE)
  all_vars <- unique(unlist(all_vars))

  # All variables in the dataset?
  all_in_data <- check_vars_lm(formulas = formulas,
                               data = data)
  if (isFALSE(all_in_data)) {
    not_in_data <- attr(all_in_data, "not_in_data")
    stop(paste(not_in_data, collapse = ","),
         " in the model but not in the dataset.")
  }
  # Clear "na.acton", if present
  tmp <- eval(my_call$data,
              envir = parent.frame())
  attr(tmp, "na.action") <- NULL
  data_listwise <- stats::na.omit(tmp[, all_vars, drop = FALSE])
  data_omitted <- attr(data_listwise,
                       "na.action")
  if (!is.null(data_omitted)) {
      omitted_listwise <- as.integer(data_omitted)
    } else {
      omitted_listwise <- integer(0)
    }
  return(omitted_listwise)
}


#' @noRd
# Input:
# - paths: Of one of the following forms
# c("x1 -> m11 -> m12 -> y1",
#   "x1 -> m2 -> y1")
# OR
# list(
#   c("x1", "m11"),
#   c("m11", "m12", "y1"),
#   c("m11", "m2", "y1")
# )
# Output:
# A named list of predictors
paths_to_models <- function(paths) {
  if (!is.list(paths)) {
    paths <- parse_paths(paths)
  }
  all_vars <- unique(unlist(paths))
  from_to_all <- lapply(paths,
                        to_direct)
  from_to_all <- do.call(rbind,
                         from_to_all)
  from_to_all <- unique(from_to_all)
  to_vars <- unique(from_to_all[, "to"])
  out0 <- sapply(to_vars,
                 function(x) {
                  i <- (from_to_all[, "to"] == x)
                  out <- from_to_all[i, "from", drop = TRUE]
                  unname(out)
                 },
                 simplify = FALSE)
  out0
}

#' @noRd
# Input:
# - x: One character vector of this form
# "x1 -> m11 -> m12 -> y1"
# - Output:
# - A character vector of this form:
# c("x1", "m11", "m12", "y1"),
parse_paths <- function(x) {
  out0 <- strsplit(x,
                   "->",
                   fixed = TRUE)
  out0 <- lapply(out0,
                 function(x) trimws(x))
  out0
}

#' @noRd
# Input:
# - A character vector of this form:
# c("x1", "m11", "m12", "y1")
# Output:
# A matrix of this form:
# "x1" "m11"
# "m11" "m12"
# "m12" "y1"
to_direct <- function(x) {
  if (length(x) == 2) {
    out <- matrix(x,
                  nrow = 1,
                  ncol = 2)
    colnames(out) <- c("from", "to")
    return(out)
  }
  x_from <- x[-length(x)]
  x_to <- x[-1]
  out <- cbind(from = x_from,
               to = x_to)
  out
}

#' @noRd
# Input:
# - from_to: A named list of iv names
# - cov: A character vector or a named list of vectors
# # Output:
# - A named vector of lm formulas
form_models_paths <- function(from_to,
                              cov = NULL,
                              moderators = NULL) {
  from_to_new <- from_to
  dvs <- names(from_to_new)
  if (!is.null(cov)) {
    if (is.list(cov)) {
      for (xx in names(cov)) {
        if (xx %in% dvs) {
          from_to_new[[xx]] <- c(from_to_new[[xx]], cov[[xx]])
        }
      }
    } else {
      for (xx in dvs) {
        from_to_new[[xx]] <- c(from_to_new[[xx]], cov)
      }
    }
  }
  if (is.null(moderators)) {
    f0 <- function(y, x) {
            out0 <- paste0(x,
                          collapse = " + ")
            out1 <- paste0(y,
                          " ~ ",
                          out0)
            out1
          }
    out0 <- mapply(f0,
                  y = dvs,
                  x = from_to_new,
                  SIMPLIFY = TRUE,
                  USE.NAMES = TRUE)
  } else {
    w_list <- fix_moderators(moderators)
    w_m <- lapply(
      dvs,
      function(m_i, w_list) {
        out <- sapply(
                  w_list,
                  function(x) x["y"] == m_i
                )
        unname(w_list[out])
      },
      w_list = w_list
    )
    names(w_m) <- dvs
    tmpfct <- function(m,
                       x,
                       w_m) {
                iv_m <- x
                for (m_i in w_m) {
                  iv_m <- setdiff(iv_m, m_i[c("x", "w")])
                  iv_m <- union(iv_m, m_i["xw"])
                }
                paste(m,
                      "~",
                      paste(iv_m,
                            collapse = " + "))
              }
    out0 <- mapply(tmpfct,
                    m = dvs,
                    x = from_to_new,
                    w_m = w_m,
                   SIMPLIFY = TRUE,
                   USE.NAMES = TRUE)
  }
  out0
}

#' @noRd
fix_moderators <- function(
  moderators
) {
  moderators_org <- moderators
  # ==== One element for one product term ====
  moderators <- unlist(moderators_org, use.names = FALSE)
  moderators_names <- sapply(
    seq_along(moderators_org),
    function(x) {
      rep(names(moderators_org)[x],
          times = length(moderators_org[[x]]))
    },
    USE.NAMES = FALSE
  )
  moderators_names <- unlist(moderators_names)
  names(moderators) <- moderators_names

  path_names <- parse_paths(names(moderators))

  # ==== Check paths ====
  tmp <- sapply(path_names, length)
  if (any(tmp != 2)) {
    tmp <- names(moderators)[tmp != 2]
    stop("Moderator(s) must be specified only for component paths:",
         tmp)
  }
  # ==== Form the output ====
  f <- function(
    i,
    moderators
  ) {
    m_i <- moderators[i]
    path_name <- parse_paths(names(m_i))[[1]]
    w_i <- moderators[[i]]
    c(x = path_name[1],
      y = path_name[2],
      w = w_i,
      xw = paste0(path_name[1], "*", w_i))
  }
  out0 <- lapply(
    seq_along(moderators),
    FUN = f,
    moderators = moderators
  )
  out0
}

#' @noRd
is_moderated <- function(
  path,
  fit
) {
  # Is a path moderated?
  tmp <- cond_indirect(
    x = path$x,
    y = path$y,
    m = path$m,
    fit = fit,
    get_prods_only = TRUE
  )
  out0 <- sapply(
    tmp,
    function(x) {
      if (identical(x, NA)) {
        return(FALSE)
      } else {
        if (!is.null(x$prod)) {
          return(TRUE)
        } else {
          return(FALSE)
        }
      }
    }
  )
  any(out0)
}


#' @noRd
get_w <- function(
  path,
  fit
) {
  # path must be a moderated path
  tmp <- cond_indirect(
    x = path$x,
    y = path$y,
    m = path$m,
    fit = fit,
    get_prods_only = TRUE
  )
  out0 <- sapply(
    tmp,
    function(x) {
      if (identical(x, NA)) {
        return(character(0))
      } else {
        x$w
      }
    }
  )
  unname(unique(unlist(out0)))
}

#' @noRd
q_mediation_has_moderators <- function(
  object
) {
  if (q_mediation_has_moderated_indirect_paths(object)) {
    return(TRUE)
  }
  if (q_mediation_has_moderated_direct_paths(object)) {
    return(TRUE)
  }
  FALSE
}

#' @noRd
q_mediation_has_moderated_indirect_paths <- function(
  object
) {
  chk <- sapply(
    object$cond_ind_out,
    is.null
  )
  if (any(!chk)) {
    return(TRUE)
  }
  FALSE
}

#' @noRd
q_mediation_has_moderated_direct_paths <- function(
  object
) {
  chk <- sapply(
    object$dir_out,
    inherits,
    what = "cond_indirect_effects"
  )
  if (any(chk)) {
    return(TRUE)
  }
  FALSE
}