diff --git a/R/doeAnalysis.R b/R/doeAnalysis.R index 3a6a40ec..cd7b28ca 100644 --- a/R/doeAnalysis.R +++ b/R/doeAnalysis.R @@ -17,269 +17,411 @@ #' @export doeAnalysis <- function(jaspResults, dataset, options, ...) { - dataset <- .doeAnalysisReadData(dataset, options) if (options[["designType"]] == "factorialDesign") { - ready <- sum(length(options[["fixedFactors"]]), length(options[["continuousFactors"]])) >= 2 && options[["dependent"]] != "" && !is.null(unlist(options[["modelTerms"]])) + ready <- sum(length(options[["fixedFactorsFactorial"]]), length(options[["continuousFactorsFactorial"]])) >= 1 && + options[["dependentFactorial"]] != "" && + !is.null(unlist(options[["modelTerms"]])) + discretePredictors <- options[["fixedFactorsFactorial"]] + continuousPredictors <- options[["continuousFactorsFactorial"]] + covariates <- options[["covariates"]] + blocks <- options[["blocksFactorial"]] + dependent <- options[["dependentFactorial"]] } else if (options[["designType"]] == "responseSurfaceDesign") { - ready <- length(options[["continuousFactors"]]) >= 1 && options[["dependent"]] != "" + ready <- length(options[["continuousFactorsResponseSurface"]]) >= 1 && options[["dependentResponseSurface"]] != "" + discretePredictors <- options[["fixedFactorsResponseSurface"]] + continuousPredictors <- options[["continuousFactorsResponseSurface"]] + covariates <- NULL + blocks <- options[["blocksResponseSurface"]] + dependent <- options[["dependentResponseSurface"]] } - .doeAnalysisCheckErrors(dataset, options, ready) - p <- try({ - .doeAnalysisMakeState(jaspResults, dataset, options, ready) - }) + dataset <- .doeAnalysisReadData(dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent) + + if (length(blocks) > 0 && !identical(blocks, "")) # data reading function renames the block variable to "block" + blocks <- "Block" + + .doeAnalysisCheckErrors(dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent, ready) + + p <- try(.doeAnalysisMakeState(jaspResults, dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent, ready)) if (isTryError(p)) { - jaspResults$setError(gettextf("The analysis crashed with the following error message: %1$s", .extractErrorMessage(p))) + jaspResults[["errorPlot"]] <- createJaspPlot(title = gettext("Error")) + jaspResults[["errorPlot"]]$setError(p[1]) + jaspResults[["errorPlot"]]$dependOn(.doeAnalysisBaseDependencies()) + return() } - .doeAnalysisSummaryTable(jaspResults, options, ready) - .doeAnalysisAnovaTable(jaspResults, options, ready) - .doeAnalysisCoefficientsTable(jaspResults, options, ready) - .doeAnalysisEquationTable(jaspResults, options, ready) - .doeAnalysisPlotPareto(jaspResults, options, ready) + coded <- options[["codeFactors"]] + + .doeAnalysisSummaryTable(jaspResults, options, ready, coded) + .doeAnalysisAnovaTable(jaspResults, options, ready, coded) + .doeAnalysisCoefficientsTable(jaspResults, options, ready, coded) + .doeAnalysisEquationTable(jaspResults, options, ready, coded) + .doeAnalysisPlotPareto(jaspResults, options, blocks, covariates, ready) .doeAnalysisPlotQQResiduals(jaspResults, options, ready) .doeAnalysisPlotHistResiduals(jaspResults, options, ready) .doeAnalysisPlotFittedVsResiduals(jaspResults, options, ready) .doeAnalysisPlotResidualsVsOrder(jaspResults, dataset, options, ready) .doeAnalysisPlotMatrixResidualPlot(jaspResults, dataset, options, ready) - .doeAnalysisPlotContourSurface(jaspResults, dataset, options, ready) + .doeAnalysisPlotContourSurface(jaspResults, dataset, options, dependent, ready) } -.doeAnalysisReadData <- function(dataset, options) { +.doeAnalysisReadData <- function(dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent) { if (!is.null(dataset)) { return(dataset) } factorVars <- NULL numericVars <- NULL - if (!identical(options[["dependent"]], "")) { - numericVars <- c(numericVars, options[["dependent"]]) + if (!identical(dependent, "")) { + numericVars <- c(numericVars, dependent) } - if (length(options[["continuousFactors"]]) > 0 && !identical(options[["continuousFactors"]], "")) { - numericVars <- c(numericVars, unlist(options[["continuousFactors"]])) + if (length(continuousPredictors) > 0 && !identical(continuousPredictors, "")) { + numericVars <- c(numericVars, unlist(continuousPredictors)) } - if (length(options[["fixedFactors"]]) > 0 && !identical(options[["fixedFactors"]], "")) { - factorVars <- c(factorVars, unlist(options[["fixedFactors"]])) + if (length(continuousPredictors) > 0 && !identical(continuousPredictors, "")) { + numericVars <- c(numericVars, unlist(continuousPredictors)) } - if (length(options[["blocks"]]) > 0 && !identical(options[["blocks"]], "")) { - factorVars <- c(factorVars, options[["blocks"]]) + if (length(covariates) > 0 && !identical(covariates, "")) { + numericVars <- c(numericVars, unlist(covariates)) } - if (length(options[["covariates"]]) > 0 && !identical(options[["covariates"]], "")) { - numericVars <- c(numericVars, unlist(options[["covariates"]])) + if (length(discretePredictors) > 0 && !identical(discretePredictors, "")) { + factorVars <- c(factorVars, unlist(discretePredictors)) + } + if (length(blocks) > 0 && !identical(blocks, "")) { + factorVars <- c(factorVars, blocks) } dataset <- .readDataSetToEnd(columns.as.numeric = numericVars, columns.as.factor = factorVars) dataset <- na.omit(dataset) - return(dataset) -} -.doeAnalysisCheckErrors <- function(dataset, options) { - if (is.null(dataset)) { - return() - } - .hasErrors(dataset, - type = c("infinity", "missingValues", "factorLevels"), - all.target = c(options[["dependent"]], options[["fixedFactors"]], options[["blocks"]], options[["continuousFactors"]]), - factorLevels.amount = "< 2", - exitAnalysisIfErrors = TRUE - ) + if (length(blocks) > 0 && !identical(blocks, "")) # name of variable should always be "Block" + names(dataset)[names(dataset) == blocks] <- "Block" + return(dataset) } - - .doeAnalysisBaseDependencies <- function() { deps <- c( - "dependent", "fixedFactors", "blocks", "runOrder", - "highestOrder", "order", "covariates", "modelTerms", - "designType", "continuousFactors", "codeFactors", "rsmPredefinedModel", - "rsmPredefinedTerms" - ) + "dependentResponseSurface", "fixedFactorsResponseSurface", "blocksResponseSurface", "runOrder", + "highestOrder", "order", "continuousFactorsFactorial", "modelTerms", "blocksFactorial", + "designType", "continuousFactorsResponseSurface", "codeFactors", "rsmPredefinedModel", "fixedFactorsFactorial", + "rsmPredefinedTerms", "dependentFactorial") return(deps) } -.doeAnalysisMakeState <- function(jaspResults, dataset, options, ready) { +.scaleDOEvariable <- function(x){2*(x-min(x))/(max(x)-min(x))-1} + +.doeAnalysisMakeState <- function(jaspResults, dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent, ready) { if (!ready || jaspResults$getError()) { return() } + result <- list() + result[["regression"]] <- list() + result[["anova"]] <- list() + resultCoded <- list() + resultCoded[["regression"]] <- list() + resultCoded[["anova"]] <- list() # set the contrasts for all categorical variables, add option to choose later - for (fac in unlist(options[["fixedFactors"]])) { + for (fac in unlist(discretePredictors)) { contrasts(dataset[[fac]]) <- "contr.sum" } # Transform to coded, -1 to 1 coding. - if (options[["codeFactors"]]) { - allVars <- c(unlist(options[["continuousFactors"]]), unlist(options[["fixedFactors"]]), options[["blocks"]]) - allVars <- allVars[allVars != ""] - for (i in seq_along(allVars)) { - var <- allVars[i] - varData <- dataset[[var]] - levels <- sort(unique(varData)) # get levels before transforming to char to preserve possible order - varData <- as.character(varData) # transform to char, otherwise you cannot add coded values to this variable as "factor level does not exist" - nLevels <- length(unique(varData)) - steps <- 2/(nLevels - 1) # divide space between -1 and 1 into equal spaces, always including 0 + allVars <- c(unlist(continuousPredictors), unlist(discretePredictors), blocks) + allVars <- allVars[allVars != ""] + datasetCoded <- dataset + if (options[["codeFactorsMethod"]] == "manual") + manualCodingTable <- do.call(rbind.data.frame, options[["codeFactorsManualTable"]]) + for (i in seq_along(allVars)) { + var <- allVars[i] + varData <- datasetCoded[[var]] + levels <- sort(unique(varData)) # get levels before transforming to char to preserve possible order + varData <- as.character(varData) # transform to char, otherwise you cannot add coded values to this variable as "factor level does not exist" + if (options[["codeFactorsMethod"]] == "automatic") { + if (var %in% unlist(discretePredictors)) { + nLevels <- length(levels) + steps <- 2/(nLevels - 1) # divide space between -1 and 1 into equal spaces codes <- seq(-1, 1, steps) - for (j in seq_along(varData)) { - codeIndex <- which(varData[j] == levels) - varData[j] <- codes[codeIndex] - } - dataset[[var]] <- as.numeric(varData) + } else if (var %in% unlist(continuousPredictors)) { + codes <- .scaleDOEvariable(levels) + } + } else if (options[["codeFactorsMethod"]] == "manual") { + indexCurrentVar <- which(manualCodingTable[["predictors"]] == var) + lowLevel <- manualCodingTable[indexCurrentVar,][["lowValue"]] + highLevel <- manualCodingTable[indexCurrentVar,][["highValue"]] + if (lowLevel == highLevel) { + stop(gettextf("The specified low/high levels for %1$s are not distinct.", var), call. = FALSE) + } + if (!lowLevel %in% levels || !highLevel %in% levels) { + invalidLevels <- c(lowLevel, highLevel)[!c(lowLevel, highLevel) %in% levels] + stop(gettextf("The specified low/high level(s) %1$s for %2$s do not match the levels in the dataset.", + paste(invalidLevels, collapse = ", "), var), call. = FALSE) + } + lowPos <- which(levels == lowLevel) + highPos <- which(levels == highLevel) + if (var %in% unlist(discretePredictors)) { + levels <- c(lowLevel, levels[-c(lowPos, highPos)], highLevel) + nLevels <- length(levels) + steps <- 2/(nLevels - 1) # divide space between -1 and 1 into equal spaces + codes <- seq(-1, 1, steps) + } else if (var %in% unlist(continuousPredictors)) { + codes <- .scaleDOEvariable(levels[lowPos:highPos]) + lowLevel <- as.numeric(lowLevel) + highLevel <- as.numeric(highLevel) + outerCodes <- 2*(levels[-c(lowPos:highPos)]-lowLevel)/(highLevel-lowLevel)-1 # if any values are above the specified high value or below the specified low value + codes <- sort(c(codes, outerCodes)) } } + for (j in seq_along(varData)) { + codeIndex <- which(varData[j] == levels) + varData[j] <- codes[codeIndex] + } + datasetCoded[[var]] <- as.numeric(varData) + } - result <- list() - result[["regression"]] <- list() - result[["anova"]] <- list() - - - if ((!options[["highestOrder"]] && !options[["rsmPredefinedModel"]]) || - (options[["highestOrder"]] && options[["order"]] == 1 && options[["designType"]] == "factorialDesign")) { + if ((options[["designType"]] == "factorialDesign" && !options[["highestOrder"]]) || + (options[["designType"]] == "factorialDesign" && options[["highestOrder"]] && options[["order"]] == 1) || + (options[["designType"]] == "responseSurfaceDesign" && !options[["rsmPredefinedModel"]])) { reorderModelTerms <- .reorderModelTerms(options) modelTerms <- reorderModelTerms$modelTerms - modelDef <- .modelFormula(modelTerms, options) + modelDef <- .modelFormula(modelTerms, options, dependent) formulaString <- modelDef$model.def + if (options[["designType"]] == "responseSurfaceDesign" && length(unlist(options[["squaredTerms"]])) > 0) { + squaredTerms <- options[["squaredTerms"]] + squaredTermsString <- paste0(" + I(", squaredTerms, "^2)", collapse = "") + formulaString <- paste0(formulaString, squaredTermsString) + } } else if (options[["highestOrder"]] && options[["designType"]] == "factorialDesign") { - formulaString <- paste0(options[["dependent"]], " ~ (.)^", options[["order"]]) + independentVariables <- c(unlist(continuousPredictors), unlist(discretePredictors)) + independentVariables <- independentVariables[independentVariables != ""] + formulaString <- .createHighestOrderInteractionFormula(dependent, independentVariables, interactionOrder = options[["order"]]) } else if (options[["rsmPredefinedModel"]] && options[["designType"]] == "responseSurfaceDesign") { modelTerms <- options[["rsmPredefinedTerms"]] - if (length(options[["continuousFactors"]]) == 1 && modelTerms == "linearAndInteractions") { + if (length(continuousPredictors) == 1 && modelTerms == "linearAndInteractions") { modelTerms <- "linear" - } else if (length(options[["continuousFactors"]]) == 1 && modelTerms == "fullQuadratic") { + } else if (length(continuousPredictors) == 1 && modelTerms == "fullQuadratic") { modelTerms <- "linearAndSquared" } - numPred <- unlist(options[["continuousFactors"]]) - catPred <- unlist(options[["fixedFactors"]]) + numPred <- unlist(continuousPredictors) + numPredStringMainEffects <- paste0(numPred, collapse = " + ") + numPredStringSecondOrderInteractionEffects <- paste0("(", numPredStringMainEffects, ")^2") + numPredStringSquaredEffects <- paste0(" + I(", numPred, "^2)", collapse = "") + catPred <- unlist(discretePredictors) catPred <- catPred[catPred != ""] - numPredString <- paste0(numPred, collapse = ", ") - if (!is.null(catPred) && length(catPred) > 0){ + if (!is.null(catPred) && length(catPred) > 0) { catPredString <- paste0(" + ", catPred, collapse = "") } else { catPredString <- "" } formulaString <- switch(modelTerms, - "linear" = paste0(options[["dependent"]], " ~ rsm::FO(", numPredString, ")", catPredString), - "linearAndInteractions" = paste0(options[["dependent"]], " ~ rsm::FO(", numPredString, ")", catPredString, " + rsm::TWI(", numPredString, ")"), - "linearAndSquared" = paste0(options[["dependent"]], " ~ rsm::FO(", numPredString, ") ", catPredString, " + rsm::PQ(", numPredString, ")"), - "fullQuadratic" = paste0(options[["dependent"]], " ~ rsm::FO(", numPredString, ")", catPredString, " + rsm::TWI(", numPredString, ") + rsm::PQ(", numPredString, ")") + "linear" = paste0(dependent, " ~ ", numPredStringMainEffects, catPredString), + "linearAndInteractions" = paste0(dependent, " ~ ", numPredStringSecondOrderInteractionEffects, catPredString), + "linearAndSquared" = paste0(dependent, " ~ ", numPredStringMainEffects, numPredStringSquaredEffects, catPredString), + "fullQuadratic" = paste0(dependent, " ~ ", numPredStringSecondOrderInteractionEffects, numPredStringSquaredEffects, catPredString) ) } - if (length(options[["blocks"]]) > 0 && !identical(options[["blocks"]], "")) { - formulaString <- paste0(formulaString, " + ", options[["blocks"]]) + if (length(blocks) > 0 && !identical(blocks, "")) + formulaString <- paste0(formulaString, " + ", blocks) + if (length(covariates) > 0 && !identical(covariates, "")) { + covariateString <- paste0(" + ", unlist(covariates), collapse = "") + formulaString <- paste0(formulaString, covariateString) } formula <- as.formula(formulaString) - if (options[["designType"]] == "factorialDesign") { + regressionFit <- lm(formula, data = dataset) + regressionFitCoded <- lm(formula, data = datasetCoded) + regressionSummary <- summary(regressionFit) + regressionSummaryCoded <- summary(regressionFitCoded) + + aliasedTerms <- attributes(alias(regressionFit)$Complete)$dimnames[[1]] + + if (!is.null(aliasedTerms)) { + allPredictors <- unlist(c(continuousPredictors, discretePredictors, blocks, covariates)) + allPredictors <- allPredictors[allPredictors != ""] + aliasedTerms <- .removeAppendedFactorLevels(predictorNames = allPredictors, terms = aliasedTerms, interactionSymbol = ":") + result[["regression"]][["aliasedTerms"]] <- gsubInteractionSymbol(aliasedTerms) # store for footnote + resultCoded[["regression"]][["aliasedTerms"]] <- gsubInteractionSymbol(aliasedTerms) # store for footnote + formula <- as.formula(paste(paste(deparse(formula), collapse=""), paste(aliasedTerms, collapse="-"), sep="-")) # remove the aliased term(s) from the model + # fit the model again regressionFit <- lm(formula, data = dataset) + regressionFitCoded <- lm(formula, data = datasetCoded) regressionSummary <- summary(regressionFit) - } else if (options[["designType"]] == "responseSurfaceDesign") { - regressionFit <- rsm::rsm(formula, data = dataset, threshold = 0) - regressionSummary <- summary(regressionFit, threshold = 0) # threshold to 0 so the canonical does not throw an error + regressionSummaryCoded <- summary(regressionFitCoded) } + names(regressionFit$coefficients) <- unname(sapply(c(names(regressionFit$coefficients)), .gsubIdentityFunction)) # remove potential identity function around squared terms + rownames(regressionSummary$coefficients) <- unname(sapply(c(rownames(regressionSummary$coefficients)), .gsubIdentityFunction)) + names(regressionFitCoded$coefficients) <- unname(sapply(c(names(regressionFitCoded$coefficients)), .gsubIdentityFunction)) + rownames(regressionSummaryCoded$coefficients) <- unname(sapply(c(rownames(regressionSummaryCoded$coefficients)), .gsubIdentityFunction)) + result[["regression"]][["formula"]] <- formula result[["regression"]][["object"]] <- regressionFit result[["regression"]][["objectSummary"]] <- regressionSummary result[["regression"]][["saturated"]] <- regressionSummary$df[2] == 0 + resultCoded[["regression"]][["formula"]] <- formula + resultCoded[["regression"]][["object"]] <- regressionFitCoded + resultCoded[["regression"]][["objectSummary"]] <- regressionSummaryCoded + resultCoded[["regression"]][["saturated"]] <- regressionSummaryCoded$df[2] == 0 + if (!result[["regression"]][["saturated"]]) { result[["regression"]][["s"]] <- regressionSummary[["sigma"]] result[["regression"]][["rsq"]] <- regressionSummary[["r.squared"]] - result[["regression"]][["adjrsq"]] <- regressionSummary[["adj.r.squared"]] + result[["regression"]][["adjrsq"]] <- max(0, regressionSummary[["adj.r.squared"]]) # Sometimes returns a negative value, so need this result[["regression"]][["predrsq"]] <- .pred_r_squared(regressionFit) - if (options[["designType"]] == "factorialDesign") { - anovaFit <- car::Anova(regressionFit) - } else if (options[["designType"]] == "responseSurfaceDesign") { - anovaFit <- regressionSummary$lof - # store lof and pure error, remove them for now and add back in later to not interfere with other calculations - pureError <- anovaFit["Pure error", ] - lackOfFit <- anovaFit["Lack of fit", ] - rowsToRemove <- c("Pure error", "Lack of fit") - anovaFit <- anovaFit[!row.names(anovaFit) %in% rowsToRemove,] - } - anovaFit[["Mean Sq"]] <- anovaFit[["Sum Sq"]] / anovaFit[["Df"]] - null.names <- names(regressionFit[["coefficients"]])[is.na(regressionFit[["coefficients"]])] - names <- c("Model", gsub(" ", "", row.names(anovaFit)[-length(row.names(anovaFit))], fixed = TRUE), null.names, "Error", "Total") - anovaNames <- gsub(" ", "", row.names(anovaFit)) - errorIndex <- which(anovaNames == "Residuals") - ssm <- sum(anovaFit$`Sum Sq`[-errorIndex]) - msm <- sum(anovaFit$`Sum Sq`[-errorIndex]) / sum(anovaFit$Df[-errorIndex]) - fval <- msm / anovaFit$`Mean Sq`[errorIndex] - pval <- pf(fval, sum(anovaFit$Df[-errorIndex]), anovaFit$Df[errorIndex], lower.tail = FALSE) - df <- c(sum(anovaFit[["Df"]][-errorIndex]), anovaFit[["Df"]][-errorIndex], rep(NA, length(null.names)), anovaFit[["Df"]][errorIndex], sum(anovaFit[["Df"]])) - adjss <- c(ssm, anovaFit[["Sum Sq"]][-errorIndex], rep(NA, length(null.names)), anovaFit[["Sum Sq"]][errorIndex], sum(anovaFit[["Sum Sq"]])) - adjms <- c(msm, anovaFit[["Mean Sq"]][-errorIndex], rep(NA, length(null.names)), anovaFit[["Mean Sq"]][errorIndex], NA) - fval <- c(fval, anovaFit[["F value"]], rep(NA, length(null.names)), NA) - pval <- c(pval, anovaFit[["Pr(>F)"]], rep(NA, length(null.names)), NA) - - #add the lof and pure error rows back in - if (options[["designType"]] == "responseSurfaceDesign") { - #imputate it in all ANOVA table vectors before the total row - df <- c(df[1:length(df)-1], lackOfFit$Df, pureError$Df, df[length(df)]) - names <- c(names[1:length(names)-1], "Lack of fit", "Pure error", names[length(names)]) - names <- gsub("rsm::FO\\(", "Linear terms\\(", names) - names <- gsub("rsm::TWI\\(", "Two-way interaction terms\\(", names) - names <- gsub("rsm::PQ\\(", "Squared terms\\(", names) - adjss <- c(adjss[1:length(adjss)-1], lackOfFit$`Sum Sq`, pureError$`Sum Sq`, adjss[length(adjss)]) - adjms <- c(adjms[1:length(adjms)-1], lackOfFit$`Mean Sq`, pureError$`Mean Sq`, adjms[length(adjms)]) - fval <- c(fval[1:length(fval)-1], lackOfFit$`F value`, NA, fval[length(fval)]) - pval <- c(pval[1:length(pval)-1], lackOfFit$`F value`, NA, pval[length(pval)]) + resultCoded[["regression"]][["s"]] <- regressionSummaryCoded[["sigma"]] + resultCoded[["regression"]][["rsq"]] <- regressionSummaryCoded[["r.squared"]] + resultCoded[["regression"]][["adjrsq"]] <- max(0, regressionSummaryCoded[["adj.r.squared"]]) # Sometimes returns a negative value, so need this + resultCoded[["regression"]][["predrsq"]] <- .pred_r_squared(regressionFitCoded) + + ssType <- options[["sumOfSquaresType"]] + anovaFitData <- if (options[["squaredTermsCoded"]]) regressionFitCoded else regressionFit + if (ssType == "type1") { + anovaFit <- anova(anovaFitData) + } else if (ssType == "type2") { + anovaFit <- car::Anova(anovaFitData, type = 2) + } else if (ssType == "type3") { + anovaFit <- car::Anova(anovaFitData, type = 3) + anovaFit <- anovaFit[-1,] # remove the intercept that is added when using type 3 SS } + anovaFit[["Mean Sq"]] <- anovaFit[["Sum Sq"]] / anovaFit[["Df"]] + anovaFit <- anovaFit[c("Df", "Sum Sq", "Mean Sq", "F value", "Pr(>F)")] # rearrange, so it has the same order as the aov function + anovaFit <- .addModelHeaderTerms(anovaFit, unlist(covariates)) } else { result[["regression"]][["s"]] <- NA result[["regression"]][["rsq"]] <- 1 result[["regression"]][["adjrsq"]] <- NA result[["regression"]][["predrsq"]] <- NA - anovaFit <- summary(aov(regressionFit))[[1]] - ssm <- sum(anovaFit[["Sum Sq"]]) - msm <- ssm / nrow(anovaFit) - names <- c("Model", names(coef(regressionFit))[!is.na(coef(regressionFit))][-1], "Error", "Total") - df <- c(sum(anovaFit[["Df"]][seq_along(options[["fixedFactors"]])]), anovaFit[["Df"]], 0, sum(anovaFit[["Df"]])) - adjss <- c(sum(anovaFit[["Sum Sq"]]), anovaFit[["Sum Sq"]], NA, sum(anovaFit[["Sum Sq"]])) - adjms <- c(sum(anovaFit[["Sum Sq"]]) / nrow(anovaFit), anovaFit[["Mean Sq"]], NA, NA) - fval <- rep(NA, length(names)) - pval <- rep(NA, length(names)) - } + resultCoded[["regression"]][["s"]] <- NA + resultCoded[["regression"]][["rsq"]] <- 1 + resultCoded[["regression"]][["adjrsq"]] <- NA + resultCoded[["regression"]][["predrsq"]] <- NA + + anovaFitData <- if (options[["squaredTermsCoded"]]) regressionFitCoded else regressionFit + anovaFit <- summary(aov(anovaFitData))[[1]] + errorRow <- data.frame(Df = 0, SS = 0, MS = 0) # add an error row to keep the format consistent + colnames(errorRow) <- colnames(anovaFit) + rownames(errorRow) <- "Error" + anovaFit <- rbind(anovaFit, errorRow) + anovaFit$`F value` <- NA # add these empty columns to the saturated design so the anova fit object always has the same format + anovaFit$`Pr(>F)` <- NA + anovaFit <- .addModelHeaderTerms(anovaFit, unlist(covariates)) + + } result[["anova"]][["object"]] <- anovaFit - result[["anova"]][["terms"]] <- jaspBase::gsubInteractionSymbol(names) - result[["anova"]][["df"]] <- df - result[["anova"]][["adjss"]] <- adjss - result[["anova"]][["adjms"]] <- adjms - result[["anova"]][["F"]] <- fval - result[["anova"]][["p"]] <- pval - - # Regression coefficients + result[["anova"]][["terms"]] <- gsubInteractionSymbol(rownames(anovaFit)) + result[["anova"]][["df"]] <- anovaFit$Df + result[["anova"]][["adjss"]] <- anovaFit$`Sum Sq` + result[["anova"]][["adjms"]] <- anovaFit$`Mean Sq` + result[["anova"]][["F"]] <- anovaFit$`F value` + result[["anova"]][["p"]] <- anovaFit$`Pr(>F)` + + resultCoded[["anova"]][["object"]] <- anovaFit + resultCoded[["anova"]][["terms"]] <- gsubInteractionSymbol(rownames(anovaFit)) + resultCoded[["anova"]][["df"]] <- anovaFit$Df + resultCoded[["anova"]][["adjss"]] <- anovaFit$`Sum Sq` + resultCoded[["anova"]][["adjms"]] <- anovaFit$`Mean Sq` + resultCoded[["anova"]][["F"]] <- anovaFit$`F value` + resultCoded[["anova"]][["p"]] <- anovaFit$`Pr(>F)` + + ############################### + ### Regression coefficients ### + ############################### + result[["regression"]][["coefficients"]] <- list() + resultCoded[["regression"]][["coefficients"]] <- list() coefs <- as.data.frame(regressionSummary[["coefficients"]]) + coefsCoded <- as.data.frame(regressionSummaryCoded[["coefficients"]]) valid_coefs <- which(!is.na(coefs[["Estimate"]])) - termNames <- jaspBase::gsubInteractionSymbol(rownames(coefs)[valid_coefs]) - result[["regression"]][["coefficients"]][["terms"]] <- termNames - result[["regression"]][["coefficients"]][["effects"]] <- effects(regressionFit, set.sign = TRUE)[valid_coefs] - result[["regression"]][["coefficients"]][["est"]] <- coef(regressionFit)[!is.na(coef(regressionFit))] - result[["regression"]][["coefficients"]][["effects"]][1] <- NA + valid_coefsCoded <- which(!is.na(coefsCoded[["Estimate"]])) + termNames <- gsubInteractionSymbol(rownames(coefs)[valid_coefs]) + termNamesCoded <- gsubInteractionSymbol(rownames(coefsCoded)[valid_coefsCoded]) - # Aliasing + #remove possible appended factor levels if ((options[["rsmPredefinedModel"]] && options[["designType"]] == "responseSurfaceDesign") || (options[["highestOrder"]] && options[["designType"]] == "factorialDesign")) { - allPredictors <- c(unlist(options[["continuousFactors"]]), unlist(options[["fixedFactors"]])) + allPredictors <- c(unlist(continuousPredictors), unlist(discretePredictors)) } else { allPredictors <- unique(unlist(options[["modelTerms"]])) } - termNamesAliased <- termNames - # remove possible appended factor levels - regexExpression <- paste0("(", paste(allPredictors, collapse = "|"), ")((\\^2)?)([^^✻]+)(✻?)") - for (term_i in seq_along(termNamesAliased)) { - termNamesAliased[term_i] <- gsub(regexExpression, "\\1\\2", termNamesAliased[term_i], perl=TRUE) - termNamesAliased[term_i] <- gsub("\\s", "", termNamesAliased[term_i]) + predictorsForLevelRemoval <- allPredictors + if (length(blocks) > 0 && !identical(blocks, "")) + predictorsForLevelRemoval <- c(predictorsForLevelRemoval, blocks) + + termNamesRemoved <- termNames + # this regex removes the appended factor levels + regexExpression <- paste0("(", paste(predictorsForLevelRemoval, collapse = "|"), ")((\\^2)?)([^✻]+)(✻?)") + for (term_i in seq_along(termNamesRemoved)) { + replacements <- if (grepl("^2", termNamesRemoved[term_i], fixed = TRUE)) "\\1\\4" else "\\1\\5" + termNamesRemoved[term_i] <- gsub(regexExpression, replacements, termNamesRemoved[term_i], perl=TRUE) + termNamesRemoved[term_i] <- gsub("\\s", "", termNamesRemoved[term_i]) } + + discretePredictorsIndices <- which(termNamesRemoved %in% discretePredictors) + nDiscretePredictorLevels <- sapply(discretePredictors, function(x) sum(termNamesRemoved == x)) + + # # append number if duplicated + # for(term_k in seq_along(termNames)) { + # n_occurences <- sum(termNames == termNames[term_k]) + # if (n_occurences > 1) { + # term_indices <- which(termNames == termNames[term_k]) + # termNames[term_indices] <- paste0(termNames[term_k], seq_len(n_occurences)) + # } + # } + + + # Coded terms never have appended factor levels, so just remove whitespace + termNames <- gsub("\\s", "", termNames) + termNamesCoded <- gsub("\\s", "", termNamesCoded) + + result[["regression"]][["coefficients"]][["terms"]] <- termNames + resultCoded[["regression"]][["coefficients"]][["terms"]] <- termNamesCoded + + # calculate effects, but not for blocks, covariates or intercept + coefEffects <- .doeCoefficientEffects(regressionFit) + coefEffectsCoded <- .doeCoefficientEffects(regressionFitCoded) + if (length(blocks) > 0 && !identical(blocks, "")) { + coefEffects[names(coefEffects) == blocks] <- NA + coefEffectsCoded[names(coefEffectsCoded) == blocks] <- NA + } + if (length(covariates) > 0 && !identical(covariates, "")) { + coefEffects[names(coefEffects) %in% unlist(covariates)] <- NA + coefEffectsCoded[names(coefEffectsCoded) %in% unlist(covariates)] <- NA + } + + result[["regression"]][["coefficients"]][["effects"]] <- coefEffects + result[["regression"]][["coefficients"]][["est"]] <- coef(regressionFit)[!is.na(coef(regressionFit))] + result[["regression"]][["coefficients"]][["effects"]][1] <- NA + result[["regression"]][["coefficients"]][["vif"]] <- .getVIF(regressionFit, predictorsForLevelRemoval) + + resultCoded[["regression"]][["coefficients"]][["effects"]] <- coefEffectsCoded + resultCoded[["regression"]][["coefficients"]][["est"]] <- coef(regressionFitCoded)[!is.na(coef(regressionFitCoded))] + resultCoded[["regression"]][["coefficients"]][["effects"]][1] <- NA + resultCoded[["regression"]][["coefficients"]][["vif"]] <- .getVIF(regressionFitCoded, predictorsForLevelRemoval) + + termNamesAliased <- termNames + termNamesAliasedCoded <- termNamesCoded allPredictorsAliases <- LETTERS[seq_along(allPredictors)] for (pred_i in seq_along(allPredictors)) { termNamesAliased <- gsub(allPredictors[pred_i], allPredictorsAliases[pred_i], termNamesAliased) + termNamesAliasedCoded <- gsub(allPredictors[pred_i], allPredictorsAliases[pred_i], termNamesAliasedCoded) + } + termNamesAliased <- gsub("✻", "", termNamesAliased) + termNamesAliasedCoded <- gsub("✻", "", termNamesAliasedCoded) + + # covariates and blocks should not get an alias in the table (but keep their default names in the equation, so specifying it here) + if (length(blocks) > 0 && !identical(blocks, "")) + termNamesAliased[termNamesAliased == blocks] <- "BLK" + if (length(covariates) > 0 && !identical(covariates, "")) { + covariateAliases <- paste0("COV", seq(1, length(covariates))) + termNamesAliased[termNamesAliased %in% unlist(covariates)] <- covariateAliases } + # append number if duplicated for(term_j in seq_along(termNamesAliased)){ n_occurences <- sum(termNamesAliased == termNamesAliased[term_j]) @@ -290,34 +432,234 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { } termNamesAliased[1] <- "" # no alias for intercept result[["regression"]][["coefficients"]][["termsAliased"]] <- termNamesAliased + resultCoded[["regression"]][["coefficients"]][["termsAliased"]] <- termNamesAliasedCoded + + + result[["regression"]][["factorLevels"]] <- list() + result[["regression"]][["factorLevels"]][["factorNamesAliased"]] <- termNamesAliased[discretePredictorsIndices] + result[["regression"]][["factorLevels"]][["factorNames"]] <- termNames[discretePredictorsIndices] + discretePredictorLevels <- unlist(lapply(names(nDiscretePredictorLevels), function(x) get_levels(x, nDiscretePredictorLevels[x], dataset))) + result[["regression"]][["factorLevels"]][["levels"]] <- discretePredictorLevels + if (!result[["regression"]][["saturated"]]) { result[["regression"]][["coefficients"]][["se"]] <- coefs[["Std. Error"]][valid_coefs] result[["regression"]][["coefficients"]][["t"]] <- coefs[["t value"]][valid_coefs] result[["regression"]][["coefficients"]][["p"]] <- coefs[["Pr(>|t|)"]][valid_coefs] + resultCoded[["regression"]][["coefficients"]][["se"]] <- coefsCoded[["Std. Error"]][valid_coefsCoded] + resultCoded[["regression"]][["coefficients"]][["t"]] <- coefsCoded[["t value"]][valid_coefsCoded] + resultCoded[["regression"]][["coefficients"]][["p"]] <- coefsCoded[["Pr(>|t|)"]][valid_coefsCoded] } else { result[["regression"]][["coefficients"]][["se"]] <- rep(NA, length(valid_coefs)) result[["regression"]][["coefficients"]][["t"]] <- rep(NA, length(valid_coefs)) result[["regression"]][["coefficients"]][["p"]] <- rep(NA, length(valid_coefs)) + resultCoded[["regression"]][["coefficients"]][["se"]] <- rep(NA, length(valid_coefsCoded)) + resultCoded[["regression"]][["coefficients"]][["t"]] <- rep(NA, length(valid_coefsCoded)) + resultCoded[["regression"]][["coefficients"]][["p"]] <- rep(NA, length(valid_coefsCoded)) } ## Model formula + ## uncoded coefs <- coef(regressionFit)[!is.na(coef(regressionFit))] + coefs <- round(coefs, .numDecimals) coefNames <- if (options[["tableAlias"]]) termNamesAliased else termNames plusOrMin <- sapply(seq_len(length(coefs)), function(x) { if (coefs[x] > 0) "+" else "-" }) - filledFormula <- sprintf("%s = %.5g %s %s %.5g %s", options[["dependent"]], coefs[1], coefNames[1], plusOrMin[2], abs(coefs[2]), coefNames[2]) - for (i in 3:length(coefs)) { - filledFormula <- sprintf("%s %s %.5g %s", filledFormula, plusOrMin[i], abs(coefs[i]), coefNames[i]) + filledFormula <- sprintf("%s = %s %s %s %s %s", dependent, coefs[1], coefNames[1], plusOrMin[2], abs(coefs[2]), coefNames[2]) + if (length(coefs) > 2) { + for (i in 3:length(coefs)) { + filledFormula <- sprintf("%s %s %s %s", filledFormula, plusOrMin[i], abs(coefs[i]), coefNames[i]) + } } - result[["regression"]][["filledFormula"]] <- jaspBase::gsubInteractionSymbol(filledFormula) + #coded + coefsCoded <- coef(regressionFitCoded)[!is.na(coef(regressionFitCoded))] + coefsCoded <- round(coefsCoded, .numDecimals) + coefNames <- if (options[["tableAlias"]]) termNamesAliasedCoded else termNames + plusOrMin <- sapply(seq_len(length(coefsCoded)), function(x) { + if (coefsCoded[x] > 0) "+" else "-" + }) + filledFormulaCoded <- sprintf("%s = %s %s %s %s %s", dependent, coefsCoded[1], coefNames[1], plusOrMin[2], abs(coefsCoded[2]), coefNames[2]) + if (length(coefsCoded) > 2) { + for (i in 3:length(coefsCoded)) { + filledFormulaCoded <- sprintf("%s %s %s %s", filledFormulaCoded, plusOrMin[i], abs(coefsCoded[i]), coefNames[i]) + } + } + result[["regression"]][["filledFormula"]] <- gsubInteractionSymbol(filledFormula) jaspResults[["doeResult"]] <- createJaspState(result) jaspResults[["doeResult"]]$dependOn(options = .doeAnalysisBaseDependencies()) + + + resultCoded[["regression"]][["filledFormula"]] <- gsubInteractionSymbol(filledFormulaCoded) + jaspResults[["doeResultCoded"]] <- createJaspState(resultCoded) + jaspResults[["doeResultCoded"]]$dependOn(options = .doeAnalysisBaseDependencies()) +} + +get_levels <- function(var, num_levels, dataset) { + levels_var <- levels(dataset[[var]]) + levels_var[2:(num_levels + 1)] +} + +.getVIF <- function(regressionFit, predictors) { + if (ncol(regressionFit$model) < 3) { + VIF <- rep(NA, length(regressionFit$coefficients)) + } else { + VIF <- car::vif(regressionFit) + VIF <- if (is.vector(VIF)) VIF else VIF[,1] + terms <- names(regressionFit$coefficients) + regexExpression <- paste0("(", paste(predictors, collapse = "|"), ")((\\^2)?)([^✻]+)(✻?)") + for (term_i in seq_along(terms)) { + replacements <- if (grepl("^2", terms[term_i], fixed = TRUE)) "\\1\\4" else "\\1\\5" + terms[term_i] <- gsub(regexExpression, replacements, terms[term_i], perl=TRUE) + terms[term_i] <- gsub("\\s", "", terms[term_i]) + } + VIF <- VIF[terms] + } + return(VIF) +} + +.addModelHeaderTerms <- function(anovaFit, covariates = "") { + rownames(anovaFit) <- gsub(" ", "", row.names(anovaFit), fixed = TRUE) + rownames(anovaFit) <- unname(sapply(rownames(anovaFit), .gsubIdentityFunction)) # remove identity function around squared terms + + # calculate model row + modelSS <- sum(anovaFit$`Sum Sq`[-nrow(anovaFit)]) + modelDf <- sum(anovaFit$Df[-nrow(anovaFit)]) + modelMS <- modelSS / modelDf + msError <- anovaFit$`Mean Sq`[nrow(anovaFit)] + modelFValue <- if (msError != 0) modelMS / msError else NA + modelPValue <- if (!is.na(modelFValue)) pf(modelFValue, modelDf, anovaFit$Df[nrow(anovaFit)], lower.tail = FALSE) else NA + modelRow <- data.frame(df = modelDf, ss = modelSS, ms = modelMS, f = modelFValue, p = modelPValue) + colnames(modelRow) <- colnames(anovaFit) + rownames(modelRow) <- "Model" + + # calculate total row + totalRow <- data.frame(df = sum(anovaFit$Df), ss = sum(anovaFit$`Sum Sq`), ms = NA, f = NA, p = NA) + colnames(totalRow) <- colnames(anovaFit) + rownames(totalRow) <- "Total" + + # calculate block row + blockTermIndex <- which(rownames(anovaFit) == "Block") + if (length(blockTermIndex) > 0) { + anovaFitBlock <- anovaFit[blockTermIndex,] + rownames(anovaFitBlock) <- sprintf("\u00A0 %s", rownames(anovaFitBlock)) # single indent + } + + # calculate covariate row + covariateTermIndices <- which(rownames(anovaFit) %in% covariates) + if (length(covariateTermIndices) > 0) { + anovaFitCovariate <- anovaFit[covariateTermIndices,] + rownames(anovaFitCovariate) <- sprintf("\u00A0 \u00A0 %s", rownames(anovaFitCovariate)) # double indent + covariateRow <- data.frame(df = sum(anovaFitCovariate$Df), ss = sum(anovaFitCovariate$`Sum Sq`), ms = NA, f = NA, p = NA) + colnames(covariateRow) <- colnames(anovaFit) + rownames(covariateRow) <- sprintf("\u00A0 %s", "Covariates") + } + + # calculate linear row and get all linear terms + linearTermIndices <- which(!grepl("\\^2|:", rownames(anovaFit[-nrow(anovaFit),])) & + rownames(anovaFit[-nrow(anovaFit),]) != "Block" & + !rownames(anovaFit[-nrow(anovaFit),]) %in% covariates) # all terms without squared symbol or colon or residuals or Block or covariates + anovaFitLinear <- anovaFit[linearTermIndices,] + rownames(anovaFitLinear) <- sprintf("\u00A0 \u00A0 %s", rownames(anovaFitLinear)) # double indent + linearRow <- data.frame(df = sum(anovaFitLinear$Df), ss = sum(anovaFitLinear$`Sum Sq`), ms = NA, f = NA, p = NA) + colnames(linearRow) <- colnames(anovaFit) + rownames(linearRow) <- sprintf("\u00A0 %s", "Linear terms") + + # calculate squared row and get all squared terms + squaredTermIndices <- which(grepl("\\^2$", rownames(anovaFit))) + if (length(squaredTermIndices) > 0) { + anovaFitSquared <- anovaFit[squaredTermIndices,] + rownames(anovaFitSquared) <- sprintf("\u00A0 \u00A0 %s", rownames(anovaFitSquared)) # double indent + squaredRow <- data.frame(df = sum(anovaFitSquared$Df), ss = sum(anovaFitSquared$`Sum Sq`), ms = NA, f = NA, p = NA) + colnames(squaredRow) <- colnames(anovaFit) + rownames(squaredRow) <- sprintf("\u00A0 %s", "Squared terms") + } + + # calculate interaction row and get all interaction terms + interactionTermIndices <- which(grepl(":", rownames(anovaFit))) + if (length(interactionTermIndices) > 0) { + anovaFitInteraction <- anovaFit[interactionTermIndices, ] + rownames(anovaFitInteraction) <- sprintf("\u00A0 \u00A0 %s", rownames(anovaFitInteraction)) # double indent + interactionRow <- data.frame(df = sum(anovaFitInteraction$Df), ss = sum(anovaFitInteraction$`Sum Sq`), ms = NA, f = NA, p = NA) + colnames(interactionRow) <- colnames(anovaFit) + rownames(interactionRow) <- sprintf("\u00A0 %s", "Interaction terms") + } + + # Model error row + errorRow <- anovaFit[nrow(anovaFit),] + rownames(errorRow) <- "Error" + + newAnovaFit <- modelRow + if (length(blockTermIndex) > 0) + newAnovaFit <- rbind(newAnovaFit, anovaFitBlock) + if (length(covariateTermIndices) > 0) + newAnovaFit <- rbind(newAnovaFit, covariateRow, anovaFitCovariate) + newAnovaFit <- rbind(newAnovaFit, linearRow, anovaFitLinear) + if (length(squaredTermIndices > 0)) + newAnovaFit <- rbind(newAnovaFit, squaredRow, anovaFitSquared) + if (length(interactionTermIndices > 0)) + newAnovaFit <- rbind(newAnovaFit, interactionRow, anovaFitInteraction) + newAnovaFit <- rbind(newAnovaFit, errorRow, totalRow) + + return(newAnovaFit) +} + +.removeAppendedFactorLevels <- function(predictorNames, terms, interactionSymbol = "✻"){ + regexExpression <- paste0("(", paste(predictorNames, collapse = "|"), ")((\\^2)?)([^", interactionSymbol, "]+)(", interactionSymbol, "?)") + for (term_i in seq_along(terms)) { + replacements <- if (grepl("^2", terms[term_i], fixed = TRUE)) "\\1\\4" else "\\1\\5" + terms[term_i] <- gsub(regexExpression, replacements, terms[term_i], perl=TRUE) + terms[term_i] <- gsub("\\s", "", terms[term_i]) + } + return(terms) +} + +.gsubIdentityFunction <- function(term) { + splitTerm <- unlist(strsplit(term, "")) # split into individual letters + if (all(splitTerm[c(1,2, length(splitTerm))] == c("I", "(", ")"))) { + cleanTerm <- paste0(splitTerm[-c(1,2, length(splitTerm))], collapse = "") # remove the first two and the last element + return(cleanTerm) + } else { + return(term) + } +} + +.doeCoefficientEffects <- function(regressionFit) { + effectVector <- c() + for (i in seq_along(regressionFit$coefficients)) { + termName <- names(regressionFit$coefficients)[i] + if (termName == "(Intercept)") { + effect <- NA + } else { + coef <- regressionFit$coefficients[i] + coefLevels <- unique(unlist(regressionFit$model[which(sapply(colnames(regressionFit$model), function(v) grepl(v, termName)))])) + factorRange <- if (is.numeric(coefLevels)) max(coefLevels) - min(coefLevels) else length(coefLevels) + effect <- coef * factorRange + } + effectVector <- c(effectVector, effect) + } + return(effectVector) +} + +.createHighestOrderInteractionFormula <- function(dependentVariable, independentVariables, interactionOrder) { + # Create a formula string with main effects + formulaStr <- paste(jaspBase::encodeColNames(independentVariables), collapse = " + ") + + # Add interaction terms up to the specified order + if (interactionOrder > 1 & length(independentVariables) > 1) { + for (i in 2:interactionOrder) { + interactions <- combn(jaspBase::encodeColNames(independentVariables), i, simplify = FALSE) + interaction_terms <- sapply(interactions, function(x) paste(x, collapse = ":")) + formulaStr <- paste(formulaStr, "+", paste(interaction_terms, collapse = " + ")) + } + } + + # Construct and return the formula + return(paste(jaspBase::encodeColNames(dependentVariable), "~", formulaStr)) } -.doeAnalysisSummaryTable <- function(jaspResults, options, ready) { +.doeAnalysisSummaryTable <- function(jaspResults, options, ready, coded) { if (!is.null(jaspResults[["tableSummary"]])) { return() } @@ -332,14 +674,17 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { if (!ready || is.null(jaspResults[["doeResult"]]) || jaspResults$getError()) { return() } - result <- jaspResults[["doeResult"]]$object[["regression"]] + result <- if (coded) jaspResults[["doeResultCoded"]]$object[["regression"]] else jaspResults[["doeResult"]]$object[["regression"]] row <- data.frame( s = result[["s"]], rsq = result[["rsq"]], adjrsq = result[["adjrsq"]], predrsq = result[["predrsq"]] ) tb$addRows(row) + if (!is.null(result[["aliasedTerms"]])) { + tb$addFootnote(gettextf("The following aliased terms were removed: %s.", paste(result[["aliasedTerms"]], collapse = ", "))) + } } -.doeAnalysisAnovaTable <- function(jaspResults, options, ready) { +.doeAnalysisAnovaTable <- function(jaspResults, options, ready, coded) { if (!is.null(jaspResults[["tableAnova"]])) { return() } @@ -356,7 +701,7 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { if (!ready || is.null(jaspResults[["doeResult"]]) || jaspResults$getError()) { return() } - result <- jaspResults[["doeResult"]]$object[["anova"]] + result <- if (coded) jaspResults[["doeResultCoded"]]$object[["anova"]] else jaspResults[["doeResult"]]$object[["anova"]] rows <- data.frame( terms = result[["terms"]], adjss = result[["adjss"]], df = result[["df"]], adjms = result[["adjms"]], fval = result[["F"]], pval = result[["p"]] @@ -364,7 +709,7 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { tb$addRows(rows) } -.doeAnalysisCoefficientsTable <- function(jaspResults, options, ready) { +.doeAnalysisCoefficientsTable <- function(jaspResults, options, ready, coded) { if (!is.null(jaspResults[["tableCoefficients"]])) { return() } @@ -385,21 +730,38 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { if (!ready || is.null(jaspResults[["doeResult"]]) || jaspResults$getError()) { return() } - result <- jaspResults[["doeResult"]]$object[["regression"]][["coefficients"]] + result <- if (coded) jaspResults[["doeResultCoded"]]$object[["regression"]][["coefficients"]] else jaspResults[["doeResult"]]$object[["regression"]][["coefficients"]] rows <- data.frame( terms = result[["terms"]], effects = result[["effects"]], coef = result[["est"]], - se = result[["se"]], tval = result[["t"]], pval = result[["p"]], vif = NA + se = result[["se"]], tval = result[["t"]], pval = result[["p"]], vif = result[["vif"]] ) if (options[["tableAlias"]]) rows["alias"] <- result[["termsAliased"]] tb$addRows(rows) + + if ((length(options[["fixedFactorsFactorial"]]) > 0 | length(options[["fixedFactorsResponseSurface"]])) && !coded) { + tb2 <- createJaspTable(gettext("Discrete Predictor Levels")) + tb2$addColumnInfo(name = "factorName", title = gettext("Name"), type = "string") + tb2$addColumnInfo(name = "factorLevel", title = gettext("Level"), type = "string") + tb2$position <- 4 + jaspResults[["tableCoefficientsLegend"]] <- tb2 + + result2 <- jaspResults[["doeResult"]]$object[["regression"]][["factorLevels"]] + factorName <- if (options[["tableAlias"]]) result2[["factorNamesAliased"]] else result2[["factorNames"]] + rows2 <- data.frame( + factorName = factorName, + factorLevel = result2[["levels"]] + ) + + tb2$addRows(rows2) + } } -.doeAnalysisEquationTable <- function(jaspResults, options, ready) { +.doeAnalysisEquationTable <- function(jaspResults, options, ready, coded) { if (!is.null(jaspResults[["tableEquation"]]) || !options[["tableEquation"]]) { return() } - codedString <- ifelse(options[["codeFactors"]], gettext("coded"), gettext("uncoded")) + codedString <- ifelse(options[["codeFactors"]], gettext("Coded"), gettext("Uncoded")) tb <- createJaspTable(gettextf("Regression Equation in %s Units", codedString)) tb$addColumnInfo(name = "formula", title = "", type = "string") tb$dependOn(options = .doeAnalysisBaseDependencies()) @@ -408,20 +770,16 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { if (!ready || is.null(jaspResults[["doeResult"]]) || jaspResults$getError()) { return() } - result <- jaspResults[["doeResult"]]$object[["regression"]] + result <- if (coded) jaspResults[["doeResultCoded"]]$object[["regression"]] else jaspResults[["doeResult"]]$object[["regression"]] row <- data.frame(formula = result[["filledFormula"]]) tb$addRows(row) } -.doeAnalysisPlotPareto <- function(jaspResults, options, ready) { +.doeAnalysisPlotPareto <- function(jaspResults, options, blocks, covariates, ready) { if (!is.null(jaspResults[["plotPareto"]]) || !options[["plotPareto"]]) { return() } - plot <- createJaspPlot(title = if (options[["codeFactors"]]) { - gettext("Pareto Chart of Standardized Effects") - } else { - gettext("Pareto Chart of Unstandardized Effects") - }, width = 600, height = 400) + plot <- createJaspPlot(title = gettext("Pareto Chart of Standardized Effects"), width = 600, height = 400) plot$dependOn(options = c("plotPareto", "tableAlias", .doeAnalysisBaseDependencies())) plot$position <- 6 jaspResults[["plotPareto"]] <- plot @@ -429,22 +787,36 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { return() } result <- jaspResults[["doeResult"]]$object[["regression"]] - t <- abs(data.frame(result[["objectSummary"]]$coefficients)$t.value[-1]) fac <- if (options[["tableAlias"]]) result[["coefficients"]][["termsAliased"]][-1] else result[["coefficients"]][["terms"]][-1] + coefDf <- data.frame(result[["objectSummary"]]$coefficients) + tDf <- data.frame("tValue" = coefDf[["t.value"]], + terms = result[["coefficients"]][["terms"]]) + + # Do not include intercept, covariates and blocks in pareto plot + tDf <- tDf[-1, ] # remove intercept + if (length(blocks) > 0 && !identical(blocks, "")) { + tDf <- tDf[tDf$terms != blocks, ] # remove the block variable + fac <- if (options[["tableAlias"]]) fac[!grepl("BLK", fac)] else fac[fac != blocks] + } + if (length(covariates) > 0 && !identical(covariates, "")) { + tDf <- tDf[!tDf$terms %in% unlist(covariates), ] # remove the covariate(s) + fac <- if (options[["tableAlias"]]) fac[!grepl("COV", fac)] else fac[!fac %in% unlist(covariates)] + } + + t <- abs(tDf[["tValue"]]) df <- result[["objectSummary"]]$df[2] crit <- abs(qt(0.025, df)) fac_t <- cbind.data.frame(fac, t) fac_t <- cbind(fac_t[order(fac_t$t), ], y = seq_len(length(t))) xBreaks <- jaspGraphs::getPrettyAxisBreaks(c(0, t, crit)) + critLabelDf <- data.frame(x = 0, y = crit, label = sprintf("t = %.2f", crit)) p <- ggplot2::ggplot(data = fac_t, mapping = ggplot2::aes(y = t, x = y)) + ggplot2::geom_bar(stat = "identity") + ggplot2::geom_hline(yintercept = crit, linetype = "dashed", color = "red") + + ggplot2::geom_label(data = critLabelDf, mapping = ggplot2::aes(x = x, y = y, label = label), col = "red", size = 5) + ggplot2::scale_x_continuous(name = gettext("Term"), breaks = fac_t$y, labels = fac_t$fac) + - ggplot2::scale_y_continuous(name = if (options[["codeFactors"]]) { - gettext("Standardized Effect") - } else { - gettext("Unstandardized Effect") - }, breaks = xBreaks, limits = range(xBreaks)) + + ggplot2::scale_y_continuous(name = + gettext("Standardized Effect"), breaks = xBreaks, limits = range(xBreaks)) + ggplot2::coord_flip() + jaspGraphs::geom_rangeframe() + jaspGraphs::themeJaspRaw() @@ -478,7 +850,8 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { return() } result <- jaspResults[["doeResult"]]$object[["regression"]] - plot$plotObject <- jaspDescriptives::.plotMarginal(resid(result[["object"]]), NULL) + plot$plotObject <- jaspDescriptives::.plotMarginal(resid(result[["object"]]), NULL, binWidthType = options[["histogramBinWidthType"]], + numberOfBins = options[["histogramManualNumberOfBins"]]) } .doeAnalysisPlotFittedVsResiduals <- function(jaspResults, options, ready) { @@ -562,26 +935,27 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { plot$plotObject <- jaspGraphs::ggMatrixPlot(plotMat) } -.doeAnalysisCheckErrors <- function(dataset, options, ready) { +.doeAnalysisCheckErrors <- function(dataset, options, continuousPredictors, discretePredictors, blocks, covariates, dependent, ready) { if (!ready) { return() } - modelTerms <- unlist(options$modelTerms, recursive = FALSE) - factorModelTerms <- options$modelTerms[sapply(modelTerms, function(x) !any(x %in% options$covariates))] - allComponents <- unique(unlist(lapply(factorModelTerms, `[[`, "components"), use.names = FALSE)) + factorLevels.target <- c(blocks, discretePredictors)[c(blocks, discretePredictors) != ""] + variance.target <- c(continuousPredictors, covariates)[c(continuousPredictors, covariates) != ""] .hasErrors( dataset = dataset, type = c("infinity", "factorLevels", "variance"), - infinity.target = c(options$dependent, allComponents), - factorLevels.target = options[["fixedFactors"]], + infinity.target = c(dependent, continuousPredictors, discretePredictors, blocks, covariates), + factorLevels.target = factorLevels.target, factorLevels.amount = "< 2", + variance.target = variance.target, + variance.equalTo = 0, exitAnalysisIfErrors = TRUE ) } -.doeAnalysisPlotContourSurface <- function(jaspResults, dataset, options, ready) { +.doeAnalysisPlotContourSurface <- function(jaspResults, dataset, options, dependent, ready) { if (!is.null(jaspResults[["contourSurfacePlot"]]) || !options[["contourSurfacePlot"]]) { return() } @@ -590,9 +964,9 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { containerTitle <- ifelse(plotType == "contourPlot", gettext("Contour plots"), gettext("Surface plots")) container <- createJaspContainer(title = containerTitle) container$dependOn(options = c("contourSurfacePlot", "contourSurfacePlotType", - "contourSurfacePlotVariables", "contourSurfacePlotLegend", - "contourSurfacePlotResponseDivision", "surfacePlotVerticalRotation", - "surfacePlotHorizontalRotation", .doeAnalysisBaseDependencies())) + "contourSurfacePlotVariables", "contourSurfacePlotLegend", + "contourSurfacePlotResponseDivision", "surfacePlotVerticalRotation", + "surfacePlotHorizontalRotation", .doeAnalysisBaseDependencies())) container$position <- 12 jaspResults[["contourSurfacePlot"]] <- container @@ -610,18 +984,18 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { for (i in seq_len(nPlots)) { variablePair <- variablePairs[i, ] variablePairString <- paste(variablePair, collapse = gettext(" and ")) - plotTitle <- gettextf("%1$s of %2$s vs %3$s", plotTypeString, options[["dependent"]], variablePairString) + plotTitle <- gettextf("%1$s of %2$s vs %3$s", plotTypeString, dependent, variablePairString) plot <- createJaspPlot(title = plotTitle, width = 500, height = 500) if(plotType == "contourPlot") { - plot$plotObject <- function(){.doeContourSurfacePlotObject(jaspResults, options, variablePair, type = "contour")} + plot$plotObject <- function(){.doeContourSurfacePlotObject(jaspResults, options, dependent, variablePair, type = "contour")} } else if (plotType == "surfacePlot") { - plot$plotObject <- function(){.doeContourSurfacePlotObject(jaspResults, options, variablePair, type = "surface")} + plot$plotObject <- function(){.doeContourSurfacePlotObject(jaspResults, options, dependent, variablePair, type = "surface")} } jaspResults[["contourSurfacePlot"]][[plotTitle]] <- plot } } -.doeContourSurfacePlotObject <- function(jaspResults, options, variablePair, type = c("contour", "surface")) { +.doeContourSurfacePlotObject <- function(jaspResults, options, dependent, variablePair, type = c("contour", "surface")) { type <- match.arg(type) result <- jaspResults[["doeResult"]]$object[["regression"]] regressionFit <- result[["object"]] @@ -633,8 +1007,8 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { } else if (type == "surface") { theta <- options[["surfacePlotHorizontalRotation"]] phi <- options[["surfacePlotVerticalRotation"]] - po <- rsm::persp.lm(regressionFit, formula, theta = theta, phi = phi, zlab = options[["dependent"]], - col = colorSet) + po <- rsm::persp.lm(regressionFit, formula, theta = theta, phi = phi, zlab = dependent, + col = colorSet) } if (options[["contourSurfacePlotLegend"]]){ partitionRanges <- levels(cut(po[[1]]$z, breaks = nResponsePartitions)) @@ -663,6 +1037,7 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { tss <- sum(lm.anova$"Sum Sq") # Calculate the predictive R^2 pred.r.squared <- 1 - .PRESS(linear.model) / (tss) + pred.r.squared <- max(0, pred.r.squared) # no negative values return(pred.r.squared) } @@ -672,14 +1047,14 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { .reorderModelTerms <- function(options) { if (length(options$modelTerms) > 0) { fixedFactors <- list() - covariates <- list() + continuousFactorsFactorial <- list() k <- 1 l <- 1 for (i in 1:length(options$modelTerms)) { - if (sum(unlist(options$modelTerms[[i]]$components) %in% options$covariates) > 0) { - covariates[[k]] <- options$modelTerms[[i]] + if (sum(unlist(options$modelTerms[[i]]$components) %in% options$continuousFactorsFactorial) > 0) { + continuousFactorsFactorial[[k]] <- options$modelTerms[[i]] k <- k + 1 } else { fixedFactors[[l]] <- options$modelTerms[[i]] @@ -687,11 +1062,11 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { } } - if (length(covariates) > length(options$covariates)) { + if (length(continuousFactorsFactorial) > length(options$continuousFactorsFactorial)) { modelTerms <- options$modelTerms interactions <- TRUE } else { - modelTerms <- c(fixedFactors, covariates) + modelTerms <- c(fixedFactors, continuousFactorsFactorial) modelTerms <- modelTerms[match(modelTerms, options$modelTerms)] interactions <- FALSE } @@ -703,16 +1078,16 @@ doeAnalysis <- function(jaspResults, dataset, options, ...) { list(modelTerms = modelTerms, interactions = interactions) } -.modelFormula <- function(modelTerms, options) { - dependent.normal <- options$dependent - dependent.base64 <- .v(options$dependent) +.modelFormula <- function(modelTerms, options, dependent) { + dependent.normal <- dependent + dependent.base64 <- jaspBase::encodeColNames(dependent) terms.base64 <- c() terms.normal <- c() for (term in modelTerms) { components <- unlist(term$components) - term.base64 <- paste(.v(components), collapse = ":", sep = "") + term.base64 <- paste(jaspBase::encodeColNames(components), collapse = ":", sep = "") term.normal <- paste(components, collapse = " \u273B ", sep = "") terms.base64 <- c(terms.base64, term.base64) diff --git a/R/doeFactorial.R b/R/doeFactorial.R index a29f941b..38e03987 100644 --- a/R/doeFactorial.R +++ b/R/doeFactorial.R @@ -17,7 +17,7 @@ #' @export doeFactorial <- function(jaspResults, dataset, options, ...) { - ready <- options[["selectedRow"]] != -1L + ready <- options[["selectedRow"]] != -1L | options[["factorialType"]] == "generalFullFactorial" # If the design type is general full factorial no need to select a design .doeFactorialDesignSummaryTable(jaspResults, options) @@ -51,7 +51,7 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { "selectedDesign2", "factorialType", "factorialTypeSpecifyGenerators", - "numberHTCFactors", + "factorialDesignTypeSplitPlotNumberHardToChangeFactors", "blocks", "centerpoints", "replications", @@ -65,12 +65,12 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { if (!is.null(jaspResults[["doeFactorialDesignSummaryTable"]])) { return() } - twoLevelDesign <- options[["categoricalNoLevels"]] == 2 + twoLevelDesign <- options[["factorialType"]] != "generalFullFactorial" tb <- createJaspTable(title = gettext("Design Summary"), position = 1L) tb$addColumnInfo(name = "title", title = gettext("Variable"), type = "string") - tb$addColumnInfo(name = "catFactors", title = gettext("Categorial factors"), type = "integer") + tb$addColumnInfo(name = "catFactors", title = gettext("Discrete predictors"), type = "integer") tb$addColumnInfo(name = "baseRuns", title = gettext("Base runs"), type = "integer") - if (options[["categoricalNoLevels"]] == 2) { + if (twoLevelDesign) { tb$addColumnInfo(name = "baseBlocks", title = gettext("Base blocks"), type = "integer") tb$addColumnInfo(name = "centerpoints", title = gettext("Centre points per block"), type = "integer") } @@ -84,26 +84,31 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { tb[["title"]] <- gettext("Value") tb[["catFactors"]] <- options[["numberOfCategorical"]] designSpec <- .doeFactorialGetSelectedDesign(jaspResults, options) - if (length(designSpec) == 0L) { # user did not select a design + if (options[["factorialType"]] != "generalFullFactorial" && length(designSpec) == 0L) { # user did not select a design tb$addFootnote(gettext("Please select a row in the design table.")) return() } - tb[["baseRuns"]] <- designSpec[["runs"]] - if (options[["categoricalNoLevels"]] == 2) { - tb[["baseBlocks"]] <- designSpec[["blocks"]] - tb[["centerpoints"]] <- designSpec[["centerpoints"]] - } tb[["replications"]] <- designSpec[["replications"]] tb[["repetitions"]] <- designSpec[["repetitions"]] if (twoLevelDesign) { - tb[["totalRuns"]] <- (designSpec[["runs"]] * designSpec[["replications"]]) + (designSpec[["blocks"]] * designSpec[["centerpoints"]] * designSpec[["replications"]]) + designSpec[["repetitions"]] + tb[["baseRuns"]] <- designSpec[["runs"]] + tb[["baseBlocks"]] <- designSpec[["blocks"]] + tb[["centerpoints"]] <- designSpec[["centerpoints"]] + runs <- (designSpec[["runs"]] * designSpec[["replications"]]) + (designSpec[["blocks"]] * designSpec[["centerpoints"]] * designSpec[["replications"]]) + designSpec[["repetitions"]] + tb[["totalRuns"]] <- runs tb[["totalBlocks"]] <- designSpec[["replications"]] * designSpec[["blocks"]] } else { df <- .doeRsmCategorical2df(options[["categoricalVariables"]]) - nLevels <- apply(df, 1, function(x) length(which(x[-1] != "."))) - tb[["totalRuns"]] <- prod(nLevels) * designSpec[["replications"]] + designSpec[["repetitions"]] + nLevels <- apply(df, 1, function(x) length(which(x[-1] != ""))) + runs <- prod(nLevels) * designSpec[["replications"]] + designSpec[["repetitions"]] + tb[["baseRuns"]] <- runs + tb[["totalRuns"]] <- runs tb[["totalBlocks"]] <- designSpec[["replications"]] } + if (!is.na(runs) && runs > 1e+05) { + tb$setError(gettext("Cannote create designs with more than 100000 total runs.")) + return() + } if (!options[["displayDesign"]]) { tb$addFootnote(gettext("Click 'Display design' to show the design.")) } @@ -118,7 +123,7 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { .doeFactorialGetSelectedDesign <- function(jaspResults, options) { row <- options[["selectedRow"]] + 1L - if (row <= 0L) { + if (row <= 0L && options[["factorialType"]] != "generalFullFactorial") { return(list()) } design <- .doeFactorialDefaultDesigns(jaspResults, options, row) @@ -127,13 +132,97 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { .doeFactorialDefaultDesigns <- function(jaspResults, options, row) { nFactors <- options[["numberOfCategorical"]] - twoLevelDesign <- options[["categoricalNoLevels"]] == 2 + twoLevelDesign <- options[["factorialType"]] != "generalFullFactorial" if (!twoLevelDesign) { + row <- 1 designs <- data.frame( name = "Full factorial", runs = options[["categoricalNoLevels"]]^nFactors, resolution = "Full" ) + } else if (options[["factorialType"]] == "factorialTypeSplit") { + nHtcFactors <- options[["factorialDesignTypeSplitPlotNumberHardToChangeFactors"]] + if (nFactors == 2) { + designs <- data.frame( + name = "Full factorial", + runs = 4, + resolution = "Full" + ) + } else if (nFactors == 3) { + designs <- data.frame( + name = "Full factorial", + runs = 8, + resolution = "Full" + ) + } else if (nFactors == 4) { + if (nHtcFactors == 1) { + designs <- data.frame( + name = c("1/2 fraction", "Full factorial"), + runs = c(8, 16), + resolution = c("IV", "Full") + ) + } else { + designs <- data.frame( + name = "Full factorial", + runs = 16, + resolution = "Full" + ) + } + } else if (nFactors == 5) { + if (nHtcFactors == 1) { + designs <- data.frame( + name = c("1/4 fraction", "1/2 fraction", "Full factorial"), + runs = c(8, 16, 32), + resolution = c("III", "V", "Full") + ) + } else if (nHtcFactors == 2) { + designs <- data.frame( + name = c("1/2 fraction", "Full factorial"), + runs = c(16, 32), + resolution = c("V", "Full") + ) + } else { + designs <- data.frame( + name = "Full factorial", + runs = 32, + resolution = "Full" + ) + } + } else if (nFactors == 6) { + if (nHtcFactors <= 2) { + designs <- data.frame( + name = c("1/4 fraction", "1/2 fraction", "Full factorial"), + runs = c(16, 32, 64), + resolution = c("IV", "VI", "Full") + ) + } else { + designs <- data.frame( + name = c("1/2 fraction", "Full factorial"), + runs = c(32, 64), + resolution = c("VI", "Full") + ) + } + } else if (nFactors == 7) { + if (nHtcFactors <= 2) { + designs <- data.frame( + name = c("1/4 fraction", "1/2 fraction", "Full factorial"), + runs = c(32, 64, 128), + resolution = c("IV", "VII", "Full") + ) + } else { + designs <- data.frame( + name = c("1/2 fraction", "Full factorial"), + runs = c(64, 128), + resolution = c("VII", "Full") + ) + } + } else if (nFactors > 7) { + designs <- data.frame( + name = "Full factorial", + runs = 2^nFactors, + resolution = "Full" + ) + } } else { if (nFactors == 2) { designs <- data.frame( @@ -217,7 +306,7 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { .doeFactorialGenerateDesign <- function(jaspResults, options) { seed <- .doeGetAndSetSeed(jaspResults, options) - twoLevelDesign <- options[["categoricalNoLevels"]] == 2 + twoLevelDesign <- options[["factorialType"]] != "generalFullFactorial" df <- .doeRsmCategorical2df(options[["categoricalVariables"]]) designSpec <- .doeFactorialGetSelectedDesign(jaspResults, options) if (length(designSpec) == 0) { @@ -259,14 +348,14 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { design <- FrF2::FrF2( nfactors = designSpec[["factors"]], nruns = designSpec[["runs"]], - hard = options[["numberHTCFactors"]], + hard = options[["factorialDesignTypeSplitPlotNumberHardToChangeFactors"]], replications = designSpec[["replications"]], alias.block.2fis = TRUE, seed = seed ) } } else { - nLevels <- apply(df, 1, function(x) length(which(x[-1] != "."))) + nLevels <- apply(df, 1, function(x) length(which(x[-1] != ""))) design <- DoE.base::fac.design( nfactors = designSpec[["factors"]], nlevels = nLevels, @@ -412,7 +501,7 @@ doeFactorial <- function(jaspResults, dataset, options, ...) { } tb$dependOn(options = c("displayDesign", "codedOutput", "runOrder", .doeFactorialBaseDependencies())) if (options[["factorialType"]] == "factorialTypeSplit") { - tb$addFootnote(gettextf("Hard-to-change factors: %1$s", paste0(df[["name"]][1:options[["numberHTCFactors"]]], collapse = ", "))) + tb$addFootnote(gettextf("Hard-to-change factors: %1$s", paste0(df[["name"]][1:options[["factorialDesignTypeSplitPlotNumberHardToChangeFactors"]]], collapse = ", "))) } jaspResults[["displayDesign"]] <- tb if (jaspResults$getError()) { diff --git a/R/doeResponseSurfaceMethodology.R b/R/doeResponseSurfaceMethodology.R index 7294aec8..c2338a22 100644 --- a/R/doeResponseSurfaceMethodology.R +++ b/R/doeResponseSurfaceMethodology.R @@ -39,8 +39,8 @@ doeResponseSurfaceMethodology <- function(jaspResults, dataset, options, ...) { tb <- createJaspTable(title = gettext("Design Summary"), position = 1L) tb$addColumnInfo(name = "title", title = gettext("Variable"), type = "string") - tb$addColumnInfo(name = "contFactors", title = gettext("Continuous factors"), type = "integer") - tb$addColumnInfo(name = "catFactors", title = gettext("Categorical factors"), type = "integer") + tb$addColumnInfo(name = "contFactors", title = gettext("Continuous predictors"), type = "integer") + tb$addColumnInfo(name = "catFactors", title = gettext("Discrete predictors"), type = "integer") tb$addColumnInfo(name = "baseRuns", title = gettext("Base runs"), type = "integer") tb$addColumnInfo(name = "baseBlocks", title = gettext("Base blocks"), type = "integer") @@ -114,6 +114,7 @@ doeResponseSurfaceMethodology <- function(jaspResults, dataset, options, ...) { .doeRsmCategorical2df <- function(tableView) { df <- do.call(cbind.data.frame, lapply(tableView, `[[`, "values")) if (ncol(df) == 0L) return(df) + df <- df[, !apply(df, 2, function(col) all(col == ""))] colnames(df) <- c("name", paste0("level", seq_len(ncol(df) - 1L))) return(df) } @@ -133,11 +134,11 @@ doeResponseSurfaceMethodology <- function(jaspResults, dataset, options, ...) { tb$addColumnInfo(name = "std.order", title = gettext("Standard order"), type = "integer") for (i in seq_len(options[["numberOfContinuous"]])) - tb$addColumnInfo(name = paste0("x", i), title = options[["continuousVariables"]][[1L]][["values"]][i], type = "number", overtitle = gettext("Continuous factors")) + tb$addColumnInfo(name = paste0("x", i), title = options[["continuousVariables"]][[1L]][["values"]][i], type = "number", overtitle = gettext("Continuous predictors")) noCat <- options[["numberOfCategorical"]] for (i in seq_len(noCat)) - tb$addColumnInfo(name = paste0("x_cat", i), title = options[["continuousVariables"]][[1L]][["values"]][i], type = "number", overtitle = gettext("Categorical factors")) + tb$addColumnInfo(name = paste0("x_cat", i), title = options[["categoricalVariables"]][[1L]][["values"]][i], type = "number", overtitle = gettext("Discrete predictors")) # avoid any shenanigans with categorical factors having duplicate names if (noCat > 0L) @@ -457,64 +458,64 @@ doeResponseSurfaceMethodology <- function(jaspResults, dataset, options, ...) { # old code ---- .doeRsmAnalysisThatMayBreak <- function(jaspResults, dataset, options) { - + op1 <- length(options[["modelTerms"]]) op2 <- length(options[["rsmResponseVariables"]]) op3 <- length(options[["rsmBlocks"]]) - + ready <- (op1 > 0 && op2 > 0) && any(options[["contour"]], options[["coef"]], options[["anova"]], options[["res"]], options[["pareto"]], options[["resNorm"]], options[["ResFitted"]], options[["displayDesign"]], options[["desirability"]], options[["contour"]]) - + if (!ready) return() - + for (i in 1:op2) { - + data <- .readDataSet(jaspResults, options, dataset, i) - + #check for more than 5 unique .dataErrorCheck(data, options) - + rsm[[i]] <- .responseSurfaceCalculate(jaspResults, options, dataset, data) - + # if (options[["showDesign"]]) # .qualityControlDesignMainRSM(jaspResults,options, position = 1) - + if (options[["contour"]]) .responseSurfaceContour(jaspResults, options, data, rsm[[i]], i, position = 2) - - + + if (options[["coef"]]) .responseSurfaceTableCall(jaspResults, options, rsm[[i]], i, position = 3) - + if (options[["anova"]]) .responseSurfaceTableAnovaCall(jaspResults, options, rsm = rsm[[i]], i, position = 4) - + # if(options[["eigen"]]) # .responseSurfaceTableEigenCall(jaspResults, options, rsm, position = 5) - + if (options[["res"]]) .responsePlotResidualCall(jaspResults, options, rsm[[i]], i, position = 6) - + if (options[["normalPlot"]]) .responseNomralProbabilityPlot(data, jaspResults, options, rsm[[i]], i, position = 7) - + if (options[["pareto"]]) .responsePlotPareto(jaspResults, options, rsm[[i]], i, position = 8) - + if (options[["resNorm"]]) .responsePlotResNorm(jaspResults, options, rsm[[i]], i, position = 9) - + if (options[["ResFitted"]]) .responsePlotResFitted(jaspResults, options, rsm[[i]],i, position = 10) - + if (options[["fourInOne"]]) .responseFourInOnePlot(jaspResults, options, rsm[[i]],i, position = 11) - + } - + if (options[["desirability"]]) .responseSurfaceOptimize(jaspResults, options, rsm, data, position = 11, dataset) } diff --git a/inst/qml/common/ShowAndExportDesign.qml b/inst/qml/common/ShowAndExportDesign.qml index d42c6694..ddcea8c2 100644 --- a/inst/qml/common/ShowAndExportDesign.qml +++ b/inst/qml/common/ShowAndExportDesign.qml @@ -23,7 +23,7 @@ Group { columns : 1 - CheckBox { name: "displayDesign"; label: qsTr("Display design"); checked: false + CheckBox { name: "displayDesign"; label: qsTr("Display design"); checked: true CheckBox{ name: "codedOutput"; label: qsTr("Coded units")} RadioButtonGroup { diff --git a/inst/qml/doeAnalysis.qml b/inst/qml/doeAnalysis.qml index 27395e57..160b5c74 100644 --- a/inst/qml/doeAnalysis.qml +++ b/inst/qml/doeAnalysis.qml @@ -2,6 +2,7 @@ import QtQuick import JASP import JASP.Controls import JASP.Widgets +import QtQuick.Layouts Form @@ -20,96 +21,216 @@ Form VariablesForm { + id: variablesFormFactorial + visible: designType.currentValue == "factorialDesign" AvailableVariablesList { - name: "allVariables" - label: qsTr("Available factors") + name: "allVariablesFactorial" + label: qsTr("Available variables") } AssignedVariablesList { - name: "dependent" - allowedColumns: ["scale", "ordinal"] - singleVariable: true - label: qsTr("Response") + name: "dependentFactorial" + allowedColumns: ["scale", "ordinal"] + singleVariable: true + label: qsTr("Response") } AssignedVariablesList { - id: factors - name: "fixedFactors" - allowedColumns: ["ordinal", "nominal", "nominalText"] - label: qsTr("Categorical Factors") - height: 125 * preferencesModel.uiScale + id: fixedFactorsFactorial + name: "fixedFactorsFactorial" + allowedColumns: ["ordinal", "nominal", "nominalText"] + label: qsTr("Discrete predictors") + height: 75 * preferencesModel.uiScale } AssignedVariablesList { - id: continuousFactors - name: "continuousFactors" - allowedColumns: ["scale", "ordinal"] - label: qsTr("Continuous Factors") - height: 125 * preferencesModel.uiScale + id: continuousFactorsFactorial + name: "continuousFactorsFactorial" + allowedColumns: ["scale", "ordinal"] + label: qsTr("Continuous predictors") + height: 75 * preferencesModel.uiScale } AssignedVariablesList { - name: "blocks" - singleVariable: true - label: qsTr("Blocks") - allowedColumns: ["ordinal", "scale", "nominal", "nominalText"] - visible: false + name: "covariates" + id: covariates + label: qsTr("Covariates") + allowedColumns: ["ordinal", "scale"] + height: 75 * preferencesModel.uiScale } AssignedVariablesList { - visible: false - name: "covariates" + name: "blocksFactorial" + singleVariable: true + label: qsTr("Blocks") + allowedColumns: ["ordinal", "scale", "nominal", "nominalText"] } } - Group + VariablesForm { + id: variablesFormResponseSurface + visible: designType.currentValue == "responseSurfaceDesign" + AvailableVariablesList + { + name: "allVariablesResponseSurface" + label: qsTr("Available variables") + } - RadioButtonGroup + AssignedVariablesList { - name: "runOrderSource" - id: runOrderSource - title: qsTr("Run order") + name: "dependentResponseSurface" + allowedColumns: ["scale", "ordinal"] + singleVariable: true + label: qsTr("Response") + } - RadioButton - { - name: "runOrderSourceRowNumber" - id : runOrderSourceRowNumber - label: qsTr("Equal to row number") - checked: true - } + AssignedVariablesList + { + id: continuousFactorsResponseSurface + name: "continuousFactorsResponseSurface" + allowedColumns: ["scale", "ordinal"] + label: qsTr("Continuous predictors") + height: 125 * preferencesModel.uiScale + } - // RadioButton - // { - // name: "runOrderSourceVariable" - // id : runOrderSourceVariable - // label: qsTr("Specified as variable") - // } + AssignedVariablesList + { + id: fixedFactorsResponseSurface + name: "fixedFactorsResponseSurface" + allowedColumns: ["ordinal", "nominal", "nominalText"] + label: qsTr("Discrete predictors") + height: 125 * preferencesModel.uiScale } - CheckBox + AssignedVariablesList { - name: "tableAlias" - label: "Use alias names" - checked: true + name: "blocksResponseSurface" + singleVariable: true + label: qsTr("Blocks") + allowedColumns: ["ordinal", "scale", "nominal", "nominalText"] } + } - CheckBox + Group + { + columns: 2 + + + Group { - name: "tableEquation" - label: qsTr("Show regression equation") + RadioButtonGroup + { + name: "runOrderSource" + id: runOrderSource + title: qsTr("Run order") + + RadioButton + { + name: "runOrderSourceRowNumber" + id : runOrderSourceRowNumber + label: qsTr("Equal to row number") + checked: true + } + + // RadioButton + // { + // name: "runOrderSourceVariable" + // id : runOrderSourceVariable + // label: qsTr("Specified as variable") + // } + } + + RadioButtonGroup + { + name: "codeFactorsMethod" + id: codeFactorsMethod + title: qsTr("Predictor levels") + + RadioButton + { + name: "automatic" + label: qsTr("Automatically detect low/high") + checked: true + } + + RadioButton + { + name: "manual" + label: qsTr("Manually specify low/high") + } + + + VariablesList + { + id : codeFactorsManualTable + name : "codeFactorsManualTable" + label : qsTr("Predictor") + visible : codeFactorsMethod.value == "manual" + optionKey : "predictors" + source : designType.currentValue == "factorialDesign" ? ["continuousFactorsFactorial", "fixedFactorsFactorial", "blocksFactorial"] : ["continuousFactorsResponseSurface", "fixedFactorsResponseSurface", "blocksResponseSurface"] + listViewType : JASP.AssignedVariables + draggable : false + preferredHeight : jaspTheme.smallDefaultVariablesFormHeight + rowComponentTitle : qsTr("Low High ") + + rowComponent: RowLayout + { + Row + { + spacing: customPriorLayout.space + Layout.preferredWidth: customPriorLayout.prefWidth + TextField + { + name: "lowValue" + fieldWidth: 40 + defaultValue: -1 + } + } + Row + { + spacing: customPriorLayout.space + Layout.preferredWidth: customPriorLayout.prefWidth + TextField + { + name: "highValue" + fieldWidth: 40 + defaultValue: 1 + } + } + } + } + } } - CheckBox + Group { - name: "codeFactors" - label: qsTr("Automatically code/standardize factors") + CheckBox + { + name: "tableAlias" + label: "Use alias names" + checked: true + } + + CheckBox + { + name: "tableEquation" + checked: true + label: qsTr("Show regression equation") + } + + CheckBox + { + name: "codeFactors" + checked: true + label: qsTr("Display results in coded units") + } } } @@ -123,13 +244,14 @@ Form name: "highestOrder" label: qsTr("Define by highest order interaction term") visible: designType.currentValue == "factorialDesign" + checked: true IntegerField { - name: "order" - defaultValue: 1 - min: 1 - max: factors.count > 0 ? factors.count : 999 + name: "order" + defaultValue: 2 + min: 1 + max: (fixedFactorsFactorial.count + continuousFactorsFactorial.count) > 1 ? (fixedFactorsFactorial.count + continuousFactorsFactorial.count) : 999 label: qsTr("Highest order interaction term") } } @@ -159,10 +281,47 @@ Form VariablesForm { - enabled: !highestOrder.checked & designType.currentValue == "factorialDesign" - preferredHeight: jaspTheme.smallDefaultVariablesFormHeight - AvailableVariablesList { name: "components"; title: qsTr("Components"); source: ["fixedFactors", "continuousFactors"]} - AssignedVariablesList { name: "modelTerms"; id: modelTerms; title: qsTr("Model Terms"); listViewType: JASP.Interaction} + enabled: (!highestOrder.checked && designType.currentValue == "factorialDesign") || (!rsmPredefinedModel.checked && designType.currentValue == "responseSurfaceDesign") + preferredHeight: jaspTheme.smallDefaultVariablesFormHeight + + AvailableVariablesList + { + name: "components" + title: qsTr("Components") + source: designType.currentValue == "factorialDesign" ? ["continuousFactorsFactorial", "fixedFactorsFactorial"] : ["continuousFactorsResponseSurface", "fixedFactorsResponseSurface"] + } + + AssignedVariablesList + { + name: "modelTerms" + id: modelTerms + title: designType.currentValue == "factorialDesign" ? qsTr("Model terms") : qsTr("Main and interaction terms") + listViewType: JASP.Interaction + //rowComponentTitle: designType.currentValue == "factorialDesign" ? "" : qsTr("Add squared term") + //rowComponent: CheckBox { name: "squaredTerm"; checked: false; visible: designType.currentValue == "responseSurfaceDesign"} + } + } + + VariablesForm + { + enabled: (!rsmPredefinedModel.checked && designType.currentValue == "responseSurfaceDesign") + visible: designType.currentValue == "responseSurfaceDesign" + preferredHeight: jaspTheme.smallDefaultVariablesFormHeight * .5 + + AvailableVariablesList + { + name: "squaredComponents" + title: qsTr("Continuous predictors") + source: "continuousFactorsResponseSurface" + } + + AssignedVariablesList + { + name: "squaredTerms" + id: squaredTerms + title: qsTr("Squared terms") + } + } } @@ -248,8 +407,20 @@ Form VariablesForm { preferredHeight: jaspTheme.smallDefaultVariablesFormHeight - AvailableVariablesList { name: "continuousPredictors"; source:"continuousFactors"; title: qsTr("Available continuous predictors")} - AssignedVariablesList { name: "contourSurfacePlotVariables"; suggestedColumns: ["scale"]; title: qsTr("Plotting variables")} + + AvailableVariablesList + { + name: "continuousPredictorsPlots" + source: designType.currentValue == "factorialDesign" ? ["continuousFactorsFactorial"] : ["continuousFactorsResponseSurface"] + title: qsTr("Available continuous predictors") + } + + AssignedVariablesList + { + name: "contourSurfacePlotVariables" + suggestedColumns: ["scale", "ordinal"] + title: qsTr("Plotting variables") + } } Group @@ -303,4 +474,57 @@ Form } } } + + Section + { + title: qsTr("Advanced options") + + Group + { + DropDown + { + name: "histogramBinWidthType" + label: qsTr("Histogram bin width type") + id: binWidthType + indexDefaultValue: 0 + values: [ + { label: qsTr("Sturges"), value: "sturges"}, + { label: qsTr("Scott"), value: "scott"}, + { label: qsTr("Doane"), value: "doane"}, + { label: qsTr("Freedman-Diaconis"), value: "fd"}, + { label: qsTr("Manual"), value: "manual"} + ] + } + + DoubleField + { + name: "histogramManualNumberOfBins" + label: qsTr("Number of bins") + defaultValue: 30 + min: 3 + max: 10000 + enabled: binWidthType.currentValue === "manual" + } + } + + DropDown + { + name: "sumOfSquaresType" + label: qsTr("Sum of squares type") + id: sumOfSquaresType + indexDefaultValue: 2 + values: [ + { label: qsTr("Type I"), value: "type1"}, + { label: qsTr("Type II"), value: "type2"}, + { label: qsTr("Type III"), value: "type3"}, + ] + } + + CheckBox + { + name: "squaredTermsCoded" + label: qsTr("Use coded data to calculate squared terms") + visible: designType.currentValue == "responseSurfaceDesign" + } + } } diff --git a/inst/qml/doeFactorial.qml b/inst/qml/doeFactorial.qml index ac1bd89b..4bab019b 100644 --- a/inst/qml/doeFactorial.qml +++ b/inst/qml/doeFactorial.qml @@ -25,6 +25,8 @@ Form { columns: 1 + Common.ShowAndExportDesign {} + Group { columns: 2 @@ -32,11 +34,11 @@ Form Group { - IntegerField { id: numberOfCategorical; label: qsTr("Number of factors"); name: "numberOfCategorical"; min: 2; defaultValue: 3; max: 256 + IntegerField { id: numberOfCategorical; label: qsTr("Number of discrete predictors"); name: "numberOfCategorical"; min: 2; defaultValue: 3; max: 256 property int intValue: defaultValue onValueChanged : { intValue = value !== "" ? value : 0 } } - IntegerField { id: numberOfLevels; label: qsTr("Maximum levels"); name: "categoricalNoLevels"; min: 2; defaultValue: 2; max: 16 + IntegerField { id: numberOfLevels; label: qsTr("Maximum discrete levels"); name: "categoricalNoLevels"; min: 2; defaultValue: 2; max: 20; enabled: factorialType.value == "generalFullFactorial" property int intValue: defaultValue onValueChanged : { intValue = value !== "" ? value : 0 } } @@ -45,7 +47,8 @@ Form RadioButtonGroup { name: "factorialType" - enabled: numberOfLevels.value == 2 + id: factorialType + onValueChanged : {numberOfLevels.value = value !== "generalFullFactorial" ? 2 : 3} RadioButton { @@ -81,14 +84,22 @@ Form IntegerField { + id: factorialDesignTypeSplitPlotNumberHardToChangeFactors name: "factorialDesignTypeSplitPlotNumberHardToChangeFactors" label: qsTr("Number of hard-to-change factors") visible: factorialTypeSplit.checked defaultValue: 1 min: 1 - max: numberOfCategorical.value-1 + max: {numberOfCategorical.value > 3 ? 3 : numberOfCategorical.value - 1} } } + + RadioButton + { + id: generalFullFactorial + name: "generalFullFactorial" + label: qsTr("General full factorial") + } } } @@ -109,17 +120,27 @@ Form rowCount : numberOfCategorical.intValue columnCount : 1 + parseInt(numberOfLevels.value) name : "categoricalVariables" - cornerText : qsTr("Factor") + cornerText : qsTr("Predictor") itemType : JASP.String function getColHeaderText(headerText, colIndex) { return colIndex === 0 ? qsTr("Name") : qsTr("Level %1").arg(colIndex); } function getRowHeaderText(headerText, rowIndex) { return String.fromCharCode(65 + rowIndex); } - function getDefaultValue(columnIndex, rowIndex) { return String.fromCharCode(columnIndex === 0 ? 65 + rowIndex : 97 + columnIndex - 1); } + function getDefaultValue(columnIndex, rowIndex) { + if (columnIndex > 2) { + return ""; // Return an empty string for columnIndex > 2 + } else if (columnIndex === 0) { + return String.fromCharCode(65 + rowIndex); // Uppercase letter for columnIndex 0 + } else { + return String.fromCharCode(97 + columnIndex - 1); // Lowercase letter otherwise + } + } + } Group { Label { text : qsTr("Design Table") } + visible: factorialType.value != "generalFullFactorial" TableView { property int designDataColumns : 3 @@ -129,77 +150,160 @@ Form return["Full factorial", numberOfLevels.intValue**numberOfCategorical.intValue, "Full"] } else { const val = numberOfCategorical.intValue - if (val == 2) { + //const htcVal = numberOffactorialDesignTypeSplitPlotNumberHardToChangeFactorsCategorical.intValue + if (factorialType.value == "factorialTypeSplit") { + if (val == 2) { return [ "Full factorial", 4, "Full" ]; - } else if (val == 3) { - return [ - "1/2 fraction", 4, "III", - "Full factorial", 8, "Full" - ]; - } else if (val == 4) { - return [ - "1/2 fraction", 8, "IV", - "Full factorial", 16, "Full" - ]; - } else if (val == 5) { - return [ - "1/4 fraction", 8, "III", - "1/2 fraction", 16, "V", - "Full factorial", 32, "Full", - ]; - } else if (val == 6) { - return [ - "1/8 fraction", 8, "III", - "1/4 fraction", 16, "IV", - "1/2 fraction", 32, "VI", - "Full factorial", 64, "Full", - ]; - } else if (val == 7) { - return [ - "1/16 fraction", 8, "III", - "1/8 fraction", 16, "IV", - "1/4 fraction", 32, "IV", - "1/2 fraction", 64, "VII", - "Full factorial", 128, "Full", - ]; - } else if (val == 8) { - return [ - "1/16 fraction", 16, "IV", - "1/8 fraction", 32, "IV", - "1/4 fraction", 64, "V", - "1/2 fraction", 128, "VIII" - ]; - } else if (val == 9) { - return [ - "1/32 fraction", 16, "III", - "1/16 fraction", 32, "IV", - "1/8 fraction", 64, "IV", - "1/4 fraction", 128, "VI" - ]; - } else if (val == 10) { - return [ - "1/64 fraction", 16, "III", - "1/32 fraction", 32, "IV", - "1/16 fraction", 64, "IV", - "1/8 fraction", 128, "V", - ]; - } else if (val == 11) { - return [ - "1/128 fraction", 16, "III", - "1/64 fraction", 32, "IV", - "1/32 fraction", 64, "IV", - "1/16 fraction", 128, "V", - ]; - } else if (val >= 12) { + } else if (val == 3) { + return [ + "Full factorial", 8, "Full" + ]; + } else if (val == 4) { + if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 1) { + return [ + "1/2 fraction", 8, "IV", + "Full factorial", 16, "Full" + ]; + } else { + return [ + "Full factorial", 16, "Full" + ]; + } + } else if (val == 5) { + if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 1) { + return [ + "1/4 fraction", 8, "III", + "1/2 fraction", 16, "V", + "Full factorial", 32, "Full" + ]; + } else if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 2) { + return [ + "1/2 fraction", 16, "V", + "Full factorial", 32, "Full" + ]; + } else { + return [ + "Full factorial", 32, "Full" + ]; + } + } else if (val == 6) { + if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 1) { + return [ + "1/4 fraction", 16, "IV", + "1/2 fraction", 32, "VI", + "Full factorial", 64, "Full" + ]; + } else if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 2) { + return [ + "1/4 fraction", 16, "IV", + "1/2 fraction", 32, "VI", + "Full factorial", 64, "Full" + ]; + } else { + return [ + "1/2 fraction", 32, "VI", + "Full factorial", 64, "Full" + ]; + } + } else if (val == 7) { + if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 1) { + return [ + "1/4 fraction", 32, "IV", + "1/2 fraction", 64, "VII", + "Full factorial", 128, "Full" + ]; + } else if (factorialDesignTypeSplitPlotNumberHardToChangeFactors.value == 2) { + return [ + "1/4 fraction", 32, "IV", + "1/2 fraction", 64, "VII", + "Full factorial", 128, "Full" + ]; + } else { + return [ + "1/2 fraction", 64, "VII", + "Full factorial", 128, "Full" + ]; + } + } else { + return [ + "Full factorial", 2**numberOfCategorical.intValue, "Full" + ]; + } + } else { + if (val == 2) { return [ - "1/256 fraction", 16, "III", - "1/128 fraction", 32, "IV", - "1/64 fraction", 64, "IV", - "1/32 fraction", 128, "IV", + "Full factorial", 4, "Full" ]; - } + } else if (val == 3) { + return [ + "1/2 fraction", 4, "III", + "Full factorial", 8, "Full" + ]; + } else if (val == 4) { + return [ + "1/2 fraction", 8, "IV", + "Full factorial", 16, "Full" + ]; + } else if (val == 5) { + return [ + "1/4 fraction", 8, "III", + "1/2 fraction", 16, "V", + "Full factorial", 32, "Full", + ]; + } else if (val == 6) { + return [ + "1/8 fraction", 8, "III", + "1/4 fraction", 16, "IV", + "1/2 fraction", 32, "VI", + "Full factorial", 64, "Full", + ]; + } else if (val == 7) { + return [ + "1/16 fraction", 8, "III", + "1/8 fraction", 16, "IV", + "1/4 fraction", 32, "IV", + "1/2 fraction", 64, "VII", + "Full factorial", 128, "Full", + ]; + } else if (val == 8) { + return [ + "1/16 fraction", 16, "IV", + "1/8 fraction", 32, "IV", + "1/4 fraction", 64, "V", + "1/2 fraction", 128, "VIII" + ]; + } else if (val == 9) { + return [ + "1/32 fraction", 16, "III", + "1/16 fraction", 32, "IV", + "1/8 fraction", 64, "IV", + "1/4 fraction", 128, "VI" + ]; + } else if (val == 10) { + return [ + "1/64 fraction", 16, "III", + "1/32 fraction", 32, "IV", + "1/16 fraction", 64, "IV", + "1/8 fraction", 128, "V", + ]; + } else if (val == 11) { + return [ + "1/128 fraction", 16, "III", + "1/64 fraction", 32, "IV", + "1/32 fraction", 64, "IV", + "1/16 fraction", 128, "V", + ]; + } else if (val >= 12) { + return [ + "1/256 fraction", 16, "III", + "1/128 fraction", 32, "IV", + "1/64 fraction", 64, "IV", + "1/32 fraction", 128, "IV", + ]; + } + } } } @@ -311,7 +415,7 @@ Form IntegerField { name: "selectedRow"; label: qsTr("debug selected row"); defaultValue: selectedDesign2.rowSelected; negativeValues: true; visible: false } IntegerField { name: "selectedCol"; label: qsTr("debug selected col"); defaultValue: selectedDesign2.colSelected; negativeValues: true; visible: false } - CheckBox { name: "showAliasStructure"; label: qsTr("Alias structure"); enabled: numberOfLevels.value == 2 & factorialTypeDefault.checked} + CheckBox { name: "showAliasStructure"; label: qsTr("Alias structure"); enabled: factorialTypeDefault.checked} SetSeed{} } @@ -325,7 +429,7 @@ Form IntegerField { name: "blocks" - enabled: !factorialTypeSplit.checked & !factorialTypeSpecify.checked & numberOfLevels.value == 2 + enabled: !factorialTypeSplit.checked & !factorialTypeSpecify.checked & !generalFullFactorial.checked label: qsTr("Blocks") defaultValue: 1 min: 1 @@ -334,7 +438,7 @@ Form IntegerField { - enabled: !factorialTypeSplit.checked & numberOfLevels.value == 2 + enabled: !factorialTypeSplit.checked & !generalFullFactorial.checked name: "centerpoints" label: qsTr("Centre points per block") defaultValue: 0 @@ -361,6 +465,4 @@ Form } } } - - Common.ShowAndExportDesign {} } diff --git a/inst/qml/doeFull.qml b/inst/qml/doeFull.qml index 0562a350..4730b993 100644 --- a/inst/qml/doeFull.qml +++ b/inst/qml/doeFull.qml @@ -28,23 +28,16 @@ Form title: qsTr("Design Space") name: "designInfo" - IntegerField - { - id: numberOfFactors - name: "numberOfFactors" - label: qsTr("Number of factors") - defaultValue: 3 - min: 2 - max: 256 - } + // IntegerField + // { + // id: numberOfFactors + // name: "numberOfFactors" + // label: qsTr("Number of factors") + // defaultValue: 3 + // min: 2 + // max: 256 + // } - IntegerField - { - visible: false - id: numberOfFactorsForTable - name: "numberOfFactorsForTable" - defaultValue: numberOfFactors.value - } } RadioButtonGroup @@ -68,6 +61,28 @@ Form } } + + IntegerField + { + id: numberOfFactors + name: "numberOfFactors" + label: qsTr("Number of factors") + defaultValue: 0 + min: 0 + max: 256 + // onValueChanged: updateModel(value) + } + + + IntegerField + { + visible: true + id: numberOfFactorsForTable + name: "numberOfFactorsForTable" + value: numberOfFactors.value + onValueChanged: updateModel(value) + } + ColumnLayout { spacing: 0 @@ -100,7 +115,7 @@ Form { name: "factors" addItemManually: false - values: numberOfFactorsForTable.value + values: numberOfFactors.value rowComponent: RowLayout { Row diff --git a/inst/qml/doeMixed.qml b/inst/qml/doeMixed.qml deleted file mode 100644 index 9c36e13c..00000000 --- a/inst/qml/doeMixed.qml +++ /dev/null @@ -1,5 +0,0 @@ -import QtQuick 2.0 - -Item { - -} diff --git a/inst/qml/doeResponseSurfaceMethodology.qml b/inst/qml/doeResponseSurfaceMethodology.qml index f77d4870..20cfa902 100644 --- a/inst/qml/doeResponseSurfaceMethodology.qml +++ b/inst/qml/doeResponseSurfaceMethodology.qml @@ -27,6 +27,8 @@ Form id: form columns: 1 + Common.ShowAndExportDesign {} + RadioButtonGroup { name : "designType" @@ -45,11 +47,11 @@ Form property int intValue: defaultValue onValueChanged : { intValue = value !== "" ? value : 0 } } - IntegerField { id: numberOfCategorical; label: qsTr("Number of categorical factors"); name: "numberOfCategorical"; min: 0; defaultValue: 0; max: 10 + IntegerField { id: numberOfCategorical; label: qsTr("Number of discrete predictors"); name: "numberOfCategorical"; min: 0; defaultValue: 0; max: 10 property int intValue: defaultValue onValueChanged : { intValue = value !== "" ? value : 0 } } - IntegerField { id: numberOfLevels; label: qsTr("Maximum categorical levels"); name: "categoricalNoLevels"; min: 2; defaultValue: 2; max: 10 + IntegerField { id: numberOfLevels; label: qsTr("Maximum discrete levels"); name: "categoricalNoLevels"; min: 2; defaultValue: 2; max: 10 property int intValue: defaultValue onValueChanged : { intValue = value !== "" ? value : 0 } } @@ -70,7 +72,7 @@ Form columnCount : 3 name : "continuousVariables" - cornerText : qsTr("Factor") + cornerText : qsTr("Predictor") columnNames : [qsTr("Name"), qsTr("Low"), qsTr("High")] isFirstColEditable : true itemType : JASP.Double @@ -101,7 +103,7 @@ Form rowCount : numberOfCategorical.intValue columnCount : 1 + parseInt(numberOfLevels.value) name : "categoricalVariables" - cornerText : qsTr("Factor") + cornerText : qsTr("Predictor") itemType : JASP.String function getColHeaderText(headerText, colIndex) { return colIndex === 0 ? qsTr("Name") : qsTr("Level %1").arg(colIndex); } @@ -370,8 +372,6 @@ Form } - Common.ShowAndExportDesign {} - // Section // { // title: qsTr("Desirability") diff --git a/tests/testthat/test-doeAnalysis.R b/tests/testthat/test-doeAnalysis.R index 31b55e22..88c76cfb 100644 --- a/tests/testthat/test-doeAnalysis.R +++ b/tests/testthat/test-doeAnalysis.R @@ -1,19 +1,23 @@ context("DoE Analysis") - +.numDecimals <- 2 # Testing factorial analysis (coded, without blocks) and residual plots (verified with other software) options <- analysisOptions("doeAnalysis") -options$dependent <- "Yield" -options$fixedFactors <- c("Exposure_time", "Develop_time", "Mask_dimension") +options$dependentFactorial <- "Yield" +options$fixedFactorsFactorial <- c("Exposure_time", "Develop_time", "Mask_dimension") options$codeFactors <- TRUE +options$codeFactorsMethod <- "automatic" options$tableEquation <- TRUE options$plotNorm <- TRUE options$plotHist <- TRUE options$plotFitted <- TRUE options$plotRunOrder <- TRUE options$tableAlias <- TRUE -options$modelTerms <- list(list(components = "Exposure_time"), list(components = "Develop_time"), - list(components = "Mask_dimension"), list(components = c("Exposure_time", +options$highestOrder <- FALSE +options$histogramBinWidthType <- "doane" +options$modelTerms <- list(list(components = "Exposure_time"), + list(components = "Develop_time"), + list(components = "Mask_dimension"), list(components = c("Exposure_time", "Develop_time")), list(components = c("Develop_time", "Mask_dimension" )), list(components = c("Exposure_time", "Mask_dimension")), list(components = c("Exposure_time", "Develop_time", "Mask_dimension" @@ -50,15 +54,17 @@ test_that("ANOVA table results match", { table <- results[["results"]][["tableAnova"]][["data"]] jaspTools::expect_equal_tables(table, list(725.133928571429, 5075.9375, 7, 8.29316858980905, 0.00391648487987164, - "Model", 4590.0625, 4590.0625, 1, 52.4953538241601, 8.8451270164271e-05, - "Exposure_time", 473.0625, 473.0625, 1, 5.41029306647606, 0.0484630885931658, - "Develop_time", 3.0625, 3.0625, 1, 0.0350250178699071, 0.856202495502322, - "Mask_dimension", 1.5625, 1.5625, 1, 0.0178699070764832, 0.896958544582933, - "Exposure_timeDevelop_time", 3.0625, - 3.0625, 1, 0.0350250178699071, 0.856202495502322, "Develop_timeMask_dimension", + "Model", "", 5066.1875, 3, "", "", " Linear terms", + 4590.0625, 4590.0625, 1, 52.4953538241601, 8.84512701642711e-05, + " Exposure_time", 473.0625, 473.0625, 1, + 5.41029306647606, 0.0484630885931658, " Develop_time", + 3.0625, 3.0625, 1, 0.0350250178699071, 0.856202495502322, " Mask_dimension", + "", 9.75, 4, "", "", " Interaction terms", 1.5625, + 1.5625, 1, 0.0178699070764832, 0.896958544582933, " Exposure_timeDevelop_time", + 3.0625, 3.0625, 1, 0.0350250178699071, 0.856202495502322, " Develop_timeMask_dimension", 0.0625, 0.0625, 1, 0.000714796283059328, 0.979325452661291, - "Exposure_timeMask_dimension", 5.0625, - 5.0625, 1, 0.0578984989278056, 0.815900529536508, "Exposure_timeDevelop_timeMask_dimension", + " Exposure_timeMask_dimension", + 5.0625, 5.0625, 1, 0.0578984989278056, 0.815900529536508, " Exposure_timeDevelop_timeMask_dimension", 87.4375, 699.5, 8, "", "", "Error", "", 5775.4375, 15, "", "", "Total")) }) @@ -66,27 +72,27 @@ test_that("ANOVA table results match", { test_that("Coded Coefficients table results match", { table <- results[["results"]][["tableCoefficients"]][["data"]] jaspTools::expect_equal_tables(table, - list("", 30.3125, "", 1.18536689121333e-06, 2.33770052615813, - "(Intercept)", 12.9668020607485, "", "A", -16.9375, -67.75, - 8.84512701642711e-05, 2.33770052615813, "Exposure_time", -7.2453677494079, - "", "B", 5.4375, 21.75, 0.0484630885931658, 2.33770052615813, - "Develop_time", 2.32600366862911, "", "C", 0.4375, 1.75, 0.856202495502322, - 2.33770052615813, "Mask_dimension", 0.187149720464411, "", "AB", - -0.312499999999999, -1.25, 0.896958544582933, 2.33770052615813, - "Exposure_timeDevelop_time", -0.133678371760293, - "", "BC", -0.4375, -1.75, 0.856202495502322, 2.33770052615813, - "Develop_timeMask_dimension", -0.187149720464411, - "", "AC", -0.0625000000000001, -0.25, 0.979325452661291, 2.33770052615813, - "Exposure_timeMask_dimension", -0.0267356743520587, - "", "ABC", 0.5625, 2.25, 0.815900529536507, 2.33770052615813, - "Exposure_timeDevelop_timeMask_dimension", - 0.240621069168528, "")) + list("(Intercept)", 30.3125, "", 1.18536689121333e-06, 2.33770052615813, + "(Intercept)", 12.9668020607485, "", "A", -16.9375, -33.875, + 8.84512701642713e-05, 2.33770052615813, "Exposure_time", -7.2453677494079, + 1, "B", 5.4375, 10.875, 0.0484630885931658, 2.33770052615813, + "Develop_time", 2.3260036686291, 1, "C", 0.4375, 0.875, 0.856202495502322, + 2.33770052615813, "Mask_dimension", 0.187149720464411, 1, "AB", + -0.312499999999999, -0.624999999999998, 0.896958544582933, 2.33770052615813, + "Exposure_timeDevelop_time", -0.133678371760293, 1, + "BC", -0.4375, -0.875000000000001, 0.856202495502322, 2.33770052615813, + "Develop_timeMask_dimension", -0.187149720464411, 1, + "AC", -0.0625, -0.125, 0.979325452661291, 2.33770052615813, + "Exposure_timeMask_dimension", -0.0267356743520587, + 1, "ABC", 0.5625, 1.125, 0.815900529536508, 2.33770052615813, + "Exposure_timeDevelop_timeMask_dimension", + 0.240621069168528, 1)) }) -test_that("Regression Equation in coded Units table results match", { +test_that("Regression Equation in Coded Units table results match", { table <- results[["results"]][["tableEquation"]][["data"]] jaspTools::expect_equal_tables(table, - list("Yield = 30.312 - 16.938 A + 5.4375 B + 0.4375 C - 0.3125 AB - 0.4375 BC - 0.0625 AC + 0.5625 ABC" + list("Yield = 30.31 (Intercept) - 16.94 A + 5.44 B + 0.44 C - 0.31 AB - 0.44 BC - 0.06 AC + 0.56 ABC" )) }) @@ -102,9 +108,10 @@ test_that("Model Summary table results match", { # Testing RSM analysis (coded, without block) and contour plots (verified with other software) options <- analysisOptions("doeAnalysis") options$designType <- "responseSurfaceDesign" -options$dependent <- "Vdk" -options$continuousFactors <- c("Inlet_feeding", "Time", "Oil_temperature") +options$dependentResponseSurface <- "Vdk" +options$continuousFactorsResponseSurface <- c("Inlet_feeding", "Time", "Oil_temperature") options$codeFactors <- TRUE +options$codeFactorsMethod <- "automatic" options$tableEquation <- TRUE options$rsmPredefinedModel <- TRUE options$rsmPredefinedTerms <- "fullQuadratic" @@ -121,46 +128,57 @@ results <- runAnalysis("doeAnalysis", "QT 9 p17 - RSM (15+6) Ovality Vdk.csv", o test_that("ANOVA table results match", { table <- results[["results"]][["tableAnova"]][["data"]] jaspTools::expect_equal_tables(table, - list(32.0705532324527, 288.634979092074, 9, 63.7424051345315, 3.31223932582688e-08, - "Model", 52.2485352887742, 156.745605866322, 3, 103.847516440495, - 2.36940699581611e-08, "Linear terms(Inlet_feeding,Time,Oil_temperature)", - 39.0123216181991, 117.036964854597, 3, 77.5396417954375, 1.10371314511512e-07, - "Two-way interaction terms(Inlet_feeding,Time,Oil_temperature)", - 4.95080279038474, 14.8524083711542, 3, 9.84005716766173, 0.00190217445835828, - "Squared terms(Inlet_feeding,Time,Oil_temperature)", 0.503127441846071, - 5.53440186030678, 11, "", "", "Error", 0.382337038728024, 1.91168519364012, - 5, 0.633232583015919, 0.633232583015919, "Lack of fit", 0.603786111111109, - 3.62271666666665, 6, "", "", "Pure error", "", 294.169380952381, - 20, "", "", "Total")) + list(17.4286687766283, 156.858018989655, 9, 34.6406642274952, 8.30307965125175e-07, + "Model", "", 38.4572155403843, 3, "", "", " Linear terms", + 11.8899000543329, 11.8899000543329, 1, 23.6319847923751, 0.000501646267633432, + " Inlet_feeding", 24.9981706073659, 24.9981706073659, + 1, 49.6855637920343, 2.12989264950597e-05, " Time", + 1.56914487868547, 1.56914487868547, 1, 3.11878213783765, 0.105096442839075, + " Oil_temperature", "", 6.41456198135817, + 3, "", "", " Squared terms", 0.971816680445325, 0.971816680445325, + 1, 1.93155172947742, 0.19207390468129, " Inlet_feeding^2", + 5.07806473672077, 5.07806473672077, 1, 10.0929989389734, 0.00880891663240329, + " Time^2", 0.364680564192077, 0.364680564192077, + 1, 0.724827417192739, 0.412715467088767, " Oil_temperature^2", + "", 111.986241467913, 3, "", "", " Interaction terms", + 101.961745328922, 101.961745328922, 1, 202.655901564035, 1.97376239173672e-08, + " Inlet_feedingTime", + 0.0982123904506134, 0.0982123904506134, 1, 0.195203803812119, + 0.667180323291378, " Inlet_feedingOil_temperature", + 9.92628374854026, 9.92628374854026, 1, 19.7291638717197, 0.000992134508871047, + " TimeOil_temperature", + 0.50312744184607, 5.53440186030677, 11, "", "", "Error", "", + 162.392420849962, 20, "", "", "Total")) }) test_that("Coded Coefficients table results match", { table <- results[["results"]][["tableCoefficients"]][["data"]] jaspTools::expect_equal_tables(table, - list(11.3372638071208, "", 6.471991047883e-12, 0.37687921214787, "(Intercept)", - 30.081955814195, "", -1.36214285714286, -8.6725, 2.25952596434628e-05, - 0.194497123284305, "Inlet_feeding", -7.00340876071343, "", 1.40850855060275, - 5.18296717368201, 1.64160761307207e-05, 0.194244773092596, "Time", - 7.25120438598012, "", -0.707142857142858, -7.39393000324301, - 0.00391707189094082, 0.194497123284305, "Oil_temperature", -3.6357496974, - "", -2.96517857142857, -10.3362390490947, 1.97376239173674e-08, - 0.20829134541906, "Inlet_feedingTime", - -14.2357262394314, "", -0.0918643117465642, -0.522344164345772, - 0.667180323291375, 0.207923074104616, "Inlet_feedingOil_temperature", - -0.441818745428623, "", -0.92517857142857, -3.15060053776106, - 0.00099213450887105, 0.20829134541906, "TimeOil_temperature", - -4.44175234245672, "", -0.606579758901038, -2.79525327541786, - 0.19207390468129, 0.436450245724234, "Inlet_feeding^2", -1.38980276639436, - "", -1.38657975890104, -2.5834641343026, 0.00880891663240334, - 0.436450245724234, "Time^2", -3.1769480541824, "", -0.371579758901037, - -0.603887873857458, 0.412715467088765, 0.436450245724234, "Oil_temperature^2", - -0.851367968150521, "")) + list(11.3372638071208, "", 6.47199104788295e-12, 0.37687921214787, + "(Intercept)", 30.081955814195, "", -1.36214285714286, -2.72428571428572, + 2.25952596434626e-05, 0.194497123284304, "Inlet_feeding", -7.00340876071343, + 1.20300751879699, 1.40850855060275, 2.81701710120549, 1.64160761307207e-05, + 0.194244773092596, "Time", 7.25120438598012, 1.18560348165058, + -0.707142857142858, -1.41428571428572, 0.00391707189094081, + 0.194497123284304, "Oil_temperature", -3.63574969748626, 1.20300751879699, + -0.606579758901038, -1.21315951780208, 0.19207390468129, 0.436450245724234, + "Inlet_feeding^2", -1.38980276639436, "", -1.38657975890104, + -2.77315951780207, 0.00880891663240336, 0.436450245724234, "Time^2", + -3.1769480541824, "", -0.371579758901038, -0.743159517802075, + 0.412715467088763, 0.436450245724234, "Oil_temperature^2", -0.851367968150524, + "", -2.96517857142857, -5.93035714285714, 1.97376239173673e-08, + 0.20829134541906, "Inlet_feedingTime", -14.2357262394314, + 1.20300751879699, -0.0918643117465637, -0.183728623493127, 0.667180323291377, + 0.207923074104616, "Inlet_feedingOil_temperature", + -0.441818745428621, 1.20300751879699, -0.92517857142857, -1.85035714285714, + 0.000992134508871048, 0.20829134541906, "TimeOil_temperature", + -4.44175234245672, 1.18560348165058)) }) -test_that("Regression Equation in coded Units table results match", { +test_that("Regression Equation in Coded Units table results match", { table <- results[["results"]][["tableEquation"]][["data"]] jaspTools::expect_equal_tables(table, - list("Vdk = 11.337 (Intercept) - 1.3621 Inlet_feeding + 1.4085 Time - 0.70714 Oil_temperature - 2.9652 Inlet_feedingTime - 0.091864 Inlet_feedingOil_temperature - 0.92518 TimeOil_temperature - 0.60658 Inlet_feeding^2 - 1.3866 Time^2 - 0.37158 Oil_temperature^2" + list("Vdk = 11.34 (Intercept) - 1.36 Inlet_feeding + 1.41 Time - 0.71 Oil_temperature - 0.61 Inlet_feeding^2 - 1.39 Time^2 - 0.37 Oil_temperature^2 - 2.97 Inlet_feedingTime - 0.09 Inlet_feedingOil_temperature - 0.93 TimeOil_temperature" )) })