R/estimate_pls.R

In seminr: Building and Estimating Structural Equation Models

#' seminr estimate_pls() function
#'
#' Estimates a pair of measurement and structural models using PLS-SEM, with optional estimation methods
#'
#' @param data A \code{dataframe} containing the manifest measurement items in named columns.
#'
#' The pair of measurement and structural models can optionally be specified as separate model objects
#'
#' @param measurement_model An optional \code{measurement_model} object representing the outer/measurement model,
#'   as generated by \code{constructs}.
#'
#' @param structural_model An optional \code{smMatrix} object representing the inner/structural model,
#'   as generated by \code{relationships}.
#'
#' The pair of measurement and structural models can also be specified as a single \code{specified_model} object
#'
#' @param model An optional \code{specified_model} object containing both the the outer/measurement and inner/structural models,
#'   as generated by \code{specify_model}.
#'
#' @param inner_weights Function that implements inner weighting scheme:
#'   \code{path_weighting} (default) or \code{path_factorial} can be used.
#'
#' @param missing Function that replaces missing values.
#'   \code{mean_replacement} is default.
#'
#' @param missing_value Value in dataset that indicates missing values.
#'   NA is used by default.
#'
#' @param maxIt A parameter that specifies that maximum number of iterations when estimating the
#'   PLS model. Default value is 300.
#'
#' @param stopCriterion A parameter specifying the stop criterion for estimating the PLS model.
#'   Default value is 7.
#'
#' @return A list of the estimated parameters for the SEMinR model including:
#'  \item{meanData}{A vector of the indicator means.}
#'  \item{sdData}{A vector of the indicator standard deviations}
#'  \item{mmMatrix}{A Matrix of the measurement model relations.}
#'  \item{smMatrix}{A Matrix of the structural model relations.}
#'  \item{constructs}{A vector of the construct names.}
#'  \item{mmVariables}{A vector of the indicator names.}
#'  \item{outer_loadings}{The matrix of estimated indicator loadings.}
#'  \item{outer_weights}{The matrix of estimated indicator weights.}
#'  \item{path_coef}{The matrix of estimated structural model relationships.}
#'  \item{iterations}{A numeric indicating the number of iterations required before the algorithm converged.}
#'  \item{weightDiff}{A numeric indicating the minimum weight difference between iterations of the algorithm.}
#'  \item{construct_scores}{A matrix of the estimated construct scores for the PLS model.}
#'  \item{rSquared}{A matrix of the estimated R Squared for each construct.}
#'  \item{inner_weights}{The inner weight estimation function.}
#'  \item{data}{A matrix of the data upon which the model was estimated (INcluding interactions.}
#'  \item{rawdata}{A matrix of the data upon which the model was estimated (EXcluding interactions.}
#'  \item{measurement_model}{The SEMinR measurement model specification.}
#'
#' @usage
#' estimate_pls(data,
#'              measurement_model = NULL, structural_model = NULL, model = NULL,
#'              inner_weights = path_weighting,
#'              missing = mean_replacement,
#'              missing_value = NA,
#'              maxIt = 300,
#'              stopCriterion = 7)
#'
#' @seealso \code{\link{specify_model}} \code{\link{relationships}} \code{\link{constructs}} \code{\link{paths}} \code{\link{interaction_term}}
#'          \code{\link{bootstrap_model}}
#'
#' @examples
#' mobi <- mobi
#'
#' #seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#'              reflective("Image",        multi_items("IMAG", 1:5)),
#'              reflective("Expectation",  multi_items("CUEX", 1:3)),
#'              reflective("Quality",      multi_items("PERQ", 1:7)),
#'              reflective("Value",        multi_items("PERV", 1:2)),
#'              reflective("Satisfaction", multi_items("CUSA", 1:3)),
#'              reflective("Complaints",   single_item("CUSCO")),
#'              reflective("Loyalty",      multi_items("CUSL", 1:3))
#'            )
#' #seminr syntax for creating structural model
#' mobi_sm <- relationships(
#'   paths(from = "Image",        to = c("Expectation", "Satisfaction", "Loyalty")),
#'   paths(from = "Expectation",  to = c("Quality", "Value", "Satisfaction")),
#'   paths(from = "Quality",      to = c("Value", "Satisfaction")),
#'   paths(from = "Value",        to = c("Satisfaction")),
#'   paths(from = "Satisfaction", to = c("Complaints", "Loyalty")),
#'   paths(from = "Complaints",   to = "Loyalty")
#' )
#'
#' mobi_pls <- estimate_pls(data = mobi,
#'                          measurement_model = mobi_mm,
#'                          structural_model = mobi_sm,
#'                          missing = mean_replacement,
#'                          missing_value = NA)
#'
#' summary(mobi_pls)
#' plot_scores(mobi_pls)
#' @export
estimate_pls <- function(data,
                         measurement_model = NULL,
                         structural_model = NULL,
                         model = NULL,
                         inner_weights = path_weighting,
                         missing = mean_replacement,
                         missing_value = NA,
                         maxIt=300,
                         stopCriterion=7) {
  # NOTE: update rerun.pls_model() if parameters change!

  message("Generating the seminr model")
  data[data == missing_value] <- NA
  rawdata <- data
  if (!is.null(model)) {
    data <- data[,all_loc_non_int_items(model$measurement_model)]

  } else {
    data <- data[,all_loc_non_int_items(measurement_model)]
  }
  data <- missing(data)
  data <- stats::na.omit(data)

  # Extract model specifications
  specified_model <- extract_models(model, measurement_model, structural_model)
  measurement_model <- specified_model$measurement_model
  structural_model <- specified_model$structural_model

  # Generate first order model if necessary
  HOCs <- HOCs_in_model(measurement_model, structural_model)

  if ( length(HOCs)>0 ) {
    HOM <- prepare_higher_order_model(data = data,
                                      sm = structural_model,
                                      mm = measurement_model,
                                      inners = inner_weights,
                                      HOCs = HOCs,
                                      maxIt=maxIt,
                                      stopCriterion=stopCriterion)
    measurement_model <- HOM$mm
    structural_model <- HOM$sm
    data <- HOM$data
    first_stage_model <- HOM$first_stage_model
  }

  processed_measurements <- process_interactions(measurement_model, data, structural_model, inner_weights)
  mmMatrix <- processed_measurements$mmMatrix
  data <- processed_measurements$data

  # warning if the model is incorrectly specified
  warnings(mmMatrix, data, structural_model)

  # Make a named list of construct measurement_mode functions
  measurement_mode_scheme <- sapply(unique(c(structural_model[,1], structural_model[,2])), get_measure_mode, mmMatrix, USE.NAMES = TRUE)

  # Run the model in simplePLS
  seminr_model = seminr::simplePLS(obsData = data,
                                   smMatrix = structural_model,
                                   mmMatrix = mmMatrix,
                                   inner_weights = inner_weights,
                                   maxIt=maxIt,
                                   stopCriterion=stopCriterion,
                                   measurement_mode_scheme = measurement_mode_scheme)

  # Store all settings needed for a rerun
  seminr_model$data <- data
  seminr_model$rawdata <- rawdata
  seminr_model$measurement_model <- measurement_model
  seminr_model$structural_model <- structural_model
  seminr_model$settings$inner_weights <- inner_weights
  seminr_model$settings$missing_value <- missing_value
  seminr_model$settings$maxIt <- maxIt
  seminr_model$settings$stopCriterion <- stopCriterion
  seminr_model$settings$missing <- missing

  # Correct for Bias in Reflective models using PLS Consistent
  seminr_model <- model_consistent(seminr_model)

  if ( length(HOCs)>0 ) {
    # Append return list with first stage model and
    seminr_model$first_stage_model <- first_stage_model
    seminr_model$hoc <- TRUE
    # Combine first and second stage measurement model matrices
    new_mm <- combine_first_order_second_order_matrices(model1 = first_stage_model, model2 = seminr_model, mmMatrix)
    seminr_model$outer_loadings <- new_mm$new_outer_loadings
    seminr_model$outer_weights <- new_mm$new_outer_weights
  }
  if(length(processed_measurements$ints)>0) {
    seminr_model$interaction <- TRUE
  }
  class(seminr_model) <- c("pls_model", "seminr_model")
  return(seminr_model)
}

not_null <- function(a, b) {
  if(!is.null(a)) {
    a
  } else {
    b
  }
}

#' Reruns a previously specified seminr model/analysis
#'
#' @param x An estimated seminr_model object - refer to specific rerun methods
#'
#' @param ... Any parameters to change during the rerun.
#'
#' @return A re-estimated model of the same class
#'
#' @seealso \code{\link{rerun.pls_model}}
#'
#' @export
rerun <- function (x, ...) {
  UseMethod("rerun", x)
}

#' Reruns a previously specified seminr PLS model
#'
#' @param x An estimated pls_model object produced by \code{\link{estimate_pls}}
#'
#' @param ... Any parameters to change during the re-estimation (e.g., data, measurement_model, etc.)
#'
#' @return A re-estimated pls_model object
#'
#' @examples
#'
#' mobi <- mobi
#'
#' mobi_mm <- constructs(
#'   composite("Image",        multi_items("IMAG", 1:5)),
#'   composite("Loyalty",      multi_items("CUSL", 1:3))
#' )
#'
#' mobi_sm <- relationships(
#'   paths(from = "Image",        to = c("Loyalty"))
#' )
#'
#' mobi_pls <- estimate_pls(data = mobi,
#'                          measurement_model = mobi_mm,
#'                          structural_model = mobi_sm,
#'                          missing = mean_replacement,
#'                          missing_value = NA)
#'
#' # Re-estimate model faithfully
#' mobi_pls2 <- rerun(mobi_pls)
#'
#' # Re-estimated model with altered measurement model
#' mobi_pls3 <- rerun(mobi_pls, measurement_model=as.reflective(mobi_mm))
#'
#' @export
rerun.pls_model <- function(x, ...) {
  args <- list(...)

  estimate_pls(
    data              = not_null(args$data,              x$rawdata),
    measurement_model = not_null(args$measurement_model, x$measurement_model),
    structural_model  = not_null(args$structural_model,  x$structural_model),
    model             = not_null(args$model,             x$model),
    inner_weights     = not_null(args$inner_weights,     x$settings$inner_weights),
    missing           = not_null(args$missing,           x$settings$missing),
    missing_value     = not_null(args$missing_value,     x$settings$missing_value),
    maxIt             = not_null(args$maxIt,             x$settings$maxIt),
    stopCriterion     = not_null(args$stopCriterion,     x$settings$stopCriterion)
  )
}