Clean up of test files, adjusting for rmdchecks, adding to section he…

…ader documentation, adding activityInfoSnap files that can help with comparisons across versions, updating snapshots

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)
@@ -261,6 +263,7 @@ 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)

R/auth.R

@@ -48,6 +48,7 @@ activityInfoRootUrl <- local({
 #' from the user's home directory at ~/.activityinfo.server.credentials
 #'
 #' @importFrom httr authenticate add_headers
+#' @importFrom rlang .data
 #' @noRd
 activityInfoAuthentication <- local({
   credentials <- NULL
@@ -58,7 +59,7 @@ activityInfoAuthentication <- local({
       if (!is.null(credentials)&&credentialType(credentials) == "basic") deprecationOfBasicAuthWarning()
     } else {
       if (is.null(credentials)&&file.exists(credentialsFile)) {
-        authObj = readRDS(file = credentialsFile) %>% filter(server == activityInfoRootUrl())
+        authObj = readRDS(file = credentialsFile) %>% filter(.data$server == activityInfoRootUrl())
 
         if (nrow(authObj) == 1) {
           credentials <<- authObj %>% pull(credentials)
@@ -128,6 +129,7 @@ credentialType <- function(credentials) {
 #' activityInfoToken("<API TOKEN>")
 #' }
 #' @export
+#' @importFrom rlang .data
 activityInfoToken <- function(token, prompt = TRUE) {
 
   if (interactive() && missing(token)) {
@@ -136,7 +138,7 @@ activityInfoToken <- function(token, prompt = TRUE) {
 
   saveToAuthFile <- function(authObj) {
     authObj <- authObj %>% 
-      filter(server != activityInfoRootUrl()) %>%
+      filter(.data$server != activityInfoRootUrl()) %>%
       add_row(server = activityInfoRootUrl(), credentials = token)
     saveRDS(object = authObj, file = credentialsFile)
   }
@@ -153,7 +155,7 @@ activityInfoToken <- function(token, prompt = TRUE) {
 
       if (file.exists(credentialsFile)) {
         authObj <- readRDS(file = credentialsFile) 
-        existingAuthObj <- authObj %>% filter(server == activityInfoRootUrl())
+        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()))

R/formField.R

@@ -708,6 +708,7 @@ 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, indentationLevel = 1L) {

R/records.R

@@ -1444,12 +1444,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())
 }

tests/testthat/_snaps/databases.md

@@ -9,64 +9,6 @@
       1 <id value>       <id value> <NA>        My first database  <id valu~ FALSE    
       2 <id value>       <id value> <NA>        My second database <id valu~ FALSE    
 
-# getDatabaseTree() works
-
-    structure(list(billingAccountId = "<id value>", continuousTranslation = FALSE, 
-        databaseId = "<id value>", description = "", grants = list(), 
-        label = "My first database", language = "", languages = list(), 
-        locks = list(), originalLanguage = "", ownerRef = list(email = "<id value>", 
-            id = "<id value>", name = "Bob"), publishedTemplate = FALSE, 
-        resources = list("Empty resources until we can ensure a sort order in the API."), 
-        role = list(id = "<id value>", 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 value>")), id = "<id value>", 
-            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 value>")), id = "<id value>", 
-            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 value>")), id = "<id value>", 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 = "<id value>", 
-            label = "Reviewer only")), storage = "", suspended = FALSE, 
-        thirdPartyTranslation = FALSE, translationFromDbMemory = FALSE, 
-        userId = "<id value>", version = "3"), class = "databaseTree")
-
 # getDatabaseResources() works
 
     Code
@@ -83,20 +25,19 @@
     list(list(activationStatus = "PENDING", databaseId = "<id value>", 
         deliveryStatus = "UNKNOWN", email = "<id value>", inviteTime = "<date or time value>", 
         lastLoginTime = "<date or time value>", name = "Test database user", 
-        userId = "<id value>", version = 1L), list(activationStatus = "PENDING", 
+        userId = "<id value>"), list(activationStatus = "PENDING", 
         databaseId = "<id value>", deliveryStatus = "UNKNOWN", email = "<id value>", 
         inviteTime = "<date or time value>", lastLoginTime = "<date or time value>", 
-        name = "Test database user", userId = "<id value>", version = 1L))
+        name = "Test database user", userId = "<id value>"))
 
 ---
 
     list(list(activationStatus = "PENDING", databaseId = "<id value>", 
         deliveryStatus = "UNKNOWN", email = "<id value>", inviteAccepted = FALSE, 
         inviteDate = "<date or time value>", lastLoginDate = "<date or time value>", 
-        name = "Test database user", userId = "<id value>", userLicenseType = "BASIC", 
-        version = 1L), list(activationStatus = "PENDING", databaseId = "<id value>", 
-        deliveryStatus = "UNKNOWN", email = "<id value>", inviteAccepted = FALSE, 
-        inviteDate = "<date or time value>", lastLoginDate = "<date or time value>", 
-        name = "Test database user", userId = "<id value>", userLicenseType = "BASIC", 
-        version = 1L))
+        name = "Test database user", userId = "<id value>", userLicenseType = "BASIC"), 
+        list(activationStatus = "PENDING", databaseId = "<id value>", 
+            deliveryStatus = "UNKNOWN", email = "<id value>", inviteAccepted = FALSE, 
+            inviteDate = "<date or time value>", lastLoginDate = "<date or time value>", 
+            name = "Test database user", userId = "<id value>", userLicenseType = "BASIC"))
 

tests/testthat/setup.R

@@ -137,6 +137,29 @@ identicalForm <- function(a,b, b_allowed_new_fields = TRUE) {
   }
 }
 
+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) {
   x <- canonicalizeActivityInfoObject(x, replaceId, replaceDate, replaceResource)
   testthat::expect_snapshot_value(x, style = "deparse")

tests/testthat/test-billingInfo.R

@@ -133,8 +133,8 @@ testthat::test_that("getBillingAccountDatabaseUsers with valid inputs returns co
   testthat::expect_true("tbl_df" %in% class(billingAccountDatabaseUsers))
   testthat::expect_true(nrow(billingAccountDatabaseUsers)>0)
 
-  invisible(sapply(names(billingAccountUsers), function(x) {
-    testthat::expect_identical(typeof(billingAccountUsers[[x]]), "character")
+  invisible(sapply(names(billingAccountDatabaseUsers), function(x) {
+    testthat::expect_identical(typeof(billingAccountDatabaseUsers[[x]]), "character")
   }))
 
   billingAccountDatabaseUsers2 <- getBillingAccountDatabaseUsers(database$billingAccountId, database$databaseId, asDataFrame = FALSE)

tests/testthat/test-databases.R

@@ -33,7 +33,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", {

tests/testthat/test-records.R

@@ -28,7 +28,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 +239,12 @@ 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")
 
-    identicalForm(schema, newSchema)
+    schemaToCompare <- schema
+    schemaToCompare$label <- "new form"
+    schemaToCompare$id <- newSchema$id
+    schemaToCompare$databaseId <- "dbid"
+
+    identicalForm(schemaToCompare, newSchema)
 
     expectActivityInfoSnapshot(newSchema)