diff --git a/DESCRIPTION b/DESCRIPTION index d312ca7..e1163a9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,8 +2,8 @@ Package: activityinfo Type: Package Title: R interface to ActivityInfo.org, an information management software for humanitarian and development operations -Version: 4.39 -Date: 2025-04-02 +Version: 5.0 +Date: 2026-09-25 Authors@R: c( person("Alex", "Bertram", email = "alex@bedatadriven.com", role = c("aut", "cre")), @@ -41,7 +41,7 @@ Suggests: ggplot2, quanteda, scales, - testthat (>= 3.0.0), + testthat (>= 3.1.7), knitr, rmarkdown, markdown, diff --git a/NAMESPACE b/NAMESPACE index 9f078e8..5d590cd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -167,8 +167,10 @@ export(migrateFieldData) export(minimalColumnStyle) export(monthFieldSchema) export(multilineFieldSchema) +export(multipleReferenceFieldSchema) export(multipleSelectFieldSchema) export(namedElementVarList) +export(noteFieldSchema) export(parameter) export(permissions) export(prettyColumnStyle) diff --git a/NEWS.md b/NEWS.md index 39a4692..c39189d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,31 @@ +## [5.0] +Potential breaking changes: +- `hideFromEntry` now hides a field from data entry (previously it hid the field from the table), `hideInTable` now hides a field from the table (previously it was ignored), and `reviewerOnly` now restricts a field to reviewers (previously it was ignored) +- Databases are no longer required to have an individual owner. `getDatabases()` and `getBillingAccountDatabases()` now return `NA` for the owner columns (`ownerId`, `ownerName`, `ownerEmail`) of databases without an owner, rather than failing +- User fields are now identified correctly when reading form schemas, so `getRecords()` includes them as columns with `minimalColumnStyle()` (previously they were left out) + +New features: +- New `noteFieldSchema()` for note fields, which display guidance during data entry but do not capture a value. Notes are not included as columns in `getRecords()` +- New `multipleReferenceFieldSchema()` for fields that reference one or more records in another form. `importRecords()` accepts comma-separated record ids for these fields +- New `requiredRule` and `validationMessage` arguments for form field schemas, to limit when a required field is required and to show a custom message when validation fails +- `as.data.frame()` of a form schema now includes the `requiredCondition` and `validationMessage` columns +- Form field schemas from `getFormSchema()` now always include `dataEntryVisible`, like `tableVisible` + +Fixes: +- `getDatabases()` and `getBillingAccountDatabases()` no longer fail when the server returns a null description, as self-managed servers do +- The `lastRecordUpdate` column of `getBillingAccountDatabases()` is now always character, including when no database has records +- `queryAuditLog()` no longer fails on events with none or several resource types; these are combined into a single comma-separated value in the `resourceTypes` column + +Testing: +- Tests with fixed server responses for databases with and without an owner, and for the fixes above +- API tests now authenticate with an API token rather than basic password authentication +- Tests updated for testthat 3.3 and to not depend on the versions of pandoc and rmarkdown +- Tests can be run against the self-managed server + +## [4.39] +- `getDatabaseBillingAccount()` now includes `parentBillingAccountId` and handles billing accounts without a parent (#150) +- Fixed `getDatabaseBillingAccount()` for billing accounts with no addons (#151, #152) + ## [4.38] - New vignettes on grant-based roles, advanced user management (bulk actions), and advanced role use-cases (#122, #133) - Improved metadata on getRecords() to include last time modified (#26, #39) diff --git a/R/audit.R b/R/audit.R index 69fbe72..2abc79f 100644 --- a/R/audit.R +++ b/R/audit.R @@ -91,6 +91,11 @@ queryAuditLog <- function(databaseId, before = Sys.time(), after, resourceId = N event$user.email <- NA } event$user <- NULL + # Fields such as resourceTypes may have none or several values: combine + # them so that each event is a single row + event <- lapply(event, function(x) { + if (length(x) == 1) x else if (length(x) == 0) NA else paste(unlist(x), collapse = ",") + }) as.data.frame(event, stringsAsFactors = FALSE) })) diff --git a/R/billingInfo.R b/R/billingInfo.R index d546d74..01b0eb3 100644 --- a/R/billingInfo.R +++ b/R/billingInfo.R @@ -54,19 +54,15 @@ getBillingAccountDatabases <- function(billingAccountId, asDataFrame = TRUE) { billingDatabases <- tibble::tibble( databaseId = unlist(lapply(billingDatabases, function(x) {x$databaseId})), label = unlist(lapply(billingDatabases, function(x) {x$label})), - description = unlist(lapply(billingDatabases, function(x) { if(nzchar(x$description)) x$description else NA_character_ })), - ownerId = unlist(lapply(billingDatabases, function(x) {x$owner[["id"]]})), - ownerName = unlist(lapply(billingDatabases, function(x) {x$owner[["name"]]})), - ownerEmail = unlist(lapply(billingDatabases, function(x) {x$owner[["email"]]})), + description = vapply(billingDatabases, function(x) {emptyToNA(x$description)}, character(1)), + ownerId = vapply(billingDatabases, function(x) {charOrNA(x$owner[["id"]])}, character(1)), + ownerName = vapply(billingDatabases, function(x) {charOrNA(x$owner[["name"]])}, character(1)), + ownerEmail = vapply(billingDatabases, function(x) {charOrNA(x$owner[["email"]])}, character(1)), formCount = unlist(lapply(billingDatabases, function(x) {x$formCount})), userCount = unlist(lapply(billingDatabases, function(x) {x$userCount})), basicUserCount = unlist(lapply(billingDatabases, function(x) {x$basicUserCount})), recordCount = unlist(lapply(billingDatabases, function(x) {x$recordCount})), - lastRecordUpdate = unlist(lapply(billingDatabases, function(x) { - if(is.null(x$lastRecordUpdate)) - {NA} else - {x$lastRecordUpdate} - })), + lastRecordUpdate = vapply(billingDatabases, function(x) {charOrNA(x$lastRecordUpdate)}, character(1)), billingAccountId = unlist(lapply(billingDatabases, function(x) {x$billingAccountId})), suspended = unlist(lapply(billingDatabases, function(x) {x$suspended})), publishedTemplate = unlist(lapply(billingDatabases, function(x) {x$publishedTemplate})) diff --git a/R/databases.R b/R/databases.R index 9a19022..4b60d29 100644 --- a/R/databases.R +++ b/R/databases.R @@ -13,7 +13,7 @@ getDatabases <- function(asDataFrame = TRUE) { return(databasesListToTibble(databases)) } else if (asDataFrame == FALSE) { return(lapply(databases, function(x) { - x$ownerId <- as.character(x$ownerId) + x$ownerId <- charOrNA(x$ownerId) x$billingAccountId <- as.character(x$billingAccountId) x })) @@ -24,14 +24,25 @@ databasesListToTibble <- function(databases) { dbDF <- dplyr::tibble( databaseId = unlist(lapply(databases, function(x) {x$databaseId})), label = unlist(lapply(databases, function(x) {x$label})), - description = unlist(lapply(databases, function(x) { if(nzchar(x$description)) x$description else NA_character_ })), - ownerId = as.character(unlist(lapply(databases, function(x) {x$ownerId}))), + description = vapply(databases, function(x) {emptyToNA(x$description)}, character(1)), + ownerId = vapply(databases, function(x) {charOrNA(x$ownerId)}, character(1)), billingAccountId = as.character(unlist(lapply(databases, function(x) {x$billingAccountId}))), suspended = unlist(lapply(databases, function(x) {x$suspended})) ) return(dbDF) } +# Databases are no longer required to have an individual owner, so +# owner fields may be null +charOrNA <- function(x) { + if (is.null(x)) NA_character_ else as.character(x) +} + +# The server may return an empty or a null description +emptyToNA <- function(x) { + if (is.null(x) || !nzchar(x)) NA_character_ else as.character(x) +} + databaseUpdates <- function() { list( resourceUpdates = list(), diff --git a/R/formField.R b/R/formField.R index 080c557..f7ac8a9 100644 --- a/R/formField.R +++ b/R/formField.R @@ -17,18 +17,28 @@ #' @param validationRule Validation rules for the form field given as a single character string; default is "" #' @param reviewerOnly Whether the form field is for reviewers only; default is FALSE #' @param typeParameters The type parameters object specific to the type given. +#' @param requiredRule A formula given as a single character string that limits +#' the requirement to the records in which the formula is satisfied. Only +#' applies when `required` is TRUE; default is "", which means the field is +#' required for every record +#' @param validationMessage A custom message given as a single character string +#' that is shown when the validation rule fails; default is NULL, which uses +#' the automatically composed message #' #' @family field schemas #' @export -formFieldSchema <- function(type, label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, typeParameters = NULL) { +formFieldSchema <- function(type, label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, typeParameters = NULL, requiredRule = "", validationMessage = NULL) { stopifnot("The label is required to be a character string" = (is.character(label)&&length(label)==1&&nchar(label)>0)) stopifnot("The description must be a character string" = is.null(description)||(is.character(description)&&length(description)==1&&nchar(description)>0)) stopifnot("The code must be a character string" = is.null(code)||(is.character(code)&&length(code)==1&&nchar(code)>0)) stopifnot("The id is required and must be a character string" = !is.null(id)&&(is.character(id)&&length(id)==1&&nchar(id)>0)) stopifnot("`relevanceRule` must be given as a character string" = !is.null(relevanceRule)&&(is.character(relevanceRule)&&length(relevanceRule)==1)) stopifnot("`validationRule` must be given as a character string" = !is.null(validationRule)&&(is.character(validationRule)&&length(validationRule)==1)) + stopifnot("`requiredRule` must be given as a character string" = !is.null(requiredRule)&&(is.character(requiredRule)&&length(requiredRule)==1)) + stopifnot("`validationMessage` must be NULL or a character string" = is.null(validationMessage)||(is.character(validationMessage)&&length(validationMessage)==1&&nchar(validationMessage)>0)) stopifnot("The key must be a logical/boolean of length 1" = is.logical(key)&&length(key)==1) stopifnot("`required` must be a logical/boolean of length 1" = is.logical(required)&&length(required)==1) + stopifnot("`requiredRule` only applies to required fields; set `required = TRUE`" = required||!nzchar(requiredRule)) stopifnot("`hideFromEntry` must be a logical/boolean of length 1" = is.logical(hideFromEntry)&&length(hideFromEntry)==1) stopifnot("`hideInTable` must be a logical/boolean of length 1" = is.logical(hideInTable)&&length(hideInTable)==1) stopifnot("`reviewerOnly` must be a logical/boolean of length 1" = is.logical(reviewerOnly)&&length(reviewerOnly)==1) @@ -46,10 +56,21 @@ formFieldSchema <- function(type, label, description = NULL, code = NULL, id = c schema$label <- label schema$relevanceCondition <- relevanceRule + schema$requiredCondition <- requiredRule schema$validationCondition <- validationRule - schema$tableVisible <- !hideFromEntry + + if (!is.null(validationMessage)) { + schema$validationMessage <- validationMessage + } + + schema$dataEntryVisible <- !hideFromEntry + schema$tableVisible <- !hideInTable schema$required <- required + if (reviewerOnly) { + schema$securityCategoryId <- "reviewer" + } + if (!is.null(description)) { schema$description = description } @@ -68,6 +89,7 @@ formFieldSchema <- function(type, label, description = NULL, code = NULL, id = c asFormFieldSchema <- function(e) { e$key <- identical(e$key, TRUE) e$required <- identical(e$required, TRUE) + e$dataEntryVisible <- !identical(e$dataEntryVisible, FALSE) e$tableVisible <- !identical(e$tableVisible, FALSE) if(is.null(e$code)) { e["code"] <- list(NULL) @@ -83,7 +105,7 @@ asFormFieldSchema <- function(e) { addFormFieldSchemaCustomClass <- function(e) { if (e$type == "FREE_TEXT") { - if (e$typeParameters$barcode) { + if (isTRUE(e$typeParameters$barcode)) { class(e) <- c("activityInfoBarcodeFieldSchema", class(e)) } else { class(e) <- c("activityInfoTextFieldSchema", class(e)) @@ -114,20 +136,22 @@ addFormFieldSchemaCustomClass <- function(e) { class(e) <- c("activityInfoAttachmentFieldSchema", class(e)) } else if (e$type == "calculated") { class(e) <- c("activityInfoCalculatedFieldSchema", class(e)) - } else if (e$type == "attachment") { - class(e) <- c("activityInfoAttachmentFieldSchema", class(e)) } else if (e$type == "subform") { class(e) <- c("activityInfoSubformFieldSchema", class(e)) } else if (e$type == "geopoint") { class(e) <- c("activityInfoGeopointFieldSchema", class(e)) } else if (e$type == "reference") { - if (grepl("@user$", e$typeParameters$range[[1]]$formId)) { + if (grepl("@users$", e$typeParameters$range[[1]]$formId)) { class(e) <- c("activityInfoUserFieldSchema", class(e)) } else { class(e) <- c("activityInfoReferenceFieldSchema", class(e)) } + } else if (e$type == "multiselectreference") { + class(e) <- c("activityInfoMultipleReferenceFieldSchema", class(e)) } else if (e$type == "section") { class(e) <- c("activityInfoSectionFieldSchema", class(e)) + } else if (e$type == "note") { + class(e) <- c("activityInfoNoteFieldSchema", class(e)) } return(e) } @@ -187,7 +211,7 @@ formFieldArgs <- function(x) { #' @inheritParams formFieldSchema #' #' @export -textFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +textFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -208,7 +232,7 @@ textFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), #' #' @family field schemas #' @export -barcodeFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +barcodeFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -269,7 +293,7 @@ serialNumberFieldSchema <- function(label, description = NULL, digits = 5L, pref #' is default #' @family field schemas #' @export -quantityFieldSchema <- function(label, description = NULL, units = "", aggregation = "SUM", code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +quantityFieldSchema <- function(label, description = NULL, units = "", aggregation = "SUM", code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { stopifnot("Units must be a character string (empty or not)" = is.character(units)&&length(units)==1) stopifnot("Aggregation must be a character string" = is.character(aggregation)&&length(aggregation)==1) schema <- do.call( @@ -298,7 +322,7 @@ quantityFieldSchema <- function(label, description = NULL, units = "", aggregati #' @inheritParams formFieldSchema #' @family field schemas #' @export -multilineFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +multilineFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -318,7 +342,7 @@ multilineFieldSchema <- function(label, description = NULL, code = NULL, id = cu #' @inheritParams formFieldSchema #' @family field schemas #' @export -dateFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +dateFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -339,7 +363,7 @@ dateFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), #' @inheritParams formFieldSchema #' @family field schemas #' @export -weekFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +weekFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -358,7 +382,7 @@ weekFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), #' @inheritParams formFieldSchema #' @family field schemas #' @export -monthFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +monthFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -370,7 +394,7 @@ monthFieldSchema <- function(label, description = NULL, code = NULL, id = cuid() schema } -selectFieldSchema <- function(cardinality, label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +selectFieldSchema <- function(cardinality, label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { stopifnot("Cardinality must be a character string 'single' or 'multiple'" = is.character(cardinality)&&length(cardinality)==1&&(cardinality %in% c("single", "multiple"))) schema <- do.call( formFieldSchema, @@ -403,7 +427,7 @@ selectFieldSchema <- function(cardinality, label, description = NULL, options = #' @param options A list of the single select field options #' @family field schemas #' @export -singleSelectFieldSchema <- function(label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +singleSelectFieldSchema <- function(label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( selectFieldSchema, args = c( @@ -423,7 +447,7 @@ singleSelectFieldSchema <- function(label, description = NULL, options = list(), #' @param options A list of the multiple select field options #' @family field schemas #' @export -multipleSelectFieldSchema <- function(label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +multipleSelectFieldSchema <- function(label, description = NULL, options = list(), code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( selectFieldSchema, args = c( @@ -520,7 +544,7 @@ print.activityInfoSelectOptions <- function(x, ...) { #' @inheritParams formFieldSchema #' @family field schemas #' @export -attachmentFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +attachmentFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { schema <- do.call( formFieldSchema, args = c( @@ -578,7 +602,7 @@ calculatedFieldSchema <- function(label, description = NULL, formula, code = NUL #' @param subformId The id of the sub-form #' @family field schemas #' @export -subformFieldSchema <- function(label, description = NULL, subformId, code = NULL, id = cuid(), hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +subformFieldSchema <- function(label, description = NULL, subformId, code = NULL, id = cuid(), hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, validationMessage = NULL) { stopifnot("The subform id must be a character string" = is.character(subformId)&&length(subformId)==1&&nchar(subformId)>0) schema <- do.call( formFieldSchema, @@ -604,7 +628,7 @@ subformFieldSchema <- function(label, description = NULL, subformId, code = NULL #' @param referencedFormId The id of the referenced form #' @family field schemas #' @export -referenceFieldSchema <- function(label, description = NULL, referencedFormId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +referenceFieldSchema <- function(label, description = NULL, referencedFormId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { stopifnot("The referenced form id must be a character string" = is.character(referencedFormId)&&length(referencedFormId)==1&&nchar(referencedFormId)>0) schema <- do.call( formFieldSchema, @@ -627,6 +651,39 @@ referenceFieldSchema <- function(label, description = NULL, referencedFormId, co schema } +#' Create a Multiple Reference field schema +#' +#' A multiple reference field can be used to make reference to one or more +#' records in another form. +#' +#' A multiple reference field cannot be a key field. +#' +#' @inheritParams formFieldSchema +#' @param referencedFormId The id of the referenced form +#' @family field schemas +#' @export +multipleReferenceFieldSchema <- function(label, description = NULL, referencedFormId, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { + stopifnot("The referenced 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 Geographic Point form field schema #' #' A Geographic Point field allow users to enter a geo-location with a certain @@ -645,7 +702,7 @@ referenceFieldSchema <- function(label, description = NULL, referencedFormId, co #' is TRUE #' @family field schemas #' @export -geopointFieldSchema <- function(label, description = NULL, requiredAccuracy = NULL, manualEntryAllowed = TRUE, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +geopointFieldSchema <- function(label, description = NULL, requiredAccuracy = NULL, manualEntryAllowed = TRUE, code = NULL, id = cuid(), required = FALSE, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { stopifnot("requiredAccuracy must be a single numeric value or NULL" = is.null(requiredAccuracy)||(is.numeric(requiredAccuracy)&&length(requiredAccuracy)==1)) stopifnot("manualEntryAllowed must be single logical" = is.logical(manualEntryAllowed)&&length(manualEntryAllowed)==1) @@ -683,7 +740,7 @@ geopointFieldSchema <- function(label, description = NULL, requiredAccuracy = NU #' @param databaseId The database id of the form and users #' @family field schemas #' @export -userFieldSchema <- function(label, description = NULL, databaseId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE) { +userFieldSchema <- function(label, description = NULL, databaseId, code = NULL, id = cuid(), key = FALSE, required = key, hideFromEntry = FALSE, hideInTable = FALSE, relevanceRule = "", validationRule = "", reviewerOnly = FALSE, requiredRule = "", validationMessage = NULL) { stopifnot("`databaseId` must be a character string" = is.character(databaseId)&&length(databaseId)==1&&nchar(databaseId)>0) schema <- do.call( formFieldSchema, @@ -729,6 +786,27 @@ sectionFieldSchema <- function(label, description = NULL, indentationLevel = 1L) schema } +#' Create a note form field schema +#' +#' A note displays its label and description to users during data entry. It +#' does not capture a value and is not included in the records table. +#' +#' @inheritParams formFieldSchema +#' @param description The text of the note +#' @family field schemas +#' @export +noteFieldSchema <- function(label, description = NULL, code = NULL, id = cuid(), hideFromEntry = FALSE, relevanceRule = "") { + schema <- do.call( + formFieldSchema, + args = c( + list(type = "note"), + formFieldArgs(as.list(environment())) + ) + ) + + schema +} + isFormFieldSchema <- function(schema) { "activityInfoFormFieldSchema" %in% class(schema) } @@ -917,7 +995,7 @@ addFormField <- function(...) { addFormField.character <- function(formId, schema, upload = FALSE, ...) { formSchema <- getFormSchema(formId = formId) sane <- checkFormField(formSchema, schema) - fromSchema <- sane$formSchema + formSchema <- sane$formSchema schema <- sane$schema formSchema$elements[[length(formSchema$elements)+1]] <- schema if (upload == TRUE) { @@ -932,7 +1010,7 @@ addFormField.character <- function(formId, schema, upload = FALSE, ...) { #' @rdname addFormField addFormField.formSchema <- function(formSchema, schema, upload = FALSE, ...) { sane <- checkFormField(formSchema, schema) - fromSchema <- sane$formSchema + formSchema <- sane$formSchema schema <- sane$schema formSchema$elements[[length(formSchema$elements)+1]] <- schema if (upload == TRUE) { diff --git a/R/forms.R b/R/forms.R index d3e8c50..39cb3aa 100644 --- a/R/forms.R +++ b/R/forms.R @@ -98,7 +98,9 @@ as.data.frame.formSchema <- function(x, row.names = NULL, optional = FALSE, ...) fieldLabel = sapply(x$elements, function(e) null2na(e$label)), fieldDescription = sapply(x$elements, function(e) null2na(e$description)), validationCondition = sapply(x$elements, function(e) null2na(e$validationCondition)), + validationMessage = sapply(x$elements, function(e) null2na(e$validationMessage)), relevanceCondition = sapply(x$elements, function(e) null2na(e$relevanceCondition)), + requiredCondition = sapply(x$elements, function(e) null2na(e$requiredCondition)), 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)), diff --git a/R/import.R b/R/import.R index df8c22a..444b233 100644 --- a/R/import.R +++ b/R/import.R @@ -151,6 +151,7 @@ prepareImport <- function(field, columnName, column) { quantity = as.double(column), enumerated = prepareEnumImport(field, columnName, column), reference = prepareReference(field, column), + multiselectreference = prepareMultipleReference(field, columnName, column), date = prepareDate(field, column), month = prepareMonth(field, columnName, column), serial = prepareSerial(field, columnName, column), @@ -250,6 +251,26 @@ prepareReference <- function(field, column) { column } +prepareMultipleReference <- function(field, columnName, column) { + column <- as.character(column) + column[!nzchar(column)] <- NA_character_ + rows <- strsplit(column, split = "\\s*,\\s*") + + lapply(rows, function(row) { + if(length(row) == 1 && is.na(row)) { + return(NA_character_) + } + invalid <- !grepl(row, pattern = "^[a-z][a-z0-9]{0,30}$") + if (any(invalid)) { + stop(sprintf("For multiple reference field '%s', the imported column `%s` contains invalid record ids: %s", + field$label, + columnName, + paste(collapse = ", ", sprintf("'%s'", head(unique(row[invalid]), n = 5))))) + } + I(row) + }) +} + prepareUserReference <- function(field, column) { column <- as.character(column) valid <- grepl(column, pattern = "^[0-9]{0,30}$") diff --git a/R/records.R b/R/records.R index 881b97f..4c4088d 100644 --- a/R/records.R +++ b/R/records.R @@ -988,6 +988,15 @@ elementVars <- function(element, formTree, style = defaultColumnStyle(), namedEl elementList <- list() + # Notes do not capture a value, so have no column + if (inherits(element, "activityInfoNoteFieldSchema")) { + if (namedElement) { + return(elementList) + } else { + return(character()) + } + } + useParentLabel <- (!missing(useParentLabel) && useParentLabel) if (useParentLabel) { stopifnot(!missing(parentLabel) && is.character(parentLabel) && length(parentLabel) == 1) diff --git a/man/attachmentFieldSchema.Rd b/man/attachmentFieldSchema.Rd index edc4df2..433a606 100644 --- a/man/attachmentFieldSchema.Rd +++ b/man/attachmentFieldSchema.Rd @@ -14,7 +14,9 @@ attachmentFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -37,6 +39,15 @@ attachmentFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ An attachments field allow users to add one or more attachments. @@ -53,7 +64,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/barcodeFieldSchema.Rd b/man/barcodeFieldSchema.Rd index 9142ea3..ac85e2d 100644 --- a/man/barcodeFieldSchema.Rd +++ b/man/barcodeFieldSchema.Rd @@ -15,7 +15,9 @@ barcodeFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -40,6 +42,15 @@ barcodeFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ Create a barcode form field schema @@ -53,7 +64,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/calculatedFieldSchema.Rd b/man/calculatedFieldSchema.Rd index 93dd850..f289539 100644 --- a/man/calculatedFieldSchema.Rd +++ b/man/calculatedFieldSchema.Rd @@ -51,7 +51,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/dateFieldSchema.Rd b/man/dateFieldSchema.Rd index 49705ae..e87f087 100644 --- a/man/dateFieldSchema.Rd +++ b/man/dateFieldSchema.Rd @@ -15,7 +15,9 @@ dateFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -40,6 +42,15 @@ dateFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ The Date format in ActivityInfo is YYYY-MM-DD so no matter the way the Date @@ -54,7 +65,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/formFieldSchema.Rd b/man/formFieldSchema.Rd index bd729f1..14a99da 100644 --- a/man/formFieldSchema.Rd +++ b/man/formFieldSchema.Rd @@ -17,7 +17,9 @@ formFieldSchema( relevanceRule = "", validationRule = "", reviewerOnly = FALSE, - typeParameters = NULL + typeParameters = NULL, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -46,6 +48,15 @@ formFieldSchema( \item{reviewerOnly}{Whether the form field is for reviewers only; default is FALSE} \item{typeParameters}{The type parameters object specific to the type given.} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ This is the function to create a basic form field schema object. It is @@ -61,7 +72,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/geopointFieldSchema.Rd b/man/geopointFieldSchema.Rd index 538a205..0227561 100644 --- a/man/geopointFieldSchema.Rd +++ b/man/geopointFieldSchema.Rd @@ -16,7 +16,9 @@ geopointFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -44,6 +46,15 @@ is TRUE} \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ A Geographic Point field allow users to enter a geo-location with a certain @@ -68,7 +79,9 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/monthFieldSchema.Rd b/man/monthFieldSchema.Rd index 66b5d4c..d85c7ac 100644 --- a/man/monthFieldSchema.Rd +++ b/man/monthFieldSchema.Rd @@ -15,7 +15,9 @@ monthFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -40,6 +42,15 @@ monthFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ The Month format in ActivityInfo is YYYY-MM. @@ -53,7 +64,9 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{geopointFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/multilineFieldSchema.Rd b/man/multilineFieldSchema.Rd index 497faa3..a054be7 100644 --- a/man/multilineFieldSchema.Rd +++ b/man/multilineFieldSchema.Rd @@ -14,7 +14,9 @@ multilineFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -37,6 +39,15 @@ multilineFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ Multi-Line Text fields can be used to collect long answers to open-ended @@ -52,7 +63,9 @@ Other field schemas: \code{\link{formFieldSchema}()}, \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/multipleReferenceFieldSchema.Rd b/man/multipleReferenceFieldSchema.Rd new file mode 100644 index 0000000..1251e3e --- /dev/null +++ b/man/multipleReferenceFieldSchema.Rd @@ -0,0 +1,83 @@ +% 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(), + required = FALSE, + hideFromEntry = FALSE, + hideInTable = FALSE, + relevanceRule = "", + validationRule = "", + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL +) +} +\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{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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} +} +\description{ +A multiple reference field can be used to make reference to one or more +records in another form. +} +\details{ +A multiple reference field cannot be a key field. +} +\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{noteFieldSchema}()}, +\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/multipleSelectFieldSchema.Rd b/man/multipleSelectFieldSchema.Rd index ee9d1e5..a7a6660 100644 --- a/man/multipleSelectFieldSchema.Rd +++ b/man/multipleSelectFieldSchema.Rd @@ -16,7 +16,9 @@ multipleSelectFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -43,6 +45,15 @@ multipleSelectFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ There is an options parameter for the list of multiple select items. Multiple @@ -59,6 +70,8 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/noteFieldSchema.Rd b/man/noteFieldSchema.Rd new file mode 100644 index 0000000..b86ad8c --- /dev/null +++ b/man/noteFieldSchema.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formField.R +\name{noteFieldSchema} +\alias{noteFieldSchema} +\title{Create a note form field schema} +\usage{ +noteFieldSchema( + label, + description = NULL, + code = NULL, + id = cuid(), + hideFromEntry = FALSE, + relevanceRule = "" +) +} +\arguments{ +\item{label}{The label of the form field} + +\item{description}{The text of the note} + +\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{hideFromEntry}{Whether the form field is hidden during data entry; default is FALSE} + +\item{relevanceRule}{Relevance rules for the form field given as a single character string; default is ""} +} +\description{ +A note displays its label and description to users during data entry. It +does not capture a value and is not included in the records table. +} +\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/quantityFieldSchema.Rd b/man/quantityFieldSchema.Rd index a39c00e..f479023 100644 --- a/man/quantityFieldSchema.Rd +++ b/man/quantityFieldSchema.Rd @@ -16,7 +16,9 @@ quantityFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -44,6 +46,15 @@ is default} \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ A Quantity field allow users to enter a numerical value. You can define the @@ -62,7 +73,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, diff --git a/man/referenceFieldSchema.Rd b/man/referenceFieldSchema.Rd index 3627f73..f5a3961 100644 --- a/man/referenceFieldSchema.Rd +++ b/man/referenceFieldSchema.Rd @@ -16,7 +16,9 @@ referenceFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -43,6 +45,15 @@ referenceFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ A reference field can be used to make reference to a record in another form. @@ -57,7 +68,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{sectionFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, diff --git a/man/sectionFieldSchema.Rd b/man/sectionFieldSchema.Rd index 9c32be0..cd68ef3 100644 --- a/man/sectionFieldSchema.Rd +++ b/man/sectionFieldSchema.Rd @@ -26,7 +26,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{serialNumberFieldSchema}()}, diff --git a/man/serialNumberFieldSchema.Rd b/man/serialNumberFieldSchema.Rd index dad1b97..ebc0ed9 100644 --- a/man/serialNumberFieldSchema.Rd +++ b/man/serialNumberFieldSchema.Rd @@ -52,7 +52,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/singleSelectFieldSchema.Rd b/man/singleSelectFieldSchema.Rd index e24e966..4a5e705 100644 --- a/man/singleSelectFieldSchema.Rd +++ b/man/singleSelectFieldSchema.Rd @@ -16,7 +16,9 @@ singleSelectFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -43,6 +45,15 @@ singleSelectFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ There is an options parameter for the list of single select items. Single @@ -62,7 +73,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/subformFieldSchema.Rd b/man/subformFieldSchema.Rd index 2184aca..b696856 100644 --- a/man/subformFieldSchema.Rd +++ b/man/subformFieldSchema.Rd @@ -14,7 +14,8 @@ subformFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + validationMessage = NULL ) } \arguments{ @@ -37,6 +38,10 @@ subformFieldSchema( \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} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ A subform field can be used to define a field that contains a subform. @@ -54,7 +59,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/textFieldSchema.Rd b/man/textFieldSchema.Rd index 5e0780c..90c11e0 100644 --- a/man/textFieldSchema.Rd +++ b/man/textFieldSchema.Rd @@ -15,7 +15,9 @@ textFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -40,6 +42,15 @@ textFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ You can define the format of the text that the users should type in a Text diff --git a/man/userFieldSchema.Rd b/man/userFieldSchema.Rd index f230d43..0d9f100 100644 --- a/man/userFieldSchema.Rd +++ b/man/userFieldSchema.Rd @@ -16,7 +16,9 @@ userFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -43,6 +45,15 @@ userFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ User fields allow you to select a specific user from a list. It is a field @@ -62,7 +73,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/man/weekFieldSchema.Rd b/man/weekFieldSchema.Rd index 4d7c4cd..9b13ad5 100644 --- a/man/weekFieldSchema.Rd +++ b/man/weekFieldSchema.Rd @@ -15,7 +15,9 @@ weekFieldSchema( hideInTable = FALSE, relevanceRule = "", validationRule = "", - reviewerOnly = FALSE + reviewerOnly = FALSE, + requiredRule = "", + validationMessage = NULL ) } \arguments{ @@ -40,6 +42,15 @@ weekFieldSchema( \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} + +\item{requiredRule}{A formula given as a single character string that limits +the requirement to the records in which the formula is satisfied. Only +applies when \code{required} is TRUE; default is "", which means the field is +required for every record} + +\item{validationMessage}{A custom message given as a single character string +that is shown when the validation rule fails; default is NULL, which uses +the automatically composed message} } \description{ The Week format in ActivityInfo is YYYY-WW. Users can directly type using @@ -56,7 +67,9 @@ Other field schemas: \code{\link{geopointFieldSchema}()}, \code{\link{monthFieldSchema}()}, \code{\link{multilineFieldSchema}()}, +\code{\link{multipleReferenceFieldSchema}()}, \code{\link{multipleSelectFieldSchema}()}, +\code{\link{noteFieldSchema}()}, \code{\link{quantityFieldSchema}()}, \code{\link{referenceFieldSchema}()}, \code{\link{sectionFieldSchema}()}, diff --git a/tests/testthat/_snaps/databases.md b/tests/testthat/_snaps/databases.md index 3f1f5a9..9bd010f 100644 --- a/tests/testthat/_snaps/databases.md +++ b/tests/testthat/_snaps/databases.md @@ -15,10 +15,10 @@ dbResources Output # A tibble: 2 x 5 - id label parentId type visibility - * - 1 c10000004 Person form c10000002 FORM PRIVATE - 2 c10000005 Children c10000004 SUB_FORM PRIVATE + id label parentId type visibility + * + 1 c10004 Person form c10002 FORM PRIVATE + 2 c10005 Children c10004 SUB_FORM PRIVATE # resourcePermissions() and synonym permissions() helper works diff --git a/tests/testthat/_snaps/formField.md b/tests/testthat/_snaps/formField.md index 8241d0a..66ff892 100644 --- a/tests/testthat/_snaps/formField.md +++ b/tests/testthat/_snaps/formField.md @@ -1,20 +1,23 @@ # Test deleteFormField() structure(list(databaseId = "", elements = list(structure(list( - code = "txt2", description = NULL, id = "", key = FALSE, - label = "Text field 2", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt2", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 2", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt4", description = NULL, id = "", key = FALSE, - label = "Text field 4", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt4", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 4", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt5", description = NULL, id = "", key = FALSE, - label = "Text field 5", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt5", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 5", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list"))), id = "", label = "R form with multiple fields to delete"), class = c("activityInfoFormSchema", "formSchema", "list")) @@ -22,25 +25,29 @@ --- structure(list(databaseId = "", elements = list(structure(list( - code = "txt1", description = NULL, id = "", key = FALSE, - label = "Text field 1", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt1", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 1", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt2", description = NULL, id = "", key = FALSE, - label = "Text field 2", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt2", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 2", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt3", description = NULL, id = "", key = FALSE, - label = "Text field 3", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt3", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 3", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt5", description = NULL, id = "", key = FALSE, - label = "Text field 5", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt5", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 5", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list"))), id = "", label = "R form with multiple fields to delete"), class = c("activityInfoFormSchema", "formSchema", "list")) @@ -48,20 +55,23 @@ --- structure(list(databaseId = "", elements = list(structure(list( - code = "txt2", description = NULL, id = "", key = FALSE, - label = "Text field 2", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt2", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 2", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt3", description = NULL, id = "", key = FALSE, - label = "Text field 3", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt3", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 3", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list")), structure(list( - code = "txt4", description = NULL, id = "", key = FALSE, - label = "Text field 4", relevanceCondition = "", required = FALSE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", + code = "txt4", dataEntryVisible = TRUE, description = NULL, + id = "", key = FALSE, label = "Text field 4", relevanceCondition = "", + required = FALSE, requiredCondition = "", tableVisible = TRUE, + type = "FREE_TEXT", typeParameters = list(barcode = FALSE), + validationCondition = ""), class = c("activityInfoTextFieldSchema", "activityInfoFormFieldSchema", "formField", "list"))), id = "", label = "R form with multiple fields to delete"), class = c("activityInfoFormSchema", "formSchema", "list")) diff --git a/tests/testthat/_snaps/rmdOutput.md b/tests/testthat/_snaps/rmdOutput.md new file mode 100644 index 0000000..88db4d9 --- /dev/null +++ b/tests/testthat/_snaps/rmdOutput.md @@ -0,0 +1,32 @@ +# Rmd outputs as expected + + Code + writeLines(text) + Output + TestMessages + Nicolas Dickinson + 2022-12-11 + This is a test of issue #29 + try({ + if (grepl(pattern = "activityinfo-R$", rstudioapi::getActiveProject())) { + devtools::load_all(".") + withr::with_options(new = list(activityinfo.interactive = FALSE), { + source(file = testthat::test_path("setup.R")) + }) + } + }, silent = TRUE) + dt <- as.data.frame(getFormSchema(formId = personFormId)) + knitr::kable(dt[,c("fieldCode", "fieldType")]) + fieldCode + fieldType + NAME + FREE_TEXT + CHILDREN + subform + NA + reference + NA + reference + NA + reference + diff --git a/tests/testthat/_snaps/rmdOutput/TestMessages.html b/tests/testthat/_snaps/rmdOutput/TestMessages.html deleted file mode 100644 index cd6002d..0000000 --- a/tests/testthat/_snaps/rmdOutput/TestMessages.html +++ /dev/null @@ -1,452 +0,0 @@ - - - - - - - - - - - - - - - -TestMessages - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - -
-

This is a test of issue #29

-
try({
-  if (grepl(pattern = "activityinfo-R$", rstudioapi::getActiveProject())) {
-    devtools::load_all(".")
-    withr::with_options(new = list(activityinfo.interactive = FALSE), {
-      source(file = testthat::test_path("setup.R"))
-    })
-  }
-}, silent = TRUE)
-
-dt <- as.data.frame(getFormSchema(formId = personFormId))
-
-knitr::kable(dt[,c("fieldCode", "fieldType")])
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
fieldCodefieldType
NAMEFREE_TEXT
CHILDRENsubform
NAreference
NAreference
NAreference
-
- - - - -
- - - - - - - - - - - - - - - diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index e851003..31d7423 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -14,13 +14,14 @@ suppressWarnings(grSoftVersion()) ##### Testing functions ##### -# creating a cuid that artificially enforces a sort order on IDs for snapshotting of API objects +# creating a cuid that artificially enforces a sort order on IDs for snapshotting of API objects. +# The ids are at most 21 characters long, the maximum that the self-managed server accepts. cuid <- local({ - i <- 10000000L + i <- 10000L function() { i <<- i + 1L - sprintf("c%d%s", i, activityinfo:::cuid()) + sprintf("c%d%s", i, substr(activityinfo:::cuid(), 2, 16)) } }) @@ -105,6 +106,11 @@ namesOrIndexes <- function(x) { } compare_recursively <- function(a, b, path = list()) { + # Some servers, such as the self-managed server, return null for an empty string + if ((identical(a, "") && is.null(b)) || (is.null(a) && identical(b, ""))) { + testthat::succeed() + return(invisible()) + } if (is.atomic(a) && is.atomic(b)) { if (!identical(a,b)) { message(sprintf("Field with name/key '%s' value has changed", paste(path, collapse="'->'"))) @@ -120,7 +126,8 @@ compare_recursively <- function(a, b, path = list()) { test <- name %in% names(b) if(!test) message(sprintf("Missing expected field name/key %s", paste(c(path, name), collapse="->"))) testthat::expect_true(test) - compare_recursively(a[[name]], b[[name]], c(path, name)) + # A missing field is a single failure; there is nothing to compare + if(test) compare_recursively(a[[name]], b[[name]], c(path, name)) } } else { message(sprintf("Incompatible structures under name/key '%s'", paste(path, collapse="'->'"))) @@ -141,16 +148,18 @@ identicalForm <- function(a,b, b_allowed_new_fields = TRUE) { } } -expectActivityInfoSnapshotCompare <- function(x, snapshotName, replaceId = TRUE, replaceDate = TRUE, replaceResource = TRUE, allowed_new_fields = TRUE) { +expectActivityInfoSnapshotCompare <- function(x, snapshotName, replaceId = TRUE, replaceDate = TRUE, replaceResource = TRUE, allowed_new_fields = TRUE, ignoreFields = character()) { if (missing(snapshotName)) stop("You must give the snapshot a name") stopifnot("The snapshotName must be a character string" = is.character(snapshotName)&&length(snapshotName)==1) x <- canonicalizeActivityInfoObject(x, replaceId, replaceDate, replaceResource) + x <- x[!(names(x) %in% ignoreFields)] path <- testthat::test_path("_activityInfoSnaps", sprintf("%s.RDS", snapshotName)) if (file.exists(path)) { y <- readRDS(file = path) + y <- y[!(names(y) %in% ignoreFields)] } else { message("Adding activityInfo snapshot: ", snapshotName, ".RDS") saveRDS(x, file = path) diff --git a/tests/testthat/test-databases.R b/tests/testthat/test-databases.R index 2f49baf..ff559f8 100644 --- a/tests/testthat/test-databases.R +++ b/tests/testthat/test-databases.R @@ -36,7 +36,11 @@ testthat::test_that("getDatabaseTree() works", { tree <- getDatabaseTree(databaseId = database$databaseId) testthat::expect_s3_class(tree, "databaseTree") testthat::expect_identical(tree$databaseId, database$databaseId) - expectActivityInfoSnapshotCompare(tree, snapshotName = "databases-databaseTree", allowed_new_fields = TRUE) + # Databases may or may not have an individual owner, so ownerRef can be null + testthat::expect_true(is.null(tree$ownerRef) || is.list(tree$ownerRef)) + # The version depends on the server's state and version format + testthat::expect_true(is.character(tree$version) && length(tree$version) == 1) + expectActivityInfoSnapshotCompare(tree, snapshotName = "databases-databaseTree", allowed_new_fields = TRUE, ignoreFields = c("ownerRef", "version")) }) testthat::test_that("getDatabaseResources() works", { @@ -50,8 +54,9 @@ testthat::test_that("getDatabaseResources() works", { dbResources <- dbResources[order(dbResources$id, dbResources$parentId, dbResources$label, dbResources$visibility),] %>% select(id, label, parentId, type, visibility) - dbResources$id <- substr(dbResources$id,1,9) - dbResources$parentId <- substr(dbResources$parentId,1,9) + # Keep only the prefix that enforces the sort order of the test ids + dbResources$id <- substr(dbResources$id,1,6) + dbResources$parentId <- substr(dbResources$parentId,1,6) row.names(dbResources) <- NULL dbResources <- canonicalizeActivityInfoObject(dbResources, replaceId = FALSE) diff --git a/tests/testthat/test-formField.r b/tests/testthat/test-formField.r index 07abbff..4d273a6 100644 --- a/tests/testthat/test-formField.r +++ b/tests/testthat/test-formField.r @@ -121,6 +121,18 @@ test_that("Test roundtrip of referenceFieldSchema()", { testField(referenceFieldSchema(label = "A referenceFieldSchema field", referencedFormId = "A dummy formId")) }) +test_that("Test roundtrip of multipleReferenceFieldSchema()", { + field <- multipleReferenceFieldSchema(label = "A multipleReferenceFieldSchema field", referencedFormId = "A dummy formId") + testthat::expect_s3_class(field, "activityInfoMultipleReferenceFieldSchema") + testField(field) +}) + +test_that("Test roundtrip of noteFieldSchema()", { + field <- noteFieldSchema(label = "A noteFieldSchema field", description = "Some guidance for the user") + testthat::expect_s3_class(field, "activityInfoNoteFieldSchema") + testField(field) +}) + test_that("Test roundtrip of sectionFieldSchema()", { testField(sectionFieldSchema(label = "A sectionFieldSchema field")) }) @@ -160,6 +172,47 @@ test_that("Test roundtrip of weekFieldSchema()", { testField(weekFieldSchema(label = "A weekFieldSchema field")) }) +test_that("Visibility and reviewer only options are set on the field schema", { + hiddenFromEntry <- textFieldSchema(label = "Hidden from entry", hideFromEntry = TRUE) + testthat::expect_false(hiddenFromEntry$dataEntryVisible) + testthat::expect_true(hiddenFromEntry$tableVisible) + + hiddenInTable <- textFieldSchema(label = "Hidden in table", hideInTable = TRUE) + testthat::expect_true(hiddenInTable$dataEntryVisible) + testthat::expect_false(hiddenInTable$tableVisible) + + testthat::expect_null(textFieldSchema(label = "Not reviewer only")$securityCategoryId) + testthat::expect_identical(textFieldSchema(label = "Reviewer only", reviewerOnly = TRUE)$securityCategoryId, "reviewer") +}) + +test_that("Test roundtrip of visibility and reviewer only options", { + testField(textFieldSchema(label = "A hidden text field", hideFromEntry = TRUE, hideInTable = TRUE, reviewerOnly = TRUE)) +}) + +test_that("A required rule can only be given for required fields", { + testthat::expect_error( + textFieldSchema(label = "Not required", requiredRule = "ISBLANK(other)"), + regexp = "requiredRule" + ) + field <- textFieldSchema(label = "Required", required = TRUE, requiredRule = "ISBLANK(other)") + testthat::expect_identical(field$requiredCondition, "ISBLANK(other)") +}) + +test_that("Test roundtrip of required rule and validation message", { + field <- quantityFieldSchema( + label = "A quantity field with rules", + required = TRUE, + requiredRule = "TRUE", + validationRule = "VALUE() > 0", + validationMessage = "Must be positive") + testthat::expect_identical(field$validationMessage, "Must be positive") + testField(field) +}) + +test_that("User fields have the user field schema class", { + testthat::expect_s3_class(userFieldSchema(label = "A user field", databaseId = "cdb123"), "activityInfoUserFieldSchema") +}) + test_that("Test toSelectOptions()", { }) diff --git a/tests/testthat/test-forms.R b/tests/testthat/test-forms.R index f2e618e..8ccb740 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) == 2 & ncol(output) == 19) testthat::expect_true(all(c( "databaseId", "formId", @@ -33,7 +33,9 @@ testthat::test_that("getFormSchema() and as.data.frame.formSchema() return a Sch "fieldLabel", "fieldDescription", "validationCondition", + "validationMessage", "relevanceCondition", + "requiredCondition", "fieldRequired", "key", "referenceFormId", diff --git a/tests/testthat/test-import.R b/tests/testthat/test-import.R index 39e0d2d..e5e5e24 100644 --- a/tests/testthat/test-import.R +++ b/tests/testthat/test-import.R @@ -44,4 +44,47 @@ test_that("importRecords() works with stageDirect = FALSE", { test_that("importRecords() works with stageDirect = TRUE", { -}) \ No newline at end of file +}) + +test_that("importRecords() works with multiple reference fields and getRecords() skips notes", { + target <- addForm(schema = formSchema( + databaseId = database$databaseId, + label = "Multiple reference target", + elements = list( + textFieldSchema(label = "Name", code = "NAME", key = TRUE)))) + + importRecords(target$id, data = data.frame(NAME = c("A", "B", "C"))) + targetRecords <- queryTable(target$id, id = "_id", name = "NAME") + ids <- targetRecords$id[order(targetRecords$name)] + + schema <- addForm(schema = formSchema( + databaseId = database$databaseId, + label = "Multiple reference source", + elements = list( + textFieldSchema(label = "Title", code = "TITLE", key = TRUE), + noteFieldSchema(label = "A note", description = "Some guidance"), + multipleReferenceFieldSchema(label = "Targets", code = "TARGETS", referencedFormId = target$id)))) + + df <- data.frame( + TITLE = c("None", "One", "Two"), + TARGETS = c(NA, ids[1], paste(ids[2], ids[3], sep = ","))) + + importRecords(schema$id, data = df) + + imported <- queryTable(schema$id, title = "TITLE", targets = "TARGETS") + imported <- imported[order(imported$title),] + + expect_identical(imported$title, c("None", "One", "Two")) + expect_true(is.na(imported$targets[1])) + expect_identical(imported$targets[2], ids[1]) + expect_setequal(strsplit(imported$targets[3], "\\s*,\\s*")[[1]], ids[2:3]) + + expect_error( + importRecords(schema$id, data = data.frame(TITLE = "Bad", TARGETS = "not a record id!")), + regexp = "invalid record ids" + ) + + records <- getRecords(schema$id, style = allColumnStyle()) %>% collect() + expect_false(any(grepl("note", names(records), ignore.case = TRUE))) + expect_true("TARGETS" %in% names(records)) +}) diff --git a/tests/testthat/test-records.R b/tests/testthat/test-records.R index a54052f..4e90cf2 100644 --- a/tests/testthat/test-records.R +++ b/tests/testthat/test-records.R @@ -304,19 +304,24 @@ testthat::test_that("getRecords() works", { }) }) - # removing columns required for a filter will result in an error - # expect warning using select after filter or sort - testthat::expect_error({ - testthat::expect_warning({ - recordIds <- rcrds %>% - addFilter('[A logical column] == "True"') %>% - addSort(list(list(dir = "DESC", field = "A date column"))) %>% - head(n = 10) %>% - select(`_id`) %>% - collect() %>% - pull("_id") - }) - }) + # expect warning using select after filter or sort, but the filter still + # applies even though its column is removed by select + testthat::expect_warning({ + recordIds <- rcrds %>% + addFilter('[A logical column] == "True"') %>% + addSort(list(list(dir = "DESC", field = "A date column"))) %>% + head(n = 10) %>% + select(`_id`) %>% + collect() %>% + pull("_id") + }, regexp = "select\\(\\) after a filter or sort") + + trueRecordIds <- rcrds %>% + filter(`A logical column` == "True") %>% + collect() %>% + pull("_id") + testthat::expect_length(recordIds, min(10L, length(trueRecordIds))) + testthat::expect_true(all(recordIds %in% trueRecordIds)) # filters will work even if the column is renamed in a lazy remote records object testthat::expect_no_warning({ diff --git a/tests/testthat/test-rmdOutput.R b/tests/testthat/test-rmdOutput.R index 29f62ae..54416f8 100644 --- a/tests/testthat/test-rmdOutput.R +++ b/tests/testthat/test-rmdOutput.R @@ -4,5 +4,14 @@ testthat::test_that("Rmd outputs as expected", { suppressMessages(capture_output(rmarkdown::render(testthat::test_path("ext/TestMessages.Rmd")))) ) ) - testthat::expect_snapshot_file(testthat::test_path("ext/TestMessages.html")) + + # Compare only the text of the rendered body: the rest of the html depends on + # the versions of pandoc and rmarkdown + html <- paste(readLines(testthat::test_path("ext/TestMessages.html"), warn = FALSE), collapse = "\n") + body <- sub(".*]*>(.*).*", "\\1", html) + body <- gsub("(?s)|", "", body, perl = TRUE) + text <- trimws(unlist(strsplit(gsub("<[^>]+>", "", body), "\n"))) + text <- text[nzchar(text)] + + testthat::expect_snapshot(writeLines(text)) }) diff --git a/tests/testthat/test-serverResponses.R b/tests/testthat/test-serverResponses.R new file mode 100644 index 0000000..1c5e635 --- /dev/null +++ b/tests/testthat/test-serverResponses.R @@ -0,0 +1,83 @@ +# Databases may or may not have an individual owner, depending on the server +# version and when the database was created. These tests use fixed server +# responses so that both cases are always tested, whatever the test server. + +databasesJson <- '[ + {"databaseId":"cowner1","label":"With owner","description":"","ownerId":"5148353961132032","billingAccountId":5308023665328128,"suspended":false,"publishedTemplate":false,"languages":[]}, + {"databaseId":"cowner2","label":"Without owner","description":null,"ownerId":null,"billingAccountId":5308023665328128,"suspended":false,"publishedTemplate":false,"languages":[]} +]' + +billingDatabasesJson <- '[ + {"databaseId":"cowner1","label":"With owner","description":"","owner":{"id":"5148353961132032","name":"Bob","email":"bob@example.com"},"formCount":1,"userCount":2,"basicUserCount":0,"recordCount":3,"lastRecordUpdate":"2026-01-01","billingAccountId":5308023665328128,"suspended":false,"publishedTemplate":false}, + {"databaseId":"cowner2","label":"Without owner","description":null,"owner":null,"formCount":0,"userCount":0,"basicUserCount":0,"recordCount":0,"lastRecordUpdate":null,"billingAccountId":5308023665328128,"suspended":false,"publishedTemplate":false} +]' + +mockResponse <- function(fn, json, env = parent.frame()) { + response <- activityinfo:::fromActivityInfoJson(json) + mock <- list(function(...) response) + names(mock) <- fn + do.call(testthat::local_mocked_bindings, c(mock, list(.env = env))) +} + +mockDatabases <- function(json, env = parent.frame()) { + mockResponse("getResource", json, env) +} + +testthat::test_that("getDatabases() works with and without database owners", { + mockDatabases(databasesJson) + + df <- getDatabases() + testthat::expect_identical(df$databaseId, c("cowner1", "cowner2")) + testthat::expect_identical(df$ownerId, c("5148353961132032", NA_character_)) + + dbList <- getDatabases(asDataFrame = FALSE) + testthat::expect_identical(dbList[[1]]$ownerId, "5148353961132032") + testthat::expect_identical(dbList[[2]]$ownerId, NA_character_) +}) + +testthat::test_that("getDatabases() works when no database has an owner", { + mockDatabases(sub('"ownerId":"5148353961132032"', '"ownerId":null', databasesJson)) + + df <- getDatabases() + testthat::expect_identical(nrow(df), 2L) + testthat::expect_identical(df$ownerId, c(NA_character_, NA_character_)) +}) + +testthat::test_that("getBillingAccountDatabases() works with and without database owners", { + mockDatabases(billingDatabasesJson) + + df <- getBillingAccountDatabases("5308023665328128") + testthat::expect_identical(df$databaseId, c("cowner1", "cowner2")) + testthat::expect_identical(df$ownerId, c("5148353961132032", NA_character_)) + testthat::expect_identical(df$ownerName, c("Bob", NA_character_)) + testthat::expect_identical(df$ownerEmail, c("bob@example.com", NA_character_)) + testthat::expect_identical(df$description, c(NA_character_, NA_character_)) + testthat::expect_identical(df$lastRecordUpdate, c("2026-01-01", NA_character_)) +}) + +testthat::test_that("getBillingAccountDatabases() columns keep their type when all values are null", { + mockDatabases(gsub('"lastRecordUpdate":"2026-01-01"', '"lastRecordUpdate":null', billingDatabasesJson)) + + df <- getBillingAccountDatabases("5308023665328128") + testthat::expect_identical(df$lastRecordUpdate, c(NA_character_, NA_character_)) +}) + +auditLogJson <- '{ + "events": [ + {"id":"e1","time":1790376900768,"formId":"cform1","description":"No resource types","type":"FORM","resourceTypes":[],"resourceId":"","user":{"id":"1","name":"Bob","email":"bob@example.com"}}, + {"id":"e2","time":1790376900769,"formId":"cform1","description":"One resource type","type":"FORM","resourceTypes":["FORM"],"resourceId":"cform1","user":{"id":"1","name":"Bob","email":"bob@example.com"}}, + {"id":"e3","time":1790376900770,"formId":"cform1","description":"Two resource types","type":"FORM","resourceTypes":["FORM","ROLE"],"resourceId":"cform1","user":null} + ], + "moreEvents": false, + "startTime": 1790376900000, + "endTime": 1790376901000 +}' + +testthat::test_that("queryAuditLog() works with events with none or several resource types", { + mockResponse("postResource", auditLogJson) + + events <- queryAuditLog("cdb1", after = as.POSIXct(1790376800, origin = "1970-01-01")) + testthat::expect_identical(nrow(events), 3L) + testthat::expect_identical(events$resourceTypes, c(NA, "FORM", "FORM,ROLE")) + testthat::expect_identical(events$user.name, c("Bob", "Bob", NA)) +})