Test snapshots do not fail when there are additional fields in API, f…

…ixing problem of duplicate names (#118)

DESCRIPTION

@@ -31,6 +31,7 @@ Imports:
     pillar (>= 1.8.1),
     rlang (>= 1.1.0),
     tibble (>= 3.2.1),
+    vctrs,
     tidyselect (>= 1.2.0),
     magrittr
 Encoding: UTF-8

NAMESPACE

@@ -281,3 +281,4 @@ importFrom(utils,head)
 importFrom(utils,lsf.str)
 importFrom(utils,read.table)
 importFrom(utils,tail)
+importFrom(vctrs,vec_as_names)

R/records.R

@@ -514,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
@@ -524,6 +525,7 @@ columnStyle <- function(
     columnNames = "pretty",
     recordId = TRUE,
     lastEditedTime = TRUE,
+    .names_repair = "unique",
     style) {
   stopifnot(is.logical(referencedId))
   stopifnot(is.logical(referencedKey))
@@ -547,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))
   }
@@ -819,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]]
@@ -855,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
   }

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 = "<id value>", elements = list(structure(list(
-        code = NULL, description = NULL, id = "<id value>", 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 = "<id value>", 
-        label = "new form"), class = c("activityInfoFormSchema", 
-    "formSchema", "list"))
-
 # Reference field with shallow reference table should provide field based names
 
     Code

tests/testthat/test-databases.R

@@ -14,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)
 })
 
@@ -45,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)
@@ -114,8 +120,10 @@ simplifyUsers <- function(returnedUsers, additionalFields = list(), addedUsers =
       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
   })
 }
@@ -127,6 +135,7 @@ testthat::test_that("addDatabaseUser() and deleteDatabaseUser() and getDatabaseU
 
   returnedUsers <- addTestUsers(database, tree, nUsers = 2)
 
+  # update snapshot; safe for now
   expectActivityInfoSnapshot(simplifyUsers(returnedUsers, addedUsers = TRUE))
 
   nUsers <- 2
@@ -156,6 +165,7 @@ testthat::test_that("addDatabaseUser() and deleteDatabaseUser() and getDatabaseU
 
   testthat::expect_equal(class(users2), "data.frame")
 
+  # update snapshot; safe for now
   expectActivityInfoSnapshot(simplifyUsers(users))
 
   deleteTestUsers(database, returnedUsers)

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)
 })
 

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"))
@@ -246,7 +254,9 @@ testthat::test_that("getRecords() works", {
 
     identicalForm(schemaToCompare, newSchema)
 
-    expectActivityInfoSnapshot(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({

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)
+
 })