From 1d14f575891a4d854f38bb35d0f3543739a08852 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Wed, 4 Dec 2024 18:41:53 +0100 Subject: [PATCH 1/7] Adding the parsing of ActivityInfo variable expressions and adding the functionality to the dplyr verbs `filter()` and `select()` to support formulas and selection respectively. --- R/eval.R | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++ R/records.R | 41 +++++++++++++++++++++--- 2 files changed, 127 insertions(+), 5 deletions(-) diff --git a/R/eval.R b/R/eval.R index 77849ae..e716253 100644 --- a/R/eval.R +++ b/R/eval.R @@ -29,6 +29,10 @@ toActivityInfoFormula <- function(.data, expr) { return(sprintf("%s", idVar)) } } else { + # ActivityInfo variable expression paths + if (pathValid(.data$formTree, chexpr2)) { + return(chexpr2) + } expr2 <- deparse(rlang::eval_tidy(exprQuo)) } } @@ -62,3 +66,90 @@ toActivityInfoFormula <- function(.data, expr) { stop(sprintf("TODO: %s", deparse(expr2))) } +parseActivityInfoVariable <- function(path) { + # Remove leading and trailing white spaces + path <- trimws(path) + + # Match sequences within square brackets or sequences of non-dot characters + pattern <- "\\[.*?\\]|[^\\.]+" + + matches <- gregexpr(pattern, path, perl = TRUE) + components <- regmatches(path, matches)[[1]] + + # Remove square brackets and trim white space + components <- trimws(gsub("\\[|\\]", "", components)) + + components +} + +findFieldIds <- function(formTree, currentFormId, pathComponents, collectedIds = list(), depth = 0) { + if (length(pathComponents) == 0) { + return(unlist(collectedIds)) + } + + # form schema + currentForm <- formTree$forms[[currentFormId]] + if (is.null(currentForm)) { + stop(paste("Form with ID", currentFormId, "not found in form tree.")) + } + + # Get next component + currentComponent <- pathComponents[1] + remainingComponents <- pathComponents[-1] + + if (depth == 0 && currentComponent == currentFormId) { + collectedIds <- currentFormId + return(findFieldIds(formTree, currentFormId, remainingComponents, collectedIds, depth + 1)) + } + + # Search form's elements + elementFound <- FALSE + for (element in currentForm$elements) { + + fieldMatch <- + element$id == currentComponent || + (!is.null(element$code) && !is.na(element$code) && element$code == currentComponent) || + trimws(element$label) == currentComponent + + if (fieldMatch) { + elementFound <- TRUE + collectedIds <- c(collectedIds, element$id) + + # If there are no more components, return the collected IDs + if (length(remainingComponents) == 0) { + return(unlist(collectedIds)) + } + + # If the element is a reference or subform, move to the referenced form + if (element$type == "reference" && !is.null(element$typeParameters$range)) { + refFormId <- element$typeParameters$range[[1]]$formId + return(findFieldIds(formTree, refFormId, remainingComponents, collectedIds)) + } else if (element$type == "subform" && !is.null(element$typeParameters$formId)) { + subformFormId <- element$typeParameters$formId + return(findFieldIds(formTree, subformFormId, remainingComponents, collectedIds)) + } else { + stop(paste("Cannot traverse non-reference field", element$label)) + } + } + + } + + # Did not match any element or form, stop with an error + stop(paste("Component", currentComponent, "not found in form", currentForm$label)) +} + +getPathIds <- function(formTree, path) { + pathComponents <- parseActivityInfoVariable(path) + rootFormId <- formTree$root + ids <- findFieldIds(formTree, rootFormId, pathComponents, collectedIds = list()) + ids +} + +pathValid <- function(formTree, path) { + tryCatch({ + getPathIds(formTree, path) + TRUE + }, error = function(e) { + FALSE + }) +} \ No newline at end of file diff --git a/R/records.R b/R/records.R index 881b97f..6f2f6a2 100644 --- a/R/records.R +++ b/R/records.R @@ -1506,10 +1506,6 @@ tbl_sum.activityInfo_tbl_df <- function(x, ...) { c("ActivityInfo tibble" = sprintf("Remote form: %s (%s)",tblLabel(attr(x, "remoteRecords")), attr(x, "remoteRecords")$formTree$root), NextMethod()) } -# select.tbl_activityInfoRemoteRecords <- function(x) { -# -# } - # ---- Source ---- @@ -1630,7 +1626,42 @@ dplyr::collect #' @export select.tbl_activityInfoRemoteRecords <- function(.data, ...) { if (!is.null(tblFilter(.data))||!is.null(tblSort(.data))) warning("Using select() after a filter or sort step. Be careful not to remove a required variable from your selection.") - + + # Extract variables to check against ActivityInfo variable expressions + vars <- unique(unlist(lapply(rlang::enquos(...), function(quo) { + var <- rlang::quo_squash(quo) + if (rlang::is_symbol(var) || is.character(var)) { + as.character(var) + } else { + NULL # Ignore other expressions like starts_with(), etc. + } + }))) + + existingVars <- names(.data$step$vars) + missingVars <- setdiff(vars, existingVars) + + # Extract valid ActivityInfo variable paths + validPaths <- list() + for (var in missingVars) { + ids <- tryCatch({ + getPathIds(.data$formTree, var) + }, error = function(e) { + NULL # Path is invalid + }) + if (!is.null(ids)) { + validPaths[[var]] <- paste(ids, collapse = ".") + } else { + warning("Invalid ActivityInfo variable path: ", var) + } + } + + if (length(validPaths)>0) { + newVars <- c(.data$step$vars, setNames(names(validPaths), names(validPaths))) + newColumns <- c(.data$step$columns, validPaths) + .data$step <- newStep(.data$step, newVars, newColumns) + } + + # replicating dplyr magic loc <- tidyselect::eval_select(rlang::expr(c(...)), .data) new_vars <- set_names(colnames(.data)[loc], names(loc)) From 6de9e467518ec5817aea0df6024f93b8f8d559c5 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Wed, 4 Dec 2024 18:52:41 +0100 Subject: [PATCH 2/7] removing additional dependency / import --- R/records.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/records.R b/R/records.R index 6f2f6a2..02b4484 100644 --- a/R/records.R +++ b/R/records.R @@ -1656,7 +1656,7 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { } if (length(validPaths)>0) { - newVars <- c(.data$step$vars, setNames(names(validPaths), names(validPaths))) + newVars <- c(.data$step$vars, set_names(names(validPaths), names(validPaths))) newColumns <- c(.data$step$columns, validPaths) .data$step <- newStep(.data$step, newVars, newColumns) } From fdd5179870a39bc3fe3aa4c1ecb7a16dc51990c6 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Thu, 5 Dec 2024 00:36:51 +0100 Subject: [PATCH 3/7] Implementing mutate() verb for activityInfoRemoteRecords that works with many formulas out of the box using AI functions and some R functions. Improvemnets to activityInfoFormula() --- R/eval.R | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++--- R/records.R | 39 ++++++++++++++++++++++++++--- 2 files changed, 101 insertions(+), 8 deletions(-) diff --git a/R/eval.R b/R/eval.R index e716253..0ac3674 100644 --- a/R/eval.R +++ b/R/eval.R @@ -1,3 +1,52 @@ +activityInfoFunctionNames <- c( + "CONCAT", + "IF", + "ISNUMBER", + "ISBLANK", + "SEARCH", + "VALUE", + "LOWER", + "TRIM", + "CONCAT", + "LEFT", + "RIGHT", + "MID", + "REGEXMATCH", + "REGEXEXTRACT", + "REGEXREPLACE", + "TEXT", + "DATE", + "YEAR", + "MONTH", + "DAY", + "YEARFRAC", + "TODAY", + "NOW", + "DATEVALUE", + "MONTHVALUE", + "WEEKVALUE", + "FORTNIGHTVALUE", + "ADDDATE", + "DAYS", + "SUM", + "ANY", + "AVERAGE", + "MAX", + "MIN", + "COUNT", + "COUNTDISTINCT", + "FIRST", + "LAST", + "TEXTJOIN", + "POWER", + "CEIL", + "FLOOR", + "COALESCE", + "GREAT_CIRCLE" +) + + + #' Convert an expression using columns in a remote records into an ActivityInfo style formula #' #' @description @@ -25,8 +74,8 @@ toActivityInfoFormula <- function(.data, expr) { if(grepl(x = idVar, pattern = "^[A-Za-z_][A-Za-z0-9_]*$")) { return(idVar) } else { - #return(sprintf("[%s]", idVar)) - return(sprintf("%s", idVar)) + return(sprintf("(%s)", idVar)) + #return(sprintf("%s", idVar)) } } else { # ActivityInfo variable expression paths @@ -40,16 +89,29 @@ toActivityInfoFormula <- function(.data, expr) { # Function calls if(is.call(expr2)) { fn <- as.character(expr2[[1]]) - if(fn %in% c("+", "-", "*", "/","==", "!=", ">", "<", ">=", "<=")) { + + if (fn %in% activityInfoFunctionNames) { + args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg)) + return(sprintf("%s(%s)", fn, paste(args, collapse = ", "))) + } else if(fn %in% c("+", "-", "*", "/","==", "!=", ">", "<", ">=", "<=", "&&", "||")) { # These binary infix operators use the same semantic and syntax in ActivityInfo return(sprintf("(%s %s %s)", toActivityInfoFormula(.data, !!expr2[[2]]), fn, toActivityInfoFormula(.data, !!expr2[[3]]))) + } else if(fn %in% c("&", "|")) { + # These binary infix operators use a slightly modified semantic and syntax in ActivityInfo + return(sprintf("(%s %s%s %s)", toActivityInfoFormula(.data, !!expr2[[2]]), fn, fn, toActivityInfoFormula(.data, !!expr2[[3]]))) + } else if(fn == "!") { + return(sprintf("%s(%s)", fn, toActivityInfoFormula(.data, !!expr2[[2]]))) + } else if(fn == "(") { + return(sprintf("(%s)", toActivityInfoFormula(.data, !!expr2[[2]]))) } else if(fn == "grepl") { # Translate a call to grepl to AI's REGEXMATCH() call <- match.call(definition = grepl, expr2) return(sprintf("REGEXMATCH(%s, %s)", toActivityInfoFormula(.data, !!call$x), toActivityInfoFormula(.data, !!call$pattern))) + } else if(fn == "paste0") { + args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg)) + return(sprintf("%s(%s)", "CONCAT", paste(args, collapse = ", "))) } else { stop("This function is not yet supported: ", fn) - #return(deparse(rlang::eval_tidy(exprQuo, data = columns))) } } diff --git a/R/records.R b/R/records.R index 02b4484..78fe956 100644 --- a/R/records.R +++ b/R/records.R @@ -1563,9 +1563,40 @@ summarise.tbl_activityInfoRemoteRecords <- function(.data, ...) { #' @export #' @importFrom dplyr mutate mutate.tbl_activityInfoRemoteRecords <- function(.data, ...) { - warn_collect("mutate") - .data <- collect(.data) - mutate(.data, ...) + + exprs <- rlang::enquos(...) + + tryCatch({ + result <- lapply(exprs, function(x) { + toActivityInfoFormula(.data, !!x) + }) + + mutatedVars <- names(result) + existingVars <- .data$step$vars + + existingColumns <- .data$step$columns + + newVars <- setdiff(mutatedVars, existingVars) + newColumns <- result[newVars] + + replacedVars <- mutatedVars[mutatedVars %in% existingVars] + replacedColumns <- result[replacedVars] + + unaffectedVars <- existingVars[!(existingVars %in% mutatedVars)] + unaffectedColumns <- existingColumns[unaffectedVars] + + combinedVars <- c(.data$step$vars, set_names(newVars, newVars)) + combinedColumns <- c(unaffectedColumns, replacedColumns, newColumns) + + .data$step <- newStep(parent = .data$step, vars = combinedVars, columns = combinedColumns) + + .data + }, + error = function(e) { + warn_collect("mutate", paste0("Could not convert r expression to an ActivityInfo formula so collecting data for dplyr::mutate(). ", e$message)) + .data <- collect(.data) + mutate(.data, ...) + }) } @@ -1658,7 +1689,7 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { if (length(validPaths)>0) { newVars <- c(.data$step$vars, set_names(names(validPaths), names(validPaths))) newColumns <- c(.data$step$columns, validPaths) - .data$step <- newStep(.data$step, newVars, newColumns) + .data$step <- newStep(parent = .data$step, vars = newVars, columns = newColumns) } # replicating dplyr magic From 9d37b9d9f579b69359d7e4910f5a54f7b269cc02 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Tue, 10 Dec 2024 14:37:47 +0100 Subject: [PATCH 4/7] Added reverse reference field, multiple reference field and tests --- R/formField.R | 76 +++++++++++++++++++++++++++++ R/forms.R | 8 ++- man/attachmentFieldSchema.Rd | 2 + man/barcodeFieldSchema.Rd | 2 + man/calculatedFieldSchema.Rd | 2 + man/dateFieldSchema.Rd | 2 + man/formFieldSchema.Rd | 2 + man/geopointFieldSchema.Rd | 2 + man/monthFieldSchema.Rd | 2 + man/multilineFieldSchema.Rd | 2 + man/multipleReferenceFieldSchema.Rd | 75 ++++++++++++++++++++++++++++ man/multipleSelectFieldSchema.Rd | 2 + man/quantityFieldSchema.Rd | 2 + man/referenceFieldSchema.Rd | 2 + man/reverseReferenceFieldSchema.Rd | 76 +++++++++++++++++++++++++++++ man/sectionFieldSchema.Rd | 2 + man/serialNumberFieldSchema.Rd | 2 + man/singleSelectFieldSchema.Rd | 2 + man/subformFieldSchema.Rd | 2 + man/userFieldSchema.Rd | 2 + man/weekFieldSchema.Rd | 2 + tests/testthat/test-formField.r | 11 +++-- tests/testthat/test-forms.R | 2 +- 23 files changed, 276 insertions(+), 6 deletions(-) create mode 100644 man/multipleReferenceFieldSchema.Rd create mode 100644 man/reverseReferenceFieldSchema.Rd diff --git a/R/formField.R b/R/formField.R index 080c557..8ad17e7 100644 --- a/R/formField.R +++ b/R/formField.R @@ -126,6 +126,10 @@ addFormFieldSchemaCustomClass <- function(e) { } else { class(e) <- c("activityInfoReferenceFieldSchema", class(e)) } + } else if (e$type == "reversereference") { + class(e) <- c("activityInfoReverseReferenceFieldSchema", class(e)) + } else if (e$type == "multiselectreference") { + class(e) <- c("activityInfoMultipleReferenceFieldSchema", class(e)) } else if (e$type == "section") { class(e) <- c("activityInfoSectionFieldSchema", class(e)) } @@ -627,6 +631,78 @@ referenceFieldSchema <- function(label, description = NULL, referencedFormId, co schema } + +#' Create a Multiple Reference field schema +#' +#' A multiple reference field is used to create a multiple select list of +#' reference records. For example, to create a field that indicates in a report +#' table, exactly which people were taking part in an activity. It will allow +#' multiple people to be selected in the field. This is a many-to-many +#' relationship +#' +#' @inheritParams formFieldSchema +#' @param referencedFormId The id of the referenced form +#' @family field schemas +#' @export +multipleReferenceFieldSchema <- function(label, description = NULL, referencedFormId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { + stopifnot("The reference form id must be a character string" = is.character(referencedFormId)&&length(referencedFormId)==1&&nchar(referencedFormId)>0) + schema <- do.call( + formFieldSchema, + args = c( + list(type = "multiselectreference"), + formFieldArgs(as.list(environment())), + list( + typeParameters = list( + "range" = list( + list( + "formId" = referencedFormId + ) + ) + ) + ) + ) + ) + + schema +} + + +#' Create a Reverse Reference field schema +#' +#' A reverse reference field is used to get records that reference the current +#' form. For example, a partner organization record could lookup and reverse +#' reference all the reports that are assigned to the partner. +#' +#' @inheritParams formFieldSchema +#' @param referencedFormId The id of the referenced form +#' @param referencedFieldId The id of the referenced field +#' @family field schemas +#' @export +reverseReferenceFieldSchema <- function(label, description = NULL, referencedFormId, referencedFieldId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { + stopifnot("The reverse reference form id must be a character string" = is.character(referencedFormId)&&length(referencedFormId)==1&&nchar(referencedFormId)>0) + stopifnot("The reverse reference field id must be a character string" = is.character(referencedFieldId)&&length(referencedFormId)==1&&nchar(referencedFormId)>0) + schema <- do.call( + formFieldSchema, + args = c( + list(type = "reversereference"), + formFieldArgs(as.list(environment())), + list( + typeParameters = list( + "formId" = referencedFormId, + "fieldId" = referencedFieldId + ) + ) + ) + ) + + schema +} + + + + + + #' Create a Geographic Point form field schema #' #' A Geographic Point field allow users to enter a geo-location with a certain diff --git a/R/forms.R b/R/forms.R index d3e8c50..f53c590 100644 --- a/R/forms.R +++ b/R/forms.R @@ -84,7 +84,8 @@ print.formSchema <- function(x, ...) { #' @export as.data.frame.formSchema <- function(x, row.names = NULL, optional = FALSE, ...) { nfields <- length(x$elements) - null2na <- function(y) if (is.null(y) || !nzchar(y)) NA else y + null2na <- function(y) tryCatch({if (is.null(y) || !nzchar(y)) NA else y}, error = function(e) {return(NA)}) + ifnullna <- function(y,z) {if (is.null(y)||is.na(y)) {z} else {y}} data.frame( row.names = row.names, @@ -101,7 +102,10 @@ as.data.frame.formSchema <- function(x, row.names = NULL, optional = FALSE, ...) relevanceCondition = sapply(x$elements, function(e) null2na(e$relevanceCondition)), fieldRequired = sapply(x$elements, function(e) null2na(e$required)), key = sapply(x$elements, function(e) identical(e$key, TRUE)), - referenceFormId = sapply(x$elements, function(e) null2na(e$typeParameters$range[[1]]$formId)), + referenceFormId = sapply(x$elements, function(e) ifnullna( + null2na(e$typeParameters$range[[1]]$formId), + null2na(e$typeParameters$formId))), + referenceFieldId = sapply(x$elements, function(e) null2na(e$typeParameters$fieldId)), formula = sapply(x$elements, function(e) null2na(e$typeParameters$formula)), dataEntryVisible = sapply(x$elements, function(e) !identical(e$dataEntryVisible, FALSE)), tableVisible = sapply(x$elements, function(e) !identical(e$tableVisible, FALSE)), diff --git a/man/attachmentFieldSchema.Rd b/man/attachmentFieldSchema.Rd index edc4df2..d069e3e 100644 --- a/man/attachmentFieldSchema.Rd +++ b/man/attachmentFieldSchema.Rd @@ -53,9 +53,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/barcodeFieldSchema.Rd b/man/barcodeFieldSchema.Rd index 9142ea3..da63a8f 100644 --- a/man/barcodeFieldSchema.Rd +++ b/man/barcodeFieldSchema.Rd @@ -53,9 +53,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/calculatedFieldSchema.Rd b/man/calculatedFieldSchema.Rd index 93dd850..5297443 100644 --- a/man/calculatedFieldSchema.Rd +++ b/man/calculatedFieldSchema.Rd @@ -51,9 +51,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/dateFieldSchema.Rd b/man/dateFieldSchema.Rd index 49705ae..899739f 100644 --- a/man/dateFieldSchema.Rd +++ b/man/dateFieldSchema.Rd @@ -54,9 +54,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/formFieldSchema.Rd b/man/formFieldSchema.Rd index bd729f1..9cba60d 100644 --- a/man/formFieldSchema.Rd +++ b/man/formFieldSchema.Rd @@ -61,9 +61,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/geopointFieldSchema.Rd b/man/geopointFieldSchema.Rd index 538a205..74fb295 100644 --- a/man/geopointFieldSchema.Rd +++ b/man/geopointFieldSchema.Rd @@ -68,9 +68,11 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/monthFieldSchema.Rd b/man/monthFieldSchema.Rd index 66b5d4c..ca0667a 100644 --- a/man/monthFieldSchema.Rd +++ b/man/monthFieldSchema.Rd @@ -53,9 +53,11 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{geopointFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/multilineFieldSchema.Rd b/man/multilineFieldSchema.Rd index 497faa3..21523cd 100644 --- a/man/multilineFieldSchema.Rd +++ b/man/multilineFieldSchema.Rd @@ -52,9 +52,11 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/multipleReferenceFieldSchema.Rd b/man/multipleReferenceFieldSchema.Rd new file mode 100644 index 0000000..8c8b760 --- /dev/null +++ b/man/multipleReferenceFieldSchema.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formField.R +\name{multipleReferenceFieldSchema} +\alias{multipleReferenceFieldSchema} +\title{Create a Multiple Reference field schema} +\usage{ +multipleReferenceFieldSchema( + label, + description = NULL, + referencedFormId, + code = NULL, + id = cuid(), + key = FALSE, + required = key, + hideFromEntry = FALSE, + hideInTable = FALSE, + relevanceRule = "", + validationRule = "", + reviewerOnly = FALSE +) +} +\arguments{ +\item{label}{The label of the form field} + +\item{description}{The description of the form field} + +\item{referencedFormId}{The id of the referenced form} + +\item{code}{The code name of the form field} + +\item{id}{The id of the form Field; default is to generate a new cuid} + +\item{key}{Whether the form field is a key field; default is FALSE} + +\item{required}{Whether the form field is required; default is FALSE} + +\item{hideFromEntry}{Whether the form field is hidden during data entry; default is FALSE} + +\item{hideInTable}{Whether the form field is hidden during data display; default is FALSE} + +\item{relevanceRule}{Relevance rules for the form field given as a single character string; default is ""} + +\item{validationRule}{Validation rules for the form field given as a single character string; default is ""} + +\item{reviewerOnly}{Whether the form field is for reviewers only; default is FALSE} +} +\description{ +A multiple reference field is used to create a multiple select list of +reference records. For example, to create a field that indicates in a report +table, exactly which people were taking part in an activity. It will allow +multiple people to be selected in the field. This is a many-to-many +relationship +} +\seealso{ +Other field schemas: +\code{\link{attachmentFieldSchema}()}, +\code{\link{barcodeFieldSchema}()}, +\code{\link{calculatedFieldSchema}()}, +\code{\link{dateFieldSchema}()}, +\code{\link{formFieldSchema}()}, +\code{\link{geopointFieldSchema}()}, +\code{\link{monthFieldSchema}()}, +\code{\link{multilineFieldSchema}()}, +\code{\link{multipleSelectFieldSchema}()}, +\code{\link{quantityFieldSchema}()}, +\code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, +\code{\link{sectionFieldSchema}()}, +\code{\link{serialNumberFieldSchema}()}, +\code{\link{singleSelectFieldSchema}()}, +\code{\link{subformFieldSchema}()}, +\code{\link{userFieldSchema}()}, +\code{\link{weekFieldSchema}()} +} +\concept{field schemas} diff --git a/man/multipleSelectFieldSchema.Rd b/man/multipleSelectFieldSchema.Rd index ee9d1e5..d1f4a59 100644 --- a/man/multipleSelectFieldSchema.Rd +++ b/man/multipleSelectFieldSchema.Rd @@ -59,8 +59,10 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/quantityFieldSchema.Rd b/man/quantityFieldSchema.Rd index a39c00e..4988d28 100644 --- a/man/quantityFieldSchema.Rd +++ b/man/quantityFieldSchema.Rd @@ -62,8 +62,10 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/referenceFieldSchema.Rd b/man/referenceFieldSchema.Rd index 3627f73..86e58e3 100644 --- a/man/referenceFieldSchema.Rd +++ b/man/referenceFieldSchema.Rd @@ -57,8 +57,10 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/reverseReferenceFieldSchema.Rd b/man/reverseReferenceFieldSchema.Rd new file mode 100644 index 0000000..3062aa1 --- /dev/null +++ b/man/reverseReferenceFieldSchema.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formField.R +\name{reverseReferenceFieldSchema} +\alias{reverseReferenceFieldSchema} +\title{Create a Reverse Reference field schema} +\usage{ +reverseReferenceFieldSchema( + label, + description = NULL, + referencedFormId, + referencedFieldId, + code = NULL, + id = cuid(), + key = FALSE, + required = key, + hideFromEntry = FALSE, + hideInTable = FALSE, + relevanceRule = "", + validationRule = "", + reviewerOnly = FALSE +) +} +\arguments{ +\item{label}{The label of the form field} + +\item{description}{The description of the form field} + +\item{referencedFormId}{The id of the referenced form} + +\item{referencedFieldId}{The id of the referenced field} + +\item{code}{The code name of the form field} + +\item{id}{The id of the form Field; default is to generate a new cuid} + +\item{key}{Whether the form field is a key field; default is FALSE} + +\item{required}{Whether the form field is required; default is FALSE} + +\item{hideFromEntry}{Whether the form field is hidden during data entry; default is FALSE} + +\item{hideInTable}{Whether the form field is hidden during data display; default is FALSE} + +\item{relevanceRule}{Relevance rules for the form field given as a single character string; default is ""} + +\item{validationRule}{Validation rules for the form field given as a single character string; default is ""} + +\item{reviewerOnly}{Whether the form field is for reviewers only; default is FALSE} +} +\description{ +A reverse reference field is used to get records that reference the current +form. For example, a partner organization record could lookup and reverse +reference all the reports that are assigned to the partner. +} +\seealso{ +Other field schemas: +\code{\link{attachmentFieldSchema}()}, +\code{\link{barcodeFieldSchema}()}, +\code{\link{calculatedFieldSchema}()}, +\code{\link{dateFieldSchema}()}, +\code{\link{formFieldSchema}()}, +\code{\link{geopointFieldSchema}()}, +\code{\link{monthFieldSchema}()}, +\code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, +\code{\link{multipleSelectFieldSchema}()}, +\code{\link{quantityFieldSchema}()}, +\code{\link{referenceFieldSchema}()}, +\code{\link{sectionFieldSchema}()}, +\code{\link{serialNumberFieldSchema}()}, +\code{\link{singleSelectFieldSchema}()}, +\code{\link{subformFieldSchema}()}, +\code{\link{userFieldSchema}()}, +\code{\link{weekFieldSchema}()} +} +\concept{field schemas} diff --git a/man/sectionFieldSchema.Rd b/man/sectionFieldSchema.Rd index 9c32be0..74a6e88 100644 --- a/man/sectionFieldSchema.Rd +++ b/man/sectionFieldSchema.Rd @@ -26,9 +26,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, \code{\link{subformFieldSchema}()}, diff --git a/man/serialNumberFieldSchema.Rd b/man/serialNumberFieldSchema.Rd index dad1b97..e7664e4 100644 --- a/man/serialNumberFieldSchema.Rd +++ b/man/serialNumberFieldSchema.Rd @@ -52,9 +52,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, \code{\link{subformFieldSchema}()}, diff --git a/man/singleSelectFieldSchema.Rd b/man/singleSelectFieldSchema.Rd index e24e966..d7835ab 100644 --- a/man/singleSelectFieldSchema.Rd +++ b/man/singleSelectFieldSchema.Rd @@ -62,9 +62,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{subformFieldSchema}()}, diff --git a/man/subformFieldSchema.Rd b/man/subformFieldSchema.Rd index 2184aca..ac2e04b 100644 --- a/man/subformFieldSchema.Rd +++ b/man/subformFieldSchema.Rd @@ -54,9 +54,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/userFieldSchema.Rd b/man/userFieldSchema.Rd index f230d43..5cdc4a1 100644 --- a/man/userFieldSchema.Rd +++ b/man/userFieldSchema.Rd @@ -62,9 +62,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/man/weekFieldSchema.Rd b/man/weekFieldSchema.Rd index 4d7c4cd..fdec364 100644 --- a/man/weekFieldSchema.Rd +++ b/man/weekFieldSchema.Rd @@ -56,9 +56,11 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, +\code{\link{reverseReferenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, \code{\link{singleSelectFieldSchema}()}, diff --git a/tests/testthat/test-formField.r b/tests/testthat/test-formField.r index 07abbff..36e8188 100644 --- a/tests/testthat/test-formField.r +++ b/tests/testthat/test-formField.r @@ -1,9 +1,6 @@ - testField <- function(fieldSchema) { testthat::expect_identical(length(class(fieldSchema)), 4L) - length(class(barcodeFieldSchema("Test"))) - databaseId = database$databaseId fmSchm <- formSchema(databaseId = databaseId, label = paste0("R form ",fieldSchema$label , " test ", cuid())) @@ -121,6 +118,14 @@ test_that("Test roundtrip of referenceFieldSchema()", { testField(referenceFieldSchema(label = "A referenceFieldSchema field", referencedFormId = "A dummy formId")) }) +test_that("Test roundtrip of reverseReferenceFieldSchema()", { + testField(reverseReferenceFieldSchema(label = "A reversedReferenceFieldSchema field", referencedFormId = "A dummy formId", referencedFieldId = "A dummy fieldId")) +}) + +test_that("Test roundtrip of multipleReferenceFieldSchema()", { + testField(multipleReferenceFieldSchema(label = "A multipleReferenceFieldSchema field to the person form", referencedFormId = personFormId)) +}) + test_that("Test roundtrip of sectionFieldSchema()", { testField(sectionFieldSchema(label = "A sectionFieldSchema field")) }) diff --git a/tests/testthat/test-forms.R b/tests/testthat/test-forms.R index f2e618e..55eec45 100644 --- a/tests/testthat/test-forms.R +++ b/tests/testthat/test-forms.R @@ -22,7 +22,7 @@ testthat::test_that("getFormSchema() and as.data.frame.formSchema() return a Sch output <- as.data.frame(output) - testthat::expect_true(inherits(output, "data.frame") & nrow(output) == 2 & ncol(output) == 17) + testthat::expect_true(inherits(output, "data.frame") & nrow(output) > 1 & ncol(output) > 10) testthat::expect_true(all(c( "databaseId", "formId", From 58a29f136665b9c6d10b62cddcf3a67703f0617f Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Tue, 10 Dec 2024 15:52:16 +0100 Subject: [PATCH 5/7] Updated select(), mutate(), and filter() and $ expansions to build activity info variable expressions from remote form objects and include those in formulas. Added and updated tests. Also fixed a bug as an empty form has no lastEdited date. --- NAMESPACE | 17 + R/eval.R | 431 ++++++++++++++++-- R/records.R | 147 +++--- man/activityInfoVariableExpression.Rd | 20 + man/getNextExpansions.Rd | 32 ++ man/toActivityInfoFormula.Rd | 48 +- .../_snaps/rmdOutput/TestMessages.html | 8 + tests/testthat/test-eval.R | 112 +++++ 8 files changed, 729 insertions(+), 86 deletions(-) create mode 100644 man/activityInfoVariableExpression.Rd create mode 100644 man/getNextExpansions.Rd create mode 100644 tests/testthat/test-eval.R diff --git a/NAMESPACE b/NAMESPACE index 9f078e8..67f0eb5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,12 @@ # Generated by roxygen2: do not edit by hand +S3method("$",activityInfoVariableExpression) +S3method("$",tbl_activityInfoRemoteRecords) +S3method(.DollarNames,activityInfoVariableExpression) +S3method(.DollarNames,tbl_activityInfoRemoteRecords) +S3method(activityInfoVariableExpression,activityInfoFormTree) +S3method(activityInfoVariableExpression,activityInfoVariableExpression) +S3method(activityInfoVariableExpression,character) S3method(addForm,character) S3method(addForm,default) S3method(addForm,formSchema) @@ -34,6 +41,10 @@ S3method(getDatabaseRole,character) S3method(getDatabaseRole,databaseTree) S3method(getDatabaseRoles,character) S3method(getDatabaseRoles,databaseTree) +S3method(getNextExpansions,activityInfoFormTree) +S3method(getNextExpansions,activityInfoVariableExpression) +S3method(getNextExpansions,character) +S3method(getNextExpansions,tbl_activityInfoRemoteRecords) S3method(getRecords,activityInfoFormSchema) S3method(getRecords,activityInfoFormTree) S3method(getRecords,activityInfo_tbl_df) @@ -55,6 +66,7 @@ S3method(mutate_,tbl_activityInfoRemoteRecords) S3method(nest_by,tbl_activityInfoRemoteRecords) S3method(print,activityInfoFormFieldSchema) S3method(print,activityInfoSelectOptions) +S3method(print,activityInfoVariableExpression) S3method(print,databaseTree) S3method(print,formSchema) S3method(pull,tbl_activityInfoRemoteRecords) @@ -107,6 +119,7 @@ export("%>%") export(activityInfoLogin) export(activityInfoRootUrl) export(activityInfoToken) +export(activityInfoVariableExpression) export(addDatabase) export(addDatabaseUser) export(addFilter) @@ -155,6 +168,7 @@ export(getDatabaseUsers) export(getDatabases) export(getFormSchema) export(getFormTree) +export(getNextExpansions) export(getQuantityTable) export(getRecord) export(getRecordHistory) @@ -167,6 +181,7 @@ export(migrateFieldData) export(minimalColumnStyle) export(monthFieldSchema) export(multilineFieldSchema) +export(multipleReferenceFieldSchema) export(multipleSelectFieldSchema) export(namedElementVarList) export(parameter) @@ -181,6 +196,7 @@ export(reference) export(referenceFieldSchema) export(relocateForm) export(resourcePermissions) +export(reverseReferenceFieldSchema) export(role) export(roleAssignment) export(roleFilter) @@ -293,6 +309,7 @@ importFrom(tidyselect,eval_select) importFrom(tidyselect,everything) importFrom(tidyselect,tidyselect_data_has_predicates) importFrom(tidyselect,tidyselect_data_proxy) +importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,lsf.str) importFrom(utils,read.table) diff --git a/R/eval.R b/R/eval.R index 0ac3674..9426d93 100644 --- a/R/eval.R +++ b/R/eval.R @@ -47,23 +47,61 @@ activityInfoFunctionNames <- c( -#' Convert an expression using columns in a remote records into an ActivityInfo style formula +#' Convert an expression using columns in a remote records into an ActivityInfo +#' style formula #' #' @description -#' This function attempts to convert an R expression using the columns of the -#' [activityinfo::getRecords] object into an ActivityInfo formula (as a string). +#' This function attempts to convert an R expression in the context of a +#' [activityinfo::getRecords] object into an ActivityInfo formula (as a +#' character string). +#' +#' It also supports ActivityInfo variable expressions like `[Form Field Label]` +#' written as a variable or derived from a getRecords object with $ syntax (see +#' example). +#' +#' It will check if the field/variable/column is available and whether the +#' functions used are in a list of supported functions but does no syntax +#' checking during translation. +#' +#' This function is used to implement the mutate() and filter() dplyr verbs. #' #' @param .data the remote records object fetched with getRecords(). #' @param expr the expression to convert +#' @param rootEnvironment the original caller environment where the data remote +#' records object resides +#' +#' @examples +#' \dontrun{ +#' +#' x <- getRecords(formId) +#' +#' # Filter out records where the partner organization in BeDataDriven using $ +#' x %>% +#' mutate(new_field = x$`[Partner organization]`$`[Name]`) %>% +#' filter(new_field == "BeDataDriven") +#' +#' # Create a label for use in a report that prefixes the partner name using +#' # a variable name and the CONCAT() function. +#' x %>% +#' mutate(new_field = `[Partner organization].[Name]`) %>% +#' mutate(report_label = CONCAT("Partner organization: ", new_field)) +#' +#' # Get the text of an expression +#' aiFormula <- toActivityInfoFormula(x, IF(ISBLANK(x$`[Partner organization]`), +#' "No partner specified", x$`[Partner organization]`$`[Name]`)) +#' +#' # returns "IF(ISBLANK((ce844hgm3x4xtgr5)), \"No partner specified\", +#' # (ce844hgm3x4xtgr5.c4cx7l663x4xtgr6))" +#' } #' #' @export -toActivityInfoFormula <- function(.data, expr) { - +toActivityInfoFormula <- function(.data, expr, rootEnvironment = parent.frame()) { stopifnot("tbl_activityInfoRemoteRecords" %in% class(.data)) columns <- tblColumns(.data) exprQuo <- rlang::enquo(expr) expr2 <- rlang::quo_get_expr(exprQuo) + formTree <- .data[["formTree"]] # Symbols: handle variable names if(is.symbol(expr2)) { @@ -77,12 +115,26 @@ toActivityInfoFormula <- function(.data, expr) { return(sprintf("(%s)", idVar)) #return(sprintf("%s", idVar)) } + } else if (exists(as.character(expr2), envir = rootEnvironment, inherits = TRUE)) { + result <- rlang::eval_tidy(expr2, env = rootEnvironment) + if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + return(sprintf("(%s)",paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = "."))) + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + return(sprintf("%s", result)) + } else { + expr2 <- deparse(rlang::eval_tidy(exprQuo)) + } } else { - # ActivityInfo variable expression paths - if (pathValid(.data$formTree, chexpr2)) { - return(chexpr2) + pathIds <- tryCatch({ + getPathIds(formTree, as.character(expr2)) + }, error = function(e) { + NULL + }) + if (is.null(pathIds)) { + stop('Cannot evaluate: ', as.character(expr2)) + } else { + return(paste(c(formTree$root, pathIds), collapse = ".")) } - expr2 <- deparse(rlang::eval_tidy(exprQuo)) } } @@ -90,25 +142,44 @@ toActivityInfoFormula <- function(.data, expr) { if(is.call(expr2)) { fn <- as.character(expr2[[1]]) - if (fn %in% activityInfoFunctionNames) { - args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg)) + if (fn == "$") { + result = rlang::eval_tidy(expr2, env = rootEnvironment) + if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + return(sprintf("%s",paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = "."))) + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + return(sprintf("%s", result)) + } + } else if (fn %in% activityInfoFunctionNames) { + args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg, rootEnvironment = rootEnvironment)) return(sprintf("%s(%s)", fn, paste(args, collapse = ", "))) } else if(fn %in% c("+", "-", "*", "/","==", "!=", ">", "<", ">=", "<=", "&&", "||")) { # These binary infix operators use the same semantic and syntax in ActivityInfo - return(sprintf("(%s %s %s)", toActivityInfoFormula(.data, !!expr2[[2]]), fn, toActivityInfoFormula(.data, !!expr2[[3]]))) + return(sprintf("(%s %s %s)", + toActivityInfoFormula(.data, !!expr2[[2]], rootEnvironment = rootEnvironment), + fn, + toActivityInfoFormula(.data, !!expr2[[3]], rootEnvironment = rootEnvironment))) } else if(fn %in% c("&", "|")) { # These binary infix operators use a slightly modified semantic and syntax in ActivityInfo - return(sprintf("(%s %s%s %s)", toActivityInfoFormula(.data, !!expr2[[2]]), fn, fn, toActivityInfoFormula(.data, !!expr2[[3]]))) + return(sprintf("(%s %s%s %s)", + toActivityInfoFormula(.data, !!expr2[[2]], rootEnvironment = rootEnvironment), + fn, + fn, + toActivityInfoFormula(.data, !!expr2[[3]], rootEnvironment = rootEnvironment))) } else if(fn == "!") { - return(sprintf("%s(%s)", fn, toActivityInfoFormula(.data, !!expr2[[2]]))) + return(sprintf("%s(%s)", + fn, + toActivityInfoFormula(.data, !!expr2[[2]], rootEnvironment = rootEnvironment))) } else if(fn == "(") { - return(sprintf("(%s)", toActivityInfoFormula(.data, !!expr2[[2]]))) + return(sprintf("(%s)", + toActivityInfoFormula(.data, !!expr2[[2]], rootEnvironment = rootEnvironment))) } else if(fn == "grepl") { # Translate a call to grepl to AI's REGEXMATCH() call <- match.call(definition = grepl, expr2) - return(sprintf("REGEXMATCH(%s, %s)", toActivityInfoFormula(.data, !!call$x), toActivityInfoFormula(.data, !!call$pattern))) + return(sprintf("REGEXMATCH(%s, %s)", + toActivityInfoFormula(.data, !!call$x, rootEnvironment = rootEnvironment), + toActivityInfoFormula(.data, !!call$pattern, rootEnvironment = rootEnvironment))) } else if(fn == "paste0") { - args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg)) + args <- lapply(as.list(expr2)[-1], function(arg) toActivityInfoFormula(.data, !!arg, rootEnvironment = rootEnvironment)) return(sprintf("%s(%s)", "CONCAT", paste(args, collapse = ", "))) } else { stop("This function is not yet supported: ", fn) @@ -117,7 +188,7 @@ toActivityInfoFormula <- function(.data, expr) { # Literals: evaluate to be sure we've got the literal. Just deparse, R and ActivityInfo use the same literal syntax # Currently to do not support lists, better to do that in the context of the handling of functions like match or %in%. - if(is.character(expr2) || is.numeric(expr2)) { + if(is.character(expr2) || is.numeric(expr2) || is.logical(expr2)) { expr2 <- rlang::eval_tidy(exprQuo) if(length(expr2) != 1) { stop(sprintf("The expression %s has a length of %d", deparse(expr2), length(expr2))) @@ -128,18 +199,30 @@ toActivityInfoFormula <- function(.data, expr) { stop(sprintf("TODO: %s", deparse(expr2))) } +parentSymbols = c("@parent", "@Parent", "Parent") + parseActivityInfoVariable <- function(path) { # Remove leading and trailing white spaces path <- trimws(path) # Match sequences within square brackets or sequences of non-dot characters - pattern <- "\\[.*?\\]|[^\\.]+" + pattern <- "\\[[^\\[\\]]*\\]|[^\\.]+" matches <- gregexpr(pattern, path, perl = TRUE) components <- regmatches(path, matches)[[1]] - # Remove square brackets and trim white space - components <- trimws(gsub("\\[|\\]", "", components)) + # Remove only the outer square brackets for each component + components <- sapply(components, function(component) { + if (startsWith(component, "[") && endsWith(component, "]")) { + # Remove only the outermost square brackets + substring(component, 2, nchar(component) - 1) + } else { + component + } + }, USE.NAMES = FALSE) + + # Trim white space from each component + components <- trimws(components) components } @@ -157,10 +240,11 @@ findFieldIds <- function(formTree, currentFormId, pathComponents, collectedIds = # Get next component currentComponent <- pathComponents[1] + names(currentComponent) <- currentFormId remainingComponents <- pathComponents[-1] if (depth == 0 && currentComponent == currentFormId) { - collectedIds <- currentFormId + collectedIds <- currentComponent return(findFieldIds(formTree, currentFormId, remainingComponents, collectedIds, depth + 1)) } @@ -175,7 +259,7 @@ findFieldIds <- function(formTree, currentFormId, pathComponents, collectedIds = if (fieldMatch) { elementFound <- TRUE - collectedIds <- c(collectedIds, element$id) + collectedIds <- c(collectedIds, set_names(element$id, names(currentComponent))) # If there are no more components, return the collected IDs if (length(remainingComponents) == 0) { @@ -183,17 +267,44 @@ findFieldIds <- function(formTree, currentFormId, pathComponents, collectedIds = } # If the element is a reference or subform, move to the referenced form - if (element$type == "reference" && !is.null(element$typeParameters$range)) { - refFormId <- element$typeParameters$range[[1]]$formId + + refFormId <- getFieldReferenceFormId(element) + + if (!is.null(refFormId)) { return(findFieldIds(formTree, refFormId, remainingComponents, collectedIds)) - } else if (element$type == "subform" && !is.null(element$typeParameters$formId)) { - subformFormId <- element$typeParameters$formId - return(findFieldIds(formTree, subformFormId, remainingComponents, collectedIds)) } else { stop(paste("Cannot traverse non-reference field", element$label)) } + + stop(paste("Cannot traverse non-reference field", element$label)) + } + } + + if (currentComponent == '_id') { + collectedIds <- c(collectedIds, currentComponent) + if (length(remainingComponents) == 0) { + return(unlist(collectedIds)) + } else { + stop("Cannot traverse `_id` column.") + } + } + + if (currentComponent == '_lastEditTime') { + collectedIds <- c(collectedIds, currentComponent) + if (length(remainingComponents) == 0) { + return(unlist(collectedIds)) + } else { + stop("Cannot traverse `_lastEditTime` column.") + } + } + + if (!is.null(currentForm$parentFormId)&¤tComponent %in% parentSymbols) { + collectedIds <- c(collectedIds, currentComponent) + if (length(remainingComponents) == 0) { + return(unlist(collectedIds)) + } else { + return(findFieldIds(formTree, currentForm$parentFormId, remainingComponents, collectedIds)) } - } # Did not match any element or form, stop with an error @@ -214,4 +325,264 @@ pathValid <- function(formTree, path) { }, error = function(e) { FALSE }) -} \ No newline at end of file +} + + +#' Get next possible expansions from an ActivityInfo variable expression or form id +#' +#' @description +#' +#' A simple helper function to get the variables/columns available from a form +#' or reference field. +#' +#' @param x An ActivityInfo get records object, form id, or form tree. +#' @param path A variable expression (path) or form ID. +#' +#' @return A character vector of possible next expansions (field labels, IDs, or codes). +#' +#' @examples +#' \dontrun{ +#' +#' x <- getRecords(formId) +#' +#' # Get a list of fields available from the "Office administrator" reference +#' # form, e.g. from the Staff form +#' available_fields <- getNextExpansions(x, "[Office administrator]") +#' +#' } +#' +#' @export +getNextExpansions <- function(x, path = NULL) { + UseMethod("getNextExpansions") +} + +#' @export +getNextExpansions.character <- function(x, path = NULL) { + getNextExpansions(getFormTree(x), path) +} + +#' @export +getNextExpansions.tbl_activityInfoRemoteRecords <- function(x, path = NULL) { + getNextExpansions(x$formTree, path) +} + +#' @export +getNextExpansions.activityInfoFormTree <- function(x, path = NULL) { + expr <- activityInfoVariableExpression(x, path) + getNextExpansions(expr) +} + +# do not use path argument +#' @export +getNextExpansions.activityInfoVariableExpression <- function(x, path = NULL) { + expr <- x + + formTree <- expr[["formTree"]] + + fieldIds <- expr[["pathIds"]] + formIds <- names(fieldIds) + + lastFieldId <- expr[["lastId"]] + currentFormId <- tail(formIds, n = 1) + + currentFormSchema <- formTree$forms[[currentFormId]] + + field <- NULL + for (el in currentFormSchema$elements) { + if (el$id == lastFieldId) { + field <- el + break + } + } + + if (is.null(field)) { + + if (lastFieldId %in% c("_id", "_lastEditTime")) { + return(character(0)) + } else if (!is.null(currentFormSchema$parentFormId)&&(lastFieldId %in% parentSymbols)) { + return(getFormExpansions(formSchema = formTree$forms[[currentFormSchema$parentFormId]])) + } + + stop("Cannot expand path (", expr[["currentPath"]], ") in form `", currentFormId,"`.") + } + + nextFormId <- getFieldReferenceFormId(field) + if (is.null(nextFormId)) return(character(0)) + + getFormExpansions(formSchema = formTree$forms[[nextFormId]]) +} + +getFormExpansions <- function(formSchema) { + stopifnot("Invalid form schema passed to getFormExpansions()." = "activityInfoFormSchema" %in% class(formSchema)) + + expansions <- c("_id", "_lastEditTime") + + if (!is.null(formSchema$parentFormId)) { + expansions <- c(expansions, "@parent") + } + + for (el in formSchema$elements) { + expansions <- c(expansions, el$id, sprintf("[%s]",el$label)) + if (!is.null(el$code)) { + expansions <- c(expansions, el$code) + } + } + + names(expansions) <- rep(formSchema$id, length(expansions)) + + expansions +} + +getFieldReferenceFormId <- function(field) { + stopifnot("getFieldReferenceFormId() requires an activityInfoFormFieldSchema" = "activityInfoFormFieldSchema" %in% class(field)) + if ((field$type == "multiselectreference"||field$type == "reference") && !is.null(field$typeParameters$range)) { + return(field$typeParameters$range[[1]]$formId) + } else if ((field$type == "subform"||field$type == "reversereference") && !is.null(field$typeParameters$formId)) { + return(field$typeParameters$formId) + } + return(NULL) +} + +#' An ActivityInfo variable expression +#' +#' @description +#' A helper object to get a reference to variables/columns available from a form +#' or reference field. These expressions support the $ syntax in R so that the +#' user can interactively expand reference and sub-form fields. +#' +#' This is also returned when using $ in a getRecords() object. +#' +#' @param x An ActivityInfo form id, form tree, or another ActivityInfo variable expression. +#' @param path The next valid element/name in the variable expression or the root form ID (optional). +#' +#' @export +activityInfoVariableExpression <- function(x, path = NULL) { + UseMethod("activityInfoVariableExpression") +} + +#' @export +activityInfoVariableExpression.character <- function(x, path = NULL) { + activityInfoVariableExpression(getFormTree(x), path) +} + +#' @export +activityInfoVariableExpression.activityInfoFormTree <- function(x, path = NULL) { + formTree <- x + + if (is.null(path)) { + stop("A NULL value passed as an ActivityInfo variable expression.") + } + + pathIds <- getPathIds(formTree, path) + lastId <- tail(pathIds, n = 1) + + x <- structure( + list( + "formTree" = formTree, + "currentPath" = path, + "pathIds" = pathIds, + "lastId" = lastId + ), + class = "activityInfoVariableExpression" + ) + + x[["nextExpansion"]] <- getNextExpansions(x) + + x[["activityInfoColumn"]] <- paste(c(formTree$root, pathIds), collapse = ".") + + x +} + +#' @export +activityInfoVariableExpression.activityInfoVariableExpression <- function(x, path = NULL) { + expr <- x + + if (is.null(path)) return(expr) + activityInfoVariableExpression(expr[['formTree']], path) +} + +#' @export +`$.activityInfoVariableExpression` <- function(x, name) { + nm <- as.character(substitute(name)) + + if (nm %in% base::names(x)) { + return(x[[nm]]) + } + + if (nm %in% x[["nextExpansion"]]) { + return(activityInfoVariableExpression(x, sprintf("%s.%s", x[["currentPath"]], nm))) + } + + stop("Invalid element: ", name) +} + +#' @export +print.activityInfoVariableExpression <- function(x, ...) { + expr <- x + cat("ActivityInfo variable expression\n") + cat(sprintf(" Database id: %s\n", expr[["formTree"]]$forms[[expr[["formTree"]]$root]]$databaseId)) + cat(sprintf(" Root form id: %s\n", expr[["formTree"]]$forms[[expr[["formTree"]]$root]]$id)) + cat(sprintf(" Path: %s\n", expr[["currentPath"]])) + cat(sprintf(" Id path: %s\n", expr[["activityInfoColumn"]])) + + invisible() +} + +#' @export +#' @importFrom utils .DollarNames +.DollarNames.activityInfoVariableExpression <- function(x, pattern = "") { + vars <- c(x[["nextExpansion"]]) + # Add backticks to variables needing escaping + # vars <- ifelse(grepl("[^A-Za-z0-9_.]", vars), paste0("`", vars, "`"), vars) + vars[grep(pattern, vars)] +} + +#' @export +`$.tbl_activityInfoRemoteRecords` <- function(x, name) { + nm <- as.character(substitute(name)) + + if (nm %in% base::names(x)) { + return(x[[nm]]) + } + + if (nm %in% x[['step']][['vars']]) { + expr <- tryCatch({ + activityInfoVariableExpression(x[['formTree']], x[['step']][['columns']][[nm]]) + }, + error = function(e) { + expr <- x[['step']][['columns']][[nm]] + class(expr) <- c("activityInfoFormulaExpression", class(expr)) + attr(expr, 'columnName') <- nm + attr(expr, 'root') <- x$formTree$root + return(expr) + }) + + return(expr) + } + + nextExpansion <- getFormExpansions(x[['formTree']]$forms[[x[['formTree']]$root]]) + + if (nm %in% nextExpansion) { + + return(activityInfoVariableExpression(x[['formTree']], nm)) + } + + stop("Invalid element: ", name) + + return(NULL) +} + +#' @export +.DollarNames.tbl_activityInfoRemoteRecords <- function(x, pattern = "") { + existingVars <- names(x[['step']]$vars) + nextExpansion <- getFormExpansions(x[['formTree']]$forms[[x[['formTree']]$root]]) + + # Combine existing vars and next expansions + vars <- c(existingVars, nextExpansion) + + # Apply filtering based on the provided pattern + vars[grep(pattern, vars)] +} + + + diff --git a/R/records.R b/R/records.R index 78fe956..ad8291e 100644 --- a/R/records.R +++ b/R/records.R @@ -765,9 +765,9 @@ dim.activityInfoFormTree <- function(x) { #' @export dimnames.tbl_activityInfoRemoteRecords <- function(x) { - if(!is.null(x$step$window)&&x$step$window[2]>0) { + if(!is.null(x[['step']]$window)&&x[['step']]$window[2]>0) { list( - as.character(1:x$step$window[2]), + as.character(1:x[['step']]$window[2]), unname(tblNames(x)) ) } else { @@ -780,9 +780,9 @@ dimnames.tbl_activityInfoRemoteRecords <- function(x) { #' @export dim.tbl_activityInfoRemoteRecords <- function(x) { - if (!is.null(x$step$window)) { + if (!is.null(x[['step']]$window)) { c( - min(x$step$window[2], x$totalRecords), + min(x[['step']]$window[2], x$totalRecords), length(tblNames(x)) ) } else { @@ -936,7 +936,7 @@ varNames.activityInfoFormSchema <- function(x, style = defaultColumnStyle(), add #' @exportS3Method varNames tbl_activityInfoRemoteRecords varNames.tbl_activityInfoRemoteRecords <- function(x, style = NULL, addNames = TRUE) { - y <- x$step$vars + y <- x[['step']]$vars if (!addNames) { unname(y) } @@ -1173,7 +1173,10 @@ getTotalLastEditTime <- function(formTree) { df <- queryTable(formTree$root, columns = list("id"="_id", "lastEditTime" = "_lastEditTime"), asTibble = TRUE, makeNames = FALSE, window = c(0L,1L), sort=list(list(dir = "DESC", field = "_lastEditTime"))) totalRecords <- attr(df, "totalRows") } - lastEditTime <- df[[1,"lastEditTime"]] + lastEditTime <- NA + if (nrow(df)>0) { + lastEditTime <- df[[1,"lastEditTime"]] + } list(totalRecords = totalRecords, lastEditTime = lastEditTime, df = df) } @@ -1209,7 +1212,7 @@ addFilter <- function(x, formulaFilter) { if(getOption("activityinfo.verbose.requests")) message(sprintf("Adding filter: %s", formulaFilter)) - x$step <- newStep(x$step, filter = formulaFilter) + x[['step']] <- newStep(x[['step']], filter = formulaFilter) x } @@ -1226,25 +1229,25 @@ addFilter <- function(x, formulaFilter) { #' @export addSort <- function(x, sort) { checkSortList(sort) - if (!is.null(x$step$sort)) { + if (!is.null(x[['step']]$sort)) { stop("It is not possible to add more than one sorting column at the moment with addSort().") - # newSort <- x$step$sort + # newSort <- x[['step']]$sort # invisible(lapply(sort, function(y) { # newSort[[length(newSort)+1]] <<- y # })) - # x$step <- newStep(x$step, sort = newSort) + # x[['step']] <- newStep(x[['step']], sort = newSort) } else { - x$step <- newStep(x$step, sort = sort) + x[['step']] <- newStep(x[['step']], sort = sort) } x } addSelect <- function(.data, new_vars) { - new_columns <- .data$step$columns[new_vars] + new_columns <- .data[['step']]$columns[new_vars] names(new_columns) <- names(new_vars) new_vars[names(new_vars)] <- names(new_vars) - newStep(.data$step, vars = new_vars, columns = new_columns) + newStep(.data[['step']], vars = new_vars, columns = new_columns) } #' Adjust the offset and limit of a remote records object @@ -1261,20 +1264,20 @@ addSelect <- function(.data, new_vars) { #' @export adjustWindow <- function(x, offSet = 0L, limit) { stopifnot(offSet>=0&&is.integer(offSet)) - if (is.null(x$step$window)) { + if (is.null(x[['step']]$window)) { oldWindow <- c(0L, as.integer(x$totalRecords)) } else { - oldWindow <- x$step$window + oldWindow <- x[['step']]$window } if(missing(limit)) { window <- c(oldWindow[1] + offSet, oldWindow[2]) - x$step <- newStep(x$step, window = window) + x[['step']] <- newStep(x[['step']], window = window) } else { stopifnot(limit>=0) stopifnot(is.integer(limit)) window <- c(oldWindow[1] + offSet, min(oldWindow[2], limit)) - x$step <- newStep(x$step, window = window) + x[['step']] <- newStep(x[['step']], window = window) } x } @@ -1290,12 +1293,12 @@ adjustWindow <- function(x, offSet = 0L, limit) { #' @export tblColumns <- function(x) { stopifnot("tbl_activityInfoRemoteRecords" %in% class(x)) - columns <- x$step$columns - columns[x$step$vars] + columns <- x[['step']]$columns + columns[x[['step']]$vars] } tblNames <- function(x) { - x$step$vars + x[['step']]$vars } tblFieldTypes <- function(x) { @@ -1318,7 +1321,7 @@ tblFieldTypes <- function(x) { #' @export tblSort <- function(x) { stopifnot("tbl_activityInfoRemoteRecords" %in% class(x)) - x$step$sort + x[['step']]$sort } #' Get the filter object of a remote records object @@ -1331,7 +1334,7 @@ tblSort <- function(x) { #' @export tblFilter <- function(x) { stopifnot("tbl_activityInfoRemoteRecords" %in% class(x)) - step <- x$step + step <- x[['step']] combinedFilter <- character() repeat{ @@ -1360,7 +1363,7 @@ tblFilter <- function(x) { #' @export tblWindow <- function(x, limit) { stopifnot("tbl_activityInfoRemoteRecords" %in% class(x)) - window <- x$step$window + window <- x[['step']]$window if (!missing(limit)) { if (is.null(window)) { window <- c(0L, as.integer(x$totalRecords)) @@ -1391,8 +1394,8 @@ extractSchemaFromFields <- function(x, databaseId, label, useColumnNames = FALSE codes <- character(0) - lapply(names(x$step$columns), function(colName) { - y <- x$elements[[x$step$columns[colName]]] + lapply(names(x[['step']]$columns), function(colName) { + y <- x$elements[[x[['step']]$columns[colName]]] if(!is.null(y)) { y$id <- cuid() if (is.null(y$code)) { @@ -1478,7 +1481,7 @@ tbl_format_header.tbl_activityInfoRemoteRecords <- function(x, setup, ...) { "Form (id)" = sprintf("%s (%s)", tblLabel(x), x$formTree$root), "Total form records" = x$totalRecords, "Last edit time" = format(as.POSIXct(x$lastEditTime, origin = "1970-01-01", tz = "UTC"), "%Y-%m-%d %H:%M:%S"), - "Table fields types" = tblFieldTypes(x), + "Table field types" = tblFieldTypes(x), "Table filter" = tblFilter(x), "Table sort" = tblSort(x), "Table Window" = if (is.null(window)) "No offset or limit" else sprintf("offSet: %d; Limit: %d", window[1], window[2]) @@ -1565,16 +1568,17 @@ summarise.tbl_activityInfoRemoteRecords <- function(.data, ...) { mutate.tbl_activityInfoRemoteRecords <- function(.data, ...) { exprs <- rlang::enquos(...) + caller_env <- rlang::caller_env() tryCatch({ result <- lapply(exprs, function(x) { - toActivityInfoFormula(.data, !!x) + toActivityInfoFormula(.data, !!x, rootEnvironment = caller_env) }) mutatedVars <- names(result) - existingVars <- .data$step$vars + existingVars <- .data[['step']]$vars - existingColumns <- .data$step$columns + existingColumns <- .data[['step']]$columns newVars <- setdiff(mutatedVars, existingVars) newColumns <- result[newVars] @@ -1585,10 +1589,10 @@ mutate.tbl_activityInfoRemoteRecords <- function(.data, ...) { unaffectedVars <- existingVars[!(existingVars %in% mutatedVars)] unaffectedColumns <- existingColumns[unaffectedVars] - combinedVars <- c(.data$step$vars, set_names(newVars, newVars)) + combinedVars <- c(.data[['step']]$vars, set_names(newVars, newVars)) combinedColumns <- c(unaffectedColumns, replacedColumns, newColumns) - .data$step <- newStep(parent = .data$step, vars = combinedVars, columns = combinedColumns) + .data[['step']] <- newStep(parent = .data[['step']], vars = combinedVars, columns = combinedColumns) .data }, @@ -1611,15 +1615,16 @@ filter.tbl_activityInfoRemoteRecords <- function(.data, ...) { filter(.data, ...) } else { exprs <- rlang::enquos(...) + caller_env <- rlang::caller_env() tryCatch({ result <- lapply(exprs, function(x) { - toActivityInfoFormula(.data, !!x) + toActivityInfoFormula(.data, !!x, rootEnvironment = caller_env) }) addFilter(.data, paste(as.character(result, collapse = "&&"))) }, error = function(e) { - warn_collect("filter", "Could not convert r expression to an ActivityInfo formula so collecting data for dplyr::filter().") + warn_collect("filter", paste0("Could not convert r expression to an ActivityInfo formula so collecting data for dplyr::filter(). ", e$message)) .data <- collect(.data) filter(.data, ...) }) @@ -1659,20 +1664,48 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { if (!is.null(tblFilter(.data))||!is.null(tblSort(.data))) warning("Using select() after a filter or sort step. Be careful not to remove a required variable from your selection.") # Extract variables to check against ActivityInfo variable expressions - vars <- unique(unlist(lapply(rlang::enquos(...), function(quo) { + vars <- character(0) + activityInfoVars <- character(0) + + quosToReplace <- list() + quos <- rlang::enquos(...) + quosNames <- names(quos) + + # Extract additional valid ActivityInfo variable paths with getPathIds() that are in symbols or text + for (i in seq_along(quos)) { + quo = quos[[i]] + name <- if (!is.null(quosNames[i]) && quosNames[i] != "") quosNames[i] else NULL + var <- rlang::quo_squash(quo) - if (rlang::is_symbol(var) || is.character(var)) { - as.character(var) - } else { - NULL # Ignore other expressions like starts_with(), etc. + nm <- rlang::quo_name(quo) + + if (rlang::is_call(var, name = "$")||(rlang::is_symbol(var)&&exists(as.character(var), envir = parent.frame(), inherits = TRUE))) { + result <- rlang::eval_tidy(quo) + + if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + fullPath <- paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = ".") + if (!is.null(name)) { + activityInfoVars[[name]] <- fullPath + quosToReplace[[nm]] <- name + } else { + activityInfoVars[[result[["currentPath"]]]] <- fullPath + quosToReplace[[nm]] <- result[["currentPath"]] + } + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + quosToReplace[[nm]] <- attributes(result)$columnName + } + } else if (rlang::is_character(var)||rlang::is_symbol(var)) { + vars <- c(vars, set_names(as.character(var), nm)) } - }))) + } - existingVars <- names(.data$step$vars) - missingVars <- setdiff(vars, existingVars) + existingVars <- names(.data[['step']]$vars) + missingVars <- vars[setdiff(names(vars), existingVars)] - # Extract valid ActivityInfo variable paths - validPaths <- list() + missingActivityInfoVars <- activityInfoVars[setdiff(names(activityInfoVars), existingVars)] + + # Extract additional valid ActivityInfo variable paths with getPathIds() that are in symbols or text + validPaths <- missingActivityInfoVars for (var in missingVars) { ids <- tryCatch({ getPathIds(.data$formTree, var) @@ -1687,17 +1720,27 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { } if (length(validPaths)>0) { - newVars <- c(.data$step$vars, set_names(names(validPaths), names(validPaths))) - newColumns <- c(.data$step$columns, validPaths) - .data$step <- newStep(parent = .data$step, vars = newVars, columns = newColumns) + newVars <- c(.data[['step']]$vars, set_names(names(validPaths), names(validPaths))) + newColumns <- c(.data[['step']]$columns, validPaths) + .data[['step']] <- newStep(parent = .data[['step']], vars = newVars, columns = newColumns) } - # replicating dplyr magic - loc <- tidyselect::eval_select(rlang::expr(c(...)), .data) + # Rebuild the quosures with replacements applied + resolvedQuos <- lapply(rlang::enquos(...), function(quo) { + nm <- rlang::quo_name(quo) + if (nm %in% names(quosToReplace)) { + rlang::expr(!!rlang::sym(quosToReplace[[nm]])) + } else { + quo + } + }) + + # Use the resolved quosures in tidyselect + loc <- tidyselect::eval_select(rlang::expr(c(!!!resolvedQuos)), .data) new_vars <- set_names(colnames(.data)[loc], names(loc)) - .data$step <- addSelect(.data, new_vars) + .data[['step']] <- addSelect(.data, new_vars) .data } @@ -1711,7 +1754,7 @@ rename.tbl_activityInfoRemoteRecords <- function(.data, ...) { new_vars <- rlang::set_names(colnames(.data), colnames(.data)) names(new_vars)[loc] <- names(loc) - .data$step <- addSelect(.data, new_vars) + .data[['step']] <- addSelect(.data, new_vars) .data } @@ -1728,7 +1771,7 @@ rename_with.tbl_lazy <- function(.data, .fn, .cols = everything(), ...) { new_vars <- set_names(colnames(.data)) names(new_vars)[cols] <- .fn(new_vars[cols], ...) - .data$step <- addSelect(.data, new_vars) + .data[['step']] <- addSelect(.data, new_vars) .data } @@ -2125,7 +2168,7 @@ head.tbl_activityInfoRemoteRecords <- function(x, n = 6L, ...) { #' @export tail.tbl_activityInfoRemoteRecords <- function(x, n = 6L, ...) { n <- as.integer(n) - adjustWindow(x, offSet = max(0L, x$step$window[2] - n), limit = n) + adjustWindow(x, offSet = max(0L, x[['step']]$window[2] - n), limit = n) } diff --git a/man/activityInfoVariableExpression.Rd b/man/activityInfoVariableExpression.Rd new file mode 100644 index 0000000..3b6324f --- /dev/null +++ b/man/activityInfoVariableExpression.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/eval.R +\name{activityInfoVariableExpression} +\alias{activityInfoVariableExpression} +\title{An ActivityInfo variable expression} +\usage{ +activityInfoVariableExpression(x, path = NULL) +} +\arguments{ +\item{x}{An ActivityInfo form id, form tree, or another ActivityInfo variable expression.} + +\item{path}{The next valid element/name in the variable expression or the root form ID (optional).} +} +\description{ +A helper object to get a reference to variables/columns available from a form +or reference field. These expressions support the $ syntax in R so that the +user can interactively expand reference and sub-form fields. + +This is also returned when using $ in a getRecords() object. +} diff --git a/man/getNextExpansions.Rd b/man/getNextExpansions.Rd new file mode 100644 index 0000000..858565a --- /dev/null +++ b/man/getNextExpansions.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/eval.R +\name{getNextExpansions} +\alias{getNextExpansions} +\title{Get next possible expansions from an ActivityInfo variable expression or form id} +\usage{ +getNextExpansions(x, path = NULL) +} +\arguments{ +\item{x}{An ActivityInfo get records object, form id, or form tree.} + +\item{path}{A variable expression (path) or form ID.} +} +\value{ +A character vector of possible next expansions (field labels, IDs, or codes). +} +\description{ +A simple helper function to get the variables/columns available from a form +or reference field. +} +\examples{ +\dontrun{ + +x <- getRecords(formId) + +# Get a list of fields available from the "Office administrator" reference +# form, e.g. from the Staff form +available_fields <- getNextExpansions(x, "[Office administrator]") + +} + +} diff --git a/man/toActivityInfoFormula.Rd b/man/toActivityInfoFormula.Rd index 6f43771..50f6c82 100644 --- a/man/toActivityInfoFormula.Rd +++ b/man/toActivityInfoFormula.Rd @@ -2,16 +2,56 @@ % Please edit documentation in R/eval.R \name{toActivityInfoFormula} \alias{toActivityInfoFormula} -\title{Convert an expression using columns in a remote records into an ActivityInfo style formula} +\title{Convert an expression using columns in a remote records into an ActivityInfo +style formula} \usage{ -toActivityInfoFormula(.data, expr) +toActivityInfoFormula(.data, expr, rootEnvironment = parent.frame()) } \arguments{ \item{.data}{the remote records object fetched with getRecords().} \item{expr}{the expression to convert} + +\item{rootEnvironment}{the original caller environment where the data remote +records object resides} } \description{ -This function attempts to convert an R expression using the columns of the -\link{getRecords} object into an ActivityInfo formula (as a string). +This function attempts to convert an R expression in the context of a +\link{getRecords} object into an ActivityInfo formula (as a +character string). + +It also supports ActivityInfo variable expressions like \verb{[Form Field Label]} +written as a variable or derived from a getRecords object with $ syntax (see +example). + +It will check if the field/variable/column is available and whether the +functions used are in a list of supported functions but does no syntax +checking during translation. + +This function is used to implement the mutate() and filter() dplyr verbs. +} +\examples{ +\dontrun{ + +x <- getRecords(formId) + +# Filter out records where the partner organization in BeDataDriven using $ +x \%>\% + mutate(new_field = x$`[Partner organization]`$`[Name]`) \%>\% + filter(new_field == "BeDataDriven") + +# Create a label for use in a report that prefixes the partner name using +# a variable name and the CONCAT() function. +x \%>\% + mutate(new_field = `[Partner organization].[Name]`) \%>\% + mutate(report_label = CONCAT("Partner organization: ", new_field)) + +# Get the text of an expression +aiFormula <- toActivityInfoFormula(x, IF(ISBLANK(x$`[Partner organization]`), + "No partner specified", x$`[Partner organization]`$`[Name]`)) + +# returns "IF(ISBLANK((ce844hgm3x4xtgr5)), \"No partner specified\", +# (ce844hgm3x4xtgr5.c4cx7l663x4xtgr6))" +} + } diff --git a/tests/testthat/_snaps/rmdOutput/TestMessages.html b/tests/testthat/_snaps/rmdOutput/TestMessages.html index cd6002d..a7ed923 100644 --- a/tests/testthat/_snaps/rmdOutput/TestMessages.html +++ b/tests/testthat/_snaps/rmdOutput/TestMessages.html @@ -388,6 +388,14 @@

This is a test of issue #29

subform +author_reverse +reversereference + + +about_reverse +reversereference + + NA reference diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R new file mode 100644 index 0000000..0bde69b --- /dev/null +++ b/tests/testthat/test-eval.R @@ -0,0 +1,112 @@ +test_that("toActivityInfoFormula() works", { + x <- getRecords( + getDatabaseResources(database$databaseId) %>% filter(label == "Person form") %>% pull(id) + ) + y <- getRecords( + getDatabaseResources(database$databaseId) %>% filter(label == "Children") %>% pull(id) + ) + + testthat::expect_equal(toActivityInfoFormula(x, `_id`),"_id") + testthat::expect_equal(toActivityInfoFormula(x, `_lastEditTime`),"_lastEditTime") + testthat::expect_equal(toActivityInfoFormula(x, `Children`),x$step$columns[["Children"]]) + testthat::expect_equal(toActivityInfoFormula(x, `[Children]`),sprintf("%s.%s", x[["formTree"]]$root, x[["step"]]$columns[["Children"]])) + testthat::expect_equal(toActivityInfoFormula(x, `[Children].[Child name]`),sprintf("%s.%s.%s", x[["formTree"]]$root, x[["step"]]$columns[["Children"]], y[["step"]]$columns[["Child name"]])) + + aIFormula <- toActivityInfoFormula(x, TEXTJOIN(",", TRUE, `[Children].NAME`)) + aIFormula2 <- toActivityInfoFormula(x, TEXTJOIN(",", TRUE, x$Children$NAME)) + + pre_df_1 <- mutate(x, children_names = TEXTJOIN(",", TRUE, x$Children$NAME)) + + df <- pre_df_1 %>% + filter(`Respondent name` == "Bob", `Respondent name` == x$`Respondent name`, `Respondent name`==`[Respondent name]`) %>% + collect() + + testthat::expect_true(nrow(df)==1) + testthat::expect_true(all(!is.na(df$children_names)&lengths(df$children_names)>0)) + + df <- x %>% + mutate( + children_names = TEXTJOIN(",", TRUE, x$Children$NAME) + ) %>% + select(starts_with("_"), children_names) %>% + collect() + + testthat::expect_true(all(!is.na(df$children_names)&lengths(df$children_names)>0)) + + df <- y %>% mutate(parent_name = y$`@parent`$NAME) %>% collect() + + testthat::expect_true(nrow(df)>1) + testthat::expect_true(all(!is.na(df$parent_name)&lengths(df$parent_name)>0)) + +}) + +test_that("$ syntax works to create variable expressions and activityInfoVariableExpression() and getNextExpansions() works", { + # these are implicit in the $ tests + # reference field + # sub-form field + # multiple reference field + # reverse reference field + + testthat::expect_no_error({ + personSchemaCopy <- getFormSchema(personFormId) + + titleFieldSchema <- textFieldSchema("Title", code = "title_field") + authorFieldSchema <- referenceFieldSchema("Author[yup!!]", code = "author_field", referencedFormId = personSchemaCopy$id) + aboutFieldSchema <- multipleReferenceFieldSchema("People referenced", code = "about_people", referencedFormId = personSchemaCopy$id) + descFieldSchema <- textFieldSchema("Description", code = "desc_field") + + entryFormSchema <- formSchema(databaseId = database$databaseId, "Journal entry") %>% + addFormField(titleFieldSchema) %>% + addFormField(authorFieldSchema) %>% + addFormField(aboutFieldSchema) %>% + addFormField(descFieldSchema) + + authorReversed <- reverseReferenceFieldSchema( + "Author (reverse reference) ------------ really long", + referencedFormId = entryFormSchema$id, + referencedFieldId = authorFieldSchema$id, + code = "author_reverse") + + aboutReversed <- reverseReferenceFieldSchema( + "People referenced (reverse reference) ------------ really long", + referencedFormId = entryFormSchema$id, + referencedFieldId = aboutFieldSchema$id, + code = "about_reverse") + + personSchemaCopy <- personSchemaCopy %>% + addFormField(authorReversed) %>% + addFormField(aboutReversed) + + dbMetadata <- addForm(databaseId = database$databaseId, schema = entryFormSchema) + dbMetadata <- updateFormSchema(schema = personSchemaCopy) + + x <- getRecords(personSchemaCopy$id) + + # with reverse reference fields + # with special characters in label using remote column expression + # with code + x$author_reverse$`[Author[yup!!]]` + x$CHILDREN$`_id` + + # with circular reference fields + x$author_reverse$author_field$CHILDREN + x$about_reverse$about_people$author_reverse$author_field + + # with multiple reference fields + x$author_reverse$about_people$CHILDREN + + # climb back up to parent + x$author_reverse$about_people$CHILDREN$`@parent`$NAME + + # using local calculated column from lazy data frame + y <- x %>% mutate(chldrn_plus_one = Children+1) + y$chldrn_plus_one + z <- collect(y) + testthat::expect_gt(nrow(z),0) + testthat::expect_gt(sum(z$chldrn_plus_one),0) + + yy <- y %>% select(y$chldrn_plus_one) %>% mutate(chldrn_plus_one2 = y$chldrn_plus_one) %>% collect() + testthat::expect_gt(nrow(yy),0) + testthat::expect_gt(sum(yy$chldrn_plus_one2),0) + }) +}) From 9f9c7adbd8dcb7e63dbc4a1303d8f89249d49b43 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Tue, 10 Dec 2024 16:52:47 +0100 Subject: [PATCH 6/7] Adding field references and auto-expansion to the introduction vignette --- vignettes/images/clipboard-1150423579.png | Bin 0 -> 16083 bytes vignettes/introduction.Rmd | 129 +++++++++++++--------- 2 files changed, 77 insertions(+), 52 deletions(-) create mode 100644 vignettes/images/clipboard-1150423579.png diff --git a/vignettes/images/clipboard-1150423579.png b/vignettes/images/clipboard-1150423579.png new file mode 100644 index 0000000000000000000000000000000000000000..234ad0540c2ec29cb3cd6c34384177a0b5a1f1f7 GIT binary patch literal 16083 zcmaL8byOTp^!G^;G`PFF1-HS1I|K{v?(PE-P@BQ3c5#JQ0kUtZAhJu1ZmXQ`$fr9!#3^_i-!$PjGv;=BGK0dgp zNQpvKP7obJPM|GB6hxq)YT^)Ij9?(=2#(TPE>KW7)c=kTGAdLTP*6gaGU6g?p8BWR zh`!i!4etTaw$EMP-?uq>3em*>YDVJ1ATZ27G(M2A(e+57+m&BN%+CMxj9T=0=QjQu zGtaOcW!PgFRrMKT1EI4N{wEfvBLa;zmPE^Zl;fMvDKJaWWj~7poW(~=JN$IDl$9>% zV}94}Uw5~j-ry|(U2T~QHygeYdTA|$B+zz%bu{^5;`u}MHEeb~EDtW!9)BRaAd40( z7Sph88`4Z7TAcD7S&a-8uesNkX(x*a?~3TWaSN>}Dr=(508{8pIEioH&_wnGa`&=$ zZ#Q?PzKhd>P%zbp^iyJjr6?^ghf%Zoh1t*(yEgdHeXkXu7b>IjJkH@K%rCcQ#S(G5 z%zj5HP7$wo-LZGQR3|L9I`~f|*}hViNLKs#K%2Z1h~x^PtJOR>9*NMeU)!)=tGFHk zKXiDPsi`3|VGWO|TBnp#0oOkmozKdvF1NT?jJ3OLG z%O>q{NPSG*>Mv_6@|>*k5UP(goix|IHeY_0qta%PCrO8T+5NU@&^3>5bz!jaA@&*9 zu`uWU>c}C`!~)7fknGMQcEU7`M3klW8`FswheFrya7BTwi|5;Y^vhx~6Asq5ubb82 zK!eyRFRP39H{=JKNvC%Dx-%7x7R>1Vz039c%;+hxZKA$xN#* zgCGwfy?p~Hd5rH9xLvdOR#$Cn!PM6^NP>FJFD$m@@4Wow_(yl|?&Ymz@7w!8kei+LNP1R%|bu~8UH({Xxh(_DTl zc~x5}&#-#BRir&8YaAswIdpv}{lL3h(miYOV_5273@N<<*Kv%t+fi_mHCo3vx_WWO zJ>hYCOY!*d4io;Vp#<~Rcx9%zUC^$&1V40`G&&qDHg9n|zXb8~tigWT zQuAcPv)3eHDfD%eRo>qiG5WCq6CqZs(RoicnT6yeDc9BqTZimqmzFas$6qAH46oS2 zd9bW4gc4w$<8N2P)8LqqSItQr+O$R2~11$PC<%C01`$eujk_1NYh{D(2Cz*eTuQaP@K!5rxvnO0NT;B8g!AXriP_(ZlxG zvM1K=M5%>Dvlq697Cen8+()YK2`_b0z){-+L}cav0aN#Ui5k)B8=44vj1($^IUN|C zp&=>V{!{dNJt?B7uD}HG&F(VF`wLx_(Pa(X&Wy{!*4!b8qk8+Kl2QO^MqRVsGCoH( z+Tof(UHThRJ^{t_rHTiVzBx5FSNlQVKA%y%AI#(3b(>ho;FKD z)(0JgX|&8t8Y!ngRUL+WwA<44x}(-4H_vUJWw3}HPI6KasA-I&ZOl5!%(rW81PgvC zW;B7O4Zrw>A`L?5bIH?C8*4`=I=>m0@Zs>{`R=N z)7|~Hs0YToV-OiFvPjKmfAQBi@8XPhBCXhqi7OGON0PXZ;roUm z&+kJyVulak*%nx&7;@EW7fqD+l!h%lP>TYmnbS4QeZrO{!06^x+c{uZXg zm6@nvsA5&jT@}1j^FD;oIns~1m0Ik_8InvToVvs)aT%BZ&D@W7iih5OG#S{VQPut z_RHo>{HC>%Iz6NT{oig#s;Y9D`1uHYGu{WtmHT=2k|E=?e|wjol><(Sz}T-f;JE%c zW(GF1w6kt}i!5}Wfgo419ieRTLI!T=+pU{`9a1Nlu*GV3%1%6P@yW;E_Al6f32%Lq z{@UFp)4p6HEZeU{A)*j00G#Escl+EVK*l6=)COSY z`8eh(Si9U#p@N?K&S%A`?{~;72o8m|c&+Z6I$qhB<{QQfOw`wm5`4!vwP?9Ik-)Qd z+l4K<5f$9dZ<^6;|IU>=wxa97#4k1(0R2Z_lS#rsyENceDWCy?Z`nLnj)nuNgEY2T zm$PKIbFS8{Z_YBUBG+bCI;)_q*sC#l#F0DO#3}1Od$%HhFv6PvoOZ}}gOQIWjom(A zxlVPB3%tYK+wi@PVYJ)mBpzMYO?+XzCg$I(=8aLoFO`wNQFQDX=5AFo%j4P}U|suF z-NjDo^>B9*juH{A;rTHNg*-ScbigVp5)e~{N-LenU@=9yq1XCz<3PR%$Ov%g*xSI6 z={E`^rU{5S2%c}hid2!j`O+QhWO6Y-a$j=@7sRjUsM|N0r0Ix9V^_Ogl87)1O!Q1* z;7LOzDTsgxGn%G$1zpy8iZ=Yj3q70;o-Z-MxZO)Ly$4TKt(Ek#$}fMoj z1u?{y&5tsIxY2iB4Qb!Ga1&3OT%5Ry$27wc5>J~7ZgGluN@^kn9KOv|8KrQ|w5tx< zC@VWhWoo~h*YGq5cd=K#j*9Quz1*23sB@e1Q>>ZV$>{KQ$kG`8PRssop3DI>9pRL}hRfVlNmu1Pe$^*3Z<1}H3WP19Qwm$_*0RcYmlsVmKS;Mho{`zAIEGYS}s z(_+%G%B*`NaBsQS z%0{N8F??S%$vH1G{i$`|ei~ub<;+V>*`;`@Omcgp>s!OA4LNTWe{2T|BVptUODpY<3wUKM zGLn7~&;xvE@3hhO`<~_H`q!Jy)jU!i@6EA3TKlCXQA38Kt8D~B$KYg<`N&eAK2JG)sqbyiKO^M^a&QMpTte%+X2}{E z`n$7uM3#^hD1eO3`SPZJ{+V+cC`wv-HV>^o%AbK6ZBL}Hl?{HxxS!*lwR(fAF{Bi5 z7pziR-s;!ruhIzgWm^WLQN5S}EURr}JOuq&^l=9*7Z;dxGB#1oc7aAk`kBK~ZRu>* ztrPBSNJanbyo<;`JHKQucmu1UD#laLTWr>`Xsup`{S=CJt-cM!Nls%wr0Dlcsh$Yl z<390j665F3*UIZBrY3{8|DL&z`d} zU5({Z;o5mm6X%3qyuv;a1i8wW{Z{(esh=}hYVv4AZ{3>t zLoyxmi^F+=n055sW@)n7U5FJ0(?E8+h_a|^U-KdmUBas*XFiY^xI|GU4lW8aP{2dZ zFX;G0Yv9FncY@nrliJKiX-AiB)-Wzd@XhL4yf zewg<^`~mUlJ>B%EWw2yScevL=X}rIu-ioXlZ{|b|@5Et2)~y+>EdiL!MS>>^FF4-|>s`$n+o^0|w zG%S8pVFUfkE|=ShEXRB>TxGEx%`a_OXGtrP{1c&)S^arXx%Fo)M9k|Lb z9BXGDdbb`XDmPNDvqi=XT2q)O6)=AqwUV>tC!*$jlJTT@?Ia+acR>5eL19R$c*jaA zAc={H(pM1+B|xzz z8?~_L2oG}dXeHtIV%lE|`HB9V@FCF&^f}*md`C~a8Mx@=qjt(BJyTuUXJNjEx>||t znG9ZqHyAF1=L~y4Hm%ImM(l1ZdQxKzO~WYyr}4r;qzUbvi=5yuZi*00dxX3tDS z-3+_JU1__DM!;_MCq#NTkG6YlA{T7OLZd6Jqa0hVGCWbrAEr-O;aI(oPuEsAZbj~* zCA@FV3b!A|m?Ilr_);5Rd$|EH2PEwbUx3r7o7)QMk+w zmh-^JDhecuZp+~Oo(Pn+)ni=?X~)cV%opjG>KMnYu26RGrlFyV6643@dC(!?7Gf)! zCRe-=G_$HP>oZNo10BlK>KjQ0{Zb$)Kg^$s9k)obLF~sQjgky8XU0V}WpdA=#;47G z0;o7@$Wn@|n`bX6?yIM75?E0&>te31Op;RpT5BdrX$TBoR)rdFY`fl&6nU^ z!KcYkxpOZ~-;WhAN}$x7m68}|XZ#o>&-SsrK(u*8g1@Rvtl28GA(x#zV0+c^D<92D zzjzRtT#4k1w{XY>mdh>AO}iyznbom^$k+o5L?F6{UK%t^ORN8ghy2qh?c!H{qJv`l z6*B>JAL~}U$2cQlENlw=g-Yv z1FZ5WhchLp{}x(H(A!hC1T8)hWK_|hObw*I-6RsD!(DaG@GOjt1(ykO+;X-BGP!w5 zonkMgR5aqNn(Kox;H|FX6$62|QV4X3E#JQVm2QwU<^#ix{FT0|yKmhmrM30&=}&Om z_n7A?JhrS?j0DhI7H$Kb@ogHM;rrCPGc6cT6dUb<^mCE z;Dds(gbADH^GrXR!gphgHG6!TImE-X_0rK$msOg(wBwicuiH$)7P0r*&REg5@u?{& z9a=~J?xe6ptY5*+OAYsDmi{Nmf~mm*5wO2?uIk8-SK5SR}x2$0R-Rz?dnQx0A(AF(nuXhY-<3T}RuI zoU0;P<0lBN6-tiMOnvalRA3*7EADaCyHa$`$$q8q_v}aATlqqw)A<4|6?fbUBHInJ z@Fmw#=p?~J7CqZQ+fD1`v-k4H4Yw%)W0Pye$r~0P>_&mRQ^8%4of~U%lLMj-T}>OF zgtYPme_b%hGX&Vi(*@Qcr_G=vEF6arKRjlG@tZ6vy*_qXce-C_1GN0V#>@>ls`fLh(l87ZE}4f5NtoA}v)g&$ z=GhIT$;L+%R#9VrBboW@v{-0Nvjxol>_>75_9wY4tmx1>_$?nXiVI~Y-dysZ8M+ni zE_qDtxa+CP-nqBmOPn+y?KHO$<_5fZ4MyYyOb50{!HQ6-&MKdn_4yEfdpssR=7YF1 z8BY)y%5axZHfYZ50o-O&^aEd;r?GaERi1}j()FsxWwT`lxSc$p;Osqq<-ulth2We4 zafwR$DCsjpb8{~Kp($?XJN4xwpf)9kj$p`Fiu#eUTPIc}E)V#jhvvHt2mdobf~j_t^QE#9`7{rTGNQ8B=$GI(}0h&%eXWf_PfL?y%HM_>= z976LFh|^4vu}kFyscU(+{_w5*-88FYo;uo$FH*^+yK4=*+=3!;wt zz#l=+qmO+fq1$&+X9#oxM99X)X~!p)X#Hd6e?~cH2eFS-?!DsA2)nypW>{M8BuVE2Dd`Et)8pSveo%1Wqp9mh2jcxapZ(A_!YZ&2 zL}onf#R(611CY=9|JKL)Ll5>C^Y5R}j*T!~Tg#%dQDip1f|GK!r>UX;P;6Oq*)H{o z?dxh?)cOnuDOBPcbk-k>AkqJ&s0ruo``N%nM`_swBCcOTN^^=bB=v2=o>GQ*n##2b zQ;Q9ng2>v3!ZQ$Y zw8v@nl*%_GB%-9TF|m{QW3RIdiHBPXosZ%!zh8eA1WSINPzP@FxB2UUp?{DlmisC7 z4UG=JxC5we#ccECQtAyyUg)o44kh8oO!Fiiq_|-6v&#cD&&%Y7p^c0ie;c*iF)Cxq z>wIH8IaiO14K(lxOLg14S5weh94QUn|2kp3RenoiG;jHyYXu2jW$v z6b>$zu=?EDGI`!&X7{in6*xvr0Bv}Tk4bz?NZC5P{TSWPC^jMayHe6OoChQ}+{1NHXyFnc>17xVl6yiW)I-Hi&G8^5pdLyfBS zqb4>vlvQ1bB5U|V)#mbwt;5q82A#N!TlamVi}$~O1gDF-o;-ef)k9%B3 zwvCyl>nSV?j*M&B%rS?Rw17XVYOZAZey0k8KuBnTmd}A_ zF(2LcYwgGOPAMwzXr-*I=Mf0q;4yF5G4=OV>KzN$z?Y3iAtN{flXm+?tUpwE@yBhe z+FAJd@#4kt@jE5B7xR`s3vcg@VjxZyzZfwuLxc2h&mc>r6WOcs#F3jNS3r5=aY*&iy+nBTNc;3-Qd}4 zS6o^g&K*hcYZv4C1*5?Nep$RfXSm_73;7mlO;VUPIv)6>msNVt0;J{{A~^Bj-$R?A4yCdE&q+6W9{0`@M$daMk;SU%wp8ucWx z!55;PxT|MHYnJHJW+-qBaV0n?QHwKtv%TK>6AH20=ah~o$ytq<+g~GL8qb+EdfxR4 z(SXffO@6?q$9|{hPbr=Hmc)m0gQp3zmqt4eF5G*@mu{zrWh^2>W|8wsPRYZoJe+-| zBV^0~FWF)cnTpZeXlvPRPfuwg$w4%W!H!)u{a}x}QB69F_^s#4M$UqhkLE-39aH7q ztcDo5b#xv3>4=LLVq2{-AQuu&d@B$s{BgLm^q?-xR^kVLO!ui#M>${>oxBz!|gy>g3Muty$Ux`MEf)4~Xn1c?h@?9H{T-st9FTKdhW)4%011OGn&y1AQgy z>Wq#|0WW7@fFOPcjE&{_B!O=kP$sg7e@5n|MXtyp19Np90W-krC9NN!*bI^8lo(4t zaP14WZXBp%*z+=YzI*BzJ6g_;^o~*W(yA0MYQ&tlWb_8i^tmEH?jRZmOCBD9 zM5Z!@MlF|eAe8gT|CH3MI~wosS3A4+hdrfY-W4qC5DFqsA+uj*^kdPJ?jOGv7~0*2 zS2}EGSgec~r~SGR56V-bSQp>;bInG;vi%!I$I){J z6Gmw{QV#(oiQt@1bus8!gW#NAmH?-Y3H7m-cY9EDtMVi@kaxm(gRAAM-_k}pID`10 zBo-rE;EpKG&b9}i%@^+p^?^j+=aso7x}rH@n`A6EQ=FBCntK*a+tT`mkIDkrI`G0jZ5oE%7vh3Y_CVcpD>!Ruur0takA& z>h+bh>f_jQ`So)e;VZy9f~vm?V9AMX$LXY&hMdQ4>frm4#ZgnPL$hF31C}tmD}A<3n>0+` z3Zfiu8{Px?-(7{*y$>*qnCJ4GWm@RuDjDm;u{8>MG!d!noqmTk;S?>GwYoa7@qzl1 ziT1u$d`t%R2fP^5eUUOtE*-CUct+Wk&XL~!r9W^!or4u(MvIh-}4qb={d|^>EzKUPP&c>~sHVpj`@R_FpkUp^xLEL_(lK<(xx#v7f5-zGXiHkb62n)P|KQb9oz(YA4 z;7Y6T{m8fQm7lTiMv@d!RIjf8d+gUPd4?leiOd2DhgnxAWOIoHW+LH%S9S^!oy{+* z?m=iGg2YJfdAZ>i5*F7Vb*GwG?kdN9>lt<|(Q5J8F!!F!zwpOrXkxOicqN9z>4%3` zVO|T$U0x(2e)F?MuMT?^Z`;T!iyv+!sdxMF)R;zxEy6aB)L}$UoK!TkIyy_<(F(hp z4ze;1FU)Wgl2#7aS7nK%Y^dFv9;u#;aXvnB%9HH;J7*lhkhtY$4EKb9VBmUJ)f=QU zzkSA4Vmxh9=9@!8T>*)QUHS=U&*JD*n-=P+^*Yv=NN$i|fFZUdN5#qv)9RYNS0u(N|uSLpfz_YX6^{!}ZA=)Q3)~Mhv%c z@a2tz*4$581aF1MecF8}H<$?;et_SSL7MXi{Ds<{@j1T=iL5P>aiF$DK$nL5J_lkoS!L z-|X0>_{3l?DTV5Xap@T#<|$IienA^T3ems6tQ{l!pIYA7_ar5Yu-Gj=fwlfFo@vNc z8pTfmdMu5-T=b9N1pE~AqubrgmW(s5C=rj{Rdtj$;O(4n%c19UgXjm2Rug6qWQpUq zmfi2MA?m`^0)IXU?t6+y<_OzS^SS*7NzTQeoEFGH^H1G_yFZ=Z0L3Pktw7LGXx*rMpE3cvtlQaXbjfg}BE1p#OsN z1ToNK*c+tsrli(>&8!70J7A#;38E1H<9CWipi2>NXSsuxFG7Qex*i_={j7(*`7;CI zPJv5WUzG4^6ud(ZEOQ$Vy?}DaJ9vyf8wYBwx?z9fa8`KT5|MpXQp zyYd$I89AY?)4C-h$uK2d8qvOdy6x|TkbQBTW><~iyF>{`zR0Zi>-CqkAKJ6S(x__` z1klP{xC+yt*^`HP#RO^8{@x>P!xTVD=y0;7fO2+Fsk+S1o!FY9j9^={TXF9CJ+JFO zss$p8;c)d6&FTj@ATq3?X}KIU(GCAB!+4StKNfMb=x4aS!>QA0H7*3^xFGqs-^3f^ z4xqzXOEjlLArM(%szB{nyOA=HO7snDA?Lo0?ViK(Dcd)1kZM$V&S2#;SlV@-xu*|R zxWXa<5{oCG8*{?%#Lmvxs=TU^OL&ukPrV7Op` z-=lGPA|793`-696`5@EF)u=ZTmd&|4b?JD9?;%MhjrWoc%WoORx2*RZ0?@b>Tubrs? zR=prHyyEBh|2cho|4n7cH2uGG_5Vm>kIDJCIYtsbPNB&+cVj`3$ zc5TuZgwTEYB55_gaZ#h6g@Vs#Zh=SRuz2ITNIYD% z_Hzw2Js23!fk#YCZ0X=2Wn;srZI4%kSg2SWyA-q;2`e%@X;B>kwWTvbc={uuO?dDm zD689N%>yv6IVSYNoZo*NqwQJgylx`vDS(tHD2kPh%Jv?+0cB!ga>^2VETFI@v?!%i zEV>`Nlqg2rC^6TqOZ=O>R>lidNBZ^gB1J(=!Y^~QNNPoVw8=SP2!RGZ_iAp(edEv* ziimG+I0`&NEA1B%GABW&Ej*x3bJQgXpE!9b&VGY2#5!EsdRoXTVeyH3O3v3Y;G~?L zoyG)sBBT68K@WrlF=0S0FAnoWx9uI0`s&3oxTvgOd?H8XBFglB>{G8=ccNNCCC3muQ zp~0mC)x7aKdOg2KMo(Vm7smkF^?QLVx zG#&lPfB|fCjKLNkk1)iCpe=BTv z;{coA+#>Bv0YZ!GOx!~cJO6o>MK=CES7AsF50Vn{uZG~^{~Za_18#T3KW`Ou>A1s8 z_^3@wYlh7J5sZyBN zKG!#ZBB2IptuO@*spI`&c=5MS5pm7$l10oy#?&nJj%-7RKgjSW zNW~P~8{^WHu^67~Y`9w&r4IP)Og9cR8vEk#(;qSPHp!1TI5!orCIVJaV*%XmQ9aOo z%z$m9aw^0UBuk2@uxVd!7Md{oH@yF#YWgoob`HO~($;G>x7w=?bsA<@OgA`Xc>d~N zp$=QGYWP(Rq_PE;bI`ROQ6z)9QLtw0GJq(8)2LVz<5o}r+a8s_(ZN(1RsO3oLC&-7 z#^5fKtv0^TyGbib?7^zMvFb;8ka1!xKf@JK^MRk>^#|5NrS39sZoTOkSP_Q}}7)#ui+U(w)HH^yi;?BAs+VrOK9^#QG$mwu*fYfmGZd?PXTt8S>SE#-LonzTc z$>$k-rwjubX<>q3v}l-ZWqG>Kt{b)BT&jn7 z6;B!PxbpfgTOqiE3YTQW(#!Eg(83~YUWefdnjkWaM=r&P_`TXH^JR?Np%HT}hBJ|% zZ99zgT`K}*dB${y3j9yJgU`{-Y^=YiZErR$*Oe%t_>F0ai%xSOO* z&&SYj;=r#wNu-xoukf@4;`Fjsc)VLWTFIA~G+DEnIa4*^JADCR^gKIs703w zOzRiOtq9w)*X4RRnMcy!#nzm%%XH%D^M_YzvZ3gI7)dlc@^r{YY8%UI3^1||Lx;hu zyJDb=d-g`b8cAl;7`m@+nd%KnrRj?1DHAv5%Q&hQJOt2;hhUbNRgh006SS5xTv zafv|l@IeOqHV)j4J?Pl3VxlT$Gz_K*-~5GQs_t4yZ&zd*jF0>iz&GbuJGoI)-#7|a z>-d7T)N_PEa~WDyq+F$Cf81+jtWfe6b`=d+#h&e9U_z*wqt6-o-9z7}M$FC&&@Oz= zn?B@iglFsx5ddAW5}Q{s;e-gMlOxUH>bVn`#>&@xt4%Qd`694^Q3G1W;k)S z!b%CC=k$7+%C4+elJcZWNse$jJDIE!LO@$#&1YW7Mw(4mW_H1~rr5POAp~OLErIHoOa~uv9L$xY zfhS%+8~8sKRctQ%gfwe9H2nN&D2e@_EOaOz%;JgE1k9O23gMCe>n|ajqKHJ&H^9v6{TnA!jTut) z(n_mB8hpEbC|%4lwi8$S?Q%c!v*YZau$ssC%SEO8*EG{!#HLp>0a#`Lv5mQgAq%nj z!xFCkf{qbhF|BiNO{P?j2^Y_25+p%V>!mOyqbr$( zonK+!Hxo$RH_Hr&;>N)`nAl@!L$$g{p|_(k`pp>H{*4& z;ci}P*E=gQZ^!Wk3ka_ahLfG`+~r$$CI9|1>-YVjSstI~&Ry`?@f-Mb$=Qa~m3aKN zz@^$&d`!r!We^i1#YvA*D;2J~>sS{f>779GLGPIJvaMvb)a4SG0rwYB-hSYAJHfc^ zppy+eMy+o;?78>V*xua zdx^hzwnT|^qki;DTmMU|io>6~Bs zS6NiJkxwI!>)YXq-S>AIquxxaM@o<>+Txf@tY4mZ^nUV zYHcpZXsrp|pDOh1VHR?+)&{?|YVDaDkCtSc`c;W9u_n^S%8>@Vf7tF>U;T0=)R#HQ zJb>`&Norx{@S>oye;T~rZ;|sNOkg&|iurWq?1G_)JSGiO`8%QFAraovq`D%SrO+%P%l^dBE79c(t0{N$os8d*YPeA^h6C zbn*=qSahx%*{A1~PVE)N)TzG~pqLS(u84p8t7Woi#HF&lGYsWb|F`$`;`#p72m8I+hks%!|M}u7dVGI8N;8#1QVO&v1>Iw zdn{I=mJ#p#M?2h{PL5MerGDcmdg@NH7VQTQfgfD~`J*%OAPF`zl_8geX1=V~A;J*o z@RTw{%92}T*Xat4i^+hund~!OL#)t%D>0{o-(lP99<%JSM>Kp0O`Vp1 zt7ft-aQODv6>B?h9FHEi-|()YJ@W?YE5trzySVvM{b4&Mb;7Fj+Sh6~ns36$mTQT1 zsr6#yCypKQpZ4RoA>)KwzT5BZ+pXrQCe5m$M|*;)IRbvDWj>4<+Z&ljPgH=oBcinD zIoSb=Ek!M$hU4)Q!jXW|Bfn7Hi03_HE?>43#eUMv%>IIW=C0p7F)>=^2%gnaKUE7^ z*=E{?=`c}}{1H;~7s;*g ze9P(vyu#Pt+=>~_uuWwX!!2F$Arv+DDqKHu*GzP5>IaxRKOlXKl~?zDv1T*UNd!eFIAqjj+J?3 zD|}9CD0cz5f_~H}fCDlj*IU)2VgomxiNm$cBnPXrI6kKtJOFwKJgyB4@@?Y=cdFt9}`r-x~G=m!PjC3Q~2JXiAP${X~15BrHkFx2M zA|^7p@A(w!?QYiVx^Q->pp;lUK&54?`mSD>Noe`wbYRIxCBGl2yI0Jf+mSvs z-qCcTpY8uzV69HLB$VdXk+LZOXLWQfwIz?s4$;#tq-v_PlABM4na^$&yq^&SE^D%z zV5+`6^0S&l$ttX0AT*23p3g^)3YeM9M7F9VrKAjQ81$+IkL2owbs2Dd^yv6|70Gbc zV}MvWI0xgg*@P_tI0rX>fxKwmdz72jBgyg{SARyQ<1~I&k(_`A)Yi9sU*!bwGJW00 zxG#@vDGtlQT`2yrRnv_JL@zVT7EaV>k2(&zesdd6Ym*Gh;$Bw*Ymp?qU9&6Ql#x@3>!9M``#AYO`e!t?v`R$a z$&#A1lyOoJ3p;U*Ri4UJx z4ZF=eSHU^ALdUTv;R-Ol?zHs6gF22RPx$2NOD9Z}vz!Xy-jREp=O@2Ld>Bj;nx@@r z2TD9X*uCInsjK|N$e#Eki0n36)f3<9tGs9SkgRHs$Nl~yq|2RlM0Hm+T5312&nJ^@ z)gez5_MkylGJsHMGJ{)RdL>jZc*!W>_sCiz#IDx}pF47DJBUqL;j5g>=sjmNAZSqz zCsRz3<)=hQ(sgE~w1n|;a;fBopKRJ-+JKo`*KF0#WvQbdrfwm5?=-LN;1}D^Wyi?6 zkMANc+(+SJlAIOuoD$bFqbN9ViR4dYclYE>>W*I%_pxm(KFx7?29M@m5Vk;$E^Z>Q zLn(ejm%7r1uoC}wlg)%`kCyXe^=K~aygd$BOAGPLM#XTA(iOFSt8?U_PeNu*&RIgk ze~PMV08?XV$MJ|sm3TeDOs!*efr0yc$VMaY?B+o56&%Re-$C{nnZ!^J)5hQf0 z01wTr5xC2ZTYC^>30;tbNxUO_0LPOsSifADPpC9i0iI8%DL zA8X%m$Tx%a$uQc!+WE^zUL(ehFsgT;GV62)nTF zRTAHR#ki~QVTpt6P3*%V49do(6xiNE**jFEA@ZNO9*lbT$L(oJLBLmWgH&0u>0e%A zl2CAh$X~ek#uKmqew~BbWJ{)e&%I=K^!o{gO8!03C=KZ%Qchqy;#+CHNqCbCC9lOj zTxiF~q;;ArYf3x=r243r-s&A`$c9O)hX~9)GYQx5=1e_Utmu#W>*zh9F8wcmfBgrE z`x%9?raT%Jd{9a_ zchmPytU}}l(WTI5`^o6YZ0VH`^^>0>{~WTU4@56^UwP*RN|rHMrm9tLKy$s1Odtiv z8l|-Z8$Dm1UF$EBfunk9g)u!xC4{XdXmr9a9IpjvasC(qO)lxmV?X!jn; zNYX!68RHd8Z9;6ln|CslYW-s29FRi1T=E{Ag#F3wmO=^sSA>?rx0z9FC7lYfz{jxU zBQMBL;hOm6RaPxOjYBBvAu0wR;}oLItFI}*4j-WADGP@n7Y?mRbu@`jJ&#YLMwj!9 z1nGjS^}N$f_RCE@Ct?cnF82=9AZ)W39PfG)31OV_|68HmzuNWB|H^CmLjGg<|0fLn fuQ_@5J6w) %\VignetteIndexEntry{Introduction to ActivityInfo and R} - %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} + %\VignetteEngine{knitr::rmarkdown} +editor_options: --- ```{r, include = FALSE} @@ -25,14 +26,9 @@ knitr::opts_chunk$set( ## Introduction -This tutorial is about the *ActivityInfo R Package* that is a client used to -access to the [ActivityInfo REST API](https://www.activityinfo.org/apidocs/index.html). -While this is an API client, names of functions and arguments are modeled more -closely to web user interface to facilitate its use. +This tutorial is about the *ActivityInfo R Package* that is a client used to access to the [ActivityInfo REST API](https://www.activityinfo.org/apidocs/index.html). While this is an API client, names of functions and arguments are modeled more closely to web user interface to facilitate its use. -With this client, you can programmatically obtain and modify your data. You can also manage users, create new -databases and forms, or define reports. Any thing else that is possible through -ActivityInfo's user interface can be automated using the API and this R package. +With this client, you can programmatically obtain and modify your data. You can also manage users, create new databases and forms, or define reports. Any thing else that is possible through ActivityInfo's user interface can be automated using the API and this R package. ## Install the R client @@ -43,22 +39,18 @@ First, you should install *ActivityInfo API R client* in your system. devtools::install_github("bedatadriven/activityinfo-R") ``` -Then, put the library call at the top of your script file. +Then, put the library call at the top of your script file. ```{r, warning=FALSE} library(activityinfo) library(dplyr) ``` -If you are using the [ActivityInfo Self-Managed Server](https://www.activityinfo.org/support/docs/self-managed/index.html), you must -provide the URL of your server using [activityInfoRootUrl](../reference/activityInfoRootUrl.html) +If you are using the [ActivityInfo Self-Managed Server](https://www.activityinfo.org/support/docs/self-managed/index.html), you must provide the URL of your server using [activityInfoRootUrl](../reference/activityInfoRootUrl.html) ## Authentication -In order to access to the *ActivityInfo API*, you must authenticate to the server -with a personal API token. You can -[generate a personal access token](https://www.activityinfo.org/support/docs/m/84880/l/1333305.html) -from the Profile Settings page in ActivityInfo. Logging in by email and password through the API is now deprecated and insecure. +In order to access to the *ActivityInfo API*, you must authenticate to the server with a personal API token. You can [generate a personal access token](https://www.activityinfo.org/support/docs/m/84880/l/1333305.html) from the Profile Settings page in ActivityInfo. Logging in by email and password through the API is now deprecated and insecure. ```{r, eval=FALSE} activityInfoToken("2d6016c9cb3be78954eb396f806a20e9") @@ -66,27 +58,22 @@ activityInfoToken("2d6016c9cb3be78954eb396f806a20e9") After the authentication process has been successfully completed, a prompt will ask if the token file named *`r basename(activityinfo:::credentialsFile)`* should be written to your home directory. Only write the file to your home directory if this is secure. Don't share or publish this token file and preserve securely as it contains your personal access token. -If you would like to avoid prompts, set `prompt = FALSE` to explicitly do this, including for Shiny server apps or non-interactive scripts. +If you would like to avoid prompts, set `prompt = FALSE` to explicitly do this, including for Shiny server apps or non-interactive scripts. + ```{r, eval=FALSE} activityInfoToken("2d6016c9cb3be78954eb396f806a20e9", prompt = FALSE) ``` ## Databases -You can list the databases that you own or have been shared with you using -[activityinfo::getDatabases]. Use the `asDf` argument to get the list -as a `data.frame`: +You can list the databases that you own or have been shared with you using [activityinfo::getDatabases]. Use the `asDf` argument to get the list as a `data.frame`: ```{r, eval=FALSE} dbList <- getDatabases() head(dbList) ``` - -In order to get details about a specific database, you can use [activityinfo::getDatabaseTree], -or [activityinfo::getDatabaseResources] to return a `data.frame` with the list -of resources in the database. "Resources" include forms, subforms, folders, -and reports. +In order to get details about a specific database, you can use [activityinfo::getDatabaseTree], or [activityinfo::getDatabaseResources] to return a `data.frame` with the list of resources in the database. "Resources" include forms, subforms, folders, and reports. ```{r} resources <- getDatabaseResources("cfcdyr0kq6ik2wmf") @@ -95,51 +82,96 @@ head(resources) ## Forms -In order to get the form or sub-form schemas that you have access to, use `getFormSchema(formId)` call, -which retrieves the the form's schema, including a list of fields in the form: - +In order to get the form or sub-form schemas that you have access to, use `getFormSchema(formId)` call, which retrieves the the form's schema, including a list of fields in the form: ```{r} schema <- getFormSchema("ceam1x8kq6ikcujg") head(schema, 4) ``` -You can find a form's ID from your browser's address bar when you have the form -page open: +You can find a form's ID from your browser's address bar when you have the form page open: ![The form id is the part following "form/"](https://www.activityinfo.org/support/screenshot/S65tNEnPlFqua.png) ## Getting records -You can get the records from an ActivityInfo form as a dplyr-compatible table. -Let's retrieve the list of projects from the [Simple 3W template](https://www.activityinfo.org/support/templates/3w.html) - +You can get the records from an ActivityInfo form as a dplyr-compatible table. Let's retrieve the list of projects from the [Simple 3W template](https://www.activityinfo.org/support/templates/3w.html) ```{r} records <- getRecords("ceam1x8kq6ikcujg") |> collect() head(records) ``` -Note that we pipe the records to [dplyr::collect], which actually retrieves -all the records from the server. +Note that we pipe the records to [dplyr::collect], which actually retrieves all the records from the server. + +For forms with tens of thousands of records, you may want to apply filtering to narrow down the results before downloading all the records from the server and select specific columns. -For forms with tens of thousands of records, you may want to apply filtering -to narrow down the results before downloading all the records from the server. -You can use the [dplyr::filter] function to apply a filter: +You can use the [dplyr::filter] function to apply a filter and the [dplyr::select] function to select columns: ```{r} unicef <- getRecords("ceam1x8kq6ikcujg", prettyColumnStyle()) |> + select(starts_with('_'), `Organization Name`) |> filter(`Organization Name` == "United Nations Childrens Fund") |> collect() ``` -This will send the filter to the server, and only download matching records. +This will send the filter and selected columns to the server, and only download matching records and fields. The select statement will include the record id and last edited time that start with the special character "\_" and the organization name. + +### Creating and using calculated columns + +The remote records can be used to select specific columns and even auto expand into reference forms or subforms. + +![](images/clipboard-1150423579.png) + +The \$ character will trigger a list potential field names. This is an example of using these field references to select columns: + +```{r} +x <- getRecords("ceam1x8kq6ikcujg") + +unicef <- x |> + select( + starts_with('_'), + `Organization Name`, + location_name_burmese = x$Location$`[Name (Burmese)]`, + location_name_en = x$Location$`[Name]` + ) |> + filter(`Organization Name` == "United Nations Childrens Fund") |> + collect() +``` + +Additionally, one can use the [dplyr::mutate] function to add calculated fields using ActivityInfo formulas and fields before downloading the data. These can be used in filters: + +```{r} +x <- getRecords("ceam1x8kq6ikcujg") + +unicef_falam <- x |> + mutate( + location_combined = + CONCAT( + "Burmese: ", x$Location$`[Name (Burmese)]`, + "; ", + "English: ", x$Location$`[Name]` + ), + location_name_burmese = x$Location$`[Name (Burmese)]`, + location_name_en = `[Location].[Name]` + ) |> + select( + starts_with('_'), + `Organization Name`, + contains("location") + ) |> + filter( + `Organization Name` == "United Nations Childrens Fund", + location_name_en == "Falam" + ) |> + collect() + +unicef$location_combined +``` ## Updating records -You can also use the R package to add, update, and import records. For single -records you can use the [activityinfo::addRecord] and [activityinfo::updateRecord] -functions: +You can also use the R package to add, update, and import records. For single records you can use the [activityinfo::addRecord] and [activityinfo::updateRecord] functions: ```{r,eval=FALSE} addRecord(formId = "cxy123", fieldValues = list( @@ -159,11 +191,9 @@ For adding or updating many records at once, you can use the [activityinfo::impo ## Adding and modifying forms -You can also add new forms and modify existing form schemas. You can add or remove -fields from a form, or add an entirely new form. +You can also add new forms and modify existing form schemas. You can add or remove fields from a form, or add an entirely new form. -The example below will add a new database, and then add a new form for a survey -to the database. +The example below will add a new database, and then add a new form for a survey to the database. ```{r, eval=FALSE} surveyDb <- addDatabase("Surveys") @@ -194,13 +224,12 @@ surveySchema <- formSchema( surveyForm <- addForm(survey) ``` + ## Managing users The R package can also be used to automate user management for a database. -For example, you could read a list of users from Active Directory or other -external source and automatically add them to an ActivityInfo database using -[activityinfo::addDatabaseUser]: +For example, you could read a list of users from Active Directory or other external source and automatically add them to an ActivityInfo database using [activityinfo::addDatabaseUser]: ```{r,eval=FALSE} @@ -211,7 +240,3 @@ addDatabaseUser( locale = "en", roleId = "admin") ``` - - - - From 1de28c65b17f559398534c3b4086cd5f46d1b689 Mon Sep 17 00:00:00 2001 From: Nicolas Dickinson Date: Mon, 16 Dec 2024 11:24:47 +0100 Subject: [PATCH 7/7] On migrateFieldData, return the getRecords() object and correct documentation, clarifying that migrateFieldData() uses an R function, removing internal use of $ on objects that override the $ function for autocompletion purposes, --- R/eval.R | 12 +++++----- R/formField.R | 10 +++++---- R/records.R | 41 +++++++++++++++++++---------------- man/migrateFieldData.Rd | 6 ++--- tests/testthat/test-eval.R | 2 +- tests/testthat/test-records.R | 2 +- 6 files changed, 39 insertions(+), 34 deletions(-) diff --git a/R/eval.R b/R/eval.R index 9426d93..dc15d34 100644 --- a/R/eval.R +++ b/R/eval.R @@ -117,9 +117,9 @@ toActivityInfoFormula <- function(.data, expr, rootEnvironment = parent.frame()) } } else if (exists(as.character(expr2), envir = rootEnvironment, inherits = TRUE)) { result <- rlang::eval_tidy(expr2, env = rootEnvironment) - if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + if (inherits(result, "activityInfoVariableExpression")&&result[["formTree"]]$root==.data[["formTree"]]$root) { return(sprintf("(%s)",paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = "."))) - } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data[["formTree"]]$root) { return(sprintf("%s", result)) } else { expr2 <- deparse(rlang::eval_tidy(exprQuo)) @@ -144,9 +144,9 @@ toActivityInfoFormula <- function(.data, expr, rootEnvironment = parent.frame()) if (fn == "$") { result = rlang::eval_tidy(expr2, env = rootEnvironment) - if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + if (inherits(result, "activityInfoVariableExpression")&&result[["formTree"]]$root==.data[["formTree"]]$root) { return(sprintf("%s",paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = "."))) - } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data[["formTree"]]$root) { return(sprintf("%s", result)) } } else if (fn %in% activityInfoFunctionNames) { @@ -363,7 +363,7 @@ getNextExpansions.character <- function(x, path = NULL) { #' @export getNextExpansions.tbl_activityInfoRemoteRecords <- function(x, path = NULL) { - getNextExpansions(x$formTree, path) + getNextExpansions(x[["formTree"]], path) } #' @export @@ -553,7 +553,7 @@ print.activityInfoVariableExpression <- function(x, ...) { expr <- x[['step']][['columns']][[nm]] class(expr) <- c("activityInfoFormulaExpression", class(expr)) attr(expr, 'columnName') <- nm - attr(expr, 'root') <- x$formTree$root + attr(expr, 'root') <- x[["formTree"]]$root return(expr) }) diff --git a/R/formField.R b/R/formField.R index 8ad17e7..61ad53d 100644 --- a/R/formField.R +++ b/R/formField.R @@ -1043,16 +1043,16 @@ checkFormField <- function(formSchema, schema, df = as.data.frame(formSchema)) { #' Migrate and convert the data of one form field into another #' #' With this function, the data from one form field (column) can be moved to -#' another form field and converted with a user-supplied function. +#' another form field and converted with a user-supplied R function. #' #' @rdname migrateFieldData #' @param .data remote records object of the form online #' @param from the source form field from which to get the data #' @param to the destination form field which will receive the converted data -#' @param fn the user-supplied conversion function; default is to do nothing +#' @param fn the user-supplied R conversion function; default is to do nothing #' @param idColumn the id column. The default is `_id` #' -#' @return The form field schema after the addition. This will be the form field schema from the server if changes are uploaded. +#' @return The remote records object. #' #' @importFrom rlang enquo #' @export @@ -1075,5 +1075,7 @@ migrateFieldData <- function(.data, from, to, fn = function(x) x, idColumn = as. cols <- tblColumns(remoteDf %>% select(id, to)) names(df) <- cols - importRecords(formId = .data$formTree$root, data = df, recordIdColumn = "_id") + importRecords(formId = .data[["formTree"]]$root, data = df, recordIdColumn = "_id") + + return(.data) } \ No newline at end of file diff --git a/R/records.R b/R/records.R index ad8291e..e01cb06 100644 --- a/R/records.R +++ b/R/records.R @@ -470,7 +470,7 @@ getRecords.activityInfo_tbl_df <- function(form, style) { if (missing(style)) { return(x) } else { - getRecords(x$formTree, style) + getRecords(x[["formTree"]], style) } } @@ -782,11 +782,11 @@ dimnames.tbl_activityInfoRemoteRecords <- function(x) { dim.tbl_activityInfoRemoteRecords <- function(x) { if (!is.null(x[['step']]$window)) { c( - min(x[['step']]$window[2], x$totalRecords), + min(x[['step']]$window[2], x[["totalRecords"]]), length(tblNames(x)) ) } else { - c(x$totalRecords, length(tblNames(x))) + c(x[["totalRecords"]], length(tblNames(x))) } } @@ -1265,7 +1265,7 @@ addSelect <- function(.data, new_vars) { adjustWindow <- function(x, offSet = 0L, limit) { stopifnot(offSet>=0&&is.integer(offSet)) if (is.null(x[['step']]$window)) { - oldWindow <- c(0L, as.integer(x$totalRecords)) + oldWindow <- c(0L, as.integer(x[["totalRecords"]])) } else { oldWindow <- x[['step']]$window } @@ -1304,7 +1304,7 @@ tblNames <- function(x) { tblFieldTypes <- function(x) { columns <- tblColumns(x) types <- unlist(lapply(columns, function(y) { - type <- class(x$elements[[y]])[1] + type <- class(x[["elements"]][[y]])[1] type <- sub("^activityInfo([a-zA-Z0-9]+)FieldSchema$", "\\1", type) type })) @@ -1366,7 +1366,7 @@ tblWindow <- function(x, limit) { window <- x[['step']]$window if (!missing(limit)) { if (is.null(window)) { - window <- c(0L, as.integer(x$totalRecords)) + window <- c(0L, as.integer(x[["totalRecords"]])) } window[2] <- min(window[2], limit) } @@ -1395,7 +1395,7 @@ extractSchemaFromFields <- function(x, databaseId, label, useColumnNames = FALSE codes <- character(0) lapply(names(x[['step']]$columns), function(colName) { - y <- x$elements[[x[['step']]$columns[colName]]] + y <- x[["elements"]][[x[['step']]$columns[colName]]] if(!is.null(y)) { y$id <- cuid() if (is.null(y$code)) { @@ -1466,7 +1466,7 @@ newStep <- function(parent, vars = parent$vars, columns = parent$columns, filter # ---- Table formatting ---- tblLabel <- function(x) { - x$formTree$forms[[x$formTree$root]]$label + x[["formTree"]]$forms[[x[["formTree"]]$root]]$label } #' @importFrom pillar tbl_format_header style_subtle align @@ -1478,9 +1478,9 @@ tbl_format_header.tbl_activityInfoRemoteRecords <- function(x, setup, ...) { columns <- tblColumns(x) named_header <- list( - "Form (id)" = sprintf("%s (%s)", tblLabel(x), x$formTree$root), - "Total form records" = x$totalRecords, - "Last edit time" = format(as.POSIXct(x$lastEditTime, origin = "1970-01-01", tz = "UTC"), "%Y-%m-%d %H:%M:%S"), + "Form (id)" = sprintf("%s (%s)", tblLabel(x), x[["formTree"]]$root), + "Total form records" = x[["totalRecords"]], + "Last edit time" = format(as.POSIXct(x[["lastEditTime"]], origin = "1970-01-01", tz = "UTC"), "%Y-%m-%d %H:%M:%S"), "Table field types" = tblFieldTypes(x), "Table filter" = tblFilter(x), "Table sort" = tblSort(x), @@ -1506,7 +1506,7 @@ tbl_sum.tbl_activityInfoRemoteRecords <- function(x, ...) { #' @export tbl_sum.activityInfo_tbl_df <- function(x, ...) { - c("ActivityInfo tibble" = sprintf("Remote form: %s (%s)",tblLabel(attr(x, "remoteRecords")), attr(x, "remoteRecords")$formTree$root), NextMethod()) + c("ActivityInfo tibble" = sprintf("Remote form: %s (%s)",tblLabel(attr(x, "remoteRecords")), attr(x, "remoteRecords")[["formTree"]]$root), NextMethod()) } # ---- Source ---- @@ -1527,7 +1527,7 @@ src_activityInfo.databaseTree <- function(x) { #' @importFrom dplyr src_tbls #' @exportS3Method src_tbls src_activityInfoFormTree src_tbls.src_activityInfoFormTree <- function(x, ...) { - names(x$formTree$forms) + names(x[["formTree"]]$forms) } #' @exportS3Method src_tbls src_activityInfoDatabaseTree @@ -1638,7 +1638,7 @@ dplyr::filter #' @importFrom dplyr collect collect.tbl_activityInfoRemoteRecords <- function(x, ...) { newTbl <- queryTable( - x$formTree, + x[["formTree"]], columns = tblColumns(x), asTibble = TRUE, makeNames = FALSE, @@ -1682,7 +1682,7 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { if (rlang::is_call(var, name = "$")||(rlang::is_symbol(var)&&exists(as.character(var), envir = parent.frame(), inherits = TRUE))) { result <- rlang::eval_tidy(quo) - if (inherits(result, "activityInfoVariableExpression")&&result$formTree$root==.data$formTree$root) { + if (inherits(result, "activityInfoVariableExpression")&&result[["formTree"]]$root==.data[["formTree"]]$root) { fullPath <- paste(c(result[["formTree"]]$root, result[["pathIds"]]), collapse = ".") if (!is.null(name)) { activityInfoVars[[name]] <- fullPath @@ -1691,7 +1691,7 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { activityInfoVars[[result[["currentPath"]]]] <- fullPath quosToReplace[[nm]] <- result[["currentPath"]] } - } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data$formTree$root) { + } else if (inherits(result, "activityInfoFormulaExpression")&&attributes(result)$root==.data[["formTree"]]$root) { quosToReplace[[nm]] <- attributes(result)$columnName } } else if (rlang::is_character(var)||rlang::is_symbol(var)) { @@ -1708,12 +1708,15 @@ select.tbl_activityInfoRemoteRecords <- function(.data, ...) { validPaths <- missingActivityInfoVars for (var in missingVars) { ids <- tryCatch({ - getPathIds(.data$formTree, var) + getPathIds(.data[["formTree"]], var) }, error = function(e) { NULL # Path is invalid }) if (!is.null(ids)) { validPaths[[var]] <- paste(ids, collapse = ".") + + validPaths[[var]] %in% names(.data[["elements"]]) + } else { warning("Invalid ActivityInfo variable path: ", var) } @@ -1782,7 +1785,7 @@ slice_head.tbl_activityInfoRemoteRecords <- function(.data, ..., n, prop) { if (missing(n)) { if (missing(prop)) stop("slice_head() must either be provide the number of rows n or prop.") stopifnot(prop>=0&&prop<=1) - n <- prop * .data$totalRecords + n <- prop * .data[["totalRecords"]] } head(.data, n = n) } @@ -1793,7 +1796,7 @@ slice_tail.tbl_activityInfoRemoteRecords <- function(.data, ..., n, prop) { if (missing(n)) { if (missing(prop)) stop("slice_tail() must either be provide the number of rows n or prop.") stopifnot(prop>=0&&prop<=1) - n <- prop * .data$totalRecords + n <- prop * .data[["totalRecords"]] } tail(.data, n = n) } diff --git a/man/migrateFieldData.Rd b/man/migrateFieldData.Rd index a22ae6a..44509cc 100644 --- a/man/migrateFieldData.Rd +++ b/man/migrateFieldData.Rd @@ -19,14 +19,14 @@ migrateFieldData( \item{to}{the destination form field which will receive the converted data} -\item{fn}{the user-supplied conversion function; default is to do nothing} +\item{fn}{the user-supplied R conversion function; default is to do nothing} \item{idColumn}{the id column. The default is \verb{_id}} } \value{ -The form field schema after the addition. This will be the form field schema from the server if changes are uploaded. +The remote records object. } \description{ With this function, the data from one form field (column) can be moved to -another form field and converted with a user-supplied function. +another form field and converted with a user-supplied R function. } diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R index 0bde69b..94896f2 100644 --- a/tests/testthat/test-eval.R +++ b/tests/testthat/test-eval.R @@ -8,7 +8,7 @@ test_that("toActivityInfoFormula() works", { testthat::expect_equal(toActivityInfoFormula(x, `_id`),"_id") testthat::expect_equal(toActivityInfoFormula(x, `_lastEditTime`),"_lastEditTime") - testthat::expect_equal(toActivityInfoFormula(x, `Children`),x$step$columns[["Children"]]) + testthat::expect_equal(toActivityInfoFormula(x, `Children`),x[["step"]]$columns[["Children"]]) testthat::expect_equal(toActivityInfoFormula(x, `[Children]`),sprintf("%s.%s", x[["formTree"]]$root, x[["step"]]$columns[["Children"]])) testthat::expect_equal(toActivityInfoFormula(x, `[Children].[Child name]`),sprintf("%s.%s.%s", x[["formTree"]]$root, x[["step"]]$columns[["Children"]], y[["step"]]$columns[["Child name"]])) diff --git a/tests/testthat/test-records.R b/tests/testthat/test-records.R index a54052f..ee2b146 100644 --- a/tests/testthat/test-records.R +++ b/tests/testthat/test-records.R @@ -405,7 +405,7 @@ testthat::test_that("getRecords() works", { ) %>% select(-values) - names(newRef1Values) <- c("personId", person$columns[["Ref 1"]]) + names(newRef1Values) <- c("personId", person[["columns"]][["Ref 1"]]) importRecords(formId = personFormId, data = newRef1Values, recordIdColumn = "personId")