Merge pull request #366 from frictionlessdata/dollar-schema-first

Create append helper function and set $schema as first attribute

Author: peterdesmet

R/upgrade_descriptor.R

@@ -14,9 +14,12 @@ upgrade_descriptor <- function(package) {
     return(package)
   }
 
-  # Set $schema
-  purrr::pluck(package, "$schema") <-
-    "https://datapackage.org/profiles/2.0/datapackage.json"
+  # Set $schema as first property
+  package <- append_with_attributes(
+    package,
+    list("$schema" = "https://datapackage.org/profiles/2.0/datapackage.json"),
+    after = 0
+  )
 
   # Set $schema to profile if URL (to custom profile)
   # https://datapackage.org/standard/data-package/#dollar-schema

R/upgrade_resource.R

@@ -12,9 +12,12 @@ upgrade_resource <- function(resource) {
     return(resource)
   }
 
-  # Set $schema
-  purrr::pluck(resource, "$schema") <-
-    "https://datapackage.org/profiles/2.0/dataresource.json"
+  # Set $schema as first property
+  resource <- append_with_attributes(
+    resource,
+    list("$schema" = "https://datapackage.org/profiles/2.0/dataresource.json"),
+    after = 0
+  )
 
   # Set type to table if resource is tabular
   # https://datapackage.org/standard/data-resource/#type

R/upgrade_schema.R

@@ -14,9 +14,12 @@ upgrade_schema <- function(schema, resource_name) {
     return(schema)
   }
 
-  # Set $schema
-  purrr::pluck(schema, "$schema") <-
-    "https://datapackage.org/profiles/2.0/tableschema.json"
+  # Set $schema as first property
+  schema <- append_with_attributes(
+    schema,
+    list("$schema" = "https://datapackage.org/profiles/2.0/tableschema.json"),
+    after = 0
+  )
 
   # Update primaryKey to array
   # https://datapackage.org/overview/changelog/#schemaprimarykey-updated

R/utils.R

@@ -100,3 +100,28 @@ get_dot_names <- function(...) {
   # Return the names that are not an empty string (no name set)
   return(dot_names[dot_names != ""])
 }
+
+#' Vector merging while preserving attributes
+#'
+#' Wrapper for [base::append] that preserves attributes.
+#'
+#' @inheritParams base::append
+#' @returns A vector containing the values in `x` with the elements of `values`
+#'   appended after the specified element of `x`, while preserving the
+#'   attributes of `x`.
+#' @noRd
+append_with_attributes <- function(x, values, after = length(x)) {
+  # Keep original attributes, except names, which length will change with append
+  original_attributes <- attributes(x)
+  original_attributes[["names"]] <- NULL
+
+  # Append values (recreates names)
+  x <- base::append(unclass(x), values, after = after)
+
+  # Put original attributes back
+  for (attribute_name in names(original_attributes)) {
+    attr(x, attribute_name) <- original_attributes[[attribute_name]]
+  }
+
+  return(x)
+}

tests/testthat/test-upgrade_descriptor.R

@@ -59,6 +59,11 @@ test_that("upgrade_descriptor() sets $schema to default v2 value or custom
   expect_identical(upgrade_descriptor(p_v1)$`$schema`, v2_profile)
 })
 
+test_that("upgrade_resource() sets $schema as first property", {
+  p_v1 <- example_package(version = "1.0")
+  expect_identical(names(upgrade_descriptor(p_v1))[[1]], "$schema")
+})
+
 test_that("upgrade_descriptor() updates contributor role to roles", {
   p_v1 <- example_package(version = "1.0")
 

tests/testthat/test-upgrade_resource.R

@@ -54,6 +54,11 @@ test_that("upgrade_resource() sets $schema to default v2 value", {
   expect_identical(upgrade_resource(resource_v1)$`$schema`, v2_profile)
 })
 
+test_that("upgrade_resource() sets $schema as first property", {
+  resource_v1 <- resource(example_package(version = "1.0"), "deployments")
+  expect_identical(names(upgrade_resource(resource_v1))[[1]], "$schema")
+})
+
 test_that("upgrade_resource() sets type for tabular resources", {
   resource_v1 <- resource(example_package(version = "1.0"), "deployments")
 

tests/testthat/test-upgrade_schema.R

@@ -23,6 +23,14 @@ test_that("upgrade_schema() sets $schema to default v2 value", {
     )
 })
 
+test_that("upgrade_schema() sets $schema as first property", {
+  schema_v1 <- schema(example_package(version = "1.0"), "deployments")
+  expect_identical(
+    names(upgrade_schema(schema_v1, "deployments"))[[1]],
+    "$schema"
+  )
+})
+
 test_that("upgrade_schema() updates primaryKey", {
   schema_v1 <- schema(example_package(version = "1.0"), "deployments")
 
@@ -33,11 +41,11 @@ test_that("upgrade_schema() updates primaryKey", {
     list("deployment_id")
   )
 
-  # Leave undefined
+  # Undefined
   schema_v1$primaryKey <- NULL
   expect_null(upgrade_schema(schema_v1, "deployments")$primaryKey)
 
-  # Leave list
+  # List
   schema_v1$primaryKey <- list("deployment_id", "other_id")
   expect_identical(
     upgrade_schema(schema_v1, "deployments")$primaryKey,
@@ -55,11 +63,11 @@ test_that("upgrade_schema() updates foreignKeys", {
     schema(example_package(version = "2.0"), "media")$foreignKeys,
   )
 
-  # Leave undefined
+  # Undefined
   schema_v1$foreignKeys <- NULL
   expect_null(upgrade_schema(schema_v1, "media")$foreignKeys)
 
-  # Extensive example
+  # Custom properties + self-referential resource
   provided_keys <- list(
     fields = "not_in_list", # Ignore
     list(

tests/testthat/test-utils.R

@@ -87,3 +87,79 @@ test_that("get_dot_names() does not return empty strings for unnamed args passed
   expect_identical(test_fn(a = "1", "2", b = "3", c = "4"), c("a", "b", "c"))
   expect_length(test_fn(a = "1", "2", b = "3", c = "4"), 3)
 })
+
+# append_with_attributes() ----
+test_that("append_with_attributes() supports base::append() functionality", {
+  list_1 <- list(a = 1, b = 2)
+  list_2 <- list(c = 3, d = 4)
+  list_nested <- list(c = list(d = 3))
+  expect_identical(
+    append_with_attributes(1:5, 0:1, after = 3),
+    append(1:5, 0:1, after = 3)
+  )
+  expect_identical(
+    append_with_attributes(list_1, list_2, after = 0),
+    append(list_1, list_2, after = 0)
+  )
+  expect_identical(
+    append_with_attributes(list_1, list_nested),
+    append(list_1, list_nested)
+  )
+})
+
+test_that("append_with_attributes() preserves attributes and classes", {
+  object <- head(letters, -1L) # a, b, ... y
+  # Add custom attributes
+  attr(object, "title") <- "Letters"
+  attr(object, "description") <- "Lowercase letters in alphabetical order"
+  # Add custom class
+  class(object) <- c("letters")
+  class(object) <- c("series", class(object))
+
+  expect_identical(
+    attributes(append_with_attributes(object, "z")),
+    attributes(object)
+  )
+  expect_s3_class(
+    append_with_attributes(object, "z"),
+    c("series", "letters")
+  )
+})
+
+test_that("append_with_attributes() preserves names", {
+  object <- head(letters, -1L) # a, b, ... y
+  # Add names
+  object <- purrr::set_names(object, toupper(object))
+  expect_named(
+    append_with_attributes(object, c("Z" = "z")),
+    toupper(letters)
+  )
+})
+
+test_that("append_with_attributes() can return a valid package", {
+  p <- create_package()
+  p_appended <- append_with_attributes(
+    p,
+    list(custom_property = "custom_value"),
+    0
+  )
+  expect_no_error(check_package(p_appended))
+  expect_identical(names(p_appended)[[1]], "custom_property")
+})
+
+test_that("append_with_attributes() can return a valid resource", {
+  resource <- resource(example_package(), "deployments")
+  resource_appended <- append_with_attributes(
+    resource,
+    list(custom_property = "custom_value"),
+    0
+  )
+  # Resource attributes are kept
+  expect_identical(
+    attr(resource_appended, "data_location"),
+    attr(resource, "data_location")
+  )
+  expect_identical(names(resource_appended)[[1]], "custom_property")
+})
+
+