From a0f50e9c2be408ff850e0bac4567bef907dbab73 Mon Sep 17 00:00:00 2001 From: boutinb Date: Mon, 19 Feb 2024 14:33:57 +0100 Subject: [PATCH 1/5] test --- DESCRIPTION | 1 + R/common.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index efa7daf..c311d87 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,4 +45,5 @@ RcppModules: jaspResults NeedsCompilation: yes Suggests: testthat (>= 3.0.0) + jasp-stats/jaspQmlR Config/testthat/edition: 3 diff --git a/R/common.R b/R/common.R index b02bc0c..d362cc1 100644 --- a/R/common.R +++ b/R/common.R @@ -1024,7 +1024,7 @@ runWrappedAnalysis <- function(analysisName, data, options, version) { return(as.character(result)) } else { - + return("OK") options <- checkAnalysisOptions(analysisName, options, version) # fool renv so it does not try to install jaspTools jaspToolsRunAnalysis <- utils::getFromNamespace("runAnalysis", asNamespace("jaspTools")) From 3a9346bb3ade442d8536da878fa67b8313a68c0a Mon Sep 17 00:00:00 2001 From: boutinb Date: Tue, 27 Feb 2024 18:06:40 +0100 Subject: [PATCH 2/5] add stuff for R Syntax --- DESCRIPTION | 6 +- NAMESPACE | 7 + R/common.R | 342 ++++++++++++++++++++++++++++++++++++++++++++-- src/jaspTable.cpp | 28 ++-- 4 files changed, 360 insertions(+), 23 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c311d87..4aae79d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,7 +34,8 @@ Imports: rvg, svglite, systemfonts, - withr + withr, + jaspQmlR Remotes: jasp-stats/jaspGraphs RoxygenNote: 7.2.3 @@ -43,7 +44,6 @@ Encoding: UTF-8 LinkingTo: Rcpp RcppModules: jaspResults NeedsCompilation: yes -Suggests: +Suggests: testthat (>= 3.0.0) - jasp-stats/jaspQmlR Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index abeebae..8bc5d25 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -83,6 +83,11 @@ export(fishZ) export(gammaDist) export(geomDist) export(getOS) +export(getColumnCount) +export(getColumnNames) +export(getColumnType) +export(getColumnValues) +export(getColumnLabels) export(gsubInteractionSymbol) export(hasSubstring) export(ifElse) @@ -129,6 +134,8 @@ export(rowVariance) export(rowVarianceNaRm) export(runJaspResults) export(runWrappedAnalysis) +export(getColumnCount) +export(initAnalysisRuntime) export(startProgressbar) export(tDist) export(unifDist) diff --git a/R/common.R b/R/common.R index d362cc1..beb8820 100644 --- a/R/common.R +++ b/R/common.R @@ -91,6 +91,7 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall if (base::exists(".requestStateFileNameNative")) { location <- .fromRCPP(".requestStateFileNameNative") + print(location) oldwd <- getwd() setwd(location$root) withr::defer(setwd(oldwd)) @@ -1010,13 +1011,203 @@ registerData <- function(data) { #TODO } -checkAnalysisOptions <- function(analysisName, options, version) { - # TODO when QMLComponents can be linked to jaspBase - return(options) +checkAnalysisOptions <- function(qmlFile, options, version) { + args <- list("options" = options, "qmlFile" = qmlFile, "version" = version) + args <- jsonlite::toJSON(args, auto_unbox = TRUE, digits = NA, null="null", force = TRUE) + args <- as.character(args) + + options <- jaspQmlR::checkOptions(args) + return(fromJSON(options)$options) +} + + +#' Run a JASP analysis in R. +#' +#' \code{runAnalysis} makes it possible to execute a JASP analysis in R. Usually this +#' process is a bit cumbersome as there are a number of objects unique to the +#' JASP environment. Think .ppi, data-reading, etc. These (rcpp) objects are +#' replaced in the jaspTools so you do not have to deal with them. Note that +#' \code{runAnalysis} sources JASP analyses every time it runs, so any change in +#' analysis code between calls is incorporated. The output of the analysis is +#' shown automatically through a call to \code{view} and returned +#' invisibly. +#' +#' +#' @param name String indicating the name of the analysis to run. This name is +#' identical to that of the main function in a JASP analysis. +#' @param dataset Data.frame, matrix, string name or string path; if it's a string then jaspTools +#' first checks if it's valid path and if it isn't if the string matches one of the JASP datasets (e.g., "debug.csv"). +#' By default the directory in Resources is checked first, unless called within a testthat environment, in which case tests/datasets is checked first. +#' @param options List of options to supply to the analysis (see also +#' \code{analysisOptions}). +#' @param view Boolean indicating whether to view the results in a webbrowser. +#' @param quiet Boolean indicating whether to suppress messages from the +#' analysis. +#' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. +#' @examples +#' +#' options <- analysisOptions("BinomialTest") +#' options[["variables"]] <- "contBinom" +#' runAnalysis("BinomialTest", "debug", options) +#' +#' # Above and below are identical (below is taken from the Qt terminal) +#' +#' options <- analysisOptions('{ +#' "id" : 6, +#' "name" : "BinomialTest", +#' "options" : { +#' "VovkSellkeMPR" : false, +#' "confidenceInterval" : false, +#' "confidenceIntervalInterval" : 0.950, +#' "descriptivesPlots" : false, +#' "descriptivesPlotsConfidenceInterval" : 0.950, +#' "hypothesis" : "notEqualToTestValue", +#' "plotHeight" : 300, +#' "plotWidth" : 160, +#' "testValue" : 0.50, +#' "variables" : [ "contBinom" ] +#' }, +#' "perform" : "run", +#' "revision" : 1, +#' "settings" : { +#' "ppi" : 192 +#' } +#' }') +#' runAnalysis("BinomialTest", "debug.csv", options) +#' +#' +#' @export runAnalysis +runAnalysis <- function(name, dataset, options, view = TRUE) { + if (is.list(options) && is.null(names(options)) && any(names(unlist(lapply(options, attributes))) == "analysisName")) + stop("The provided list of options is not named. Did you mean to index in the options list (e.g., options[[1]])?") + + if (!is.list(options) || is.null(names(options))) + stop("The options should be a named list") + + if (missing(name)) { + name <- attr(options, "analysisName") + if (is.null(name)) + stop("Please supply an analysis name") + } + + oldWd <- getwd() + oldLang <- Sys.getenv("LANG") + oldLanguage <- Sys.getenv("LANGUAGE") + on.exit({ + .resetRunTimeInternals() + setwd(oldWd) + Sys.setenv(LANG = oldLang) + Sys.setenv(LANGUAGE = oldLanguage) + }, add = TRUE) + + initAnalysisRuntime(dataset = dataset) + + returnVal <- runJaspResults(name, "", "null", jsonlite::toJSON(options), "null", paste0(name, "Internal")) + + # always TRUE after jaspResults is merged into jaspBase + jsonResults <- if (inherits(returnVal, c("jaspResultsR", "R6"))) { + getJsonResultsFromJaspResults(returnVal) + } else { + getJsonResultsFromJaspResultsLegacy() + } + + transferPlotsFromjaspResults() + + results <- processJsonResults(jsonResults) + +# if (view) +# view(jsonResults) + return(returnVal$toRObject()) + #return(invisible(results)) +} + +.pkgenv <- list2env(list( + internal = list(jaspToolsPath = "", + dataset = "", + state = list(), + modulesMd5Sums = list() + ) + ), parent = emptyenv()) + +.setInternal <- function(name, value) { + .pkgenv[["internal"]][[name]] <- value +} + +.getInternal <- function(name) { + if (! name %in% names(.pkgenv[["internal"]])) + stop(paste("Could not locate internal variable", name)) + return(.pkgenv[["internal"]][[name]]) +} + +initAnalysisRuntime <- function(dataset, ...) { + # dataset to be found in the analysis when it needs to be read + .setInternal("dataset", dataset) +} + +processJsonResults <- function(jsonResults) { + if (jsonlite::validate(jsonResults)) + results <- jsonlite::fromJSON(jsonResults, simplifyVector=FALSE) + else + stop("Could not process json result from jaspResults") + + results[["state"]] <- .getInternal("state") + + figures <- results$state$figures + if (length(figures) > 1 && !is.null(names(figures))) + results$state$figures <- figures[order(as.numeric(tools::file_path_sans_ext(basename(names(figures)))))] + + return(results) } +transferPlotsFromjaspResults <- function() { + pathPlotsjaspResults <- file.path(tempdir(), "jaspResults", "plots") # as defined in jaspResults pkg + pathPlotsjaspTools <- getTempOutputLocation("html") + if (dir.exists(pathPlotsjaspResults)) { + plots <- list.files(pathPlotsjaspResults) + if (length(plots) > 0) { + file.copy(file.path(pathPlotsjaspResults, plots), pathPlotsjaspTools, overwrite=TRUE) + } + } +} + +getTempOutputLocation <- function(dir = NULL) { + loc <- file.path(tempdir(), "jaspTools") + if (!is.null(dir)) { + if (!dir %in% c("state", "html")) + stop("Unknown output directory requested ", dir) + + loc <- file.path(loc, dir) + } + return(loc) +} + +.initOutputDirs <- function() { + htmlDir <- getTempOutputLocation("html") + if (!dir.exists(htmlDir)) + dir.create(file.path(htmlDir, "plots"), recursive = TRUE) + + stateDir <- getTempOutputLocation("state") + if (!dir.exists(stateDir)) + dir.create(stateDir, recursive = TRUE) +} + +getJsonResultsFromJaspResults <- function(jaspResults) { + return(jaspResults$.__enclos_env__$private$getResults()) +} + +getJsonResultsFromJaspResultsLegacy <- function() { + return(jaspResults$.__enclos_env__$private$getResults()) +} + +.resetRunTimeInternals <- function() { + .setInternal("state", list()) + .setInternal("dataset", "") +} + + + #' @export -runWrappedAnalysis <- function(analysisName, data, options, version) { +runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { if (jaspResultsCalledFromJasp()) { result <- list("options" = options, "analysis" = analysisName, "version" = version) @@ -1024,11 +1215,144 @@ runWrappedAnalysis <- function(analysisName, data, options, version) { return(as.character(result)) } else { - return("OK") - options <- checkAnalysisOptions(analysisName, options, version) - # fool renv so it does not try to install jaspTools - jaspToolsRunAnalysis <- utils::getFromNamespace("runAnalysis", asNamespace("jaspTools")) - return(jaspToolsRunAnalysis(analysisName, data, options)) + .initOutputDirs() + moduleName <- base::strsplit(analysisName, "::")[[1]][[1]] + qmlFile <- paste(.libPaths(), moduleName, "qml", qmlFile, sep="/") + print(qmlFile) + options <- checkAnalysisOptions(qmlFile, options, version) + print(options) + .insertRbridgeIntoEnv(.GlobalEnv) + return(runAnalysis(analysisName, data, options)) } } + + +# functions / properties to replace JASP's rcpp functions / properties + +# These are not used in combination with getAnywhere() in the code so they cannot be found +.insertRbridgeIntoEnv <- function(env) { + env[[".automaticColumnEncDecoding"]] <- FALSE + env[[".encodeColNamesStrict"]] <- function(x) return(x) + env[[".decodeColNamesStrict"]] <- function(x) return(x) + env[[".encodeColNamesLax"]] <- function(x) return(x) + env[[".decodeColNamesLax"]] <- function(x) return(x) + env[[".encodeColNamesStrict"]] <- function(x) return(x) + + env[[".setColumnDataAsScale"]] <- function(...) return(TRUE) + env[[".setColumnDataAsOrdinal"]] <- function(...) return(TRUE) + env[[".setColumnDataAsNominal"]] <- function(...) return(TRUE) + env[[".setColumnDataAsNominalText"]] <- function(...) return(TRUE) + + env[[".allColumnNamesDataset"]] <- function(...) { + dataset <- .getInternal("dataset") + dataset <- loadCorrectDataset(dataset) + return(colnames(dataset)) + } +} + +# These are used in combination with getAnywhere() and can stay in the jaspTools namespace +.ppi <- 192 + +.baseCitation <- "x" + +.readDatasetToEndNative <- function(columns = c(), columns.as.numeric = c(), columns.as.ordinal = c(), + columns.as.factor = c(), all.columns = FALSE) { + + dataset <- .getInternal("dataset") + dataset <- loadCorrectDataset(dataset) + + if (all.columns) { + columns <- colnames(dataset) + columns <- columns[columns != ""] + } + dataset <- jaspBase:::.vdf(dataset, columns, columns.as.numeric, columns.as.ordinal, + columns.as.factor, all.columns, exclude.na.listwise = c()) + + return(dataset) +} + +.readDataSetHeaderNative <- function(columns = c(), columns.as.numeric = c(), columns.as.ordinal = c(), + columns.as.factor = c(), all.columns = FALSE) { + + dataset <- .readDatasetToEndNative(columns, columns.as.numeric, columns.as.ordinal, + columns.as.factor, all.columns) + dataset <- dataset[0, , drop = FALSE] + + return(dataset) +} + +.requestTempFileNameNative <- function(...) { + root <- getTempOutputLocation("html") + numPlots <- length(list.files(file.path(root, "plots"))) + list( + root = root, + relativePath = file.path("plots", paste0(numPlots + 1, ".png")) + ) +} + +.requestStateFileNameNative <- function() { + root <- getTempOutputLocation("state") + name <- "state" + list( + root = root, + relativePath = name + ) +} + +.callbackNative <- function(...) { + list(status="ok") +} + +.imageBackground <- function(...) return("white") + +#' @export +getColumnCount <- function() { + + dataset <- .getInternal("dataset") + return(length(colnames(dataset))) +} + +#' @export +getColumnNames <- function() { + + dataset <- .getInternal("dataset") + return(colnames(dataset)) +} + +#' @export +getColumnType <- function(colName) { + + dataset <- .getInternal("dataset") + rawType <- sapply(myData, typeof)[[colName]] + + diffValues <- length(unique(dataset[[colName]])) + + if (rawType == "integer") { + if (diffValues < 10) return("nominal") + else return("scale") + } else if (rawType == "double") { + return("scale") + } else if (rawType == "character") { + return("nominalText") + } else if (rawType == "logical") { + return("scale") + } + + return("nominalText") +} + +#' @export +getColumnValues <- function(colName) { + + dataset <- .getInternal("dataset") + return(dataset[[colName]]) +} + +#' @export +getColumnLabels <- function(colName) { + + dataset <- .getInternal("dataset") + return(unique(dataset[[colName]])) +} + diff --git a/src/jaspTable.cpp b/src/jaspTable.cpp index 387ee9a..4479a88 100644 --- a/src/jaspTable.cpp +++ b/src/jaspTable.cpp @@ -519,9 +519,12 @@ Rcpp::List jaspTable::toRObject() df.attr("class") = Rcpp::CharacterVector({"jaspTableWrapper", "jaspWrapper", "data.frame"}); std::vector rowNames; - rowNames.reserve(_data[0].size()); - for (size_t i = 0; i < _data[0].size(); i++) - rowNames.push_back(_rowNames[i] != "" ? _rowNames[i] : std::to_string(i + 1)); // R numbers from 1 to n by default + if (_data.size() > 0) + { + rowNames.reserve(_data[0].size()); + for (size_t i = 0; i < _data[0].size(); i++) + rowNames.push_back(_rowNames[i] != "" ? _rowNames[i] : std::to_string(i + 1)); // R numbers from 1 to n by default + } df.attr("row.names") = rowNames; @@ -777,7 +780,7 @@ void jaspTable::rectangularDataWithNamesToString(std::stringstream & out, std::s else if(topNames[row].size() < vierkant[0][row].size()) stringExtend(topNames[row], vierkant[0][row].size()); - size_t extraSpaceSide = sideNames[0].size() + sideOvertitleSpace; + size_t extraSpaceSide = sideOvertitleSpace + sideNames.size() > 0 ? sideNames[0].size() : 0; //lets print the topOvertitles { @@ -826,16 +829,19 @@ void jaspTable::rectangularDataWithNamesToString(std::stringstream & out, std::s colSep << "-|\n"; //then the actual columns X rows - for(size_t col=0; col= vierkant.size() && sideNames.size() >= vierkant.size() ) { - //put the side overtitle here - out << colSep.str(); - out << prefix << sideOvertitleRow[col] << sideNames[col] << " | "; + for(size_t col=0; col0? " | " : "") << vierkant[col][row]; + for(size_t row=0; row0? " | " : "") << vierkant[col][row]; - out << " |\n"; + out << " |\n"; + } } out << colSep.str(); From e75c80e31dbcebeda27dfb6e8ec1a72afe53834d Mon Sep 17 00:00:00 2001 From: boutinb Date: Wed, 28 Feb 2024 17:55:01 +0100 Subject: [PATCH 3/5] Update common.R --- R/common.R | 87 +++++++----------------------------------------------- 1 file changed, 10 insertions(+), 77 deletions(-) diff --git a/R/common.R b/R/common.R index beb8820..649118c 100644 --- a/R/common.R +++ b/R/common.R @@ -91,7 +91,6 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall if (base::exists(".requestStateFileNameNative")) { location <- .fromRCPP(".requestStateFileNameNative") - print(location) oldwd <- getwd() setwd(location$root) withr::defer(setwd(oldwd)) @@ -516,16 +515,7 @@ jaspResultsStrings <- function() { location <- .fromRCPP(".requestStateFileNameNative") relativePath <- location$relativePath - # when run through jaspTools do not save the state, but store it internally - if ("jaspTools" %in% loadedNamespaces()) { - # fool renv so it does not try to install jaspTools - .setInternal <- utils::getFromNamespace(".setInternal", asNamespace("jaspTools")) - .setInternal("state", state) - return(list(relativePath = relativePath)) - } - - try(suppressWarnings(base::save(state, file=relativePath, compress=FALSE)), silent = FALSE) - + .setInternal("state", state) return(list(relativePath = relativePath)) } @@ -1013,69 +1003,13 @@ registerData <- function(data) { checkAnalysisOptions <- function(qmlFile, options, version) { args <- list("options" = options, "qmlFile" = qmlFile, "version" = version) - args <- jsonlite::toJSON(args, auto_unbox = TRUE, digits = NA, null="null", force = TRUE) + args <- toJSON(args) args <- as.character(args) options <- jaspQmlR::checkOptions(args) return(fromJSON(options)$options) } - -#' Run a JASP analysis in R. -#' -#' \code{runAnalysis} makes it possible to execute a JASP analysis in R. Usually this -#' process is a bit cumbersome as there are a number of objects unique to the -#' JASP environment. Think .ppi, data-reading, etc. These (rcpp) objects are -#' replaced in the jaspTools so you do not have to deal with them. Note that -#' \code{runAnalysis} sources JASP analyses every time it runs, so any change in -#' analysis code between calls is incorporated. The output of the analysis is -#' shown automatically through a call to \code{view} and returned -#' invisibly. -#' -#' -#' @param name String indicating the name of the analysis to run. This name is -#' identical to that of the main function in a JASP analysis. -#' @param dataset Data.frame, matrix, string name or string path; if it's a string then jaspTools -#' first checks if it's valid path and if it isn't if the string matches one of the JASP datasets (e.g., "debug.csv"). -#' By default the directory in Resources is checked first, unless called within a testthat environment, in which case tests/datasets is checked first. -#' @param options List of options to supply to the analysis (see also -#' \code{analysisOptions}). -#' @param view Boolean indicating whether to view the results in a webbrowser. -#' @param quiet Boolean indicating whether to suppress messages from the -#' analysis. -#' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. -#' @examples -#' -#' options <- analysisOptions("BinomialTest") -#' options[["variables"]] <- "contBinom" -#' runAnalysis("BinomialTest", "debug", options) -#' -#' # Above and below are identical (below is taken from the Qt terminal) -#' -#' options <- analysisOptions('{ -#' "id" : 6, -#' "name" : "BinomialTest", -#' "options" : { -#' "VovkSellkeMPR" : false, -#' "confidenceInterval" : false, -#' "confidenceIntervalInterval" : 0.950, -#' "descriptivesPlots" : false, -#' "descriptivesPlotsConfidenceInterval" : 0.950, -#' "hypothesis" : "notEqualToTestValue", -#' "plotHeight" : 300, -#' "plotWidth" : 160, -#' "testValue" : 0.50, -#' "variables" : [ "contBinom" ] -#' }, -#' "perform" : "run", -#' "revision" : 1, -#' "settings" : { -#' "ppi" : 192 -#' } -#' }') -#' runAnalysis("BinomialTest", "debug.csv", options) -#' -#' #' @export runAnalysis runAnalysis <- function(name, dataset, options, view = TRUE) { if (is.list(options) && is.null(names(options)) && any(names(unlist(lapply(options, attributes))) == "analysisName")) @@ -1100,9 +1034,7 @@ runAnalysis <- function(name, dataset, options, view = TRUE) { Sys.setenv(LANGUAGE = oldLanguage) }, add = TRUE) - initAnalysisRuntime(dataset = dataset) - - returnVal <- runJaspResults(name, "", "null", jsonlite::toJSON(options), "null", paste0(name, "Internal")) + returnVal <- runJaspResults(name, "", "null", toJSON(options), "null", paste0(name, "Internal")) # always TRUE after jaspResults is merged into jaspBase jsonResults <- if (inherits(returnVal, c("jaspResultsR", "R6"))) { @@ -1139,7 +1071,7 @@ runAnalysis <- function(name, dataset, options, view = TRUE) { return(.pkgenv[["internal"]][[name]]) } -initAnalysisRuntime <- function(dataset, ...) { +initAnalysisRuntime <- function(dataset) { # dataset to be found in the analysis when it needs to be read .setInternal("dataset", dataset) } @@ -1211,14 +1143,14 @@ runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { if (jaspResultsCalledFromJasp()) { result <- list("options" = options, "analysis" = analysisName, "version" = version) - result <- jsonlite::toJSON(result, auto_unbox = TRUE, digits = NA, null="null", force = TRUE) + result <- toJSON(result) return(as.character(result)) } else { .initOutputDirs() + initAnalysisRuntime(dataset = data) moduleName <- base::strsplit(analysisName, "::")[[1]][[1]] qmlFile <- paste(.libPaths(), moduleName, "qml", qmlFile, sep="/") - print(qmlFile) options <- checkAnalysisOptions(qmlFile, options, version) print(options) .insertRbridgeIntoEnv(.GlobalEnv) @@ -1317,7 +1249,7 @@ getColumnCount <- function() { getColumnNames <- function() { dataset <- .getInternal("dataset") - return(colnames(dataset)) + return(as.array(colnames(dataset))) } #' @export @@ -1346,13 +1278,14 @@ getColumnType <- function(colName) { getColumnValues <- function(colName) { dataset <- .getInternal("dataset") - return(dataset[[colName]]) + return(as.array(dataset[[colName]])) } #' @export getColumnLabels <- function(colName) { dataset <- .getInternal("dataset") - return(unique(dataset[[colName]])) + labels <- unique(dataset[[colName]]) + return(as.array(labels)) } From f68d1c4bb1409c62b99d9844420ccae218a23f97 Mon Sep 17 00:00:00 2001 From: boutinb Date: Wed, 6 Mar 2024 12:59:59 +0100 Subject: [PATCH 4/5] print object --- DESCRIPTION | 4 ++-- R/common.R | 15 +++++++-------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4aae79d..4370c29 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,8 +34,7 @@ Imports: rvg, svglite, systemfonts, - withr, - jaspQmlR + withr Remotes: jasp-stats/jaspGraphs RoxygenNote: 7.2.3 @@ -45,5 +44,6 @@ LinkingTo: Rcpp RcppModules: jaspResults NeedsCompilation: yes Suggests: + jaspQmlR, testthat (>= 3.0.0) Config/testthat/edition: 3 diff --git a/R/common.R b/R/common.R index 649118c..63a5dc1 100644 --- a/R/common.R +++ b/R/common.R @@ -1007,7 +1007,7 @@ checkAnalysisOptions <- function(qmlFile, options, version) { args <- as.character(args) options <- jaspQmlR::checkOptions(args) - return(fromJSON(options)$options) + return(fromJSON(options)) } #' @export runAnalysis @@ -1049,7 +1049,7 @@ runAnalysis <- function(name, dataset, options, view = TRUE) { # if (view) # view(jsonResults) - return(returnVal$toRObject()) + return(list(rObject = returnVal$toRObject(), jsonResults=jsonResults)) #return(invisible(results)) } @@ -1151,15 +1151,16 @@ runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { initAnalysisRuntime(dataset = data) moduleName <- base::strsplit(analysisName, "::")[[1]][[1]] qmlFile <- paste(.libPaths(), moduleName, "qml", qmlFile, sep="/") - options <- checkAnalysisOptions(qmlFile, options, version) - print(options) + checkResult <- checkAnalysisOptions(qmlFile, options, version) .insertRbridgeIntoEnv(.GlobalEnv) - return(runAnalysis(analysisName, data, options)) + error <- as.character(checkResult$error) + if (error != "") + return(error) + return(runAnalysis(analysisName, data, checkResult$options)) } } - # functions / properties to replace JASP's rcpp functions / properties # These are not used in combination with getAnywhere() in the code so they cannot be found @@ -1178,7 +1179,6 @@ runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { env[[".allColumnNamesDataset"]] <- function(...) { dataset <- .getInternal("dataset") - dataset <- loadCorrectDataset(dataset) return(colnames(dataset)) } } @@ -1192,7 +1192,6 @@ runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { columns.as.factor = c(), all.columns = FALSE) { dataset <- .getInternal("dataset") - dataset <- loadCorrectDataset(dataset) if (all.columns) { columns <- colnames(dataset) From cbb56b517a5b1f1b2d28a4f732fd6059b206b0a9 Mon Sep 17 00:00:00 2001 From: boutinb Date: Tue, 12 Mar 2024 15:17:48 +0100 Subject: [PATCH 5/5] Better handling when dataset does not exist --- R/common.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/R/common.R b/R/common.R index 63a5dc1..38f155c 100644 --- a/R/common.R +++ b/R/common.R @@ -1241,6 +1241,9 @@ runWrappedAnalysis <- function(analysisName, qmlFile, data, options, version) { getColumnCount <- function() { dataset <- .getInternal("dataset") + if (!is.data.frame(dataset)) + return(0) + return(length(colnames(dataset))) } @@ -1248,6 +1251,10 @@ getColumnCount <- function() { getColumnNames <- function() { dataset <- .getInternal("dataset") + if (!is.data.frame(dataset)) { + return(array()) + } + return(as.array(colnames(dataset))) } @@ -1255,6 +1262,9 @@ getColumnNames <- function() { getColumnType <- function(colName) { dataset <- .getInternal("dataset") + if (!is.data.frame(dataset)) + return("unknown") + rawType <- sapply(myData, typeof)[[colName]] diffValues <- length(unique(dataset[[colName]])) @@ -1277,6 +1287,9 @@ getColumnType <- function(colName) { getColumnValues <- function(colName) { dataset <- .getInternal("dataset") + if (!is.data.frame(dataset)) + return(array()) + return(as.array(dataset[[colName]])) } @@ -1284,6 +1297,9 @@ getColumnValues <- function(colName) { getColumnLabels <- function(colName) { dataset <- .getInternal("dataset") + if (!is.data.frame(dataset)) + return(array()) + labels <- unique(dataset[[colName]]) return(as.array(labels)) }