From b985160ea5152e4f984045642bf3567153c5f0d9 Mon Sep 17 00:00:00 2001 From: Julius Pfadt Date: Mon, 13 May 2024 16:05:55 +0200 Subject: [PATCH] undo reset --- R/PLSSEMWrapper.R | 7 +- R/plssem.R | 102 ++++++++++++++++----------- inst/qml/PLSSEM.qml | 60 +++++----------- tests/testthat/test-plssem.R | 130 ++++++++++++++++++++++------------- 4 files changed, 164 insertions(+), 135 deletions(-) diff --git a/R/PLSSEMWrapper.R b/R/PLSSEMWrapper.R index a16c654a..23c048b9 100644 --- a/R/PLSSEMWrapper.R +++ b/R/PLSSEMWrapper.R @@ -24,7 +24,7 @@ PLSSEM <- function( benchmark = "none", bootstrapSamples = 200, ciLevel = 0.95, - compositeCorrelationDisattenuated = TRUE, + consistentPartialLeastSquares = TRUE, convergenceCriterion = "absoluteDifference", correctionFactor = "squaredEuclidean", correlationMatrix = "pearson", @@ -50,8 +50,7 @@ PLSSEM <- function( robustMethod = "bootstrap", seed = 1, setSeed = FALSE, - structuralModelIgnored = FALSE, - weightingApproach = "PLS-PM") { + structuralModelIgnored = FALSE) { defaultArgCalls <- formals(jaspSem::PLSSEM) defaultArgs <- lapply(defaultArgCalls, eval) @@ -62,7 +61,7 @@ PLSSEM <- function( options[["data"]] <- NULL options[["version"]] <- NULL - optionsWithFormula <- c("convergenceCriterion", "correctionFactor", "group", "handlingOfFlippedSigns", "innerWeightingScheme", "models", "weightingApproach") + optionsWithFormula <- c("convergenceCriterion", "correctionFactor", "group", "handlingOfFlippedSigns", "innerWeightingScheme", "models") for (name in optionsWithFormula) { if ((name %in% optionsWithFormula) && inherits(options[[name]], "formula")) options[[name]] = jaspBase::jaspFormula(options[[name]], data) } diff --git a/R/plssem.R b/R/plssem.R index f422baf1..0a589d19 100644 --- a/R/plssem.R +++ b/R/plssem.R @@ -41,6 +41,8 @@ PLSSEMInternal <- function(jaspResults, dataset, options, ...) { .semMardiasCoefficient(modelContainer, dataset, options, ready) .plsSemReliabilities(modelContainer, dataset, options, ready) .plsSemCor(modelContainer, options, ready) + + .plsAddConstructScores(jaspResults, modelContainer, options, ready) } .plsSemPrepOpts <- function(options) { @@ -149,14 +151,15 @@ checkCSemModel <- function(model, availableVars) { .plsSemModelContainer <- function(jaspResults) { + if (!is.null(jaspResults[["modelContainer"]])) { modelContainer <- jaspResults[["modelContainer"]] } else { modelContainer <- createJaspContainer() - modelContainer$dependOn(c("weightingApproach", "correlationMatrix", "convergenceCriterion", - "estimateStructural", "group", "correctionFactor", "compositeCorrelationDisattenuated", + modelContainer$dependOn(c("correlationMatrix", "convergenceCriterion", + "estimateStructural", "group", "correctionFactor", "consistentPartialLeastSquares", "structuralModelIgnored", "innerWeightingScheme", "errorCalculationMethod", "robustMethod", "bootstrapSamples", "ciLevel", - "setSeed", "seed", "handlingOfInadmissibles", "Data", "handlingOfFlippedSigns", "endogenousIndicatorPrediction", + "setSeed", "seed", "handlingOfInadmissibles", "endogenousIndicatorPrediction", "kFolds", "repetitions", "benchmark", "predictedScore")) jaspResults[["modelContainer"]] <- modelContainer } @@ -237,11 +240,7 @@ checkCSemModel <- function(model, availableVars) { .user_funs = tickFunction, .resample_method = options[["robustMethod"]], .handle_inadmissibles = options[["handlingOfInadmissibles"]], - .sign_change_option = switch(options[["handlingOfFlippedSigns"]], - "individualReestimation" = "individual_reestimate", - "constructReestimation" = "construct_reestimate", - options[["handlingOfFlippedSigns"]] - ), + .sign_change_option = "none", .seed = if (options[["setSeed"]]) options[["seed"]])) @@ -278,7 +277,7 @@ checkCSemModel <- function(model, availableVars) { cSemOpts <- list() # model features - cSemOpts[[".approach_weights"]] <- options[["weightingApproach"]] + cSemOpts[[".approach_weights"]] <- "PLS-PM" cSemOpts[[".approach_cor_robust"]] <- if (options[["correlationMatrix"]] == "pearson") "none" else options[["correlationMatrix"]] cSemOpts[[".approach_nl"]] <- options[["approachNonLinear"]] cSemOpts[[".conv_criterion"]] <- switch(options[["convergenceCriterion"]], @@ -290,7 +289,7 @@ checkCSemModel <- function(model, availableVars) { cSemOpts[[".PLS_ignore_structural_model"]] <- options[["structuralModelIgnored"]] cSemOpts[[".PLS_weight_scheme_inner"]] <- options[["innerWeightingScheme"]] - if (options[["compositeCorrelationDisattenuated"]]) { + if (options[["consistentPartialLeastSquares"]]) { cSemOpts[".disattenuate"] <- TRUE cSemOpts[".PLS_approach_cf"] <- switch(options[["correctionFactor"]], "squaredEuclidean" = "dist_squared_euclid", @@ -1059,19 +1058,19 @@ checkCSemModel <- function(model, availableVars) { predictcont <- createJaspContainer(name, initCollapsed = TRUE) } - #Error messages + # Error messages if (options[["benchmark"]] != "none" && options[["benchmark"]] != "all") { benchmarks <- options[["benchmark"]] } else if (options[["benchmark"]] == "all") { benchmarks <- c("lm", "PLS-PM", "GSCA", "PCA", "MAXVAR") - benchmarks <- benchmarks[benchmarks != options[["weightingApproach"]]] + benchmarks <- benchmarks[benchmarks != "PLS-PM"] } else { benchmarks <- NULL } - if (options[["benchmark"]] != "none" && options[["benchmark"]] != "all" && benchmarks == options[["weightingApproach"]]) { + if (options[["benchmark"]] != "none" && options[["benchmark"]] != "all" && benchmarks == "PLS-PM") { errormsg <- gettextf("The target model uses the same weighting approach as the benchmark model, please choose another benchmark.") modelContainer$setError(errormsg) modelContainer$dependOn("benchmark") @@ -1961,44 +1960,65 @@ checkCSemModel <- function(model, availableVars) { return() } -.plsSEMVIFhelper <- function(fit){ - # Make VIFs into a matrix - # Restructure the VIFs into a table. - VIFspath <- cSEM::assess(.object = fit,.quality_criterion = 'vif') - - idx <- which(VIFspath$VIF!=0,arr.ind = T) - if(nrow(idx)!=0){ - VIFDf <- data.frame(Relation=paste(rownames(VIFspath$VIF)[idx[,'row']],'~',colnames(VIFspath$VIF)[idx[,'col']]), - vif=VIFspath$VIF[cbind(rownames(VIFspath$VIF)[idx[,'row']],colnames(VIFspath$VIF)[idx[,'col']])]) +.plsAddConstructScores <- function(jaspResults, modelContainer, options, ready) { - VIFvector <-setNames(VIFDf$vif, VIFDf$Relation) - } else{ - VIFvector <- NULL + if (!ready || + !is.null(jaspResults[["addedScoresContainer"]]) || + modelContainer$getError() || + !options[["addConstructScores"]]) + { + return() } - return(VIFvector) -} -.plsSEMVIFBhelper <- function(fit){ - VIFsweights <- cSEM::calculateVIFModeB(fit) + container <- createJaspContainer() + container$dependOn(optionsFromObject = modelContainer) + jaspResults[["addedScoresContainer"]] <- container - # If there is only one weight, cSEM::calculateVIFModeB() returns NA for that VIF - # therefore, replace NAs with 0 - VIFsweights[is.na(VIFsweights)] <- 0 + models <- modelContainer[["models"]][["object"]] + results <- modelContainer[["results"]][["object"]] + modelNames <- sapply(models, function(x) x[["name"]]) + modelNames <- gsub(" ", "_", modelNames) + allNamesR <- c() + # loop over the models + for (i in seq_len(length(results))) { + scores <- cSEM::getConstructScores(results[[i]])$Construct_scores - if(!is.null(VIFsweights)&sum(VIFsweights)!=0){ - idx <- which(VIFsweights!=0,arr.ind = T) + # then loop over the scores + scoreNames <- colnames(scores) + for (ii in seq_len(ncol(scores))) { - VIFBDf <- data.frame(Relation=paste(rownames(VIFsweights)[idx[,'row']],'<~',colnames(VIFsweights)[idx[,'col']]), - vif=VIFsweights[cbind(rownames(VIFsweights)[idx[,'row']],colnames(VIFsweights)[idx[,'col']])]) + colNameR <- paste0(modelNames[i], "_", scoreNames[ii]) - VIFBvector <-setNames(VIFBDf$vif, VIFBDf$Relation) + if (jaspBase:::columnExists(colNameR) && !jaspBase:::columnIsMine(colNameR)) { + .quitAnalysis(gettextf("Column '%s' name already exists in the dataset", colNameR)) + } - } else{ - VIFBvector <- NULL + container[[colNameR]] <- jaspBase::createJaspColumn(colNameR) + container[[colNameR]]$setScale(scores[, ii]) + + # save the names to keep track of all names + allNamesR <- c(allNamesR, colNameR) + } } - return(VIFBvector) -} + # check if there are previous colNames that are not needed anymore and delete the cols + oldNames <- jaspResults[["createdColumnNames"]][["object"]] + newNames <- allNamesR + if (!is.null(oldNames)) { + noMatch <- which(!(oldNames %in% newNames)) + if (length(noMatch) > 0) { + for (iii in 1:length(noMatch)) { + jaspBase:::columnDelete(oldNames[noMatch[iii]]) + } + } + } + + # save the created col names + jaspResults[["createdColumnNames"]] <- createJaspState(allNamesR) + + return() + +} diff --git a/inst/qml/PLSSEM.qml b/inst/qml/PLSSEM.qml index 4f92eda6..37cac873 100644 --- a/inst/qml/PLSSEM.qml +++ b/inst/qml/PLSSEM.qml @@ -45,16 +45,10 @@ Form Group { - CheckBox - { - enabled: approachWeigths.currentValue == "PLS-PM" && approachInner.currentValue != "path" - name: "structuralModelIgnored" - label: qsTr("Ignore structural model") - } CheckBox { - name: "compositeCorrelationDisattenuated"; label: qsTr("Disattenuate composite correlations"); checked: true + name: "consistentPartialLeastSquares"; label: qsTr("Consistent partial least squares"); checked: true DropDown { name: "correctionFactor" @@ -133,30 +127,9 @@ Form Group { + DropDown { - name: "weightingApproach" - label: qsTr("Weighting approach") - id: approachWeigths - values: - [ - { label: qsTr("PLS-PM"), value: "PLS-PM" }, - { label: qsTr("GSCA"), value: "GSCA" }, - { label: qsTr("SUMCORR"), value: "SUMCORR" }, - { label: qsTr("MAXVAR"), value: "MAXVAR" }, - { label: qsTr("SSQCORR"), value: "SSQCORR" }, - { label: qsTr("MINVAR"), value: "MINVAR" }, - { label: qsTr("GENVAR"), value: "GENVAR" }, - { label: qsTr("PCA"), value: "PCA" }, - { label: qsTr("Unit"), value: "unit" }, - { label: qsTr("Bartlett"), value: "bartlett" }, - { label: qsTr("Regression"), value: "regression" } - ] - } - - DropDown - { - enabled: approachWeigths.currentValue == "PLS-PM" name: "innerWeightingScheme" label: qsTr("Inner weighting scheme") id: approachInner @@ -167,6 +140,13 @@ Form ] } + CheckBox + { + enabled: approachInner.currentValue != "path" + name: "structuralModelIgnored" + label: qsTr("Ignore structural model") + } + DropDown { name: "convergenceCriterion" @@ -194,18 +174,6 @@ Form RadioButton { value: "ignore"; label: qsTr("Ignore") } RadioButton { value: "drop"; label: qsTr("Drop") } } - - DropDown - { - name: "handlingOfFlippedSigns" - label: qsTr("Handling of flipped signs") - values: [ - { value: "none", label: qsTr("None") }, - { value: "individual", label: qsTr("Individual") }, - { value: "individualReestimation", label: qsTr("Individual re-estimation") }, - { value: "constructReestimation", label: qsTr("Construct re-estimation") } - ] - } } } @@ -215,7 +183,7 @@ Form Group { - CheckBox { name: "rSquared"; label: qsTr("R-squared") } + CheckBox { name: "rSquared"; label: qsTr("R-squared") } CheckBox { name: "additionalFitMeasures"; label: qsTr("Additional fit measures") } CheckBox { name: "mardiasCoefficient"; label: qsTr("Mardia's coefficient") } CheckBox { name: "reliabilityMeasures"; label: qsTr("Reliability measures") } @@ -223,11 +191,17 @@ Form Group { - CheckBox { name: "observedIndicatorCorrelation"; label: qsTr("Observed indicator correlations") } + CheckBox { name: "observedIndicatorCorrelation"; label: qsTr("Observed indicator correlations") } CheckBox { name: "impliedIndicatorCorrelation"; label: qsTr("Implied indicator correlations") } CheckBox { name: "observedConstructCorrelation"; label: qsTr("Observed construct correlations") } CheckBox { name: "impliedConstructCorrelation"; label: qsTr("Implied construct correlations") } } + + CheckBox + { + name: "addConstructScores" + text: qsTr("Add construct scores to data") + } } Section diff --git a/tests/testthat/test-plssem.R b/tests/testthat/test-plssem.R index ce7df69f..2e49d00b 100644 --- a/tests/testthat/test-plssem.R +++ b/tests/testthat/test-plssem.R @@ -1,20 +1,20 @@ context("Partial Least Squares Structural Equation Modeling") -# basic PLS SEM works -options <- jaspTools::analysisOptions("PLSSEM") -model <- " - ind60 =~ x1 + x2 + x3 - dem60 =~ y1 + y2 + y3 + y4 - dem65 =~ y5 + y6 + y7 + y8 - dem60 ~ ind60 - dem65 ~ ind60 + dem60 -" -options$models <- list(list(name = "Model1", syntax = list(model = model, columns = c("x1", "x2", "x3", "y1", "y2", "y3", "y4", "y5", "y6", "y7", "y8")))) -options$group <- "" -options$innerWeightingScheme <- "path" -options$convergenceCriterion <- "absoluteDifference" -options$correctionFactor <- "squaredEuclidean" -options$handlingOfFlippedSigns <- "none" +test_that("Basic PLSSEM works", { + + options <- jaspTools::analysisOptions("PLSSEM") + model <- " + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + y2 + y3 + y4 + dem65 =~ y5 + y6 + y7 + y8 + dem60 ~ ind60 + dem65 ~ ind60 + dem60 + " + options$models <- list(list(name = "Model1", syntax = list(model = model, columns = c("x1", "x2", "x3", "y1", "y2", "y3", "y4", "y5", "y6", "y7", "y8")))) + options$group <- "" + options$innerWeightingScheme <- "path" + options$convergenceCriterion <- "absoluteDifference" + options$correctionFactor <- "squaredEuclidean" results <- jaspTools::runAnalysis("PLSSEM", "poldem_grouped.csv", options) @@ -40,13 +40,37 @@ test_that("Loadings table results match", { }) -test_that("Regression Coefficients table results match", { - table <- results[["results"]][["modelContainer"]][["collection"]][["modelContainer_params"]][["collection"]][["modelContainer_params_path"]][["data"]] - jaspTools::expect_equal_tables(table, - list(0.438843974833827, 0.238518982057254, "dem60", "ind60", "", 0.158644372913763, - 0.898128069469413, "dem65", "ind60", 1.23851898205725, 0.908670674402449, - 29.4646949739788, "dem65", "dem60", 1.23851898205725)) -}) + options <- jaspTools::analysisOptions("PLSSEM") + model1 = " + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + y2 + y3 + y4 + dem65 =~ y5 + y6 + y7 + y8 + dem60 ~ ind60 + dem65 ~ dem60 + " + model2 = " + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + y2 + y3 + y4 + dem65 =~ y5 + y6 + y7 + y8 + dem60 ~ ind60 + dem65 ~ ind60 + dem60 + " + options$models <- list(list(name = "Model1", syntax = list(model = model1, columns = c("x1", "x2", "x3", "y1", "y2", "y3", "y4", "y5", "y6", "y7", "y8"))), + list(name = "Model2", syntax = list(model = model2, columns = c("x1", "x2", "x3", "y1", "y2", "y3", "y4", "y5", "y6", "y7", "y8")))) + options$group <- "group" + options$innerWeightingScheme <- "path" + options$convergenceCriterion <- "absoluteDifference" + options$correctionFactor <- "squaredEuclidean" + options$additionalFitMeasures <- TRUE + options$rSquared <- TRUE + options$mardiasCoefficient <- TRUE + options$reliabilityMeasures <- TRUE + options$impliedConstructCorrelation <- TRUE + options$impliedIndicatorCorrelation <- TRUE + options$observedConstructCorrelation <- TRUE + options$observedIndicatorCorrelation <- TRUE + options$innerWeightingScheme <- "centroid" + options$structuralModelIgnored <- TRUE test_that("Total effects table results match", { table <- results[["results"]][["modelContainer"]][["collection"]][["modelContainer_params"]][["collection"]][["modelContainer_params_total"]][["data"]] @@ -333,12 +357,25 @@ test_that("1 table results match", { 1, 0.706803134908571, "dem65")) }) -test_that("2 table results match", { - table <- results[["results"]][["modelContainer"]][["collection"]][["modelContainer_cors"]][["collection"]][["modelContainer_cors_Model2"]][["collection"]][["modelContainer_cors_Model2_observedCon"]][["collection"]][["modelContainer_cors_Model2_observedCon_2"]][["data"]] - jaspTools::expect_equal_tables(table, - list("", "", 1, "ind60", 1, "", 0.319599163621636, "dem60", 0.996650485797297, - 1, 0.402495202076674, "dem65")) -}) + options <- jaspTools::analysisOptions("PLSSEM") + model <- " + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + y2 + y3 + y4 + dem65 =~ y5 + y6 + y7 + y8 + dem60 ~ ind60 + dem65 ~ ind60 + dem60 + " + options$models <- list(list(name = "Model1", syntax = list(model = model, columns = c("x1", "x2", "x3", "y1", "y2", "y3", "y4", "y5", "y6", "y7", "y8")))) + options$group <- "" + options$innerWeightingScheme <- "path" + options$convergenceCriterion <- "absoluteDifference" + options$correctionFactor <- "squaredEuclidean" + options$setSeed <- TRUE + options$seed <- 123 + options$errorCalculationMethod <- "robust" + options$robustMethod <- "bootstrap" + options$bootstrapSamples <- 200 + options$handlingOfInadmissibles <- "ignore" test_that("1 table results match", { table <- results[["results"]][["modelContainer"]][["collection"]][["modelContainer_cors"]][["collection"]][["modelContainer_cors_Model2"]][["collection"]][["modelContainer_cors_Model2_observedInd"]][["collection"]][["modelContainer_cors_Model2_observedInd_1"]][["data"]] @@ -686,25 +723,24 @@ model <- " QUAL <~ qual1 + qual2 + qual3 + qual4 + qual5 VAL <~ val1 + val2 + val3 - # Reflective measurement model - SAT =~ sat1 + sat2 + sat3 + sat4 - LOY =~ loy1 + loy2 + loy3 + loy4 - " -options$models <- list(list(name = "Model1", syntax = list(model = model, columns = c("imag1", "imag2", "imag3", - "expe1", "expe2", "expe3", - "qual1", "qual2", "qual3", "qual4", "qual5", - "val1", "val2", "val3", - "sat1", "sat2", "sat3", "sat4", - "loy1", "loy2", "loy3", "loy4")))) -options$group <- "" -options$innerWeightingScheme <- "path" -options$convergenceCriterion <- "absoluteDifference" -options$correctionFactor <- "squaredEuclidean" -options$handlingOfFlippedSigns <- "none" -options$additionalFitMeasures <- TRUE -options$rSquared <- TRUE -options$mardiasCoefficient <- TRUE -options$reliabilityMeasures <- TRUE + # Reflective measurement model + SAT =~ sat1 + sat2 + sat3 + sat4 + LOY =~ loy1 + loy2 + loy3 + loy4 + " + options$models <- list(list(name = "Model1", syntax = list(model = model, columns = c("imag1", "imag2", "imag3", + "expe1", "expe2", "expe3", + "qual1", "qual2", "qual3", "qual4", "qual5", + "val1", "val2", "val3", + "sat1", "sat2", "sat3", "sat4", + "loy1", "loy2", "loy3", "loy4")))) + options$group <- "" + options$innerWeightingScheme <- "path" + options$convergenceCriterion <- "absoluteDifference" + options$correctionFactor <- "squaredEuclidean" + options$additionalFitMeasures <- TRUE + options$rSquared <- TRUE + options$mardiasCoefficient <- TRUE + options$reliabilityMeasures <- TRUE results <- jaspTools::runAnalysis("PLSSEM", cSEM::satisfaction, options)