R/merge_mod_levels.R

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

#' @title Merge the Generated Levels of
#' Moderators
#'
#' @description Merge the levels of
#' moderators generated by
#' [mod_levels()] into a data frame.
#'
#' @details It merges the levels of
#' moderators generated by
#' [mod_levels()] into a data frame,
#' with each row represents a
#' combination of the levels. The output
#' is to be used by
#' [cond_indirect_effects()].
#'
#' Users usually do not need to use this
#' function because
#' [cond_indirect_effects()] will merge
#' the levels internally if necessary.
#' This function is used when users need
#' to customize the levels for each
#' moderator and so cannot use
#' [mod_levels_list()] or the default
#' levels in [cond_indirect_effects()].
#'
#' @return A `wlevels`-class object,
#' which is a data frame of the
#' combinations of levels, with
#' additional attributes about the
#' levels.
#'
#' @param ... The output from
#'  [mod_levels()], or a list of levels
#'  generated by [mod_levels_list()].
#'
#'
#' @seealso [mod_levels()] on generating
#' the levels of a moderator.
#'
#' @examples
#'
#' data(data_med_mod_ab)
#' dat <- data_med_mod_ab
#' # Form the levels from a list of lm() outputs
#' lm_m <- lm(m ~ x*w1 + c1 + c2, dat)
#' lm_y <- lm(y ~ m*w2 + x + w1 + c1 + c2, dat)
#' lm_out <- lm2list(lm_m, lm_y)
#' w1_levels <- mod_levels(lm_out, w = "w1")
#' w1_levels
#' w2_levels <- mod_levels(lm_out, w = "w2")
#' w2_levels
#' merge_mod_levels(w1_levels, w2_levels)
#'
#' @export
#'
#'

merge_mod_levels <- function(...) {
    x <- list(...)
    p <- length(x)
    if (p == 1) {
        if (is.list(x[[1]]) && !is.data.frame(x[[1]])) {
            x <- unlist(x, recursive = FALSE)
            p <- length(x)
          }
      }
    wnames <- paste0("w", seq_len(p))
    names(x) <- wnames
    q <- sapply(x, nrow)
    i <- sapply(q, seq_len, simplify = FALSE)
    qi <- expand.grid(rev(i))
    qi <- qi[, rev(seq_len(ncol(qi))), drop = FALSE]
    qinrow <- nrow(qi)
    qi0 <- split(qi, seq_len(qinrow))
    tmpfct <- function(a1, a2, x) {
        out <- x[[a1]][a2, , drop = FALSE]
        # colnames(out) <- a1
        out
      }
    out <- lapply(qi0, function(y) {
                      mapply(tmpfct,
                             a1 = colnames(y),
                             a2 = y[1, ],
                             MoreArgs = list(x = x),
                             USE.NAMES = FALSE,
                             SIMPLIFY = FALSE)
                    })
    out1 <- lapply(out, function(x) {
                data.frame(x, row.names = NULL)
              })
    out2 <- do.call(rbind, out1)
    out2levels0 <- lapply(out, function(x) {
                sapply(x, row.names)
              })
    out2levels <- data.frame(do.call(rbind, out2levels0))
    tmpfct2 <- function(y) {
        tmp <- attr(y, "wname")
        if (!is.null(tmp)) {
            return(tmp)
          }
        if (ncol(y) == 1) return(colnames(y))
        yn0 <- find_prefix(colnames(y))
        if (yn0 != "") {
            return(yn0)
          } else {
            ""
          }
      }
    wnames0 <- lapply(x, tmpfct2)
    tmpfct3 <- function(z1, z2) {
        if (z2 == "") {
            return(z1)
          } else{
            return(z2)
          }
      }
    wnames1 <- mapply(tmpfct3,
                      z1 = names(wnames0),
                      z2 = wnames0)
    colnames(out2levels) <- wnames1
    tmp <- mapply(function(a, b) {paste0(a, ": ", b)},
                  a = colnames(out2levels),
                  b = out2levels)
    wlevels <- apply(tmp, 1, paste, collapse = "; ")
    rownames(out2) <- wlevels
    attr(out2, "wlevels") <- out2levels
    wvars <- lapply(x, colnames)
    names(wvars) <- wnames1
    attr(out2, "wvars") <- wvars
    w_type <- sapply(x, attr, which = "w_type")
    names(w_type) <- wnames1
    attr(out2, "w_type") <- w_type
    class(out2) <- c("wlevels", class(out2))
    out2
  }