R/specify_interactions.R

In seminr: Building and Estimating Structural Equation Models

#' Interaction function
#'
#' \code{interaction_term} creates interaction measurement items by applying
#' product indicator, two stage, or orthogonal approaches to creating new
#' interaction constructs.
#'
#' This function automatically generates interaction measurement items for a PLS
#' or a CBSEM model.
#'
#' @param iv The independent variable that is subject to moderation.
#' @param moderator The moderator variable.
#' @param method The method to generate the estimated interaction term with a
#'   default of `two_stage`.
#' @param weights The weighting mode for interaction items in a PLS model (only)
#'   with default of `modeA`.
#'
#' @return An un-evaluated function (promise) for generating a vector of interaction terms.
#'
#' Interaction Combinations as generated by the \code{\link{interaction}} or
#' \code{\link{interaction_term}} methods.
#'
#' @usage
#' interaction_term(iv, moderator, method, weights)
#'
#' @examples
#' data(mobi)
#'
#' # seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#'   composite("Image",        multi_items("IMAG", 1:5)),
#'   composite("Expectation",  multi_items("CUEX", 1:3)),
#'   composite("Value",        multi_items("PERV", 1:2)),
#'   composite("Satisfaction", multi_items("CUSA", 1:3)),
#'   interaction_term(iv = "Image", moderator = "Expectation", method = orthogonal),
#'   interaction_term(iv = "Image", moderator = "Value", method = product_indicator)
#' )
#'
#' #  structural model: note that name of the interactions construct should be
#' #  the names of its two main constructs joined by a '*' in between.
#' mobi_sm <- relationships(
#'   paths(to = "Satisfaction",
#'         from = c("Image", "Expectation", "Value",
#'                  "Image*Expectation", "Image*Value"))
#' )
#'
#' mobi_pls <- estimate_pls(mobi, mobi_mm, mobi_sm)
#' summary(mobi_pls)
#'
#' @export
interaction_term <- function(iv, moderator, method=product_indicator, weights = mode_A) {
  intxn <- method(iv, moderator, weights)
  class(intxn) <- class(method())

  return(intxn)
}

#' \code{orthogonal} creates interaction measurement items by using the
#' orthogonalized approach wherein
#'
#' This function automatically generates interaction measurement items for a PLS SEM using the orthogonalized approach..
#'
#' @param iv The independent variable that is subject to moderation.
#' @param moderator The moderator variable.
#' @param weights is the relationship between the items and the interaction terms. This can be
#' specified as \code{correlation_weights} or \code{mode_A} for correlation weights (Mode A) or as
#' \code{regression_weights} or \code{mode_B} for regression weights (Mode B). Default is correlation weights.
#'
#' @return An un-evaluated function (promise) for estimating an orthogonal interaction effect.
#'
#' @usage
#'  # orthogonalization approach as per Henseler & Chin (2010):
#'  orthogonal(iv, moderator, weights)
#'
#' @references Henseler & Chin (2010), A comparison of approaches for the analysis of interaction effects
#' between latent variables using partial least squares path modeling. Structural Equation Modeling, 17(1),82-109.
#'
#' @examples
#' data(mobi)
#'
#' # seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#'   composite("Image",        multi_items("IMAG", 1:5)),
#'   composite("Expectation",  multi_items("CUEX", 1:3)),
#'   composite("Value",        multi_items("PERV", 1:2)),
#'   composite("Satisfaction", multi_items("CUSA", 1:3)),
#'   interaction_term(iv = "Image", moderator = "Expectation", method = orthogonal),
#'   interaction_term(iv = "Image", moderator = "Value", method = orthogonal)
#' )
#'
#' #  structural model: note that name of the interactions construct should be
#' #  the names of its two main constructs joined by a '*' in between.
#' mobi_sm <- relationships(
#'   paths(to = "Satisfaction",
#'         from = c("Image", "Expectation", "Value",
#'                  "Image*Expectation", "Image*Value"))
#' )
#'
#' mobi_pls <- estimate_pls(mobi, mobi_mm, mobi_sm)
#' summary(mobi_pls)
#'
#' @export
orthogonal <- function(iv, moderator, weights) {
  ortho_construct <- function(data, measurement_model, structural_model, ints, ...) {
    interaction_name <- paste(iv, moderator, sep = "*")
    iv1_items <- measurement_model[measurement_model[, "construct"] == iv, "measurement"]
    iv2_items <- measurement_model[measurement_model[, "construct"] == moderator, "measurement"]

    iv1_data <- as.data.frame(scale(data[iv1_items]))
    iv2_data <- as.data.frame(scale(data[iv2_items]))

    multiples_list <- lapply(iv1_data, mult, iv2_data)
    interaction_data <- do.call("cbind", multiples_list)
    colnames(interaction_data) <- as.vector(sapply(iv1_items, name_items, iv2_items))
    # Create formula
    frmla <- stats::as.formula(paste("interaction_data[,i]", paste(as.vector(c(iv1_items,iv2_items)), collapse ="+"), sep = " ~ "))

    # iterate and orthogonalize
    for(i in 1:ncol(interaction_data)) {
      interaction_data[, i] <- stats::lm(formula = frmla, data = data)$residuals
    }
    intxn_mm <- matrix(measure_interaction(interaction_name, interaction_data, weights), ncol = 3, byrow = TRUE)
    return(list(name = interaction_name,
                data = interaction_data,
                mm = intxn_mm))
  }
  class(ortho_construct) <- append(class(ortho_construct), c("interaction", "orthogonal_interaction"))
  return(ortho_construct)
}

#' \code{product_indicator} creates interaction measurement items by scaled product indicator approach.
#'
#' This function automatically generates interaction measurement items for a PLS SEM using scaled product indicator approach.
#'
#' @param iv The independent variable that is subject to moderation.
#' @param moderator The moderator variable.
#' @param weights is the relationship between the items and the interaction terms. This can be
#' specified as \code{correlation_weights} or \code{mode_A} for correlation weights (Mode A) or as
#' \code{regression_weights} or \code{mode_B} for regression weights (Mode B). Default is correlation weights.
#'
#' @return An un-evaluated function (promise) for estimating a product-indicator interaction effect.
#'
#' @usage
#'  # standardized product indicator approach as per Henseler & Chin (2010):
#'  product_indicator(iv, moderator, weights)
#'
#' @references Henseler & Chin (2010), A comparison of approaches for the analysis of interaction effects
#' between latent variables using partial least squares path modeling. Structural Equation Modeling, 17(1),82-109.
#'
#' @examples
#' data(mobi)
#'
#' # seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#'  composite("Image",        multi_items("IMAG", 1:5),weights = mode_A),
#'  composite("Expectation",  multi_items("CUEX", 1:3),weights = mode_A),
#'  composite("Value",        multi_items("PERV", 1:2),weights = mode_A),
#'  composite("Satisfaction", multi_items("CUSA", 1:3),weights = mode_A),
#'  interaction_term(iv = "Image",
#'                   moderator = "Expectation",
#'                   method = product_indicator,
#'                   weights = mode_A),
#'  interaction_term(iv = "Image",
#'                   moderator = "Value",
#'                   method = product_indicator,
#'                   weights = mode_A)
#' )
#'
#' # structural model: note that name of the interactions construct should be
#' #  the names of its two main constructs joined by a '*' in between.
#' mobi_sm <- relationships(
#'   paths(to = "Satisfaction",
#'         from = c("Image", "Expectation", "Value",
#'                 "Image*Expectation", "Image*Value"))
#' )
#'
#' # Load data, assemble model, and estimate using semPLS
#' mobi <- mobi
#' seminr_model <- estimate_pls(mobi, mobi_mm, mobi_sm, inner_weights = path_factorial)
#'
#' @export
product_indicator <- function(iv, moderator, weights) {
  scaled_interaction <- function(data, measurement_model, structural_model, ints, ...) {
    interaction_name <- paste(iv, moderator, sep = "*")
    iv1_items <- measurement_model[measurement_model[, "construct"] == iv, "measurement"]
    iv2_items <- measurement_model[measurement_model[, "construct"] == moderator, "measurement"]

    iv1_data <- as.data.frame(scale(data[iv1_items]))
    iv2_data <- as.data.frame(scale(data[iv2_items]))

    multiples_list <- lapply(iv1_data, mult, iv2_data)
    interaction_data <- do.call("cbind", multiples_list)
    colnames(interaction_data) <- as.vector(sapply(iv1_items, name_items, iv2_items))
    intxn_mm <- matrix(measure_interaction(interaction_name, interaction_data, weights), ncol = 3, byrow = TRUE)
    return(list(name = interaction_name,
                data = interaction_data,
                mm = intxn_mm))
  }
  class(scaled_interaction) <- append(class(scaled_interaction), c("interaction", "scaled_interaction"))
  return(scaled_interaction)
}

#' Creates an interaction measurement item using a two-stage approach.
#' The two-stage procedure for both PLS and CBSEM models estimates construct
#' scores in the first stage, and uses them to produce a single-item product
#' item for the interaction term in the second stage.
#' For a PLS model, the first stage uses PLS to compute construct scores.
#' For a CBSEM model, the first stage uses a CFA to produce ten Berge
#' construct scores.
#'
#' @param iv The independent variable that is subject to moderation.
#' @param moderator The moderator variable.
#' @param weights is the relationship between the items and the interaction terms. This can be
#' specified as \code{correlation_weights} or \code{mode_A} for correlation weights (Mode A) or as
#' \code{regression_weights} or \code{mode_B} for regression weights (Mode B). Default is correlation weights.
#'
#' @return An un-evaluated function (promise) for estimating a two-stage interaction effect.
#'
#' @usage
#'  # two stage approach as per Henseler & Chin (2010):
#'  two_stage(iv, moderator, weights)
#'
#' @references Henseler & Chin (2010), A comparison of approaches for the analysis of interaction effects
#' between latent variables using partial least squares path modeling. Structural Equation Modeling, 17(1),82-109.
#'
#' @examples
#' data(mobi)
#'
#' # seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#'   composite("Image",        multi_items("IMAG", 1:5)),
#'   composite("Expectation",  multi_items("CUEX", 1:3)),
#'   composite("Value",        multi_items("PERV", 1:2)),
#'   composite("Satisfaction", multi_items("CUSA", 1:3)),
#'   interaction_term(iv = "Image", moderator = "Expectation", method = two_stage)
#' )
#'
#' #  structural model: note that name of the interactions construct should be
#' #  the names of its two main constructs joined by a '*' in between.
#' mobi_sm <- relationships(
#'   paths(to = "Satisfaction",
#'         from = c("Image", "Expectation", "Value",
#'                  "Image*Expectation"))
#' )
#'
#' # PLS example:
#' mobi_pls <- estimate_pls(mobi, mobi_mm, mobi_sm)
#' summary(mobi_pls)
#'
#' # CBSEM example:
#' mobi_cbsem <- estimate_cbsem(mobi, as.reflective(mobi_mm), mobi_sm)
#' summary(mobi_cbsem)
#'
#' @export
two_stage <- function(iv, moderator, weights) {
  # Create an interaction function that takes extra params (...) for particular estimation
  two_stage_interaction <- function(data, mmMatrix, structural_model, ints, estimate_first_stage, ...) {
    interaction_name <- paste(iv, moderator, sep = "*")
    # remove interactions from structural model
    structural_model <- structural_model[ !grepl("\\*", structural_model[,"source"]), ]
    measurement_mode_scheme <- sapply(unique(c(structural_model[,1],structural_model[,2])), get_measure_mode, mmMatrix, USE.NAMES = TRUE)
    first_stage <- estimate_first_stage(
      data = data, smMatrix = structural_model, mmMatrix = mmMatrix,
      measurement_mode_scheme = measurement_mode_scheme, ...)

    interaction_term <- as.matrix(first_stage$construct_scores[, iv] * first_stage$construct_scores[, moderator], ncol = 1)[,, drop = FALSE]

    # Give interaction data column a unique name
    colnames(interaction_term) <- c(paste(interaction_name, "_intxn", sep = ""))

    intxn_mm <- matrix(measure_interaction(interaction_name, interaction_term, weights), ncol = 3, byrow = TRUE)

    return(list(name = interaction_name,
                data = interaction_term[,1, drop = FALSE],
                mm = intxn_mm))
  }
  class(two_stage_interaction) <- append(class(two_stage_interaction), c("interaction", "two_stage_interaction"))
  return(two_stage_interaction)
}

first_stage_pls <- function(data, smMatrix, mmMatrix,  measurement_mode_scheme, ...) {
  seminr::simplePLS(
    obsData = data,
    smMatrix = smMatrix,
    mmMatrix = mmMatrix,
    measurement_mode_scheme = measurement_mode_scheme,
    ...
  )
}

first_stage_cbsem <- function(data, smMatrix, mmMatrix, measurement_mode_scheme, ...) {
  seminr::estimate_cfa(
    data = data,
    measurement_model = mmMatrix, lavaan_model=NULL,
    ...
  )
}

process_interactions <- function(measurement_model, data, structural_model, inner_weights) {
  ints <- mm_interactions(measurement_model)
  mmMatrix <- mm2matrix(measurement_model)

  if(length(ints)>0) {
    # update data with new interaction items
    names(ints) <- c()
    create_interaction <- function(intxn_function) { intxn_function(data, mmMatrix, structural_model, ints, first_stage_pls, inner_weights) }
    intxns_list <- lapply(ints, create_interaction)

    get_data <- function(intxn) { intxn$data }
    interaction_data <- do.call("cbind", lapply(intxns_list, get_data))

    # Append data with interaction data
    intxns_mm <- do.call("rbind", lapply(intxns_list, function(intxn) { intxn$mm }))
    data <- cbind(data, interaction_data)

    mmMatrix <- rbind(mmMatrix, intxns_mm)
  }
  return(list(data = data,
              mmMatrix = mmMatrix,
              ints = ints))
}

process_cbsem_interactions <- function(measurement_model, data, structural_model, ...) {
  ints <- mm_interactions(measurement_model)
  mmMatrix <- mm2matrix(measurement_model)

  if(length(ints) > 0) {
    # update data with new interaction items
    names(ints) <- c()
    # create_interaction <- function(intxn_function) { intxn_function(data, mmMatrix, structural_model, ints, first_stage_pls, inner_weights) }
    create_interaction <- function(intxn_function) { intxn_function(data, mmMatrix, structural_model, ints, first_stage_cbsem, ...) }
    intxns_list <- lapply(ints, create_interaction)

    get_data <- function(intxn) { intxn$data }
    interaction_data <- do.call("cbind", lapply(intxns_list, get_data))

    # Append data with interaction data
    intxns_mm <- do.call("rbind", lapply(intxns_list, function(intxn) { intxn$mm }))
    data <- cbind(data, interaction_data)

    # mmMatrix <- rbind(mmMatrix, intxns_mm)
    mmMatrix <- rbind(mmMatrix, as.reflective(intxns_mm))
  }
  return(list(data = data,
              mmMatrix = mmMatrix,
              ints = ints))
}