Merge pull request #148 from bedatadriven/version-4.38

Version 4.38

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.37
-Date: 2024-10-16
+Version: 4.38
+Date: 2024-12-17
 Authors@R: c(
     person("Alex", "Bertram", email = "alex@bedatadriven.com", 
            role = c("aut", "cre")),
@@ -47,7 +47,11 @@ Suggests:
     markdown,
     withr,
     assertthat,
+    tidyverse,
+    tidyr,
     purrr,
+    readr,
+    readxl,
     tinytex
 VignetteBuilder: knitr
 Config/testthat/edition: 3

NAMESPACE

@@ -28,8 +28,12 @@ S3method(do,tbl_activityInfoRemoteRecords)
 S3method(do_,tbl_activityInfoRemoteRecords)
 S3method(filter,tbl_activityInfoRemoteRecords)
 S3method(filter_,tbl_activityInfoRemoteRecords)
+S3method(getDatabaseResources,character)
+S3method(getDatabaseResources,databaseTree)
 S3method(getDatabaseRole,character)
 S3method(getDatabaseRole,databaseTree)
+S3method(getDatabaseRoles,character)
+S3method(getDatabaseRoles,databaseTree)
 S3method(getRecords,activityInfoFormSchema)
 S3method(getRecords,activityInfoFormTree)
 S3method(getRecords,activityInfo_tbl_df)
@@ -143,6 +147,7 @@ export(getBillingAccountUsers)
 export(getDatabaseBillingAccount)
 export(getDatabaseResources)
 export(getDatabaseRole)
+export(getDatabaseRoles)
 export(getDatabaseSchema)
 export(getDatabaseTree)
 export(getDatabaseUser)

NEWS.md

@@ -1,3 +1,9 @@
+## [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)
+- Improved getDatabaseUsers() to include recent metadata fields (locked, userLicenseType, activitationStatus etc.) (#128, #130)
+- Improved testthat snapshot functions and removing snapshots that depend on the server
+
 ## [4.37]
 - Legacy roles are no longer supported from 4.37 onwards
 - Potential breaking change: the maxDepth parameter in column styles is now set to two by default; parent and reference columns no longer expand indefinitely

R/databases.R

@@ -106,19 +106,23 @@ getDatabaseTree <- function(databaseId) {
 #'
 #' @export
 getDatabaseResources <- function(database) {
-  if(is.character(database)) {
-    databaseTree <- getDatabaseTree(database)  
-  } else if(is.list(database)) {
-    databaseTree <- database
-  } else {
-    stop("The `database` argument must be a database id or a databaseTree")
-  }
+  UseMethod("getDatabaseResources")
+}
+
+#' @export
+getDatabaseResources.character <- function(database) {
+  tree <- getDatabaseTree(database)  
+  getDatabaseResources(tree)
+}
+
+#' @export
+getDatabaseResources.databaseTree <- function(database) {
   dplyr::tibble(
-    id = unlist(lapply(databaseTree$resources, function(x) {x$id})),
-    label = unlist(lapply(databaseTree$resources, function(x) {x$label})),
-    type = unlist(lapply(databaseTree$resources, function(x) {x$type})),
-    parentId = unlist(lapply(databaseTree$resources, function(x) {x$parentId})),
-    visibility = unlist(lapply(databaseTree$resources, function(x) {x$visibility}))
+    id = unlist(lapply(database$resources, function(x) {x$id})),
+    label = unlist(lapply(database$resources, function(x) {x$label})),
+    type = unlist(lapply(database$resources, function(x) {x$type})),
+    parentId = unlist(lapply(database$resources, function(x) {x$parentId})),
+    visibility = unlist(lapply(database$resources, function(x) {x$visibility}))
   )
 }
 
@@ -215,8 +219,11 @@ getDatabaseUsers <- function(databaseId, asDataFrame = TRUE) {
       version = unlist(lapply(users, function(x) {x$version})),
       inviteDate = as.Date(unlist(lapply(users, function(x) {x$inviteDate}))),
       deliveryStatus = unlist(lapply(users, function(x) {x$deliveryStatus})),
-      inviteAccepted = unlist(lapply(users, function(x) {x$inviteAccepted})) # ,
-      # role = lapply(users, function(x) {x$role})
+      inviteAccepted = unlist(lapply(users, function(x) {x$inviteAccepted})),
+      locked = unlist(lapply(users, function(x) {x$locked})),
+      userLicenseType = unlist(lapply(users, function(x) {x$userLicenseType})),
+      lastLoginDate = as.Date(unlist(lapply(users, function(x) {if(is.null(x$lastLoginDate)) NA else x$lastLoginDate}))),
+      activationStatus = unlist(lapply(users, function(x) {x$activationStatus}))
     )
 
     usersDF$role <- lapply(users, function(x) {x$role})
@@ -318,15 +325,16 @@ checkUserRole <- function(databaseId, newUser, roleId, roleParameters, roleResou
 
 #' addDatabaseUser
 #'
-#' Invites a user to a database.
+#' Invites a user to a database and assigns a role
 #'
 #' @param databaseId the id of the database to which they should be added
 #' @param email the user's email
 #' @param name the user's name (only used if they do not already have an ActivityInfo account)
 #' @param locale the locale ("en', "fr", "ar", etc) to use inviting the user (only used if they do not already have an ActivityInfo account)
 #' @param roleId the id of the role to assign to the user.
 #' @param roleParameters a named list containing the role parameter values
-#' @param roleResources a list of folders in which this role should be assigned (or the databaseId if they should have this role in the whole database)
+#' @param roleResources an optional list of optional grant-based resources assigned to the user
+#' @param assignment optionally create and pass a \code{\link[activityinfo]{roleAssignment}} like in updateUserRole()
 #'
 #' @details
 #'
@@ -347,6 +355,8 @@ checkUserRole <- function(databaseId, newUser, roleId, roleParameters, roleResou
 #' in many database templates has a `partner` parameter that is used to filter which
 #' records are visible to the user. The value of this parameter is the record id of the
 #' user's partner in the related Partner form.
+#' 
+#' Optional grants can be specified by adding the resource id of those grants to a list and passing that to `roleResources`.
 #'
 #' @examples
 #' \dontrun{
@@ -372,9 +382,17 @@ checkUserRole <- function(databaseId, newUser, roleId, roleParameters, roleResou
 #' @export
 addDatabaseUser <- function(databaseId, email, name, locale = NA_character_, roleId,
                             roleParameters = list(),
-                            roleResources = c(databaseId)) {
+                            roleResources = c(databaseId), assignment) {
 
   url <- paste(activityInfoRootUrl(), "resources", "databases", databaseId, "users", sep = "/")
+
+  if (!missing(assignment)) {
+    stopifnot("An assignment must be created with roleAssignment()" = ("activityInfoRoleAssignment" %in% class(assignment)))
+    stopifnot("Either an assignment must be provided or roleId to addDatabaseUser(), but not both." = missing(roleId))
+    roleId = assignment$id
+    roleParameters = assignment$parameters
+    roleResources = assignment$resources
+  }
 
   request <- list(
     email = email,
@@ -415,6 +433,44 @@ addDatabaseUser <- function(databaseId, email, name, locale = NA_character_, rol
   }
 }
 
+
+#' getDatabaseRoles
+#'
+#' Get database roles in a data frame.
+#'
+#' @param database database tree using \link{getDatabaseTree} or the databaseId
+#'
+#' @examples
+#' \dontrun{
+#' dbTree <- getDatabaseTree(databaseId = "ck3pqrp9a1z") # fetch the database tree
+#' roles <- getDatabaseRoles(dbTree) # get the database roles
+#' }
+#' @export
+#'
+getDatabaseRoles <- function(database) {
+  UseMethod("getDatabaseRoles")
+}
+
+#' @export
+getDatabaseRoles.character <- function(database) {
+  tree <- getDatabaseTree(databaseId = database)
+  getDatabaseRoles(tree)
+}
+
+#' @export
+getDatabaseRoles.databaseTree <- function(database) {
+  dplyr::tibble(
+    id = unlist(lapply(database$roles, function(x) {x$id})),
+    label = unlist(lapply(database$roles, function(x) {x$label})),
+    permissions = lapply(database$roles, function(x) {x$permissions}),
+    parameters = lapply(database$roles, function(x) {x$parameters}),
+    filters = lapply(database$roles, function(x) {x$filters}),
+    grants = lapply(database$roles, function(x) {x$grants}),
+    version = unlist(lapply(database$roles, function(x) {x$version})),
+    grantBased = unlist(lapply(database$roles, function(x) {x$grantBased}))
+  )
+}
+
 #' getDatabaseRole
 #'
 #' Helper method to fetch a role based on its id using the database tree or database id.
@@ -428,7 +484,6 @@ addDatabaseUser <- function(databaseId, email, name, locale = NA_character_, rol
 #' dbTree <- getDatabaseTree(databaseId = "ck3pqrp9a1z") # fetch the database tree
 #' role <- getDatabaseRole(dbTree, roleId = "rp") # extract the reporting partner role
 #' }
-#' 
 #' @export
 #'
 getDatabaseRole <- function(database, roleId) {
@@ -585,7 +640,7 @@ updateUserRole <- function(databaseId, userId, assignment) {
 roleAssignment <- function(roleId, roleParameters = list(), roleResources) {
   stopifnot(is.list(roleParameters))
   if (any(is.na(names(roleParameters)))) {
-    stop("roleParameters must be named with each parameter name.")
+    stop("In the `roleParameters` list, each item must be named")
   }
 
   if (length(roleParameters) == 0) {
@@ -935,7 +990,8 @@ deleteRoles <- function(databaseId, roleIds) {
 #' See \link{role} for the creation of roles.
 #'
 #' @param id the id of the parameter, for example "partner", which can
-#' be used in a formula as "@user.partner" 
+#' be used in a formula as "@user.partner". The id starts with a letter and may
+#' contain letters, numbers and underscores _ under 32 characters.
 #' @param label the label of the partner, for example, "Reporting partner"
 #' @param range the id of a reference table, for example the list of partners, 
 #' or a formula
@@ -949,7 +1005,7 @@ deleteRoles <- function(databaseId, roleIds) {
 #' }
 parameter <- function(id, label, range) {
   stopifnot("The id must be a character string" = is.null(id)||(is.character(id)&&length(id)==1&&nchar(id)>0))
-  stopifnot("The id must start with a letter, must be made of letters and underscores _ and cannot be longer than 32 characters" = is.null(id)||grepl("^[A-Za-z][A-Za-z0-9_]{0,31}$", id))
+  stopifnot("The id must start with a letter, must be made of letters, numbers and underscores _ and cannot be longer than 32 characters" = is.null(id)||grepl("^[A-Za-z][A-Za-z0-9_]{0,31}$", id))
   stopifnot("The label is required to be a character string" = (is.character(label)&&length(label)==1&&nchar(label)>0))
   stopifnot("The range is required and must be a character string" = !is.null(range)&&(is.character(range)&&length(range)==1&&nchar(range)>0))
 
@@ -1063,7 +1119,8 @@ roleFilter <- function(id, label, filter) {
 #' Some administrative permissions are defined at the level of the role rather 
 #' than within grants. See \link{databasePermissions}.
 #'
-#' @param id the id of the role
+#' @param id the id of the role, must start with a lower case letter and may 
+#' contain up to 32 lower case letters and numbers 
 #' @param label the label or name of the role, e.g. "Viewer" or "Administrator" 
 #' @param parameters a list of \link{parameter} items defining role parameters
 #' @param grants a list of \link{grant} items for each resource and their 
@@ -1103,7 +1160,7 @@ roleFilter <- function(id, label, filter) {
 #' }
 role <- function(id, label, parameters = list(), grants, permissions = databasePermissions()) {
   stopifnot("The id must be a character string" = is.null(id)||(is.character(id)&&length(id)==1&&nchar(id)>0))
-  stopifnot("The id must start with a letter, must be made of lowercase letters and underscores _ and cannot be longer than 32 characters" = is.null(id)||grepl("^[a-z][a-z0-9_]{0,31}$", id))
+  stopifnot("The id must start with a letter, must be made of lowercase letters and numbers and cannot be longer than 32 characters" = is.null(id)||grepl("^[a-z][a-z0-9]{0,31}$", id))
 
   stopifnot("The label is required to be a character string" = (is.character(label)&&length(label)==1&&nchar(label)>0))
 

R/records.R

@@ -262,6 +262,7 @@ getRecordHistory <- function(formId, recordId, asDataFrame = TRUE) {
     recHistDF <- dplyr::tibble(
       formId = unlist(lapply(recHist, function(x) {x$formId})),
       recordId = unlist(lapply(recHist, function(x) {x$recordId})),
+      version = unlist(lapply(recHist, function(x) {x$version})),
       time = format(as.POSIXct(unlist(lapply(recHist, function(x) {x$time})), origin = "1970-01-01", tz = "UTC"), "%Y-%m-%d %H:%M:%S"), #unlist(lapply(reHist, function(x) {x$time})),
       subFieldId = unlist(lapply(recHist, function(x) {x$subFieldId})),
       subFieldLabel = unlist(lapply(recHist, function(x) {x$subFieldLabel})),
@@ -1088,7 +1089,7 @@ elementVarName <- function(y, style) {
 
   colNameStyle <- style$columnNames[[1]]
 
-  colName = NULL
+  colName <- NULL
 
   if(colNameStyle == "code") {
     colName <- y[["code"]]
@@ -1140,12 +1141,15 @@ elementVarName <- function(y, style) {
 tbl.src_activityInfo <- function(src, formTree, style = defaultColumnStyle(),...) {
   stopifnot(formTree$root %in% dplyr::src_tbls(src))
 
-  totalRecords = getTotalRecords(formTree)
-  step = firstStep(formTree, style, totalRecords)
+  recordsMetadata <- getTotalLastEditTime(formTree)
+  totalRecords <- recordsMetadata[["totalRecords"]]
+  lastEditTime <- recordsMetadata[["lastEditTime"]]
+
+  step <- firstStep(formTree, style, totalRecords)
   idStyle <- style
   idStyle$columnNames <- "id"
 
-  elements = namedElementVarList(formTree = formTree, style = idStyle)
+  elements <- namedElementVarList(formTree = formTree, style = idStyle)
 
   dplyr::make_tbl(
     c("activityInfoRemoteRecords", "lazy"),
@@ -1155,10 +1159,24 @@ tbl.src_activityInfo <- function(src, formTree, style = defaultColumnStyle(),...
     "columns" = step$columns,
     "step" = step,
     "elements" = elements,
-    "totalRecords" = totalRecords
+    "totalRecords" = totalRecords,
+    "lastEditTime" = lastEditTime
   )
 }
 
+getTotalLastEditTime <- function(formTree) {
+  df <- queryTable(formTree$root, columns = list("id"="_id", "lastEditTime" = "_lastEditTime"), asTibble = TRUE, makeNames = FALSE, window = c(0L,1L), sort=list(list(dir = "DESC", field = "_lastEditTime")))
+  totalRecords <- attr(df, "totalRows")
+  if (totalRecords==0) {
+    # required to check the formTree as queryTable used in totalRecords does not error if there are no permissions but returns 0 rows
+    formTree <- getFormTree(formTree$root)
+    df <- queryTable(formTree$root, columns = list("id"="_id", "lastEditTime" = "_lastEditTime"), asTibble = TRUE, makeNames = FALSE, window = c(0L,1L), sort=list(list(dir = "DESC", field = "_lastEditTime")))
+    totalRecords <- attr(df, "totalRows")
+  }
+  lastEditTime <- df[[1,"lastEditTime"]]
+  list(totalRecords = totalRecords, lastEditTime = lastEditTime, df = df)
+}
+
 getTotalRecords <- function(formTree) {
   df <- queryTable(formTree$root, columns = list("id"="_id"), asTibble = TRUE, makeNames = FALSE, window = c(0L,1L))
   totalRecords <- attr(df, "totalRows")
@@ -1455,10 +1473,11 @@ tbl_format_header.tbl_activityInfoRemoteRecords <- function(x, setup, ...) {
 
   window <- tblWindow(x)
   columns <- tblColumns(x)
-
+  
   named_header <- list(
     "Form (id)" = sprintf("%s (%s)", tblLabel(x), x$formTree$root),
     "Total form records" = x$totalRecords,
+    "Last edit time" = format(as.POSIXct(x$lastEditTime, origin = "1970-01-01", tz = "UTC"), "%Y-%m-%d %H:%M:%S"),
     "Table fields types" = tblFieldTypes(x),
     "Table filter" = tblFilter(x),
     "Table sort" = tblSort(x),