#' Reliability‑Corrected Single‑Item SEM
#'
#' Replace (some of) the first‑order latent variables in a lavaan measurement
#' model by single composite indicators whose error variances are fixed from
#' Cronbach's \eqn{\alpha}. The function returns a modified lavaan model
#' syntax together with an augmented data set that contains the newly created
#' composite variables, so that you can fit the full SEM in a single step.
#'
#' The resulting object can be fed directly into \code{modsem} or \code{lavaan::sem}
#' by supplying \code{syntax = $syntax} and \code{data = $data}.
#'
#' @param syntax A character string containing lavaan model syntax.  Must at
#'   least include the measurement relations (\code{=~}).
#'
#' @param data A \code{data.frame}, \code{tibble} or object coercible to a data frame that
#'   holds the raw observed indicators.
#'
#' @param choose \emph{Optional.} Character vector with the names of the latent
#'   variables you wish to replace by single indicators.  Defaults to \strong{all}
#'   first‑order latent variables in \code{syntax}.
#'
#' @param scale.corrected Should reliability-corrected items be scale-corrected? If \code{TRUE}
#'   reliability-corrected single items are corrected for differences in factor loadings between
#'   the items. Default is \code{TRUE}.
#'
#' @param missing How should missing values be handled in the CFA? Default is \code{"fiml"}.
#'
#' @param warn.lav Should warnings from \code{lavaan::cfa} be displayed? If \code{FALSE}, they
#'   are suppressed.
#'
#' @param group Character. A variable name in the data frame defining the groups in a multiple
#'   group analysis
#'
#' @return An object of S3 class \code{ModsemRelcorr} (a named list) with elements:
#' \describe{
#'   \item{\code{syntax}}{Modified lavaan syntax string.}
#'   \item{\code{data}}{Data frame with additional composite indicator columns.}
#'   \item{\code{parTable}}{Parameter table corresponding to `syntax`.}
#'   \item{\code{reliability}}{Named numeric vector of reliabilities (one per latent
#'     variable).}
#'   \item{\code{AVE}}{Named numeric vector with Average Variance Extracted values.}
#'   \item{\code{lVs}}{Character vector of latent variables that were corrected.}
#'   \item{\code{single.items}}{Character vector with names for the generated reliability corrected items}
#' }
#'
#' @examples
#' \dontrun{
#' tpb_uk <- "
#' # Outer Model (Based on Hagger et al., 2007)
#'  ATT =~ att3 + att2 + att1 + att4
#'  SN =~ sn4 + sn2 + sn3 + sn1
#'  PBC =~ pbc2 + pbc1 + pbc3 + pbc4
#'  INT =~ int2 + int1 + int3 + int4
#'  BEH =~ beh3 + beh2 + beh1 + beh4
#'
#' # Inner Model (Based on Steinmetz et al., 2011)
#'  INT ~ ATT + SN + PBC
#'  BEH ~ INT + PBC
#'  BEH ~ INT:PBC
#' "
#'
#' corrected <- relcorr_single_item(syntax = tpb_uk, data = TPB_UK)
#' print(corrected)
#'
#' syntax <- corrected$syntax
#' data   <- corrected$data
#'
#' est_dca <- modsem(syntax, data = data, method = "dblcent")
#' est_lms <- modsem(syntax, data = data, method="lms", nodes=32)
#' summary(est_lms)
#' }
#'
#' @export
relcorr_single_item <- function(syntax,
                                data,
                                choose = NULL,
                                scale.corrected = TRUE,
                                missing = "fiml",
                                warn.lav = TRUE,
                                group = NULL) {
  data <- as.data.frame(data)

  if (is.null(group)) {
    return(relcorrSingleItemGroup(
      syntax = syntax, data = data, choose = choose,
      scale.corrected = scale.corrected,
      missing = missing, warn.lav = warn.lav
    ))
  }

  mod_stopif(length(group) > 1L, "`group` must be a character vector of length 1!")
  mod_stopif(!group %in% colnames(data), sprintf("Unable to find `%s` in data!", group))

  group.info <- parseModelArgumentsByGroupDA(
    model.syntax = syntax,
    cov.syntax   = NULL,
    data         = data,
    group        = group
  )

  parTable      <- group.info$parTable
  group.label   <- as.character(group.info$group.levels)
  groups        <- getGroupsParTable(parTable)
  data[[group]] <- as.character(data[[group]])

  out <- list(parTable = NULL, syntax = NULL, data = NULL,
              relcorr.groups = vector("list", length = length(groups)))

  for (g in groups) {
    g.val      <- group.label[[g]]
    data.g     <- data[data[[group]] == g.val, , drop = FALSE]
    parTable.g <- parTable[parTable$group == g, , drop = FALSE]
    parTable.g <- parTable.g[, colnames(parTable.g) != "group", drop = FALSE]

    relcorr.g <- relcorrSingleItemGroup(
      parTable        = parTable.g,
      data            = data.g,
      choose          = choose,
      scale.corrected = scale.corrected,
      missing         = missing,
      warn.lav        = warn.lav
    )

    out$relcorr.groups[[g]] <- relcorr.g

    newParTable.g <- relcorr.g$parTable
    newParTable.g$group <- g
    newData.g <- relcorr.g$data

    out$parTable <- rbind(out$parTable, newParTable.g)
    out$data     <- rbind(out$data, newData.g)
  }

  out$syntax <- parTableToSyntax(out$parTable)
  class(out) <- "MultiGroupModsemRelcorr"

  out
}


relcorrSingleItemGroup <- function(syntax = NULL,
                                   parTable = NULL,
                                   data,
                                   choose = NULL,
                                   scale.corrected = TRUE,
                                   missing = "fiml",
                                   warn.lav = TRUE) {
  data <- as.data.frame(data)

  if (is.null(parTable))
    parTable <- modsemify(syntax)

  intTerms      <- parTable$rhs[grepl(":", parTable$rhs)]

  parTableOuter <- parTable[parTable$op == "=~", ]
  parTableInner <- parTable[parTable$op != "=~", ]

  lVs            <- getLVs(parTable)
  allIndsLVs     <- getIndsLVs(parTable, lVs = lVs)
  allInds        <- unique(unlist(allIndsLVs))
  higherOrderLVs <- getHigherOrderLVs(parTable)
  firstOrderLVs  <- setdiff(lVs, higherOrderLVs)

  mod_stopif(any(higherOrderLVs %in% allInds),
         "Third order (or higher) latent variables are not allowed (yet)!")

  choose <- if (is.null(choose)) lVs else choose
  ignore <- setdiff(lVs, choose)

  mod_warnif(any(!choose %in% lVs), paste0("Could not find latent variables:\n",
         paste(choose[!choose %in% lVs], collapse = ", ")))
  choose <- choose[choose %in% lVs]

  ignoreRows <- parTableOuter$lhs %in% ignore

  parTableInner <- rbind(parTableInner, parTableOuter[ignoreRows, ])
  parTableOuter <- parTableOuter[!ignoreRows, ]

  mod_stopif(!NROW(parTableOuter), paste0("Cannot ignore all latent variables when creating ",
         "reliability corrected items!"))

  mod_warnif(any(!canBeNumeric(parTableOuter$mod, includeNA = TRUE)),
         paste0("Labels and modifiers in the measurement model used to create reliability ",
         "corrected single items will be ignored!\nThis may cause the model constraints ",
         "in the structural model to break!"))

  lVs  <- setdiff(firstOrderLVs, ignore)
  indsLVs <- getIndsLVs(parTableOuter, lVs = lVs)
  inds <- unlist(indsLVs)
  R <- stats::cov(data[inds], use = "pairwise.complete.obs")
  k <- length(lVs)

  # Add residual Covariances
  rescovind <- parTableInner$lhs %in% inds &
               parTableInner$rhs %in% inds &
               parTableInner$op == "~~"
  parTableOuter <- rbind(parTableOuter, parTableInner[rescovind, ])
  parTableInner <- parTableInner[!rescovind, ]

  # Check if there are any indicators in the structural model
  indsInInner <- parTableInner$lhs %in% inds | parTableInner$rhs %in% inds
  if (any(indsInInner)) {
    removing <- apply(
      X = parTableInner[indsInInner, c("lhs", "op", "rhs"), drop = FALSE],
      MARGIN = 1L, FUN = paste0, collapse = ""
    )

    mod_msg_warn(
      paste0("Removing expressions containing indicators!\n",
             paste0(removing, collapse = ", "))
    )

    parTableInner <- parTableInner[!indsInInner, ]
  }

  wrap      <- if (warn.lav) \(x) x else suppressWarnings
  cfaSyntax <- parTableToSyntax(parTableOuter)
  cfa       <- wrap(lavaan::cfa(cfaSyntax, data = data, se = "none", missing = missing))

  cov.lv      <- lavaan::lavInspect(cfa, "cov.lv")
  stdSolution <- lavaan::lavInspect(cfa, "std")
  lambda <- stdSolution$lambda
  theta  <- stdSolution$theta

  avefunc <- \(lV) calcAVE(lV, lambda.std = lambda)
  relfunc <- \(lV) calcChronbach(R = R, x = indsLVs[[lV]])

  rel.std <- vapply(lVs, FUN.VALUE = numeric(1L), relfunc)
  AVE.std <- vapply(lVs, FUN.VALUE = numeric(1L), avefunc)
  res.std <- 1 - rel.std
  singleInds <- getSingleIndNames(lVs)

  rchar <- c(letters, seq_len(9))
  while(any(singleInds %in% colnames(data))) {
    singleInds <- paste0(singleInds, sample(rchar, length(singleInds)))
  }

  varNewInds <- structure(numeric(length(lVs)), names=singleInds)
  newData <- data

  if (scale.corrected) {
    res <- stats::setNames(numeric(length(lVs)), nm = lVs)

    for (lV in lVs) {
      ITEM <- getScaleCorrectedItem(parTable = parTable, lV = lV,
                                    data = data, cfa = cfa)

      newIndName <- singleInds[[lV]]
      newInd     <- ITEM$item
      residual   <- ITEM$residual

      newData[[newIndName]] <- newInd
      res[[lV]] <- residual
    }

  } else {
    for (lV in lVs) {
      indsLV     <- indsLVs[[lV]]
      newIndName <- singleInds[[lV]]
      X          <- as.matrix(data[indsLV])
      newInd     <- rowMeans(data[indsLV], na.rm = TRUE)

      newData[[newIndName]]    <- newInd
      varNewInds[[newIndName]] <- stats::var(newInd, na.rm = TRUE)
    }

    rel <- rel.std * varNewInds
    res <- res.std * varNewInds
  }

  if (length(higherOrderLVs)) {
    for (lV in intersect(lVs, allInds)) {
      res[[lV]] <- res[[lV]] + getHigherOrderResidual(lV = lV, cfa = cfa)
    }
  }

  resCovMat <- getCompositeRVCOV(lVs = lVs, parTable = parTable, cfa = cfa,
                                 scale.corrected = scale.corrected)
  # Ensure diagonals match the already computed residual variances
  diag(resCovMat) <- as.numeric(res[lVs])

  # first order lVs
  newParTable <- parTableInner
  firstOrder  <- !lVs %in% allInds
  secondOrder <- lVs %in% allInds

  if (any(firstOrder)) {
    lVs1        <- lVs[firstOrder]
    singleInds1 <- singleInds[firstOrder]
    k1          <- length(lVs1)
    res1        <- format(res[firstOrder], scientific = FALSE)

    lhs <- unname(c(lVs1, singleInds1))
    rhs <- unname(c(singleInds1, singleInds1))
    op  <- c(rep("=~", k1), rep("~~", k1))
    mod <- unname(c(rep("1", k1), res1))

    newParTable <- rbind(
      newParTable, data.frame(lhs = lhs, op = op, rhs = rhs, mod = mod)
    )
  }

  if (any(secondOrder)) {
    mod_msg_note(
      paste0("Correcting first order items/lVs for higher order measurement model!",
      "Note that the first order LVs no longer can be used directly in the",
      "structural model!")
    )

    lVs2        <- lVs[secondOrder]
    singleInds2 <- singleInds[secondOrder]
    k2          <- length(lVs2)
    res2        <- res[secondOrder]

    for (hlV in higherOrderLVs) {
      lVs2h <- intersect(lVs2, allIndsLVs[[hlV]])
      singleInds2h <- singleInds2[lVs2h]
      res2h <- format(res2[lVs2h], scientific = FALSE)
      k2h   <- length(singleInds2h)

      lhs <- unname(c(rep(hlV, k2h), singleInds2h))
      rhs <- unname(c(singleInds2h, singleInds2h))
      op  <- c(rep("=~", k2h), rep("~~", k2h))
      mod <- unname(c(rep("", k2h), res2h))

      newParTable <- rbind(
        newParTable, data.frame(lhs = lhs, op = op, rhs = rhs, mod = mod)
      )
    }
  }

  if (length(lVs)) {
    lvPairs <- utils::combn(lVs, 2, simplify = FALSE)

    addRows <- lapply(lvPairs, function(pair) {
      lv_i <- pair[1]
      lv_j <- pair[2]
      val  <- resCovMat[lv_i, lv_j]

      if (abs(val) < 1e-12)
        return(NULL)

      data.frame(
        lhs = unname(singleInds[[lv_i]]),
        op  = "~~",
        rhs = unname(singleInds[[lv_j]]),
        mod = format(unname(val), scientific=FALSE)
      )
    })

    newRows <- do.call(rbind, Filter(Negate(is.null), addRows))

    if (!is.null(addRows) && NROW(newRows))
      newParTable <- rbind(newParTable, newRows)
  }

  newSyntax <- parTableToSyntax(newParTable)

  out <- list(syntax = newSyntax, data = newData,
              parTable = newParTable, reliability = rel.std,
              AVE = AVE.std, lVs = lVs, single.items = singleInds,
              intTerms = intTerms, residuals = res, res.std = res.std,
              cov.lv = cov.lv, residual_covariances = resCovMat)

  class(out) <- c("list", "ModsemRelcorr")

  out
}


getScaleCorrectedItem <- function(parTable, lV, data, cfa) {
  measr  <- parTable[parTable$lhs == lV & parTable$op == "=~", ]
  inds   <- unique(measr$rhs)

  matrices <- lavaan::lavInspect(cfa, what = "coef")

  theta  <- matrices$theta[inds, inds]
  lambda <- as.vector(matrices$lambda[inds, lV])

  I <- rep(1, length(inds))
  X <- as.matrix(data[, inds])

  # Ignore loadings for values in X which are missing
  L <- matrix(lambda, nrow = nrow(X), ncol = ncol(X), byrow = TRUE)
  L[is.na(X)] <- NA_real_

  item <- rowSums(X, na.rm = TRUE) / rowSums(L, na.rm = TRUE)

  residual <- (t(I) %*% theta %*% I) / sum(lambda)^2

  list(X = X, item = as.numeric(item), residual = as.numeric(residual))
}


getHigherOrderResidual <- function(lV, cfa) {
  parTable <- lavaan::parameterEstimates(cfa)
  inds     <- getInds(parTable)

  if (!lV %in% inds) return(0)

  residual <- parTable[parTable$lhs == lV &
                       parTable$op == "~~" &
                       parTable$rhs == lV, "est"]

  ifelse(!length(residual), yes = 0, no = residual[[1L]])
}


simulateCrossResCovRCS <- function(corrected,
                                   elemsInIntTerms,
                                   mc.reps = 3e4,
                                   parTable,
                                   include.normal.inds = FALSE) {
  if ( inherits(corrected, "ModsemRelcorr") &&
      !inherits(corrected, "MultiGroupModsemRelcorr")) {

    return(simulateCrossResCovRCS_Group(
      corrected           = corrected,
      elemsInIntTerms     = elemsInIntTerms,
      mc.reps             = mc.reps,
      parTable            = parTable,
      include.normal.inds = include.normal.inds
    ))
  }

  newRows <- NULL

  for (g in seq_along(corrected$relcorr.groups)) {
    corrected.g <- corrected$relcorr.groups[[g]]

    simCrossResCov.g <- simulateCrossResCovRCS_Group(
      corrected           = corrected.g,
      elemsInIntTerms     = elemsInIntTerms,
      mc.reps             = mc.reps,
      parTable            = parTable,
      include.normal.inds = include.normal.inds
    )

    newRows.g <- simCrossResCov.g$rows
    newRows.g$group <- g

    newRows <- rbind(newRows, newRows.g)
  }

  syntaxAdditions <- parTableToSyntax(newRows)

  list(syntax = syntaxAdditions, rows = newRows)
}


simulateCrossResCovRCS_Group <- function(corrected,
                                         elemsInIntTerms,
                                         mc.reps = 3e4,
                                         parTable,
                                         include.normal.inds = FALSE) {
  EMPTY <- list(syntax = "", rows = NULL)

  if (!length(elemsInIntTerms))
    return(EMPTY)

  intTerms        <- names(elemsInIntTerms)
  single.items    <- corrected$single.items
  residuals       <- corrected$residuals
  constructs      <- names(single.items)

  intTermIsRCS <- vapply(elemsInIntTerms, FUN.VALUE = logical(1L),
                         FUN = \(elems) all(elems %in% constructs))
  elemsInIntTerms <- elemsInIntTerms[intTermIsRCS]
  intTerms <- intTerms[intTermIsRCS]

  if (!length(elemsInIntTerms))
    return(EMPTY)

  Phi   <- corrected$cov.lv
  Theta <- diag(residuals)
  nm    <- names(residuals)
  Phi   <- Phi[nm, nm]
  dimnames(Theta) <- list(nm, nm)

  XI  <- mvtnorm::rmvnorm(mc.reps, sigma = Phi)
  EPS <- mvtnorm::rmvnorm(mc.reps, sigma = Theta)
  Y   <- XI + EPS

  CONSTRUCTS <- as.data.frame(XI)
  ITEMS      <- as.data.frame(Y)

  colnames(CONSTRUCTS) <- nm
  colnames(ITEMS)      <- single.items[nm]

  if (include.normal.inds) {
    RESIDUALS  <- as.data.frame(EPS)
    colnames(RESIDUALS)  <- single.items[nm]
  } else RESIDUALS <- list()

  for (intTerm in intTerms) {
    elems  <- elemsInIntTerms[[intTerm]]
    items  <- single.items[elems]
    nameXZ <- paste0(items, collapse = "")

    xz.construct <- multiplyIndicatorsCpp(CONSTRUCTS[elems])
    xz.item      <- multiplyIndicatorsCpp(ITEMS[items])

    CONSTRUCTS[[intTerm]] <- xz.construct
    ITEMS[[nameXZ]]      <- xz.item
  }

  Epsilon <- stats::cov(ITEMS) - stats::cov(CONSTRUCTS)
  newRows <- NULL

  for (i in seq_len(NROW(Epsilon))) {
    for (j in seq_len(i)) {
      mod <- format(Epsilon[i, j], scientific = FALSE)
      lhs <- rownames(Epsilon)[[i]]
      rhs <- colnames(Epsilon)[[j]]

      elems.lhs <- stringr::str_split_1(lhs, "composite_")
      elems.rhs <- stringr::str_split_1(rhs, "composite_")

      elems.lhs <- elems.lhs[elems.lhs != ""]
      elems.rhs <- elems.rhs[elems.rhs != ""]

      matching <- parTable[((parTable$lhs == lhs & parTable$rhs == rhs) |
                            (parTable$lhs == rhs & parTable$rhs == lhs)) &
                           parTable$op == "~~", ]

      if (NROW(matching) || !length(intersect(elems.lhs, elems.rhs)))
        next

      newRows <- rbind(
        newRows,
        createParTableRow(c(lhs, rhs), op = "~~", mod = mod)
      )
    }
  }

  syntaxAdditions <- parTableToSyntax(newRows)

  list(syntax = syntaxAdditions, rows = newRows)
}


#' @export
print.ModsemRelcorr <- function(x,...) {
  sep <- strrep(" ", 4)
  indent <- strrep(" ", 2)

  lVs <- x$lVs
  lVsf <- format(paste0(lVs, ":"), justify = "left")
  AVE_rel <- format(c(x$AVE, x$reliability), digits = 3, nsmall = 2, justify = "right")

  idxAVE <- seq_along(x$AVE)
  AVEs  <- AVE_rel[idxAVE]
  rels  <- AVE_rel[-idxAVE]

  cat("Average Variance Extracted:\n")
  for (i in seq_along(lVs)) {
    lV <- lVsf[[i]]
    AVE <- AVEs[[i]]
    cat(paste0(indent, lV, sep, AVE, "\n"))
  }

  cat(paste0("\nChronbach's Alpha:\n"))
  for (i in seq_along(lVs)) {
    lV <- lVsf[[i]]
    rel <- rels[[i]]
    cat(paste0(indent, lV, sep, rel, "\n"))
  }

  cat(paste0("\nGenerated Syntax:\n"))
  cat(padString(x$syntax, pad = indent))

  cat(paste0("Generated Items:\n"))
  datastr <- utils::capture.output(utils::str(x$data[x$single.items]))
  cat(padString(datastr, pad = indent))
}


getSingleIndNames <- function(lVs) {
  structure(paste0("composite_", lVs, "_"), names=lVs)
}


calcChronbach <- function(R, x) {
  Rx <- R[x, x]
  k <- length(x)

  if (k == 1) return(1) # should be treated like an observed variable

  mod_warnif(any(Rx < 0), paste0("Some item covariances are negative! Consider ",
         "recoding your items!"))

  Rx <- abs(Rx)
  varSum <- sum(diag(Rx))
  covSum <- sum(Rx[lower.tri(Rx)])

  (k / (k - 1)) * (1 - varSum / (varSum + 2 * covSum))
}


calcConstructRel <- function(lambda.std, lV) {
  lambda.std <- lambda.std[, lV, drop=FALSE]
  lambda.std <- lambda.std[lambda.std != 0]

  mod_warnif(any(lambda.std < 0), paste0("Some items have negative factor loadings!\n",
         "Consider recoding your items!"))

  sum(lambda.std) ^ 2 / (sum(lambda.std) ^ 2 + sum(1 - lambda.std ^ 2))
}


calcAVE <- function(lambda.std, lV) {
  inds <- rownames(lambda.std)

  lambda.std <- structure(lambda.std[, lV, drop=TRUE], names = inds)
  lambda.std <- lambda.std[lambda.std != 0]

  sum(lambda.std ^ 2) / length(lambda.std)
}


getCompositeRVCOV <- function(lVs, parTable, cfa, scale.corrected) {
  matrices <- lavaan::lavInspect(cfa, what = "coef")
  lambda   <- matrices$lambda
  theta    <- matrices$theta

  inds <- rownames(lambda)[apply(lambda, MARGIN = 1L, FUN = \(x) any(x != 0))]
  lambda <- lambda[inds, lVs, drop = FALSE]
  theta  <- theta[inds, inds, drop = FALSE]

  I <- lambda
  I[I!=0] <- 1

  T <- t(I) %*% theta %*% I

  FUN <- if (scale.corrected) sum else \(x) sum(x != 0)

  l <- apply(lambda, MARGIN = 2L, FUN = FUN)
  l.inv <- 1 / l
  l.inv[l <= 0] <- 1L

  if (length(l.inv) > 1) {
    L.inv <- diag(l.inv)
    dimnames(L.inv) <- list(names(l.inv), names(l.inv))

  } else {
    L.inv <- matrix(l.inv, nrow = 1, ncol = 1)
    dimnames(L.inv) <- list(names(l.inv), names(l.inv))
  }

  L.inv %*% T %*% L.inv
}
