Higher order

.Rbuildignore

@@ -10,3 +10,5 @@
 ^USAGE\.md$
 ^\.travis\.yml$
 ^cran-comments\.md$
+^doc$
+^Meta$

.gitignore

@@ -5,3 +5,5 @@
 _*
 .DS*
 .R*
+doc
+Meta

NAMESPACE

@@ -13,6 +13,7 @@ export(confidence_interval)
 export(constructs)
 export(correlation_weights)
 export(estimate_pls)
+export(interaction_2stage)
 export(interaction_ortho)
 export(interaction_scaled)
 export(interactions)
@@ -30,3 +31,4 @@ export(report_paths)
 export(rho_A)
 export(simplePLS)
 export(single_item)
+export(two_stage_HOC)

R/higher_order.R

@@ -0,0 +1,108 @@
+# Takes a HOC name and replaces that constructs relationships with the dimensions of the HOC
+substitute_dimensions_for_HOC <- function(construct, sm,mm) {
+  # Identify dimensions of HOCs
+  dimensions <- mm[mm[,"type"] == "HOCA" | mm[,"type"] == "HOCB",][mm[mm[,"type"] == "HOCB" | mm[,"type"] == "HOCA",][,"construct"] == construct,"measurement"]
+  # identify antecedent relationships to HOC
+  antecedents <- sm[which(sm[,"target"] == construct),"source"]
+  # change antecedent relationship to first order constructs in structural model
+  if (!length(antecedents) == 0) {
+    sm <- rbind(sm,
+                relationships(paths(from = antecedents,
+                                    to = dimensions)))
+    sm <- sm[-which(sm[,"target"] == construct),]
+  }
+
+  # identify outcomes
+  outcomes <- sm[which(sm[,"source"] == construct),"target"]
+  if (!length(outcomes) == 0) {
+    sm <- rbind(sm,
+                relationships(paths(from = dimensions,
+                                    to = outcomes)))
+    sm <- sm[-which(sm[,"source"] == construct),]
+  }
+  return(sm)
+}
+
+remove_HOC_in_measurement_model <- function(construct,mm) {
+  mm[!mm[,"construct"] == construct,]
+}
+
+# Function to parse measurement and structural model and create the higher order model with complete information
+prepare_higher_order_model <- function(data,sm , mm, ints, inners) {
+  #retain the mm and sm
+  orig_mm <- mm
+  orig_sm <- sm
+  # Identify HOCs
+  HOCs <- unique(mm[which(mm[,"type"] == "HOCA" | mm[,"type"] == "HOCB"),"construct"])
+
+  # Rebuild model for first stage
+  # Add new HOC paths to SM
+  for (construct in HOCs) {
+    sm <- substitute_dimensions_for_HOC(construct, sm,mm)
+    #mm <- remove_HOC_in_measurement_model(construct,mm)
+  }
+  # Identify all the dimensions
+  dimensions <- orig_mm[which(orig_mm[,"construct"] == HOCs),"measurement"]
+  # remove HOCs from mm
+  new_mm <- mm[-which(mm[,"construct"] == HOCs),]
+
+  # Run first stage
+  new_model <- estimate_pls(data = data,
+                            measurement_model = new_mm,
+                            interactions = ints,
+                            structural_model = sm,
+                            inner_weights = inners)
+
+  # Add the construct scores to data
+  data <- cbind(data, new_model$construct_scores[,dimensions])
+
+  # Update the mm to include the type of the new data and item
+  mm[mm[,"type"] == "HOCA","type"] <- "A"
+  mm[mm[,"type"] == "HOCB","type"] <- "B"
+
+
+  # pass the updated mm, sm and data back to estimate_model()
+  return(list(data = data,
+              sm = orig_sm,
+              mm = mm))
+}
+
+
+
+#' HOC construct
+#'
+#' \code{two_stage_HOC} creates the constructs from further constructs using the two-stage method (Becker et al., 2012).
+#'
+#' This function conveniently maps first order constructs onto second order constructs using
+#' construct names.
+#'
+#' @param construct_name of second order construct
+#' @param dimensions the first order constructs
+#' @param weights is the relationship between the second order construct and first order constructs. 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.
+#'
+#' @usage
+#'  two_stage_HOC(construct_name, dimensions,weights = correlation_weights)
+#'
+#' @seealso See \code{\link{constructs}}, \code{\link{reflective}}
+#'
+#' @examples
+#'   mobi_mm <- constructs(
+#'     composite("Image",        multi_items("IMAG", 1:5), weights = correlation_weights),
+#'     composite("Expectation",  multi_items("CUEX", 1:3), weights = mode_A),
+#'     two_stage_HOC("Quality",      c("Image","Expectation"), weights = regression_weights),
+#'     composite("Value",        multi_items("PERV", 1:2), weights = mode_B)
+#'   )
+#' @export
+two_stage_HOC <- function(construct_name, dimensions, weights = correlation_weights) {
+  construct_names <- rep(construct_name, length(dimensions))
+  # TODO remove the duplicated conditional
+  # TODO possibly remove the construct_names object as the construct name should be coerced to fitr the matrix
+  if(identical(weights,correlation_weights) | identical(weights,mode_A)) {
+    return(c(rbind(construct_names,dimensions,"HOCA")))
+  }
+  if(identical(weights, regression_weights) | identical(weights, mode_B)) {
+    return(c(rbind(construct_names,dimensions,"HOCB")))
+  }
+}

R/interactions.R

@@ -39,8 +39,8 @@
 #'
 #' @export
 interactions <- function(...) {
-  function(data, mm, all_intxns=list(...)) {
-    create_interaction <- function(intxn_function) { intxn_function(data, mm) }
+  function(data, mm, sm, ints, inners, all_intxns=list(...)) {
+    create_interaction <- function(intxn_function) { intxn_function(data, mm, sm, ints, inners) }
     intxns_list <- lapply(all_intxns, create_interaction)
     return(intxns_list)
   }
@@ -88,7 +88,7 @@ interactions <- function(...) {
 #'
 #' @export
 interaction_ortho <- function(construct1, construct2) {
-  function(data, mm) {
+  function(data, mm, sm, ints, inners) {
     interaction_name <- paste(construct1, construct2, sep="*")
     iv1_items <- mm[mm[, "construct"] == construct1, "measurement"]
     iv2_items <- mm[mm[, "construct"] == construct2, "measurement"]
@@ -116,7 +116,9 @@ interaction_ortho <- function(construct1, construct2) {
     for(i in 1:ncol(interaction_data)) {
       interaction_data[,i] <- stats::lm(formula = frmla, data = data)$residuals
     }
-    return(list(name = interaction_name, data = interaction_data))
+    return(list(name = interaction_name,
+                data = interaction_data
+                ))
   }
 }
 
@@ -162,7 +164,7 @@ interaction_ortho <- function(construct1, construct2) {
 #'
 #' @export
 interaction_scaled <- function(construct1, construct2) {
-  function(data, mm) {
+  function(data, mm, sm, ints, inners) {
     interaction_name <- paste(construct1, construct2, sep="*")
     iv1_items <- mm[mm[, "construct"] == construct1, "measurement"]
     iv2_items <- mm[mm[, "construct"] == construct2, "measurement"]
@@ -183,7 +185,77 @@ interaction_scaled <- function(construct1, construct2) {
     #colnames(interaction_data) <- gsub("\\.", "\\*", colnames(interaction_data))
     colnames(interaction_data) <- as.vector(sapply(iv1_items, name_items))
 
-    return(list(name = interaction_name, data = interaction_data))
+    return(list(name = interaction_name,
+                data = interaction_data))
+  }
+}
+
+#' \code{interaction_2stage} creates an interaction measurement item by the two-stage approach.
+#'
+#' This function automatically generates an interaction measurement item for a PLS SEM using the two-stage approach.
+#'
+#' @param construct1 The first construct which is subject to the interaction.
+#' @param construct2 The second construct which is subject to the interaction.
+#'
+#' @usage
+#'  # two stage approach as per Henseler & Chin (2010):
+#'  interaction_2stage("construct1", "construct2")
+#'
+#' @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))
+#' )
+#' mobi_xm <- interactions(
+#'   interaction_2stage("Image", "Expectation")
+#' )
+#'
+#' #  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"))
+#' )
+#'
+#' mobi_pls <- estimate_pls(mobi, mobi_mm, mobi_xm, mobi_sm)
+#' summary(mobi_pls)
+#'
+#' @export
+interaction_2stage <- function(construct1, construct2) {
+  function(data, mm, sm, ints, inners) {
+    interaction_name <- paste(construct1, construct2, sep="*")
+
+    # remove interactions from structural model
+    if(length(sm[-which(grepl("\\*", sm[,1])),]) > 0) {
+      sm <- sm[-which(grepl("\\*", sm[,1])),,drop=FALSE]
+    }
+    if(length(sm[-which(grepl("\\*", sm[,2])),]) > 0) {
+      sm <- sm[-which(grepl("\\*", sm[,2])),,drop=FALSE]
+    }
+
+    # Run the first stage
+    measurement_mode_scheme <- sapply(unique(c(sm[,1],sm[,2])), get_measure_mode, mm, USE.NAMES = TRUE)
+    first_stage <- seminr::simplePLS(obsData = data,
+                                     smMatrix = sm,
+                                     mmMatrix = mm,
+                                     inner_weights = inners,
+                                     measurement_mode_scheme = measurement_mode_scheme)
+
+    interaction_term <- scale(as.matrix(first_stage$construct_scores[,construct1] * first_stage$construct_scores[,construct2], ncol = 1)[,, drop = FALSE])
+
+    colnames(interaction_term) <- c(interaction_name)
+
+    return(list(name = interaction_name,
+                data = interaction_term[,1, drop = FALSE]))
   }
 }
 

R/model.R

@@ -60,25 +60,39 @@ estimate_pls <- function(data, measurement_model, interactions=NULL, structural_
   data <- stats::na.omit(data)
   rawdata <- data
   raw_measurement_model <- measurement_model
+  # Generate first order model if necessary
+  if ("HOCA" %in% measurement_model[,"type"] | "HOCB" %in% measurement_model[,"type"] ) {
+    HOM <- prepare_higher_order_model(data = data,
+                                      sm = structural_model,
+                                      mm = measurement_model,
+                                      ints = interactions,
+                                      inners = inner_weights)
+    measurement_model <- HOM$mm
+    structural_model <- HOM$sm
+    data <- HOM$data
+  }
+
+  # Generate interactions
   if(!is.null(interactions)) {
     # update data with new interaction items
-    intxns_list <- interactions(data, measurement_model)
+    intxns_list <- interactions(data = data,
+                                mm = measurement_model,
+                                sm = structural_model,
+                                ints = interactions,
+                                inners = inner_weights)
     get_data <- function(intxn) { intxn$data }
     interaction_data <- do.call("cbind", lapply(intxns_list, get_data))
 
     # Append data with interaction data
     data <- cbind(data, interaction_data)
 
     # update measurement model with interaction constructs
-    measure_interaction <- function(intxn) {
-      composite(intxn$name, names(intxn$data),weights = mode_A)
-    }
     intxns_mm <- constructs(do.call("c", lapply(intxns_list, measure_interaction)))
     measurement_model <- rbind(measurement_model, intxns_mm)
   }
 
   # warning if the model is incorrectly specified
-  warning_struc_meas_model_complete(structural_model,measurement_model,data)
+  #warning_struc_meas_model_complete(structural_model,measurement_model,data)
 
   # Make a named list of construct measurement_mode functions
   measurement_mode_scheme <- sapply(unique(c(structural_model[,1],structural_model[,2])), get_measure_mode, measurement_model, USE.NAMES = TRUE)

R/model_extraction.R

@@ -9,3 +9,11 @@ items_of_construct <- function(construct, model) {
 antecedents_of_construct <- function(construct, model) {
   model$smMatrix[model$smMatrix[,2] == construct, 1]
 }
+# update measurement model with interaction constructs
+measure_interaction <- function(intxn) {
+  if (length(names(intxn$data))>1) {
+    composite(intxn$name, names(intxn$data),weights = mode_A)
+  } else {
+    composite(intxn$name, colnames(intxn$data),weights = mode_A)
+  }
+}

R/warnings.R

@@ -8,7 +8,7 @@ warning_single_item_formative <- function(mmMatrix) {
 }
 
 warning_missing_data <- function(data, mmMatrix) {
-  data <- data[, mmMatrix[which(!grepl("\\*", mmMatrix[,2])),2]]
+  data <- data[, mmMatrix[which(!grepl("\\*", mmMatrix[,2]) & !(mmMatrix[,"type"] == "HOCA" | mmMatrix[,"type"] == "HOCB")),2]]
   N <- nrow(data)
   missing_values <- which(stats::complete.cases(data)==FALSE)
   if(length(missing_values)==0){

README.Rmd

@@ -35,7 +35,7 @@ SEMinR follows the latest best-practices in methodological literature:
 
 ## Documentation
 
-The vignette for Seminr can be found in the [seminr/inst/doc/](https://github.com/ISS-Analytics/seminr/blob/master/inst/doc/SEMinR.html) folder or by running the `vignette("SEMinR")` command after installation.
+The vignette for Seminr can be found in the [seminr/doc/](https://github.com/ISS-Analytics/seminr/blob/master/doc/SEMinR.html) folder or by running the `vignette("SEMinR")` command after installation.
 
 Demo code for use of Seminr can be found in the [seminr/demo/](https://github.com/ISS-Analytics/seminr/tree/master/demo) folder or by running the `demo("seminr-contained")`, `demo("seminr-ecsi")` or `demo("seminr-interaction")` commands after installation.
 

demo/00Index

@@ -3,3 +3,5 @@ seminr-ecsi-plsc   A demonstration of Consistent PLS estimation of the ECSI mode
 seminr-ecsi   A demonstration of the regular style of SEMinR syntax
 seminr-interaction   A demonstration of modeling an interaction using SEMinR syntax
 seminr-alternative-models   A demonstration of alternate model specification, quick and easy
+seminr-hoc   A demonstration of modeling a higher order construct in SEMinR syntax
+seminr-2Sinteraction    A demonstration of modeling a two-stage interaction in SEMinR syntax

demo/seminr-2Sinteraction.R

@@ -0,0 +1,33 @@
+# Simple Style: Seperate declaration of measurement and structural model, no interactions.
+library(seminr)
+
+# Creating measurement mode
+# - note: composite() has a default parameter setting of mode A
+# - note: items can be a list of names: c("CUEX1", "CUEX2", "CUEX3")
+#         which can be constructed quickly as: multi_items("CUEX", 1:3)
+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 constructs must be created after the measurement model is defined.
+# We are using the two_stage method as per Henseler & Chin (2010)
+mobi_xm <- interactions(
+  interaction_2stage("Image", "Expectation")
+)
+
+# Creating structural model
+# - note, multiple paths can be created in each line
+mobi_sm <- relationships(
+  paths(to = "Satisfaction",
+        from = c("Image", "Expectation", "Value",
+                 "Image*Expectation"))
+)
+
+# Estimate the model with the HOC
+mobi_pls <- estimate_pls(data = mobi,
+                         measurement_model = mobi_mm,
+                         interactions = mobi_xm,
+                         structural_model = mobi_sm)

demo/seminr-hoc.R

@@ -0,0 +1,29 @@
+# Simple Style: Seperate declaration of measurement and structural model, no interactions.
+library(seminr)
+
+# Creating measurement mode
+# - note: composite() has a default parameter setting of mode A
+# - note: items can be a list of names: c("CUEX1", "CUEX2", "CUEX3")
+#         which can be constructed quickly as: multi_items("CUEX", 1:3)
+mobi_mm <- constructs(
+  composite("Image",        multi_items("IMAG", 1:5)),
+  composite("Expectation",  multi_items("CUEX", 1:3)),
+  composite("Quality",      multi_items("PERQ", 1:7)),
+  composite("Value",        multi_items("PERV", 1:2)),
+  two_stage_HOC("Satisfaction", c("Image","Value")),
+  composite("Complaints",   single_item("CUSCO")),
+  composite("Loyalty",      multi_items("CUSL", 1:3))
+)
+
+# Creating structural model
+# - note, multiple paths can be created in each line
+mobi_sm <- relationships(
+  paths(from = c("Expectation","Quality"),  to = "Satisfaction"),
+  paths(from = "Satisfaction", to = c("Complaints", "Loyalty"))
+)
+
+# Estimate the model with the HOC
+mobi_pls <- estimate_pls(data = mobi,
+                         measurement_model = mobi_mm,
+                         interactions = NULL,
+                         structural_model = mobi_sm)