diff --git a/DESCRIPTION b/DESCRIPTION index 8bd657dc..8e4116e7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,6 +24,7 @@ Imports: officer, pkgbuild, plyr, + pillar, qgraph, ragg, R6, @@ -34,6 +35,7 @@ Imports: rvg, svglite, systemfonts, + vctrs, withr Remotes: jasp-stats/jaspGraphs diff --git a/NAMESPACE b/NAMESPACE index dd2be29e..254efe2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,8 @@ S3method("[[<-",jaspContainerR) S3method("[[<-",jaspTableR) S3method(.RCodeInOptionsIsOk,default) S3method(.RCodeInOptionsIsOk,list) +S3method(as.numeric2,default) +S3method(as.numeric2,integer) S3method(decodeplot,"function") S3method(decodeplot,gDesc) S3method(decodeplot,gTree) @@ -18,6 +20,9 @@ S3method(decodeplot,jaspGraphsPlot) S3method(decodeplot,patchwork) S3method(decodeplot,qgraph) S3method(decodeplot,recordedplot) +S3method(format,jaspNominal) +S3method(format,jaspOrdinal) +S3method(format,jaspScale) S3method(gsubInteractionSymbol,character) S3method(gsubInteractionSymbol,list) S3method(ifElse,character) @@ -25,11 +30,74 @@ S3method(ifElse,factor) S3method(ifElse,integer) S3method(ifElse,numeric) S3method(ifElse,ordered) +S3method(jasp2r,data.frame) +S3method(jasp2r,default) +S3method(jasp2r,jaspNominal) +S3method(jasp2r,jaspOrdinal) +S3method(jasp2r,jaspScale) +S3method(obj_print_footer,jaspNominal) +S3method(obj_print_footer,jaspOrdinal) S3method(print,jaspObjR) +S3method(r2jasp,character) +S3method(r2jasp,data.frame) +S3method(r2jasp,default) +S3method(r2jasp,factor) +S3method(r2jasp,jaspNominal) +S3method(r2jasp,jaspOrdinal) +S3method(r2jasp,jaspScale) +S3method(r2jasp,jaspText) +S3method(r2jasp,logical) +S3method(r2jasp,numeric) +S3method(r2jasp,ordered) S3method(replaceNA,character) S3method(replaceNA,factor) S3method(replaceNA,numeric) S3method(replaceNA,ordered) +S3method(vec_cast,character.jaspNominal) +S3method(vec_cast,character.jaspOrdinal) +S3method(vec_cast,character.jaspScale) +S3method(vec_cast,character.jaspText) +S3method(vec_cast,double.jaspNominal) +S3method(vec_cast,double.jaspOrdinal) +S3method(vec_cast,double.jaspScale) +S3method(vec_cast,double.jaspText) +S3method(vec_cast,integer.jaspNominal) +S3method(vec_cast,integer.jaspOrdinal) +S3method(vec_cast,integer.jaspScale) +S3method(vec_cast,integer.jaspText) +S3method(vec_cast,jaspNominal.character) +S3method(vec_cast,jaspNominal.double) +S3method(vec_cast,jaspNominal.factor) +S3method(vec_cast,jaspNominal.integer) +S3method(vec_cast,jaspNominal.jaspNominal) +S3method(vec_cast,jaspNominal.jaspOrdinal) +S3method(vec_cast,jaspNominal.jaspScale) +S3method(vec_cast,jaspNominal.jaspText) +S3method(vec_cast,jaspNominal.logical) +S3method(vec_cast,jaspNominal.ordered) +S3method(vec_cast,jaspOrdinal.character) +S3method(vec_cast,jaspOrdinal.double) +S3method(vec_cast,jaspOrdinal.factor) +S3method(vec_cast,jaspOrdinal.integer) +S3method(vec_cast,jaspOrdinal.jaspNominal) +S3method(vec_cast,jaspOrdinal.jaspOrdinal) +S3method(vec_cast,jaspOrdinal.jaspScale) +S3method(vec_cast,jaspOrdinal.ordered) +S3method(vec_cast,jaspScale.character) +S3method(vec_cast,jaspScale.double) +S3method(vec_cast,jaspScale.factor) +S3method(vec_cast,jaspScale.integer) +S3method(vec_cast,jaspScale.jaspNominal) +S3method(vec_cast,jaspScale.jaspOrdinal) +S3method(vec_cast,jaspScale.jaspScale) +S3method(vec_cast,jaspScale.jaspText) +S3method(vec_cast,jaspScale.logical) +S3method(vec_cast,jaspScale.ordered) +S3method(vec_cast,logical.jaspScale) +S3method(vec_ptype_abbr,jaspNominal) +S3method(vec_ptype_abbr,jaspOrdinal) +S3method(vec_ptype_abbr,jaspScale) +S3method(vec_ptype_abbr,jaspText) S3method(zScores,factor) S3method(zScores,numeric) export("%setOrRetrieve%") @@ -60,6 +128,10 @@ export(VovkSellkeMPR) export(VovkSellkeMPROneSided) export(YeoJohnson) export(addRenvBeforeAfterDispatch) +export(as.numeric2) +export(asJaspNominal) +export(asJaspOrdinal) +export(asJaspScale) export(assignFunctionInPackage) export(betaDist) export(binomDist) @@ -73,6 +145,7 @@ export(createJaspQmlSource) export(createJaspReport) export(createJaspState) export(createJaspTable) +export(dataSetColumnSpecification) export(decodeColNames) export(decodeName) export(encodeColNames) @@ -81,6 +154,7 @@ export(fDist) export(fishZ) export(gammaDist) export(geomDist) +export(getDataSet) export(getOS) export(gsubInteractionSymbol) export(hasSubstring) @@ -92,14 +166,22 @@ export(interactionSymbol) export(invBoxCox) export(invFishZ) export(invLogit) +export(isJaspNominal) +export(isJaspOrdinal) +export(isJaspScale) +export(isJaspText) export(isRecomputed) export(isTryError) +export(jasp2r) export(jaspColumnR) export(jaspDeps) export(jaspFormula) export(jaspFormulaRhs) +export(jaspNominal) +export(jaspOrdinal) export(jaspQmlSourceR) export(jaspResultsCalledFromJasp) +export(jaspScale) export(logNormDist) export(logit) export(makeJaspFormula) @@ -109,11 +191,13 @@ export(normalDist) export(poisDist) export(powerTransform) export(progressbarTick) +export(r2jasp) export(readDataSetHeader) export(readDataSetToEnd) export(replaceNA) export(runJaspResults) export(runWrappedAnalysis) +export(setDataSet) export(startProgressbar) export(tDist) export(unifDist) @@ -122,4 +206,8 @@ export(v) export(weibullDist) export(zScores) importFrom(stats,na.omit) +importFrom(vctrs,obj_print_footer) +importFrom(vctrs,vec_cast) +importFrom(vctrs,vec_ptype2) +importFrom(vctrs,vec_ptype_abbr) useDynLib(jaspBase, .registration=TRUE) diff --git a/R/column-types.R b/R/column-types.R new file mode 100644 index 00000000..47adeea9 --- /dev/null +++ b/R/column-types.R @@ -0,0 +1,497 @@ +#' @name column-types +#' @rdname column-types +#' @importFrom vctrs vec_ptype2 vec_cast vec_ptype_abbr obj_print_footer +#' @title JASP Column Types +#' +#' @description Columns types in JASP. +#' @param x object to be coerced or tested. +#' @param values set of possible values (similar to `levels` in [factor()]). +#' @param labels set of labels of the values (similar to `labels` in [factor()]). +#' @param ... not used. +#' @param dataset Data frame or tibble that contains data. +#' +#' @details +#' JASP recognizes 3 main data types (Scale, Ordinal, Nominal), +#' with Nominal being further split between basic Nominal and Text. +#' These types roughly correspond to [numeric()], [ordered()], and [factor()]. +#' +#' However, the correspondence between the base R types is not 100%. Thus, when passing a dataset from R to a JASP analysis, +#' JASP converts columns to these JASP types. Information from these columns is used for validating the input of the analysis +#' to ensure that the behavior is identical between R syntax and JASP application. +#' +#' The conversion uses simple heuristics (e.g., [`numeric()`] columns are converted to [`jaspScale()`]). For overriding +#' these heuristics, it is possible to convert a column to a specific JASP type before passing it to an analysis. +#' +#' To make it easier to reason how are these column conversion rules used within JASP, use [`jasp2r()`] and [`r2jasp()`] +#' functions that implement the implicit conversion rules using S3 dispatch. +#' Alternatively, it is possible to use functions [`setDataSet()`], [`getDataSet()`], and [`dataSetColumnSpecification()`], +#' that allow you to explicitly pass the data set to JASP, retrieve it, and check the column meta-data. +#' +#' @example inst/examples/ex-column-types.R +NULL + + +# jaspScale ----- +newJaspScale <- function(x = double()) { + if (!rlang::is_double(x) && !rlang::is_integer(x)) { + rlang::abort("`x` must be a double or integer vector.") + } + type <- typeof(x) + vctrs::new_vctr(x, class = c("jaspScale", type)) +} + + +#' @rdname column-types +#' @export +jaspScale <- function(x = double()) { + if (!rlang::is_bare_double(x)) { + x <- tryCatch( + expr = vctrs::vec_cast(x, integer()), + error = function(e) vctrs::vec_cast(x, double()) + ) + } + newJaspScale(x) +} + +#' @rdname column-types +#' @export +isJaspScale <- function(x) { + inherits(x, "jaspScale") +} + +#' @export +vec_ptype_abbr.jaspScale <- function(x, ...) { + return("jspScl") +} + +#' @export +format.jaspScale <- function(x, ...) { + x <- vctrs::vec_data(x) + miss <- is.na(x) + infty <- is.infinite(x) + valid <- !miss# & !infty + + out <- rep(NA_character_, vctrs::vec_size(x)) + out[valid] <- format(x[valid], ...) + #out[miss] <- NA + out[infty] <- ifelse(x[infty] > 0, "\u221E", "-\u221E") + + return(out) +} + +#' @rdname column-types +#' @export +asJaspScale <- function(x, ...) { + vctrs::vec_cast(x, newJaspScale()) +} + +## Casting ---- +### to jaspScale ---- +#' @export +vec_cast.jaspScale.double <- function(x, to, ...) { jaspScale(x) } +#' @export +vec_cast.jaspScale.integer <- function(x, to, ...) { jaspScale(x) } +#' @export +vec_cast.jaspScale.character <- function(x, to, ...) { jaspScale(as.double(x)) } +#' @export +vec_cast.jaspScale.logical <- function(x, to, ...) { jaspScale(as.double(x)) } +#' @export +vec_cast.jaspScale.factor <- function(x, to, ...) { x |> as.character() |> as.double() |> jaspScale() } +#' @export +vec_cast.jaspScale.ordered <- function(x, to, ...) { x |> as.character() |> as.double() |> jaspScale() } + +### to R types---- +#' @export +vec_cast.double.jaspScale <- function(x, to, ...) { vctrs::vec_data(x) |> as.double() } +#' @export +vec_cast.integer.jaspScale <- function(x, to, ...) { vctrs::vec_data(x) |> as.integer() } +#' @export +vec_cast.character.jaspScale <- function(x, to, ...) { vctrs::vec_data(x) |> as.character() } +#' @export +vec_cast.logical.jaspScale <- function(x, to, ...) { vctrs::vec_data(x) |> as.logical() } + +# jaspOrdinal ---- +newJaspOrdinal <- function(x = integer(), values = integer(), labels = character()) { + if (!rlang::is_integer(x) || !rlang::is_character(labels)) + rlang::abort("`x` must be integer vectors, `labels` must be a character vector.") + + vctrs::new_vctr(x, values = values, labels = labels, class = "jaspOrdinal") +} + +#' @rdname column-types +#' @export +jaspOrdinal <- function(x = integer(), values = sort(unique(x)), labels = values) { + if (!all(na.omit(x) %in% values)) { + rlang::abort("`values` must be a superset of `x`.") + } + if (length(values) != length(labels)) { + rlang::abort("`values` and `labels` must be of same length.") + } + + x <- vctrs::vec_cast(x, integer()) + idx <- match(x, values) + values <- as.character(values) + labels <- as.character(labels) + + vctr <- newJaspOrdinal(x = idx, values = values, labels = labels) + + return(vctr) +} + +#' @rdname column-types +#' @export +isJaspOrdinal <- function(x) { + inherits(x, "jaspOrdinal") +} + +#' @export +vec_ptype_abbr.jaspOrdinal <- function(x, ...) { + return("jspOrd") +} + +#' @export +format.jaspOrdinal <- function(x, ...) { + lab <- attr(x, "labels") + x <- vctrs::vec_data(x) + + valid <- !is.na(x) + + out <- rep(NA_character_, vctrs::vec_size(x)) + out[valid] <- lab[x[valid]] + + return(out) +} + +#' @export +obj_print_footer.jaspOrdinal <- function(x, ...) { + val <- attr(x, "values") + lab <- attr(x, "labels") + + out <- paste(sprintf("%s(%s)", lab, val), collapse = " < ") + cat("Labels(Values):", out) +} + +#' @rdname column-types +#' @export +asJaspOrdinal <- function(x, ...) { + if(is.ordered(x)) { + vec_cast.jaspOrdinal.ordered(x, ...) + } else { + vctrs::vec_cast(x, newJaspOrdinal()) + } +} + + +## Casting ---- +### to jaspOrdinal ---- +#' @export +vec_cast.jaspOrdinal.double <- function(x, to, ...) { jaspOrdinal(x) } +#' @export +vec_cast.jaspOrdinal.integer <- function(x, to, ...) { jaspOrdinal(x) } +#' @export +vec_cast.jaspOrdinal.character <- function(x, to, ...) { + xx <- as.integer(x) + jaspOrdinal(xx) +} +#' @export +vec_cast.jaspOrdinal.factor <- function(x, to, ...) { + xx <- as.integer(x) + labels <- levels(x) + jaspOrdinal(xx, labels = labels) +} +#' @export +vec_cast.jaspOrdinal.ordered <- vec_cast.jaspOrdinal.factor + +### to R types ---- +#' @export +vec_cast.double.jaspOrdinal <- function(x, to, ...) { + values <- attr(x, "values") + x <- vctrs::vec_data(x) + as.double(values[x]) +} +#' @export +vec_cast.integer.jaspOrdinal <- function(x, to, ...) { + vec_cast.double.jaspOrdinal(x, to, ...) |> as.integer() +} +#' @export +vec_cast.character.jaspOrdinal <- function(x, to, ...) { + data <- vctrs::vec_data(x) + labels <- attr(x, "labels") + return(labels[data]) +} + +# jaspNominal(Text) ---- +newJaspNominal <- function(x = integer(), values = integer(), labels = character(), class = character()) { + if (!rlang::is_integer(x) || !rlang::is_character(labels)) + rlang::abort("`x` must be integer vectors, `labels` must be a character vector.") + + vctrs::new_vctr(x, values = values, labels = labels, class = c(class, "jaspNominal")) +} + +newJaspText <- function(x = integer(), values = character(), labels = character()) { + newJaspNominal(x = x, values = values, labels = labels, class = "jaspText") +} + +#' @rdname column-types +#' @export +jaspNominal <- function(x = integer(), values = sort(unique(x)), labels = values) { + if (!all(na.omit(x) %in% values)) { + rlang::abort("`values` must be a superset of `x`.") + } + if (length(values) != length(labels)) { + rlang::abort("`values` and `labels` must be of same length.") + } + + cast_integers <- try(vctrs::vec_cast(x, integer()), silent = TRUE) + idx <- match(x, values) + values <- as.character(values) + labels <- as.character(labels) + + if (isTryError(cast_integers)) { + labels <- as.character(labels) + vctr <- newJaspText(x = idx, values = values, labels = labels) + } else { + labels <- as.character(labels) + vctr <- newJaspNominal(x = idx, values = values, labels = labels) + } + + return(vctr) +} + +#' @rdname column-types +#' @export +isJaspNominal <- function(x) { + inherits(x, "jaspNominal") +} + +#' @rdname column-types +#' @export +isJaspText <- function(x) { + inherits(x, "jaspText") +} + +#' @export +vec_ptype_abbr.jaspNominal <- function(x, ...) { + return("jspNom") +} + +#' @export +vec_ptype_abbr.jaspText <- function(x, ...) { + return("jspTxt") +} + +#' @export +format.jaspNominal <- function(x, ...) { + lab <- attr(x, "labels") + x <- vctrs::vec_data(x) + + valid <- !is.na(x) + + out <- rep(NA_character_, vctrs::vec_size(x)) + out[valid] <- lab[x[valid]] + + return(out) +} + +#' @export +obj_print_footer.jaspNominal <- function(x, ...) { + val <- attr(x, "values") + lab <- attr(x, "labels") + + out <- paste(sprintf("%s(%s)", lab, val), collapse = ", ") + cat("Labels(Values):", out) +} + +#' @rdname column-types +#' @export +asJaspNominal <- function(x, ...) { + vctrs::vec_cast(x, newJaspNominal()) +} + + +## Casting ---- +### to jaspNominal ---- +#' @export +vec_cast.jaspNominal.double <- function(x, to, ...) { jaspNominal(x) } +#' @export +vec_cast.jaspNominal.integer <- function(x, to, ...) { jaspNominal(x) } +#' @export +vec_cast.jaspNominal.character <- function(x, to, ...) { jaspNominal(x) } +#' @export +vec_cast.jaspNominal.logical <- function(x, to, ...) { jaspNominal(x) } +#' @export +vec_cast.jaspNominal.factor <- function(x, to, ...) { + xx <- as.integer(x) + labels <- levels(x) + jaspNominal(xx, values = seq_along(labels), labels = labels) +} +#' @export +vec_cast.jaspNominal.ordered <- vec_cast.jaspNominal.factor + +### to R types ---- +#' @export +vec_cast.double.jaspNominal <- function(x, to, ...) { + data <- vctrs::vec_data(x) + values <- attr(x, "values") + values[data] |> as.double() +} +#' @export +vec_cast.integer.jaspNominal <- function(x, to, ...) { + vec_cast.double.jaspNominal(x, to, ...) |> as.integer() +} +#' @export +vec_cast.character.jaspNominal <- function(x, to, ...) { + data <- vctrs::vec_data(x) + labels <- attr(x, "labels") + return(labels[data]) +} +#' @export +vec_cast.double.jaspText <- vec_cast.double.jaspNominal +#' @export +vec_cast.integer.jaspText <- vec_cast.integer.jaspNominal +#' @export +vec_cast.character.jaspText <- vec_cast.character.jaspNominal + +# S3 conversions ---- +#' @rdname column-types +#' @export +jasp2r <- function(x) { + UseMethod("jasp2r") +} + +#' @export +jasp2r.default <- function(x) { + warning("Object is not of JASP type, no conversion done") + return(x) +} + +#' @export +jasp2r.data.frame <- function(x) { + out <- as.data.frame(lapply(x, jasp2r)) + colnames(out) <- colnames(x) + return(out) +} + +#' @export +jasp2r.jaspScale <- function(x) { + as.numeric2(x) +} + +#' @export +jasp2r.jaspOrdinal <- function(x) { + idx <- vctrs::vec_data(x) + values <- attr(x, "values") + labels <- attr(x, "labels") + ordered(values[idx], levels = values, labels = labels) +} + +#' @export +jasp2r.jaspNominal <- function(x) { + idx <- vctrs::vec_data(x) + values <- attr(x, "values") + labels <- attr(x, "labels") + factor(values[idx], levels = values, labels = labels) +} + +#' @rdname column-types +#' @export +r2jasp <- function(x) { + UseMethod("r2jasp") +} + +#' @export +r2jasp.default <- function(x) { + warning("Object is not of type that can be automatically converted to a JASP type.") + return(x) +} + +#' @export +r2jasp.data.frame <- function(x) { + out <- as.data.frame(lapply(x, r2jasp)) + colnames(out) <- colnames(x) + return(out) +} + +#' @export +r2jasp.jaspScale <- function(x) x +#' @export +r2jasp.jaspOrdinal <- function(x) x +#' @export +r2jasp.jaspNominal <- function(x) x +#' @export +r2jasp.jaspText <- function(x) x + +#' @export +r2jasp.numeric <- function(x) { + asJaspScale(x) +} + +#' @export +r2jasp.ordered <- function(x) { + asJaspOrdinal(x) +} + +#' @export +r2jasp.factor <- function(x) { + asJaspNominal(x) +} + +#' @export +r2jasp.character <- function(x) { + asJaspNominal(x) +} + +#' @export +r2jasp.logical <- function(x) { + asJaspNominal(x) +} + +# Casting between JASP types ---- + +#' @export +vec_cast.jaspScale.jaspScale <- function(x, to, ...) { x } +#' @export +vec_cast.jaspScale.jaspOrdinal <- function(x, to, ...) { x |> as.double() |> asJaspScale() } +#' @export +vec_cast.jaspScale.jaspNominal <- function(x, to, ...) { x |> as.double() |> asJaspScale() } +#' @export +vec_cast.jaspScale.jaspText <- function(x, to, ...) { x |> as.character() |> asJaspScale() } + +#' @export +vec_cast.jaspOrdinal.jaspScale <- function(x, to, ...) { x |> as.double() |> asJaspOrdinal() } +#' @export +vec_cast.jaspOrdinal.jaspOrdinal <- function(x, to, ...) { x } +#' @export +vec_cast.jaspOrdinal.jaspNominal <- function(x, to, ...) { + class(x) <- c("jaspOrdinal", "vctrs_vctr") + x +} + +#' @export +vec_cast.jaspNominal.jaspScale <- function(x, to, ...) { x |> as.double() |> asJaspNominal() } +#' @export +vec_cast.jaspNominal.jaspOrdinal <- function(x, to, ...) { + class(x) <- c("jaspNominal", "vctrs_vctr") + x +} +#' @export +vec_cast.jaspNominal.jaspNominal <- function(x, to, ...) { x } +#' @export +vec_cast.jaspNominal.jaspText <- function(x, to, ...) { x } + +# Corner cases ---- +# as.numeric2() preserves integers instead of converting them to doubles +#' @export +as.numeric2 <- function(x, ...) { + UseMethod("as.numeric2") +} + +#' @export +as.numeric2.default <- function(x, ...) { + as.numeric(x, ...) +} + +#' @export +as.numeric2.integer <- function(x, ...) { + as.integer(x, ...) +} diff --git a/R/common.R b/R/common.R index 537033ae..75b22907 100644 --- a/R/common.R +++ b/R/common.R @@ -274,7 +274,11 @@ isTryError <- function(obj){ if (all.columns == FALSE && is.null(columns) && is.null(columns.as.numeric) && is.null(columns.as.ordinal) && is.null(columns.as.factor)) return (data.frame()) - dataset <- .fromRCPP(".readDatasetToEndNative", unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns != FALSE) + if (isInsideJASP()) { + dataset <- .fromRCPP(".readDatasetToEndNative", unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns != FALSE) + } else { + dataset <- .readDataSetToEndFromR(unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns) + } dataset <- .excludeNaListwise(dataset, exclude.na.listwise) dataset @@ -291,7 +295,11 @@ isTryError <- function(obj){ if (all.columns == FALSE && is.null(columns) && is.null(columns.as.numeric) && is.null(columns.as.ordinal) && is.null(columns.as.factor)) return (data.frame()) - dataset <- .fromRCPP(".readDataSetHeaderNative", unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns != FALSE) + if (isInsideJASP()) { + dataset <- .fromRCPP(".readDataSetHeaderNative", unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns != FALSE) + } else { + dataset <- .readDataSetHeaderFromR(unlist(columns), unlist(columns.as.numeric), unlist(columns.as.ordinal), unlist(columns.as.factor), all.columns) + } dataset } @@ -539,7 +547,7 @@ jaspResultsStrings <- function() { base::tryCatch( base::load(location$relativePath), error=function(e) e - #,warning=function(w) w #Commented out because if there *is* a warning, which there of course shouldnt be, the state wont be loaded *at all*. + #,warning=function(w) w #Commented out because if there *is* a warning, which there of course shouldnt be, the state wont be loaded *at all*. ) } diff --git a/R/readDataSet.R b/R/readDataSet.R new file mode 100644 index 00000000..62898fa3 --- /dev/null +++ b/R/readDataSet.R @@ -0,0 +1,71 @@ +#' @rdname column-types +#' @export +setDataSet <- function(dataset) { + .internal[["dataset"]] <- r2jasp(dataset) +} + +#' @rdname column-types +#' @export +getDataSet <- function() { + return(.internal[["dataset"]]) +} + +#' @rdname column-types +#' @export +dataSetColumnSpecification <- function() { + dataset <- .readDataSetHeaderFromR(all.columns = TRUE) + if (is.null(dataset)) stop("No dataset set!") + + specification <- list() + for(i in seq_len(ncol(dataset))) { + cl <- class(dataset[[i]])[1] + specification[[i]] <- list( + name = colnames(dataset)[[i]], + type = cl, + values = if(cl == "jaspScale") NA else attr(dataset[[i]], "values"), + labels = if(cl == "jaspScale") NA else attr(dataset[[i]], "labels") + ) + } + return(specification) +} + +.readDataSetToEndFromR <- function(columns=NULL, columns.as.numeric=NULL, columns.as.ordinal=NULL, columns.as.factor=NULL, all.columns=FALSE, ...) { + dataset <- .internal[["dataset"]] + dataset <- .dataSetSubsetColumns(dataset, columns=columns, columns.as.numeric=columns.as.numeric, columns.as.ordinal=columns.as.ordinal, columns.as.factor=columns.as.factor, all.columns=all.columns, ...) + return(dataset) +} + +.readDataSetHeaderFromR <- function(columns=NULL, columns.as.numeric=NULL, columns.as.ordinal=NULL, columns.as.factor=NULL, all.columns=FALSE, ...) { + dataset <- .readDataSetToEndFromR(columns=columns, columns.as.numeric=columns.as.numeric, columns.as.ordinal=columns.as.ordinal, columns.as.factor=columns.as.factor, all.columns=all.columns, ...) + dataset <- dataset[NULL, ] + return(dataset) +} + +.dataSetSubsetColumns <- function(dataset, columns=NULL, columns.as.numeric=NULL, columns.as.ordinal=NULL, columns.as.factor=NULL, all.columns=FALSE, ...) { + if(!all.columns) { + cols <- unique(c(columns, columns.as.numeric, columns.as.ordinal, columns.as.factor)) + cols <- cols[cols %in% colnames(dataset)] + dataset <- dataset[, cols, drop = FALSE] + } else { + dataset <- jasp2r(dataset) + } + + dataset <- .convertColumns(dataset, columns, jasp2r) + dataset <- .convertColumns(dataset, columns.as.numeric, as.numeric2) + dataset <- .convertColumns(dataset, columns.as.ordinal, as.ordered) + dataset <- .convertColumns(dataset, columns.as.factor, as.factor ) + + return(dataset) +} + +.convertColumns <- function(dataset, columns, type) { + for(column in columns) { + data <- dataset[[column]] + if(!is.null(data)) { + dataset[[column]] <- type(data) + } else { + warning("Variable ", column, " not found!") + } + } + return(dataset) +} diff --git a/R/setOrRetrieve.R b/R/setOrRetrieve.R index 4dffdc38..fb226887 100644 --- a/R/setOrRetrieve.R +++ b/R/setOrRetrieve.R @@ -2,7 +2,8 @@ # It's not 100% clear if "address" is the best choice here, but it should be a little bit faster than constructing hashes using identical. # See also https://github.com/wch/r-source/blob/trunk/src/library/utils/src/hashtab.c recomputedHashtab = hashtab(type = "address", NULL), - lastRecomputed = TRUE + lastRecomputed = TRUE, + dataset = NULL ), parent = emptyenv()) saveHashOfJaspObject <- function(x) { diff --git a/inst/examples/ex-column-types.R b/inst/examples/ex-column-types.R new file mode 100644 index 00000000..92850f84 --- /dev/null +++ b/inst/examples/ex-column-types.R @@ -0,0 +1,30 @@ +# load mtcars +df <- mtcars +str(df) + +# by default numeric columns are converted to jaspScale +r2jasp(df) |> str() + +# change cyl to an ordinal variable +df$cyl <- jaspOrdinal(df$cyl, values = c(2, 4, 6, 8), labels = c("two", "four", "six", "eight")) +# change vs and am to nominal variables +df$vs <- jaspNominal(df$vs, labels = c("No", "Yes")) +df$am <- jaspNominal(df$am, labels = c("No", "Yes")) +# create a new variable that is a nominal text +df$group <- jaspNominal(rep(LETTERS[1:2], 16)) + +# factor and ordered will be converted to Nominal and Ordinal, respectively +df$gear <- as.factor(df$gear) +df$carb <- as.ordered(df$carb) + +str(df) + +# pass the data set to JASP +setDataSet(df) +# and retrieve it back +getDataSet() |> str() +# get the column specification of the set data frame as a list +dataSetColumnSpecification() + +# check how are these columns converted back to R types +getDataSet() |> jasp2r() |> str() diff --git a/man/column-types.Rd b/man/column-types.Rd new file mode 100644 index 00000000..3cec1670 --- /dev/null +++ b/man/column-types.Rd @@ -0,0 +1,114 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/column-types.R, R/readDataSet.R +\name{column-types} +\alias{column-types} +\alias{jaspScale} +\alias{isJaspScale} +\alias{asJaspScale} +\alias{jaspOrdinal} +\alias{isJaspOrdinal} +\alias{asJaspOrdinal} +\alias{jaspNominal} +\alias{isJaspNominal} +\alias{isJaspText} +\alias{asJaspNominal} +\alias{jasp2r} +\alias{r2jasp} +\alias{setDataSet} +\alias{getDataSet} +\alias{dataSetColumnSpecification} +\title{JASP Column Types} +\usage{ +jaspScale(x = double()) + +isJaspScale(x) + +asJaspScale(x, ...) + +jaspOrdinal(x = integer(), values = sort(unique(x)), labels = values) + +isJaspOrdinal(x) + +asJaspOrdinal(x, ...) + +jaspNominal(x = integer(), values = sort(unique(x)), labels = values) + +isJaspNominal(x) + +isJaspText(x) + +asJaspNominal(x, ...) + +jasp2r(x) + +r2jasp(x) + +setDataSet(dataset) + +getDataSet() + +dataSetColumnSpecification() +} +\arguments{ +\item{x}{object to be coerced or tested.} + +\item{...}{not used.} + +\item{values}{set of possible values (similar to \code{levels} in \code{\link[=factor]{factor()}}).} + +\item{labels}{set of labels of the values (similar to \code{labels} in \code{\link[=factor]{factor()}}).} + +\item{dataset}{Data frame or tibble that contains data.} +} +\description{ +Columns types in JASP. +} +\details{ +JASP recognizes 3 main data types (Scale, Ordinal, Nominal), +with Nominal being further split between basic Nominal and Text. +These types roughly correspond to \code{\link[=numeric]{numeric()}}, \code{\link[=ordered]{ordered()}}, and \code{\link[=factor]{factor()}}. + +However, the correspondence between the base R types is not 100\%. Thus, when passing a dataset from R to a JASP analysis, +JASP converts columns to these JASP types. Information from these columns is used for validating the input of the analysis +to ensure that the behavior is identical between R syntax and JASP application. + +The conversion uses simple heuristics (e.g., \code{\link[=numeric]{numeric()}} columns are converted to \code{\link[=jaspScale]{jaspScale()}}). For overriding +these heuristics, it is possible to convert a column to a specific JASP type before passing it to an analysis. + +To make it easier to reason how are these column conversion rules used within JASP, use \code{\link[=jasp2r]{jasp2r()}} and \code{\link[=r2jasp]{r2jasp()}} +functions that implement the implicit conversion rules using S3 dispatch. +Alternatively, it is possible to use functions \code{\link[=setDataSet]{setDataSet()}}, \code{\link[=getDataSet]{getDataSet()}}, and \code{\link[=dataSetColumnSpecification]{dataSetColumnSpecification()}}, +that allow you to explicitly pass the data set to JASP, retrieve it, and check the column meta-data. +} +\examples{ +# load mtcars +df <- mtcars +str(df) + +# by default numeric columns are converted to jaspScale +r2jasp(df) |> str() + +# change cyl to an ordinal variable +df$cyl <- jaspOrdinal(df$cyl, values = c(2, 4, 6, 8), labels = c("two", "four", "six", "eight")) +# change vs and am to nominal variables +df$vs <- jaspNominal(df$vs, labels = c("No", "Yes")) +df$am <- jaspNominal(df$am, labels = c("No", "Yes")) +# create a new variable that is a nominal text +df$group <- jaspNominal(rep(LETTERS[1:2], 16)) + +# factor and ordered will be converted to Nominal and Ordinal, respectively +df$gear <- as.factor(df$gear) +df$carb <- as.ordered(df$carb) + +str(df) + +# pass the data set to JASP +setDataSet(df) +# and retrieve it back +getDataSet() |> str() +# get the column specification of the set data frame as a list +dataSetColumnSpecification() + +# check how are these columns converted back to R types +getDataSet() |> jasp2r() |> str() +} diff --git a/tests/testthat/test-column-types.R b/tests/testthat/test-column-types.R new file mode 100644 index 00000000..e805971b --- /dev/null +++ b/tests/testthat/test-column-types.R @@ -0,0 +1,159 @@ +# jaspScale ---- +test_that("Converting jaspScale to R types works", { + x <- rnorm(10) + z <- jaspScale(x) + + expect_equal(as.numeric(z), x ) + expect_equal(as.integer(z), as.integer(x) ) + expect_equal(as.double(z), as.double(x) ) + expect_equal(as.character(z), as.character(x)) + expect_equal(as.factor(z), as.factor(x) ) + expect_equal(as.ordered(z), as.ordered(x) ) + expect_equal(as.logical(z), as.logical(x) ) +}) + +test_that("Converting R types to jaspScale works", { + expect_vector(asJaspScale(rnorm(10)), jaspScale(rnorm(10))) + expect_vector(asJaspScale(integer()), jaspScale(integer())) + expect_vector(asJaspScale(character()), jaspScale()) + + # these types should coerce to jaspScale the same way as to a double + types <- list( + numeric = rnorm(10), + integer = 1L:10L, + character = c("a", "b", 1, 2.3, NA), + logical = c(TRUE, FALSE, NA) + ) + + for (x in types) + expect_identical( + suppressWarnings(x |> asJaspScale() |> as.double()), + suppressWarnings(x |> as.double()) + ) + + # these types should convert differently to jaspScale + types <- list( + factor = factor(c("a", "b", 1, 2)), + ordered = ordered(c("a", "b", 1, 2)) + ) + + for (x in types) + expect_identical( + suppressWarnings(x |> asJaspScale() |> as.double()), + suppressWarnings(x |> as.character() |> as.double()) + ) +}) + +# jaspOrdinal ---- +test_that("Converting jaspOrdinal to R types works", { + x <- c(4, 6, 2, 2, 6, NA) + values <- c(2, 6, 4) + labels <- c("two", "six", "four") + nom <- jaspOrdinal(x, values = values, labels = labels) + + expect_equal(as.numeric(nom), x) + expect_equal(as.integer(nom), x) + expect_equal(as.double(nom), x) + expect_equal(as.character(nom), labels[match(x, values)]) + expect_equal(as.factor(nom), factor(x, levels = values, labels = labels)) + expect_equal(as.ordered(nom), ordered(x, levels = values, labels = labels)) + expect_error(as.logical(nom), regexp = "Can't convert `x` to ") +}) + +test_that("Converting R types to jaspOrdinal works", { + expect_vector (asJaspOrdinal(integer()), jaspOrdinal(integer())) + expect_error (rnorm(10) |> asJaspOrdinal(), regexp = "Can't convert from `x` to due to loss of precision.") + expect_error (letters |> jaspOrdinal(), regexp = "Can't convert `x` to .") + expect_warning(letters |> asJaspOrdinal(), regexp = "NAs introduced by coercion") +}) + +# jaspNominal ----- +test_that("Converting jaspNominal to R types works", { + x <- c(4, 6, 2, 2, 6, NA) + values <- c(2, 6, 4) + labels <- c("two", "six", "four") + nom <- jaspNominal(x, values = values, labels = labels) + + expect_equal(as.numeric(nom), x) + expect_equal(as.integer(nom), x) + expect_equal(as.double(nom), x) + expect_equal(as.character(nom), labels[match(x, values)]) + expect_equal(as.factor(nom), factor(x, levels = values, labels = labels)) + expect_equal(as.ordered(nom), ordered(x, levels = values, labels = labels)) + expect_error(as.logical(nom), regexp = "Can't convert `x` to ") +}) + +test_that("Converting R types to jaspNominal works", { + expect_vector(asJaspNominal(integer()), jaspNominal(integer())) + expect_vector(asJaspNominal(character()), jaspNominal(character())) +}) + +# auto converting ---- +test_that("jasp2r works", { + expect_vector(jaspScale() |> jasp2r(), numeric()) + expect_vector(jaspOrdinal() |> jasp2r(), factor(ordered=TRUE)) + expect_vector(jaspNominal() |> jasp2r(), factor()) +}) + +test_that("r2jasp works", { + expect_vector(numeric() |> r2jasp(), jaspScale()) + expect_vector(integer() |> r2jasp(), jaspScale(integer())) + expect_vector(double() |> r2jasp(), jaspScale()) + expect_vector(logical() |> r2jasp(), jaspNominal()) + expect_vector(factor() |> r2jasp(), jaspNominal()) + expect_vector(character() |> r2jasp(), newJaspText()) +}) + +# JASP to JASP ---- +test_that("from jaspScale works", { + x <- jaspScale(rnorm(3)) + y <- jaspScale(1:3) + + expect_equal(x |> asJaspScale(), x) + expect_equal(y |> asJaspScale(), y) + + expect_error (x |> asJaspOrdinal(), regexp = "Can't convert from `x` to due to loss of precision.") + expect_equal(y |> asJaspOrdinal(), jaspOrdinal(1:3)) + + expect_equal(x |> asJaspNominal(), x |> as.double() |> jaspNominal()) + expect_equal(y |> asJaspNominal(), y |> as.integer() |> jaspNominal()) +}) + +test_that("from jaspOrdinal works", { + x <- c(2, 6, 4, 2, 2, 6, 4) + values <- c(4, 6, 2) + labels <- letters[1:3] + ord <- jaspOrdinal(x = x, values = values, labels = labels) + + expect_equal(ord |> asJaspScale(), jaspScale(x)) + expect_equal(ord |> asJaspOrdinal(), ord) + expect_equal(ord |> asJaspNominal(), jaspNominal(x, values, labels)) +}) + +test_that("from jaspNominal works", { + x <- c(2, 6, 4, 2, 2, 6, 4) + values <- c(4, 6, 2) + labels <- letters[1:3] + nom <- jaspNominal(x = x, values = values, labels = labels) + + expect_equal(nom |> asJaspScale(), jaspScale(x)) + expect_equal(nom |> asJaspOrdinal(), jaspOrdinal(x, values, labels)) + expect_equal(nom |> asJaspNominal(), nom) +}) + +test_that("from jaspText works", { + x <- c("a", "b", "c", "1", "2.4") + txt <- jaspNominal(x) + + expect_warning(txt |> asJaspScale(), regexp = "NAs introduced by coercion") + expect_equal (suppressWarnings(txt |> asJaspScale() |> as.double()), suppressWarnings(as.double(x))) + expect_error (txt |> asJaspOrdinal(), regexp = "Can't convert `x` to .") + expect_equal (txt |> asJaspNominal(), txt) +}) + +test_that("as.numeric2 works as expected", { + num <- rnorm(3) + int <- 1L:3L + expect_vector(num |> as.numeric2(), double(), size = 3) + expect_vector(int |> as.numeric2(), integer(), size = 3) +})