diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..2d19fc7 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..9eec13b --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,55 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: + - main + - master + - cran-* + - version-* + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: +# - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'release'} +# - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} +# - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + TEST_URL: ${{ secrets.TEST_URL }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 32762dc..fe5be78 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -1,11 +1,6 @@ -name: Test +name: activityinfo-R-package-tests on: - push: - branches: - - main - - master - - cran-* - - version-* + workflow_dispatch: env: TEST_URL: ${{ secrets.TEST_URL }} diff --git a/.github/workflows/tic.yml b/.github/workflows/tic.yml deleted file mode 100644 index b629ec4..0000000 --- a/.github/workflows/tic.yml +++ /dev/null @@ -1,93 +0,0 @@ -## tic GitHub Actions template: linux-macos-windows-deploy -## revision date: 2022-11-23 -on: - workflow_dispatch: - push: - branches: - - main - - master - - cran-* - - version-* - pull_request: - -name: tic - -env: - TEST_URL: ${{ secrets.TEST_URL }} - -jobs: - all: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - # use a different tic template type if you do not want to build on all listed platforms - # - { os: windows-latest, r: "release" } - - { os: macOS-latest, r: "release", pkgdown: "true", latex: "true" } - - { os: ubuntu-latest, r: "devel" } - - { os: ubuntu-latest, r: "release" } - - env: - # make sure to run `tic::use_ghactions_deploy()` to set up deployment - TIC_DEPLOY_KEY: ${{ secrets.TIC_DEPLOY_KEY }} - # prevent rgl issues because no X11 display is available - RGL_USE_NULL: true - # if you use bookdown or blogdown, replace "PKGDOWN" by the respective - # capitalized term. This also might need to be done in tic.R - BUILD_PKGDOWN: ${{ matrix.config.pkgdown }} - # use GITHUB_TOKEN from GitHub to workaround rate limits in {remotes} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v3 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - Ncpus: 4 - - - uses: r-lib/actions/setup-tinytex@v2 - if: matrix.config.latex == 'true' - - - uses: r-lib/actions/setup-pandoc@v2 - - # set date/week for use in cache creation - # https://github.community/t5/GitHub-Actions/How-to-set-and-access-a-Workflow-variable/m-p/42970 - # - cache R packages daily - - name: "[Cache] Prepare daily timestamp for cache" - if: runner.os != 'Windows' - id: date - run: echo "date=$(date '+%d-%m')" >> $GITHUB_OUTPUT - - - name: "[Cache] Cache R packages" - if: runner.os != 'Windows' - uses: pat-s/always-upload-cache@v3 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-r-${{ matrix.config.r }}-${{steps.date.outputs.date}} - restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-${{steps.date.outputs.date}} - - - name: "[Stage] Install pak" - run: Rscript -e "install.packages('pak', repos = 'https://r-lib.github.io/p/pak/stable')" - - - name: "[Stage] Install" - run: Rscript -e "if (grepl('Ubuntu', Sys.info()[['version']]) && !grepl('Under development', R.version[['status']])) {options(repos = c(CRAN = sprintf('https://packagemanager.rstudio.com/all/__linux__/%s/latest', system('lsb_release -cs', intern = TRUE))))}else{options(repos = c(CRAN = 'cloud.r-project.org'))}; pak::pkg_install('ropensci/tic')" -e "print(tic::dsl_load())" -e "tic::prepare_all_stages()" -e "tic::before_install()" -e "tic::install()" - - - name: "[Stage] Script" - env: - TEST_URL: ${{ secrets.TEST_URL }} - run: Rscript -e 'tic::script()' - - - name: "[Stage] After Success" - run: Rscript -e "tic::after_success()" - - - name: "[Stage] Upload R CMD check artifacts" - if: failure() - uses: actions/upload-artifact@v2 - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check diff --git a/DESCRIPTION b/DESCRIPTION index b4f336a..9055f68 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: activityinfo Type: Package Title: R interface to ActivityInfo.org, an information management software for - humanitarian and development operations. -Version: 4.35.1 + humanitarian and development operations +Version: 4.36 Date: 2023-05-25 Authors@R: c( person("Alex", "Bertram", email = "alex@bedatadriven.com", @@ -18,7 +18,7 @@ Maintainer: Alex Bertram Description: An interface to ActivityInfo, a web-based information management software used for partner reporting, monitoring and evaluation and case management in - humanitarian aid, emergencies and international development + humanitarian aid, emergencies and international development. License: GPL-3 Depends: dplyr (>= 1.1.1) @@ -31,10 +31,11 @@ Imports: pillar (>= 1.8.1), rlang (>= 1.1.0), tibble (>= 3.2.1), + vctrs, tidyselect (>= 1.2.0), magrittr Encoding: UTF-8 -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Roxygen: list(markdown = TRUE) Suggests: ggplot2, @@ -46,6 +47,7 @@ Suggests: markdown, withr, assertthat, - purrr + purrr, + tinytex VignetteBuilder: knitr Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 144b251..04c6285 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,6 +66,8 @@ S3method(slice_max,tbl_activityInfoRemoteRecords) S3method(slice_min,tbl_activityInfoRemoteRecords) S3method(slice_sample,tbl_activityInfoRemoteRecords) S3method(slice_tail,tbl_activityInfoRemoteRecords) +S3method(src_activityInfo,databaseTree) +S3method(src_activityInfo,formTree) S3method(src_tbls,src_activityInfoDatabaseTree) S3method(src_tbls,src_activityInfoFormTree) S3method(summarise,tbl_activityInfoRemoteRecords) @@ -128,6 +130,12 @@ export(formFieldSchema) export(formSchema) export(geopointFieldSchema) export(getAttachment) +export(getBillingAccount) +export(getBillingAccountDatabaseUsers) +export(getBillingAccountDatabases) +export(getBillingAccountDomains) +export(getBillingAccountUsers) +export(getDatabaseBillingAccount) export(getDatabaseResources) export(getDatabaseSchema) export(getDatabaseTree) @@ -255,12 +263,15 @@ importFrom(magrittr,"%>%") importFrom(pillar,align) importFrom(pillar,style_subtle) importFrom(pillar,tbl_format_header) +importFrom(rlang,.data) importFrom(rlang,enquo) importFrom(rlang,rep_named) importFrom(rlang,set_names) importFrom(stats,runif) importFrom(stringr,str_replace) +importFrom(tibble,as_tibble) importFrom(tibble,tbl_sum) +importFrom(tibble,tibble) importFrom(tibble,view) importFrom(tidyselect,eval_select) importFrom(tidyselect,everything) @@ -270,3 +281,4 @@ importFrom(utils,head) importFrom(utils,lsf.str) importFrom(utils,read.table) importFrom(utils,tail) +importFrom(vctrs,vec_as_names) diff --git a/NEWS.md b/NEWS.md index f020351..999d6a9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +## [4.36] +- API tokens are now stored per root URL of the server. The token will need to be added again using activityInfoToken(token). The location of the token file has changed from "~/.activityinfo.credentials" to "~/.activityinfo.server.credentials" to avoid accidentally overwriting and losing the old tokens. (#101) +- Column name de-duplication in getRecords() (#118) +- Updated GitHub Action checks (#116) +- Snapshot tests allow new properties +- Allow custom IDs in addRecord (#111, #104) +- Billing account info functions (#97) +- API Token now stored per root URL (#101) +- Only add parent columns to query if there are fields defined on parentVarNames (#103) ## [4.35.1] - Fix for `getQuantityTable()` (#115) diff --git a/R/auth.R b/R/auth.R index 2a5d44e..f794653 100644 --- a/R/auth.R +++ b/R/auth.R @@ -5,7 +5,8 @@ options(activityinfo.verbose.tasks = FALSE) } -credentialsFile <- "~/.activityinfo.credentials" +# the legacy credentials file was "~/.activityinfo.credentials", changing the name to ensure we don't overwrite the old key file accidentally +credentialsFile <- "~/.activityinfo.server.credentials" credentials <- environment() @@ -33,6 +34,7 @@ activityInfoRootUrl <- local({ function(newUrl) { if (!missing(newUrl)) { url <<- newUrl + activityInfoAuthentication(NULL) invisible() } else { url @@ -43,9 +45,10 @@ activityInfoRootUrl <- local({ # ---- ActivityInfoAuthentication() ---- #' Constructs a httr::authentication object from saved credentials -#' from the user's home directory at ~/.activityinfo.credentials +#' from the user's home directory at ~/.activityinfo.server.credentials #' #' @importFrom httr authenticate add_headers +#' @importFrom rlang .data #' @noRd activityInfoAuthentication <- local({ credentials <- NULL @@ -53,16 +56,16 @@ activityInfoAuthentication <- local({ function(newValue) { if (!missing(newValue)) { credentials <<- newValue + if (!is.null(credentials)&&credentialType(credentials) == "basic") deprecationOfBasicAuthWarning() } else { - # Look for credentials first in ~/.activityinfo.credentials - if (is.null(credentials) && file.exists(credentialsFile)) { - # message(sprintf("Reading credentials from %s...\n", path.expand(path = credentialsFile))) - line <- readLines("~/.activityinfo.credentials", warn = FALSE)[1] - if (nchar(line) <= 2) { - warning(sprintf("...file exists, but is empty or improperly formatted.\n", path.expand(path = credentialsFile))) - } else { - if (credentialType(line) == "basic") deprecationOfBasicAuthWarning() - credentials <<- line + if (is.null(credentials)&&file.exists(credentialsFile)) { + authObj = readRDS(file = credentialsFile) %>% filter(.data$server == activityInfoRootUrl()) + + if (nrow(authObj) == 1) { + credentials <<- authObj %>% pull(credentials) + if (credentialType(credentials) == "basic") deprecationOfBasicAuthWarning() + } else if (nrow(authObj) > 1) { + warning(sprintf("...file exists, but has more than one key. Try saving the key again.\n", path.expand(path = credentialsFile))) } } @@ -126,11 +129,20 @@ credentialType <- function(credentials) { #' activityInfoToken("") #' } #' @export +#' @importFrom rlang .data activityInfoToken <- function(token, prompt = TRUE) { + if (interactive() && missing(token)) { token <- readline("Enter your token: ") } + saveToAuthFile <- function(authObj) { + authObj <- authObj %>% + filter(.data$server != activityInfoRootUrl()) %>% + add_row(server = activityInfoRootUrl(), credentials = token) + saveRDS(object = authObj, file = credentialsFile) + } + activityInfoAuthentication(token) if (interactive() && prompt) { @@ -140,7 +152,24 @@ activityInfoToken <- function(token, prompt = TRUE) { save <- readline("Save token? ") if (substr(tolower(save), 1, 1) == "y") { - cat(token, file = credentialsFile) + + if (file.exists(credentialsFile)) { + authObj <- readRDS(file = credentialsFile) + existingAuthObj <- authObj %>% filter(.data$server == activityInfoRootUrl()) + + if (nrow(existingAuthObj)==1) { + cat(sprintf("You already have a saved token. Do you want to replace existing token for %s?\n", activityInfoRootUrl())) + save2 <- readline("Save token? ") + if (substr(tolower(save2), 1, 1) == "y") { + saveToAuthFile(authObj) + } + } else { + saveToAuthFile(authObj) + } + } else { + authObj <- tibble(server = activityInfoRootUrl(), credentials = token) + saveToAuthFile(authObj) + } } } } diff --git a/R/billingInfo.R b/R/billingInfo.R new file mode 100644 index 0000000..ced813c --- /dev/null +++ b/R/billingInfo.R @@ -0,0 +1,176 @@ +#' @title getBillingAccount +#' @description Get billing account information +#' @param billingAccountId Billing ID +#' @param asDataFrame Output as data.frame, Default: TRUE +#' @return Billing account information in list or data.frame output +#' @rdname getBillingAccount +#' @export +#' @importFrom tibble as_tibble + +getBillingAccount <- function(billingAccountId, asDataFrame = TRUE) { + if(missing(billingAccountId)) stop("A billingAccountId must be provided") + stopifnot("A single billingAccountId must be provided" = (length(billingAccountId)==1)) + + billingInfo <- getResource(paste0("/billingAccounts/", billingAccountId), task = "Getting billing account info") + billingInfo$id <- as.character(billingInfo$id) + if (asDataFrame == TRUE) { + billingInfo <- tibble::as_tibble(billingInfo) + return(billingInfo) + } else { + return(billingInfo) + } +} + + +#' @title getBillingAccountDatabases +#' @description Data for all databases under billing account +#' @param billingAccountId Billing ID +#' @param asDataFrame Output as data.frame, Default: TRUE +#' @return Information on databases under billing account in list or data.frame output +#' @rdname getBillingAccountDatabases +#' @export +#' @importFrom tibble tibble + +getBillingAccountDatabases <- function(billingAccountId, asDataFrame = TRUE) { + if(missing(billingAccountId)) stop("A billingAccountId must be provided") + stopifnot("A single billingAccountId must be provided" = (length(billingAccountId)==1)) + + billingDatabases <- getResource(paste0("/billingAccounts/", billingAccountId, "/databases"), + task = "Getting billing account databases") + + billingDatabases <- lapply(billingDatabases, function(x) { + x$billingAccountId <- as.character(x$billingAccountId) + x + }) + + if (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"]]})), + 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} + })), + billingAccountId = unlist(lapply(billingDatabases, function(x) {x$billingAccountId})), + suspended = unlist(lapply(billingDatabases, function(x) {x$suspended})), + publishedTemplate = unlist(lapply(billingDatabases, function(x) {x$publishedTemplate})) + ) + return(billingDatabases) + } else { + return(billingDatabases) + } +} + + +#' @title getBillingAccountDomains +#' @description Billing account email domain info +#' @param billingAccountId Billing ID +#' @return Information on billing account email domain in list output +#' @rdname getBillingAccountDomains +#' @export + +getBillingAccountDomains <- function(billingAccountId) { + if(missing(billingAccountId)) stop("A billingAccountId must be provided") + stopifnot("A single billingAccountId must be provided" = (length(billingAccountId)==1)) + + billingDomains <- getResource(paste0("/billingAccounts/", billingAccountId, "/domains"), task = "Getting billing account domains") + return(billingDomains) +} + + +#' @title getBillingAccountUsers +#' @description Billing account users +#' @param billingAccountId Billing ID +#' @param asDataFrame Output as data.frame, Default: TRUE +#' @return Billing account user(s) in list or data.frame output +#' @rdname getBillingAccountUsers +#' @export +#' @importFrom tibble tibble + +getBillingAccountUsers <- function(billingAccountId, asDataFrame = TRUE) { + if(missing(billingAccountId)) stop("A billingAccountId must be provided") + stopifnot("A single billingAccountId must be provided" = (length(billingAccountId)==1)) + + billingUsers <- getResource(paste0("/billingAccounts/", billingAccountId, "/users"), task = "Getting billing account users") + if (asDataFrame == TRUE) { + billingUsers <- tibble::tibble( + userId = unlist(lapply(billingUsers, function(x) {x$userId})), + billingAccountId = unlist(lapply(billingUsers, function(x) {x$billingAccountId})), + email = unlist(lapply(billingUsers, function(x) {x$email})), + name = unlist(lapply(billingUsers, function(x) {x$name})), + billingAccountRole = unlist(lapply(billingUsers, function(x) {x$billingAccountRole})), + userLicenseType = unlist(lapply(billingUsers, function(x) {x$userLicenseType})), + lastLoginTime = unlist(lapply(billingUsers, function (x) {format(as.POSIXct(x$lastLoginTime, origin = "1970-01-01", tz = "UTC"), "%H:%M:%S")})) + ) + return(billingUsers) + } else { + return(billingUsers) + } + return(billingUsers) +} + + +#' @title getDatabaseBillingAccount +#' @description Get database owner for a given database. This gives the owning organization rather than the user who created the database. +#' @param databaseId Database ID +#' @param asDataFrame Data.frame output, Default: TRUE +#' @return Database owner in list output +#' @rdname getDatabaseBillingAccount +#' @export + +getDatabaseBillingAccount <- function(databaseId, asDataFrame = TRUE) { + if(missing(databaseId)) stop("A databaseId must be provided") + stopifnot("A single databaseId must be provided" = (length(databaseId)==1)) + + databaseOwner <- getResource(paste0("/databases/", databaseId, "/billingAccount"), task = "Getting database owner") + databaseOwner$id <- as.character(databaseOwner$id) + + if (asDataFrame) { + databaseOwner <- as_tibble(databaseOwner) + } + return(databaseOwner) +} + + +#' @title getBillingAccountDatabaseUsers +#' @description Get data for users from a specific database. Can be more useful than `getDatabaseUsers()` as you also retrieve the database owner's info as well. +#' @param billingAccountId Billing ID +#' @param asDataFrame Data.frame output, Default: TRUE +#' @param databaseId Database ID +#' @return User information from the specified database in list or data.frame output +#' @rdname getBillingAccountDatabaseUsers +#' @export +#' @importFrom tibble tibble + +getBillingAccountDatabaseUsers <- function(billingAccountId, databaseId, asDataFrame = TRUE) { + if(missing(billingAccountId)||missing(databaseId)) stop("A billingAccountId and a databaseId must be provided") + stopifnot("A single billingAccountId must be provided" = (length(billingAccountId)==1)) + stopifnot("A single databaseId must be provided" = (length(databaseId)==1)) + + databaseUsers <- getResource(paste0("billingAccounts/", billingAccountId, "/users?databaseId=", databaseId), task = "Getting database data") + if (asDataFrame == TRUE) { + databaseUsers <- tibble::tibble( + userId = unlist(lapply(databaseUsers, function(x) {x$userId})), + billingAccountId = unlist(lapply(databaseUsers, function(x) {x$billingAccountId})), + email = unlist(lapply(databaseUsers, function(x) {x$email})), + name = unlist(lapply(databaseUsers, function(x) {x$name})), + billingAccountRole = unlist(lapply(databaseUsers, function(x) {x$billingAccountRole})), + userLicenseType = unlist(lapply(databaseUsers, function(x) {x$userLicenseType})), + lastLoginTime = unlist(lapply(databaseUsers, function (x) {format(as.POSIXct(x$lastLoginTime, origin = "1970-01-01", tz = "UTC"), "%H:%M:%S")})) + ) + return(databaseUsers) + } else { + return(databaseUsers) + } +} + + diff --git a/R/databases.R b/R/databases.R index bc05493..924eec3 100644 --- a/R/databases.R +++ b/R/databases.R @@ -10,20 +10,28 @@ getDatabases <- function(asDataFrame = TRUE) { databases <- getResource("databases", task = "Getting all databases") if (asDataFrame == TRUE) { - 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 = unlist(lapply(databases, function(x) {x$ownerId})), - billingAccountId = unlist(lapply(databases, function(x) {x$billingAccountId})), - suspended = unlist(lapply(databases, function(x) {x$suspended})) - ) - return(dbDF) + return(databasesListToTibble(databases)) } else if (asDataFrame == FALSE) { - return(databases) + return(lapply(databases, function(x) { + x$ownerId <- as.character(x$ownerId) + x$billingAccountId <- as.character(x$billingAccountId) + x + })) } } +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}))), + billingAccountId = as.character(unlist(lapply(databases, function(x) {x$billingAccountId}))), + suspended = unlist(lapply(databases, function(x) {x$suspended})) + ) + return(dbDF) +} + databaseUpdates <- function() { list( resourceUpdates = list(), @@ -76,6 +84,7 @@ getDatabaseTree <- function(databaseId) { ) class(tree$resources) <- "databaseResources" class(tree) <- "databaseTree" + tree$billingAccountId <- as.character(tree$billingAccountId) tree } @@ -128,7 +137,7 @@ getDatabaseResources <- function(database) { #' newDb <- addDatabase("Programme information system") #' } addDatabase <- function(label, databaseId = cuid()) { - postResource( + x <- postResource( "databases", body = list( id = databaseId, @@ -137,6 +146,8 @@ addDatabase <- function(label, databaseId = cuid()) { ), task = sprintf("Creating new database '%s' with id %s", label, databaseId) ) + x$billingAccountId <- as.character(x$billingAccountId) + x } #' deleteDatabase diff --git a/R/formField.R b/R/formField.R index a889dea..a04aec6 100644 --- a/R/formField.R +++ b/R/formField.R @@ -708,14 +708,20 @@ userFieldSchema <- function(label, description = NULL, databaseId, code = NULL, #' A special form field to define a section header for the form. #' #' @inheritParams formFieldSchema +#' @param indentationLevel section indentation level; default is 1 #' @family field schemas #' @export -sectionFieldSchema <- function(label, description = NULL) { +sectionFieldSchema <- function(label, description = NULL, indentationLevel = 1L) { schema <- do.call( formFieldSchema, args = c( list(type = "section"), - as.list(environment()) + formFieldArgs(as.list(environment())), + list( + typeParameters = list( + "indentationLevel" = indentationLevel + ) + ) ) ) diff --git a/R/records.R b/R/records.R index 09aa5f1..c92d12b 100644 --- a/R/records.R +++ b/R/records.R @@ -1,8 +1,8 @@ #' Checks whether a record exists #' -#' @param the id of the form to check -#' @param the id of the record to check +#' @param formId the id of the form to check +#' @param recordId the id of the record to check recordExists <- function(formId, recordId) { tryCatch({ getRecord(formId, recordId) @@ -23,6 +23,7 @@ recordExists <- function(formId, recordId) { #' @param formId the id of the form to which the record should be added #' @param parentRecordId the id of this record's parent record, if the form is a subform #' @param fieldValues a named list of fields to change. +#' @param recordId the id of the new record when a custom id is desired. The given id must be in cuid-compatible format. #' @export #' @family record functions #' @examples @@ -73,12 +74,21 @@ recordExists <- function(formId, recordId) { #' )) #' #' } -addRecord <- function(formId, parentRecordId = NA_character_, fieldValues) { +addRecord <- function(formId, parentRecordId = NA_character_, fieldValues, recordId = NA_character_) { stopifnot(is.character(formId)) stopifnot(is.character(parentRecordId)) stopifnot(is.list(fieldValues)) - - recordId <- cuid() + stopifnot(is.character(recordId)) + + if (identical(recordId, NA_character_)) { + # generate a record id if not provided + recordId <- cuid() + } else { + # check provided record id does not exist before continuing + if (recordExists(formId, recordId)) { + stop(sprintf("Record %s in form %s already exists.", recordId, formId)) + } + } changes <- list( list( formId = formId, @@ -504,6 +514,7 @@ getRecords.default <- getRecords.character #' @param allReferenceFields include all the fields in referenced records; the #' default is FALSE #' @param columnNames Can be "pretty", "label", "id", c("code", "id), or c("code", "label"); default is "pretty". +#' @param .names_repair Treatment of problematic column names following the approach used in tibbles / vctrs. Default is "unique". #' @param style a style to modify with one or more parameters #' #' @export @@ -514,6 +525,7 @@ columnStyle <- function( columnNames = "pretty", recordId = TRUE, lastEditedTime = TRUE, + .names_repair = "unique", style) { stopifnot(is.logical(referencedId)) stopifnot(is.logical(referencedKey)) @@ -537,7 +549,8 @@ columnStyle <- function( "allReferenceFields" = allReferenceFields, "columnNames" = columnNames, "recordId" = recordId, - "lastEditedTime" = lastEditedTime + "lastEditedTime" = lastEditedTime, + ".names_repair" = .names_repair ) class(style) <- c("activityInfoColumnStyle", class(style)) } @@ -809,6 +822,7 @@ varNames <- function(x, style, addNames) { UseMethod("varNames") } +#' @importFrom vctrs vec_as_names #' @exportS3Method varNames activityInfoFormTree varNames.activityInfoFormTree <- function(x, style = defaultColumnStyle(), addNames = FALSE) { fmSchema <- x$forms[[x$root]] @@ -827,13 +841,15 @@ varNames.activityInfoFormTree <- function(x, style = defaultColumnStyle(), addNa })) parentVarNames <- parentVarNames[lengths(parentVarNames)!=0] } - - if(identical(style$columnNames, "pretty")) { - parentVarNames <- paste("Parent", parentVarNames, sep = " ") - } else { - parentVarNames <- paste("@parent", parentVarNames, sep = ".") + + if (!is.null(parentVarNames)) { + if(identical(style$columnNames, "pretty")) { + parentVarNames <- paste("Parent", parentVarNames, sep = " ") + } else { + parentVarNames <- paste("@parent", parentVarNames, sep = ".") + } } - + vrNames <- c(vrNames, "@parent", parentVarNames) } if (style$recordId) vrNames[length(vrNames)+1] <- "_id" @@ -843,6 +859,8 @@ varNames.activityInfoFormTree <- function(x, style = defaultColumnStyle(), addNa elementVars(element = y, formTree = x, style = style, namedElement = FALSE) }))) + vrNames <- vctrs::vec_as_names(vrNames, repair = style[[".names_repair"]]) + if(addNames) { names(vrNames) <- vrNames } @@ -1432,12 +1450,15 @@ tbl_sum.activityInfo_tbl_df <- function(x, ...) { # ---- Source ---- + src_activityInfo <- function(x) { UseMethod("src_activityInfo") } +#' @exportS3Method src_activityInfo formTree src_activityInfo.formTree <- function(x) { dplyr::src(subclass = c("activityInfoFormTree", "activityInfo"), formTree = x, url <- activityInfoRootUrl()) } +#' @exportS3Method src_activityInfo databaseTree src_activityInfo.databaseTree <- function(x) { dplyr::src(subclass = c("activityInfoDatabaseTree", "activityInfo"), databaseTree = x, url <- activityInfoRootUrl()) } diff --git a/R/rest.R b/R/rest.R index db7ca1d..e8232f7 100644 --- a/R/rest.R +++ b/R/rest.R @@ -202,7 +202,7 @@ fromActivityInfoJson <- function(x) { return(invisible()) } } - fromJSON(txt = x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE) + fromJSON(txt = x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, bigint_as_char = TRUE) } #' diff --git a/man/addRecord.Rd b/man/addRecord.Rd index 8e8fffa..9e6410d 100644 --- a/man/addRecord.Rd +++ b/man/addRecord.Rd @@ -4,7 +4,12 @@ \alias{addRecord} \title{Adds a new record} \usage{ -addRecord(formId, parentRecordId = NA_character_, fieldValues) +addRecord( + formId, + parentRecordId = NA_character_, + fieldValues, + recordId = NA_character_ +) } \arguments{ \item{formId}{the id of the form to which the record should be added} @@ -12,6 +17,8 @@ addRecord(formId, parentRecordId = NA_character_, fieldValues) \item{parentRecordId}{the id of this record's parent record, if the form is a subform} \item{fieldValues}{a named list of fields to change.} + +\item{recordId}{the id of the new record when a custom id is desired. The given id must be in cuid-compatible format.} } \description{ Adds a new record @@ -69,8 +76,8 @@ addRecord(formId = "cxy123", fieldValues = list( Other record functions: \code{\link{deleteRecord}()}, \code{\link{getAttachment}()}, -\code{\link{getRecordHistory}()}, \code{\link{getRecord}()}, +\code{\link{getRecordHistory}()}, \code{\link{recoverRecord}()}, \code{\link{updateRecord}()} } diff --git a/man/columnStyle.Rd b/man/columnStyle.Rd index 7a516c6..fd0de26 100644 --- a/man/columnStyle.Rd +++ b/man/columnStyle.Rd @@ -11,6 +11,7 @@ columnStyle( columnNames = "pretty", recordId = TRUE, lastEditedTime = TRUE, + .names_repair = "unique", style ) } @@ -31,6 +32,8 @@ default is TRUE to make it easier to join data in R} \item{lastEditedTime}{the time the record was last edited; default is TRUE} +\item{.names_repair}{Treatment of problematic column names following the approach used in tibbles / vctrs. Default is "unique".} + \item{style}{a style to modify with one or more parameters} } \description{ diff --git a/man/deleteRecord.Rd b/man/deleteRecord.Rd index 7023bed..75cd8ce 100644 --- a/man/deleteRecord.Rd +++ b/man/deleteRecord.Rd @@ -29,8 +29,8 @@ recoverRecord(formId = "cyx123", recordId = "c23g322j432") Other record functions: \code{\link{addRecord}()}, \code{\link{getAttachment}()}, -\code{\link{getRecordHistory}()}, \code{\link{getRecord}()}, +\code{\link{getRecordHistory}()}, \code{\link{recoverRecord}()}, \code{\link{updateRecord}()} } diff --git a/man/getAttachment.Rd b/man/getAttachment.Rd index 5956f55..fdfe467 100644 --- a/man/getAttachment.Rd +++ b/man/getAttachment.Rd @@ -23,8 +23,8 @@ of the temporary file is returned. Other record functions: \code{\link{addRecord}()}, \code{\link{deleteRecord}()}, -\code{\link{getRecordHistory}()}, \code{\link{getRecord}()}, +\code{\link{getRecordHistory}()}, \code{\link{recoverRecord}()}, \code{\link{updateRecord}()} } diff --git a/man/getBillingAccount.Rd b/man/getBillingAccount.Rd new file mode 100644 index 0000000..1c54e90 --- /dev/null +++ b/man/getBillingAccount.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getBillingAccount} +\alias{getBillingAccount} +\title{getBillingAccount} +\usage{ +getBillingAccount(billingAccountId, asDataFrame = TRUE) +} +\arguments{ +\item{billingAccountId}{Billing ID} + +\item{asDataFrame}{Output as data.frame, Default: TRUE} +} +\value{ +Billing account information in list or data.frame output +} +\description{ +Get billing account information +} diff --git a/man/getBillingAccountDatabaseUsers.Rd b/man/getBillingAccountDatabaseUsers.Rd new file mode 100644 index 0000000..c3a4e19 --- /dev/null +++ b/man/getBillingAccountDatabaseUsers.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getBillingAccountDatabaseUsers} +\alias{getBillingAccountDatabaseUsers} +\title{getBillingAccountDatabaseUsers} +\usage{ +getBillingAccountDatabaseUsers( + billingAccountId, + databaseId, + asDataFrame = TRUE +) +} +\arguments{ +\item{billingAccountId}{Billing ID} + +\item{databaseId}{Database ID} + +\item{asDataFrame}{Data.frame output, Default: TRUE} +} +\value{ +User information from the specified database in list or data.frame output +} +\description{ +Get data for users from a specific database. Can be more useful than \code{getDatabaseUsers()} as you also retrieve the database owner's info as well. +} diff --git a/man/getBillingAccountDatabases.Rd b/man/getBillingAccountDatabases.Rd new file mode 100644 index 0000000..835e9d1 --- /dev/null +++ b/man/getBillingAccountDatabases.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getBillingAccountDatabases} +\alias{getBillingAccountDatabases} +\title{getBillingAccountDatabases} +\usage{ +getBillingAccountDatabases(billingAccountId, asDataFrame = TRUE) +} +\arguments{ +\item{billingAccountId}{Billing ID} + +\item{asDataFrame}{Output as data.frame, Default: TRUE} +} +\value{ +Information on databases under billing account in list or data.frame output +} +\description{ +Data for all databases under billing account +} diff --git a/man/getBillingAccountDomains.Rd b/man/getBillingAccountDomains.Rd new file mode 100644 index 0000000..a7d3ebc --- /dev/null +++ b/man/getBillingAccountDomains.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getBillingAccountDomains} +\alias{getBillingAccountDomains} +\title{getBillingAccountDomains} +\usage{ +getBillingAccountDomains(billingAccountId) +} +\arguments{ +\item{billingAccountId}{Billing ID} +} +\value{ +Information on billing account email domain in list output +} +\description{ +Billing account email domain info +} diff --git a/man/getBillingAccountUsers.Rd b/man/getBillingAccountUsers.Rd new file mode 100644 index 0000000..cdc5bd6 --- /dev/null +++ b/man/getBillingAccountUsers.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getBillingAccountUsers} +\alias{getBillingAccountUsers} +\title{getBillingAccountUsers} +\usage{ +getBillingAccountUsers(billingAccountId, asDataFrame = TRUE) +} +\arguments{ +\item{billingAccountId}{Billing ID} + +\item{asDataFrame}{Output as data.frame, Default: TRUE} +} +\value{ +Billing account user(s) in list or data.frame output +} +\description{ +Billing account users +} diff --git a/man/getDatabaseBillingAccount.Rd b/man/getDatabaseBillingAccount.Rd new file mode 100644 index 0000000..12e38c1 --- /dev/null +++ b/man/getDatabaseBillingAccount.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/billingInfo.R +\name{getDatabaseBillingAccount} +\alias{getDatabaseBillingAccount} +\title{getDatabaseBillingAccount} +\usage{ +getDatabaseBillingAccount(databaseId, asDataFrame = TRUE) +} +\arguments{ +\item{databaseId}{Database ID} + +\item{asDataFrame}{Data.frame output, Default: TRUE} +} +\value{ +Database owner in list output +} +\description{ +Get database owner for a given database. This gives the owning organization rather than the user who created the database. +} diff --git a/man/recordExists.Rd b/man/recordExists.Rd index b95de4d..a78b146 100644 --- a/man/recordExists.Rd +++ b/man/recordExists.Rd @@ -7,7 +7,9 @@ recordExists(formId, recordId) } \arguments{ -\item{the}{id of the record to check} +\item{formId}{the id of the form to check} + +\item{recordId}{the id of the record to check} } \description{ Checks whether a record exists diff --git a/man/recoverRecord.Rd b/man/recoverRecord.Rd index d39177b..3b0c852 100644 --- a/man/recoverRecord.Rd +++ b/man/recoverRecord.Rd @@ -30,8 +30,8 @@ Other record functions: \code{\link{addRecord}()}, \code{\link{deleteRecord}()}, \code{\link{getAttachment}()}, -\code{\link{getRecordHistory}()}, \code{\link{getRecord}()}, +\code{\link{getRecordHistory}()}, \code{\link{updateRecord}()} } \concept{record functions} diff --git a/man/sectionFieldSchema.Rd b/man/sectionFieldSchema.Rd index 37e11f0..9c32be0 100644 --- a/man/sectionFieldSchema.Rd +++ b/man/sectionFieldSchema.Rd @@ -4,12 +4,14 @@ \alias{sectionFieldSchema} \title{Create a section header form field schema} \usage{ -sectionFieldSchema(label, description = NULL) +sectionFieldSchema(label, description = NULL, indentationLevel = 1L) } \arguments{ \item{label}{The label of the form field} \item{description}{The description of the form field} + +\item{indentationLevel}{section indentation level; default is 1} } \description{ A special form field to define a section header for the form. diff --git a/man/updateRecord.Rd b/man/updateRecord.Rd index eb90996..0a3d5c3 100644 --- a/man/updateRecord.Rd +++ b/man/updateRecord.Rd @@ -75,8 +75,8 @@ Other record functions: \code{\link{addRecord}()}, \code{\link{deleteRecord}()}, \code{\link{getAttachment}()}, -\code{\link{getRecordHistory}()}, \code{\link{getRecord}()}, +\code{\link{getRecordHistory}()}, \code{\link{recoverRecord}()} } \concept{record functions} diff --git a/tests/testthat/_activityInfoSnaps/databases-databaseTree.RDS b/tests/testthat/_activityInfoSnaps/databases-databaseTree.RDS new file mode 100644 index 0000000..6cdc9ac Binary files /dev/null and b/tests/testthat/_activityInfoSnaps/databases-databaseTree.RDS differ diff --git a/tests/testthat/_activityInfoSnaps/extractSchemaFromFields.RDS b/tests/testthat/_activityInfoSnaps/extractSchemaFromFields.RDS new file mode 100644 index 0000000..63c52ba Binary files /dev/null and b/tests/testthat/_activityInfoSnaps/extractSchemaFromFields.RDS differ diff --git a/tests/testthat/_snaps/databases.md b/tests/testthat/_snaps/databases.md index 04bdbfc..db8bb45 100644 --- a/tests/testthat/_snaps/databases.md +++ b/tests/testthat/_snaps/databases.md @@ -9,64 +9,6 @@ 1 My first database My second database ", - id = "", name = "Bob"), publishedTemplate = FALSE, - resources = list("Empty resources until we can ensure a sort order in the API."), - role = list(id = "", parameters = list(), resources = list()), - roles = list(list(filters = list(), grantBased = TRUE, grants = list( - list(operations = list(list(filter = NULL, operation = "VIEW", - securityCategories = list()), list(filter = NULL, - operation = "DISCOVER", securityCategories = list()), - list(filter = NULL, operation = "EDIT_RECORD", securityCategories = list()), - list(filter = NULL, operation = "ADD_RECORD", securityCategories = list()), - list(filter = NULL, operation = "DELETE_RECORD", - securityCategories = list()), list(filter = NULL, - operation = "EXPORT_RECORDS", securityCategories = list())), - optional = FALSE, resourceId = "")), id = "", - label = "Data Entry", parameters = list(), permissions = list(), - version = 0L), list(filters = list(), grantBased = TRUE, - grants = list(list(operations = list(list(filter = NULL, - operation = "VIEW", securityCategories = list()), - list(filter = NULL, operation = "DISCOVER", securityCategories = list())), - optional = FALSE, resourceId = "")), id = "", - label = "Read only", parameters = list(), permissions = list(), - version = 0L), list(filters = list(), grantBased = TRUE, - grants = list(list(operations = list(list(filter = NULL, - operation = "VIEW", securityCategories = list()), - list(filter = NULL, operation = "DISCOVER", securityCategories = list()), - list(filter = NULL, operation = "ADD_RECORD", securityCategories = list()), - list(filter = NULL, operation = "EDIT_RECORD", securityCategories = "reviewer"), - list(filter = NULL, operation = "DELETE_RECORD", - securityCategories = list()), list(filter = NULL, - operation = "BULK_DELETE", securityCategories = list()), - list(filter = NULL, operation = "EXPORT_RECORDS", - securityCategories = list()), list(filter = NULL, - operation = "LOCK_RECORDS", securityCategories = list()), - list(filter = NULL, operation = "ADD_RESOURCE", securityCategories = list()), - list(filter = NULL, operation = "EDIT_RESOURCE", - securityCategories = list()), list(filter = NULL, - operation = "DELETE_RESOURCE", securityCategories = list()), - list(filter = NULL, operation = "MANAGE_COLLECTION_LINKS", - securityCategories = list()), list(filter = NULL, - operation = "AUDIT", securityCategories = list()), - list(filter = NULL, - operation = "PUBLISH_REPORTS", securityCategories = list()), - list(filter = NULL, operation = "MANAGE_TRANSLATIONS", - securityCategories = list())), optional = FALSE, - resourceId = "")), id = "", label = "Administrator", - parameters = list(), permissions = list(list(filter = NULL, - operation = "MANAGE_USERS", securityCategories = list()), - list(filter = NULL, operation = "MANAGE_ROLES", securityCategories = list())), - version = 0L)), securityCategories = list(list(id = "", - label = "Reviewer only")), storage = "", suspended = FALSE, - thirdPartyTranslation = FALSE, translationFromDbMemory = FALSE, - userId = "", version = "3"), class = "databaseTree") - # getDatabaseResources() works Code @@ -78,31 +20,24 @@ 1 c10000004 Person form c10000002 FORM PRIVATE 2 c10000005 Children c10000004 SUB_FORM PRIVATE -# addDatabaseUser() and deleteDatabaseUser() and getDatabaseUsers() and getDatabaseUser() and getDatabaseUser2() work +# addDatabaseUser() and deleteDatabaseUser() and getDatabaseUsers() and getDatabaseUser() and getDatabaseUser2() work and expected fields are present - list(list(added = TRUE, user = list(activationStatus = "PENDING", + list(list(activationStatus = "PENDING", databaseId = "", + deliveryStatus = "UNKNOWN", email = "", inviteTime = "", + lastLoginTime = "", name = "Test database user", + userId = ""), list(activationStatus = "PENDING", databaseId = "", deliveryStatus = "UNKNOWN", email = "", - grants = list(), inviteTime = "", lastLoginTime = "", - name = "Test database user", role = list(id = "", - parameters = list(), resources = "Empty resources until we can ensure a sort order in the API."), - userId = "", version = 1)), list(added = TRUE, - user = list(activationStatus = "PENDING", databaseId = "", - deliveryStatus = "UNKNOWN", email = "", grants = list(), - inviteTime = "", lastLoginTime = "", - name = "Test database user", role = list(id = "", - parameters = list(), resources = "Empty resources until we can ensure a sort order in the API."), - userId = "", version = 1))) + inviteTime = "", lastLoginTime = "", + name = "Test database user", userId = "")) --- - list(list(databaseId = "", deliveryStatus = "UNKNOWN", - email = "", inviteAccepted = FALSE, inviteDate = "", - name = "Test database user", role = list(id = "", - parameters = list(), resources = "Empty resources until we can ensure a sort order in the API."), - userId = "", userLicenseType = "BASIC", version = 1L), - list(databaseId = "", deliveryStatus = "UNKNOWN", - email = "", inviteAccepted = FALSE, inviteDate = "", - name = "Test database user", role = list(id = "", - parameters = list(), resources = "Empty resources until we can ensure a sort order in the API."), - userId = "", userLicenseType = "BASIC", version = 1L)) + list(list(activationStatus = "PENDING", databaseId = "", + deliveryStatus = "UNKNOWN", email = "", inviteAccepted = FALSE, + inviteDate = "", lastLoginDate = "", + name = "Test database user", userId = "", userLicenseType = "BASIC"), + list(activationStatus = "PENDING", databaseId = "", + deliveryStatus = "UNKNOWN", email = "", inviteAccepted = FALSE, + inviteDate = "", lastLoginDate = "", + name = "Test database user", userId = "", userLicenseType = "BASIC")) diff --git a/tests/testthat/_snaps/records.md b/tests/testthat/_snaps/records.md index 963a93a..764d051 100644 --- a/tests/testthat/_snaps/records.md +++ b/tests/testthat/_snaps/records.md @@ -533,17 +533,6 @@ 499 499 4_stuff False 2021-07-24 500 500 5_stuff False 2021-07-25 -# Copying of schemas with extractSchemaFromFields() - - structure(list(databaseId = "", elements = list(structure(list( - code = NULL, description = NULL, id = "", key = TRUE, - label = "Identifier number", relevanceCondition = "", required = TRUE, - tableVisible = TRUE, type = "FREE_TEXT", typeParameters = list( - barcode = FALSE), validationCondition = ""), class = c("activityInfoTextFieldSchema", - "activityInfoFormFieldSchema", "formField", "list"))), id = "", - label = "new form"), class = c("activityInfoFormSchema", - "formSchema", "list")) - # Reference field with shallow reference table should provide field based names Code diff --git a/tests/testthat/_snaps/tableQuery.md b/tests/testthat/_snaps/tableQuery.md deleted file mode 100644 index d0b8f6c..0000000 --- a/tests/testthat/_snaps/tableQuery.md +++ /dev/null @@ -1,4 +0,0 @@ -# queryTable() returns a single column data.frame if the input is a single column, has expected snapshot content, and provides warning if deprecated parameter is used - - "structure(list(Person.name = c(\"Bob\", \"Alice\")), row.names = 1:2, class = \"data.frame\", offSet = 0L, rows = 2L, totalRows = 2L)" - diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 6a41156..068a939 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -100,12 +100,64 @@ namesOrIndexes <- function(x) { } } -identicalForm <- function(a,b) { +compare_recursively <- function(a, b, path = list()) { + if (is.atomic(a) && is.atomic(b)) { + if (!identical(a,b)) { + message(sprintf("Field with name/key '%s' value has changed", paste(path, collapse="'->'"))) + } + expect_identical(object = b, expected = a) + } else if (is.list(a) && is.list(b)) { + additionalFields <- names(b)[!names(b) %in% names(a)] + if (length(additionalFields)>0) { + message(sprintf("Additional fields found at name/key '%s': '%s'", paste(path, collapse = "'->'"), paste(additionalFields, collapse = "', '"))) + } + for (name in names(a)) { + # Check if the name in 'a' exists in 'b', then compare their values recursively + 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)) + } + } else { + message(sprintf("Incompatible structures under name/key '%s'", paste(path, collapse="'->'"))) + expect_identical(object = b, expected = a) + } +} + +identicalForm <- function(a,b, b_allowed_new_fields = TRUE) { a <- a[!(namesOrIndexes(a) %in% c("schemaVersion"))] b <- b[!(namesOrIndexes(b) %in% c("schemaVersion"))] a <- canonicalizeActivityInfoObject(a, replaceId = FALSE, replaceDate = FALSE, replaceResource = FALSE) b <- canonicalizeActivityInfoObject(b, replaceId = FALSE, replaceDate = FALSE, replaceResource = FALSE) - testthat::expect_identical(a,b) + + if (b_allowed_new_fields) { + compare_recursively(a, b) + } else { + expect_identical(object = b, expected = a) + } +} + +expectActivityInfoSnapshotCompare <- function(x, snapshotName, replaceId = TRUE, replaceDate = TRUE, replaceResource = TRUE, allowed_new_fields = TRUE) { + 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) + + path <- sprintf("%s/_activityInfoSnaps/%s.RDS", getwd(), snapshotName) + + if (file.exists(path)) { + y <- readRDS(file = path) + } else { + message("Adding activityInfo snapshot: ", snapshotName, ".RDS") + saveRDS(x, file = path) + return(invisible(NULL)) + } + + if (allowed_new_fields) { + compare_recursively(y, x) + } else { + expect_identical(object = x, expected = y) + } } expectActivityInfoSnapshot <- function(x, replaceId = TRUE, replaceDate = TRUE, replaceResource = TRUE) { @@ -113,9 +165,10 @@ expectActivityInfoSnapshot <- function(x, replaceId = TRUE, replaceDate = TRUE, testthat::expect_snapshot_value(x, style = "deparse") } - setupBlankDatabase <- function(label) { - activityinfo:::postResource("databases", body = list(id = cuid(), label = label, templateId = "blank"), task = sprintf("Creating test database '%s' post request", label)) + db <- activityinfo:::postResource("databases", body = list(id = cuid(), label = label, templateId = "blank"), task = sprintf("Creating test database '%s' post request", label)) + db$billingAccountId <- as.character(db$billingAccountId) + db } ##### Setup code ##### @@ -158,7 +211,10 @@ tryCatch( activityInfoRootUrl(preprodRootUrl) # Use these credentials for the rest of the tests -activityinfo:::activityInfoAuthentication(sprintf("%s:%s", testUser$email, testUser$password)) +testthat::expect_warning({ + activityinfo:::activityInfoAuthentication(sprintf("%s:%s", testUser$email, testUser$password)) +}, regexp = "deprecating") + # Add a new database for this user diff --git a/tests/testthat/test-billingInfo.R b/tests/testthat/test-billingInfo.R new file mode 100644 index 0000000..7a7f15b --- /dev/null +++ b/tests/testthat/test-billingInfo.R @@ -0,0 +1,156 @@ +testthat::test_that("getDatabaseBillingAccount returns the same as getBillingAccount", { + testthat::expect_identical(getDatabaseBillingAccount(database$databaseId), getBillingAccount(database$billingAccountId)) +}) + +testthat::test_that("getBillingAccount without billingAccountId throws error", { + testthat::expect_error(getBillingAccount(), regexp = "A billingAccountId must be provided") + testthat::expect_error(getBillingAccount("invalid"), regexp = "404") +}) + +testthat::test_that("getDatabaseBillingAccount with valid input returns correct output", { + returnedDatabaseBillingAccount <- getDatabaseBillingAccount(databaseId = database$databaseId) + testthat::expect_true("tbl_df" %in% class(returnedDatabaseBillingAccount)) + testthat::expect_identical(database$billingAccountId, returnedDatabaseBillingAccount[["id"]]) + + testthat::expect_true(nrow(returnedDatabaseBillingAccount)==1) + + logical_columns <- c("trial", "staleCounts", "automaticCollection") + numeric_columns <- c("expirationTime", "userLimit", "userCount", "fullUserCount", "basicUserCount", "databaseCount", "expectedPaymentTime") + character_columns <- c("id", "name", "status", "planName") + + invisible(sapply(logical_columns, function(x) { + testthat::expect_identical(typeof(returnedDatabaseBillingAccount[[x]]), "logical") + })) + + invisible(sapply(numeric_columns, function(x) { + testthat::expect_true(is.numeric(returnedDatabaseBillingAccount[[x]])) + })) + + invisible(sapply(character_columns, function(x) { + testthat::expect_identical(typeof(returnedDatabaseBillingAccount[[x]]), "character") + })) + + returnedDatabaseBillingAccount2 <- getDatabaseBillingAccount(databaseId = database$databaseId, asDataFrame = FALSE) + testthat::expect_identical(class(returnedDatabaseBillingAccount2), "list") + testthat::expect_identical(returnedDatabaseBillingAccount$id, returnedDatabaseBillingAccount2$id) + + additionalColumns <- names(returnedDatabaseBillingAccount2)[!(names(returnedDatabaseBillingAccount2) %in% c(logical_columns,numeric_columns,character_columns))] + if (length(additionalColumns)>0) { + message(sprintf("There are additional names in getDatabaseBillingAccount() to be added as columns: '%s'", paste(additionalColumns, collapse = "', '"))) + } + +}) + +testthat::test_that("getDatabaseBillingAccount without databaseId throws error", { + testthat::expect_error(getDatabaseBillingAccount(), regexp = "A databaseId must be provided") + testthat::expect_error(getDatabaseBillingAccount("invalid"), regexp = "404") +}) + +testthat::test_that("getBillingAccountDatabases with valid input returns correct output", { + billingAccountDatabases <- getBillingAccountDatabases(database$billingAccountId) + testthat::expect_true(nrow(billingAccountDatabases) > 1) + testthat::expect_true("tbl_df" %in% class(billingAccountDatabases)) + + logical_columns <- c("suspended", "publishedTemplate") + numeric_columns <- c("formCount", "userCount", "basicUserCount", "recordCount") + character_columns <- c("databaseId", "label", "description", "ownerId", "ownerName", "ownerEmail", "lastRecordUpdate", "billingAccountId") + + invisible(sapply(logical_columns, function(x) { + testthat::expect_identical(typeof(billingAccountDatabases[[x]]), "logical") + })) + + invisible(sapply(numeric_columns, function(x) { + testthat::expect_true(is.numeric(billingAccountDatabases[[x]])) + })) + + invisible(sapply(character_columns, function(x) { + testthat::expect_identical(typeof(billingAccountDatabases[[x]]), "character") + })) + + billingAccountDatabases2 <- getBillingAccountDatabases(database$billingAccountId, asDataFrame = FALSE) + + testthat::expect_identical(class(billingAccountDatabases2), "list") + testthat::expect_identical( + billingAccountDatabases$databaseId, + sapply(billingAccountDatabases2, function(x) { + x$databaseId + })) + + withoutOwner <- billingAccountDatabases2[[1]] + withoutOwner$owner <- NULL + billingAccountDatabasesNames <- names(withoutOwner) + + additionalColumns <- billingAccountDatabasesNames[!(billingAccountDatabasesNames %in% c(logical_columns,numeric_columns,character_columns))] + if (length(additionalColumns)>0) { + message(sprintf("There are additional names in getBillingAccountDatabases() to be added as columns: '%s'", paste(additionalColumns, collapse = "', '"))) + } + +}) + +testthat::test_that("getBillingAccountDatabases without billingAccountId throws error", { + testthat::expect_error(getBillingAccountDatabases(), regexp = "A billingAccountId must be provided") + testthat::expect_error(getBillingAccountDatabases("invalid"), regexp = "404") +}) + +testthat::test_that("getBillingAccountDomains with valid input returns correct output", { + billingAccountDomains <- getBillingAccountDomains(database$billingAccountId) + testthat::expect_identical(class(billingAccountDomains), "list") +}) + +testthat::test_that("getBillingAccountDomains without billingAccountId throws error", { + testthat::expect_error(getBillingAccountDomains(), regexp = "A billingAccountId must be provided") + testthat::expect_error(getBillingAccountDomains("invalid"), regexp = "404") +}) + +testthat::test_that("getBillingAccountUsers with valid input returns correct output", { + billingAccountUsers <- getBillingAccountUsers(database$billingAccountId) + testthat::expect_true("tbl_df" %in% class(billingAccountUsers)) + testthat::expect_true(nrow(billingAccountUsers)>0) + + invisible(sapply(names(billingAccountUsers), function(x) { + testthat::expect_identical(typeof(billingAccountUsers[[x]]), "character") + })) + + billingAccountUsers2 <- getBillingAccountUsers(database$billingAccountId, asDataFrame = FALSE) + billingAccountUsersNames <- names(billingAccountUsers2[[1]]) + + additionalColumns <- billingAccountUsersNames[!(billingAccountUsersNames %in% names(billingAccountUsers))] + if (length(additionalColumns)>0) { + message(sprintf("There are additional names in getBillingAccountUsers() to be added as columns: '%s'", paste(additionalColumns, collapse = "', '"))) + } + +}) + +testthat::test_that("getBillingAccountUsers without billingAccountId throws error", { + testthat::expect_error(getBillingAccountUsers(), regexp = "A billingAccountId must be provided") + testthat::expect_error(getBillingAccountUsers("invalid"), regexp = "404") +}) + +testthat::test_that("getBillingAccountDatabaseUsers with valid inputs returns correct output", { + testthat::expect_no_error( + billingAccountDatabaseUsers <- getBillingAccountDatabaseUsers(database$billingAccountId, database$databaseId) + ) + testthat::expect_true("tbl_df" %in% class(billingAccountDatabaseUsers)) + testthat::expect_true(nrow(billingAccountDatabaseUsers)>0) + + invisible(sapply(names(billingAccountDatabaseUsers), function(x) { + testthat::expect_identical(typeof(billingAccountDatabaseUsers[[x]]), "character") + })) + + billingAccountDatabaseUsers2 <- getBillingAccountDatabaseUsers(database$billingAccountId, database$databaseId, asDataFrame = FALSE) + + billingAccountDatabaseUsersNames <- names(billingAccountDatabaseUsers2[[1]]) + + additionalColumns <- billingAccountDatabaseUsersNames[!(billingAccountDatabaseUsersNames %in% names(billingAccountDatabaseUsers))] + if (length(additionalColumns)>0) { + message(sprintf("There are additional names in getBillingAccountDatabaseUsers() to be added as columns: '%s'", paste(additionalColumns, collapse = "', '"))) + } + +}) + +testthat::test_that("getBillingAccountDatabaseUsers missing or invalid billingAccountId or databaseId throws error", { + testthat::expect_error(getBillingAccountDatabaseUsers(), regexp = "A billingAccountId and a databaseId must be provided") + testthat::expect_error(getBillingAccountDatabaseUsers(databaseId = "invalid"), regexp = "A billingAccountId and a databaseId must be provided") + testthat::expect_error(getBillingAccountDatabaseUsers(billingAccountId = "invalid"), regexp = "A billingAccountId and a databaseId must be provided") + testthat::expect_error(getBillingAccountDatabaseUsers(databaseId = "invalid", billingAccountId = "invalid"), regexp = "404") +}) \ No newline at end of file diff --git a/tests/testthat/test-databases.R b/tests/testthat/test-databases.R index 6fbce99..c2bebb1 100644 --- a/tests/testthat/test-databases.R +++ b/tests/testthat/test-databases.R @@ -1,3 +1,4 @@ + testthat::test_that("addDatabase() and deleteDatabase() works", { testthat::expect_no_error({ dbTest <- addDatabase("Another test database on the fly!") @@ -13,9 +14,13 @@ testthat::test_that("addDatabase() and deleteDatabase() works", { }) testthat::test_that("getDatabases() works", { - databases <- getDatabases() + + # update snapshot; works for now + databases <- getDatabases() %>% + select("billingAccountId", "databaseId", "description", "label", "ownerId", "suspended") databases <- canonicalizeActivityInfoObject(databases) + testthat::expect_snapshot(databases) }) @@ -32,7 +37,7 @@ testthat::test_that("getDatabaseTree() works", { testthat::expect_s3_class(tree, "databaseTree") testthat::expect_named(tree, c("databaseId", "userId", "version", "label", "description", "ownerRef", "billingAccountId", "language", "originalLanguage", "continuousTranslation", "translationFromDbMemory", "thirdPartyTranslation", "languages", "role", "suspended", "storage", "publishedTemplate", "resources", "grants", "locks", "roles", "securityCategories")) testthat::expect_identical(tree$databaseId, database$databaseId) - expectActivityInfoSnapshot(tree) + expectActivityInfoSnapshotCompare(tree, snapshotName = "databases-databaseTree", allowed_new_fields = TRUE) }) testthat::test_that("getDatabaseResources() works", { @@ -44,11 +49,13 @@ testthat::test_that("getDatabaseResources() works", { subForms <- dbResources[dbResources$type == "SUB_FORM",] }) - dbResources <- dbResources[order(dbResources$id, dbResources$parentId, dbResources$label, dbResources$visibility),] + 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) row.names(dbResources) <- NULL dbResources <- canonicalizeActivityInfoObject(dbResources, replaceId = FALSE) + testthat::expect_snapshot(dbResources) @@ -82,23 +89,61 @@ deleteTestUsers <- function(database, returnedUsers) { }) } -testthat::test_that("addDatabaseUser() and deleteDatabaseUser() and getDatabaseUsers() and getDatabaseUser() and getDatabaseUser2() work", { +# Simplifies the user object for snapshots and warns when expected fields are missing and provides an informative message when there are new fields +simplifyUsers <- function(returnedUsers, additionalFields = list(), addedUsers = FALSE, expectAdded = TRUE) { + expectedFields <- c(additionalFields, "databaseId","deliveryStatus","email", "name", "role", "userId") + + if (addedUsers) { + expectedFields <- c("inviteTime",'version', 'activationStatus', 'lastLoginTime', 'grants', expectedFields) + returnedUsers <- lapply(returnedUsers, function(x) { + if (expectAdded) testthat::expect_true(x$added) + x$user + }) + } else { + expectedFields <- c("inviteDate", "inviteAccepted", "version", "activationStatus",'userLicenseType', 'lastLoginDate', expectedFields) #, "lastLoginTime", "grants" + } + + lapply(returnedUsers, function(x) { + allExpectedNamesPresent <- all(expectedFields %in% names(x)) + if(!allExpectedNamesPresent) { + warning("Expected fields/names missing in user: ", paste(expectedFields[!(expectedFields %in% names(x))], collapse = ", ")) + } + testthat::expect_true(allExpectedNamesPresent) + + if (!all(names(x) %in% expectedFields)) { + missingFields <- names(x)[!names(x) %in% expectedFields] + if (addedUsers) { + msg <- "The following additional names were found in after adding a user and inspecting returned user: '%s'" + } else { + msg <- "The following additional names were found in user: '%s'" + } + message(sprintf(msg, paste(missingFields, collapse="', '"))) + } + x["version"] <- NULL + x <- x[names(x) %in% expectedFields] + x <- x[sapply(x, is.atomic)] + x <- x[order(names(x))] + + x + }) +} + +testthat::test_that("addDatabaseUser() and deleteDatabaseUser() and getDatabaseUsers() and getDatabaseUser() and getDatabaseUser2() work and expected fields are present", { databases <- getDatabases() database <- databases[1,] tree <- getDatabaseTree(databaseId = database$databaseId) returnedUsers <- addTestUsers(database, tree, nUsers = 2) - - - expectActivityInfoSnapshot(returnedUsers) + # update snapshot; safe for now + expectActivityInfoSnapshot(simplifyUsers(returnedUsers, addedUsers = TRUE)) -nUsers <- 2 + nUsers <- 2 testthat::expect_no_error({ users <- getDatabaseUsers(databaseId = database$databaseId, asDataFrame=FALSE) }) - + testthat::expect_gte(length(users), expected = nUsers) if (length(users) == 0) stop("No users available to test.") @@ -120,7 +165,8 @@ nUsers <- 2 testthat::expect_equal(class(users2), "data.frame") - expectActivityInfoSnapshot(users) + # update snapshot; safe for now + expectActivityInfoSnapshot(simplifyUsers(users)) deleteTestUsers(database, returnedUsers) }) diff --git a/tests/testthat/test-extractLong.R b/tests/testthat/test-extractLong.R new file mode 100644 index 0000000..5ddec84 --- /dev/null +++ b/tests/testthat/test-extractLong.R @@ -0,0 +1 @@ +test_that("getQuantityTable works", {}) \ No newline at end of file diff --git a/tests/testthat/test-formField.r b/tests/testthat/test-formField.r index 4e58162..e98e9d0 100644 --- a/tests/testthat/test-formField.r +++ b/tests/testthat/test-formField.r @@ -26,7 +26,8 @@ test_that("Test deleteFormField()", { addFormField(textFieldSchema(label = "Text field 3", code = "txt3", id = "text3")) %>% addFormField(textFieldSchema(label = "Text field 4", code = "txt4", id = "text4")) %>% addFormField(textFieldSchema(label = "Text field 5", code = "txt5", id = "text5")) - + + ## Safe snapshots because made from R test1 <- fmSchm %>% deleteFormField(code = c("txt1", "txt3")) expectActivityInfoSnapshot(test1) @@ -35,6 +36,7 @@ test_that("Test deleteFormField()", { test3 <- fmSchm %>% deleteFormField(label = c("Text field 1", "Text field 5")) expectActivityInfoSnapshot(test3) + ## testthat::expect_warning({ fmSchm %>% deleteFormField(id = c("Text field 1", "Text field 5")) @@ -245,6 +247,7 @@ testthat::test_that("migrateFieldData() works", { recordsMinimal <- getRecords(newSchema, minimalColumnStyle()) %>% collect() %>% as.data.frame() + # should be a safe snapshot with minimalColumnStyle testthat::expect_snapshot(recordsMinimal) }) diff --git a/tests/testthat/test-records.R b/tests/testthat/test-records.R index 7bd4c89..b76482f 100644 --- a/tests/testthat/test-records.R +++ b/tests/testthat/test-records.R @@ -16,6 +16,14 @@ testthat::test_that("add, update, and deleteRecord() works", { alice <- getRecord(form$id, alice$recordId) assertthat::assert_that(alice$fields[[ageField$id]] == 25) + # It shouldn't be possible to add a record with an existing id + expect_error( + alice2 <- addRecord(formId = form$id, fieldValues = list(NAME = "Alice Duplicate", AGE = 25), recordId = alice$recordId) + ) + + # It is possible to add a record with a user provided id + eliza <- addRecord(formId = form$id, fieldValues = list(NAME = "Eliza", AGE = as.integer(format(Sys.Date(), "%Y")) - 1964), recordId = cuid()) + # It shouldn't be possible to update or delete non-existant records expect_error(updateRecord(form$id, recordId = "foobar", fieldValues = list(AGE = 25))) expect_error(deleteRecord(form$id, recordId = "foobar")) @@ -28,7 +36,32 @@ testthat::test_that("add, update, and deleteRecord() works", { }) testthat::test_that("getRecordHistory() works", { + firstFormId <- getDatabaseResources(getDatabases(FALSE)[[1]]$databaseId)$id[[1]] + firstRecordId <- (getRecords(form = firstFormId) |> collect() |> pull(`_id`))[[1]] + recordHistory <- getRecordHistory(formId = firstFormId, recordId = firstRecordId) + + testthat::expect_true(nrow(recordHistory)>0) + + list_columns = c("user", "values") + character_columns = c("formId", "recordId", "time", "subFieldId", "subFieldLabel", "subRecordKey", "changeType") + + invisible(sapply(list_columns, function(x) { + testthat::expect_identical(class(recordHistory[[x]]), "list") + })) + invisible(sapply(character_columns, function(x) { + testthat::expect_identical(typeof(recordHistory[[x]]), "character") + })) + + recordHistory2 <- getRecordHistory(formId = firstFormId, recordId = firstRecordId, asDataFrame = FALSE) + recordHistoryNames <- names(recordHistory2$entries[[1]]) + + testthat::expect_true(all(c(list_columns, character_columns) %in% recordHistoryNames)) + + additionalColumns <- recordHistoryNames[!(recordHistoryNames %in% c(list_columns, character_columns))] + if (length(additionalColumns)>0) { + message(sprintf("There are additional names in getRecordHistory() to be added as columns: '%s'", paste(additionalColumns, collapse = "', '"))) + } }) testthat::test_that("getRecord() works", { @@ -214,7 +247,16 @@ testthat::test_that("getRecords() works", { testthat::test_that("Copying of schemas with extractSchemaFromFields()", { newSchema <- rcrds %>% select(id = `Identifier number`) %>% extractSchemaFromFields(databaseId = "dbid", label = "new form") - expectActivityInfoSnapshot(newSchema) + schemaToCompare <- schema + schemaToCompare$label <- "new form" + schemaToCompare$id <- newSchema$id + schemaToCompare$databaseId <- "dbid" + + identicalForm(schemaToCompare, newSchema) + + # removing newSchema snapshot - not per se safe - should use new snapshot function + expectActivityInfoSnapshotCompare(newSchema, "extractSchemaFromFields") + #expectActivityInfoSnapshot(newSchema) # no form schema elements to provide - expect warning testthat::expect_warning({ diff --git a/tests/testthat/test-tableQuery.R b/tests/testthat/test-tableQuery.R index ca67476..f1d27f6 100644 --- a/tests/testthat/test-tableQuery.R +++ b/tests/testthat/test-tableQuery.R @@ -68,12 +68,13 @@ testthat::test_that("queryTable() returns a single column data.frame if the inpu output <- do.call(activityinfo::queryTable, input_parameters2) }) - testthat::expect_true(inherits(output, "data.frame")) testthat::expect_true(all(names_valid %in% colnames(output))) testthat::expect_identical(length(colnames(output)), 1L) - - testthat::expect_snapshot_value(deparse(output)) + + testthat::expect_true(all(output$Person.name %in% c("Alice","Bob"))) + testthat::expect_equal(nrow(output), 2) + }) diff --git a/tic.R b/tic.R deleted file mode 100644 index 4a6080f..0000000 --- a/tic.R +++ /dev/null @@ -1,2 +0,0 @@ -# installs dependencies, runs R CMD check, runs covr::codecov() -do_package_checks()