R/htmt.R

In semTools: Useful Tools for Structural Equation Modeling

### Ylenio Longo & Terrence D. Jorgensen
### Last updated: 31 January 2023

##' Assessing Discriminant Validity using Heterotrait--Monotrait Ratio
##'
##' This function assesses discriminant validity through the
##' heterotrait-monotrait ratio (HTMT) of the correlations (Henseler, Ringlet &
##' Sarstedt, 2015). Specifically, it assesses the arithmetic (Henseler et al.,
##' ) or geometric (Roemer et al., 2021) mean correlation
##' among indicators across constructs (i.e. heterotrait--heteromethod
##' correlations) relative to the geometric-mean correlation among indicators
##' within the same construct (i.e. monotrait--heteromethod correlations).
##' The resulting HTMT(2) values are interpreted as estimates of inter-construct
##' correlations. Absolute values of the correlations are recommended to
##' calculate the HTMT matrix, and are required to calculate HTMT2. Correlations
##' are estimated using the [lavaan::lavCor()] function.
##'
##'
##' @importFrom stats cov2cor
##'
##' @param model lavaan [lavaan::model.syntax()] of a confirmatory factor
##'   analysis model where at least two factors are required for indicators
##'   measuring the same construct.
##' @param data A `data.frame` or data `matrix`
##' @param sample.cov A covariance or correlation matrix can be used, instead of
##'   `data=`, to estimate the HTMT values.
##' @param missing If `"listwise"`, cases with missing values are removed listwise
##'   from the data frame. If `"direct"` or `"ml"` or `"fiml"` and the estimator is
##'   maximum likelihood, an EM algorithm is used to estimate the unrestricted
##'   covariance matrix (and mean vector). If `"pairwise"`, pairwise deletion is
##'   used. If `"default"`, the value is set depending on the estimator and the
##'   mimic option (see details in [lavaan::lavCor()]).
##' @param ordered Character vector. Only used if object is a `data.frame`.
##'   Treat these variables as ordered (ordinal) variables. Importantly, all
##'   other variables will be treated as numeric (unless `is.ordered` in
##'   `data=`). See also [lavaan::lavCor()].
##' @param absolute `logical` indicating whether HTMT values should be
##'   estimated based on absolute correlations (default is `TRUE`). This
##'   is recommended for HTMT but required for HTMT2 (so silently ignored).
##' @param htmt2 `logical` indicating whether to use the geometric mean
##'   (default, appropriate for congeneric indicators) or arithmetic mean
##'   (which assumes tau-equivalence).
##'
##' @return A matrix showing HTMT(2) values (i.e., discriminant validity)
##'   between each pair of factors.
##'
##' @author
##' Ylenio Longo (University of Nottingham; \email{yleniolongo@@gmail.com})
##'
##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com})
##'
##' @references
##'   Henseler, J., Ringle, C. M., & Sarstedt, M. (2015). A new criterion for
##'   assessing discriminant validity in variance-based structural equation
##'   modeling. *Journal of the Academy of Marketing Science, 43*(1),
##'   115--135. \doi{10.1007/s11747-014-0403-8}
##'
##'   Roemer, E., Schuberth, F., & Henseler, J. (2021). HTMT2---An improved
##'   criterion for assessing discriminant validity in structural equation
##'   modeling. *Industrial Management & Data Systems, 121*(21), 2637--2650.
##'   \doi{10.1108/IMDS-02-2021-0082}
##'
##'   Voorhees, C. M., Brady, M. K., Calantone, R., & Ramirez, E. (2016).
##'   Discriminant validity testing in marketing: An analysis, causes for
##'   concern, and proposed remedies.
##'   *Journal of the Academy of Marketing Science, 44*(1), 119--134.
##'   \doi{10.1007/s11747-015-0455-4}
##'
##' @examples
##'
##' HS.model <- ' visual  =~ x1 + x2 + x3
##'               textual =~ x4 + x5 + x6
##'               speed   =~ x7 + x8 + x9 '
##'
##' dat <- HolzingerSwineford1939[, paste0("x", 1:9)]
##' htmt(HS.model, dat)
##'
##' ## save covariance matrix
##' HS.cov <- cov(HolzingerSwineford1939[, paste0("x", 1:9)])
##' ## HTMT using arithmetic mean
##' htmt(HS.model, sample.cov = HS.cov, htmt2 = FALSE)
##'
##' @export
htmt <- function(model, data = NULL, sample.cov = NULL, missing = "listwise",
                  ordered = NULL, absolute = TRUE, htmt2 = TRUE) {
  model <- lavaan::lavaanify(model)
  model <- model[model$op %in% "=~", ]
  factors <- unique(model$lhs)
  nf <- length(factors)
  var <- list()
  for (i in 1:nf) {
    var[[i]] <- model$rhs[which(model$lhs %in% factors[i])]
  }
  varnames <- c(unlist(var))
  if(!is.null(data)) { # if data
    if(any(! varnames %in% colnames(data))) {
      absent.vars <- which(! varnames %in% colnames(data))
      stop("Missing observed variables in the dataset: ",
           paste(varnames[absent.vars], collapse = " "))
    }
    data <- data[ , c(varnames)]
    R <- lavaan::lavCor(data, missing = missing, ordered = ordered)
    rownames(R) <- names(data)
    colnames(R) <- names(data)
  } else {
    if (any(! varnames %in% colnames(sample.cov))) {
      absent.vars <- which(! varnames %in% colnames(sample.cov))
      stop("Missing observed variables in the covariance or correlation matrix: ",
           paste(varnames[absent.vars], collapse = " "))
    }
    diagR <- diag(sample.cov)
    if (max(diagR) != 1 & min(diagR) != 1) { #if covariance matrix
      R <- cov2cor(sample.cov[varnames, varnames])
    } else { # if correlation matrix
      R <- sample.cov[varnames, varnames]
    }
  }
  if (absolute || htmt2) {
    R <- abs(R)
  }
  diag(R) <- NA
  m.cor.w <- list()
  for (i in 1:nf) {
    if (htmt2) {
      m.cor.w[[i]] <- exp(mean(log(R[ var[[i]], var[[i]] ]), na.rm = TRUE))
    } else m.cor.w[[i]] <- mean(R[ var[[i]], var[[i]] ], na.rm = TRUE)
  }
  m.cor.w <- as.numeric(m.cor.w)
  comb <- expand.grid(1:nf, 1:nf)
  g <- list()
  for (i in 1:nrow(comb)) {
    g[[i]] <- sqrt(m.cor.w[comb[i, 2]] * m.cor.w[comb[i, 1]])
  }
  g <- as.numeric(g)
  paste(comb[, 2], comb[, 1])
  m.cor.a <- list()
  for (i in 1:nrow(comb)) {
    if (htmt2) {
      m.cor.a[[i]] <- exp(mean(log(R[ var[[comb[i, 2]]],
                                      var[[comb[i, 1]]] ]),
                               na.rm = TRUE))
    } else m.cor.a[[i]] <- mean(R[ var[[ comb[i,2] ]],
                                   var[[ comb[i,1] ]] ], na.rm = TRUE)
  }
  m.cor.a <- as.numeric(m.cor.a)
  outhtmt <- m.cor.a / g
  res <- matrix(outhtmt, nrow = nf, ncol = nf, dimnames = list(factors))
  colnames(res) <- factors
  class(res) <- c("lavaan.matrix.symmetric", "matrix")
  res
}