update descriptions with dedicated function

ropensci · Aug 26, 2024 · f21b5cf · f21b5cf
1 parent 64570c3
commit f21b5cf
Show file tree

Hide file tree

Showing 22 changed files with 239 additions and 116 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -74,6 +74,7 @@ Collate:
     'reexport.R'
     'relabel.R'
     'rename_variable.R'
+    'update_description.R'
     'upgrade_data.R'
     'utils.R'
     'verify_vc.R'
diff --git a/NAMESPACE b/NAMESPACE
@@ -62,6 +62,7 @@ export(rename_variable)
 export(repository)
 export(rm_data)
 export(status)
+export(update_description)
 export(upgrade_data)
 export(verify_vc)
 export(write_vc)
@@ -88,6 +89,7 @@ importFrom(utils,file_test)
 importFrom(utils,flush.console)
 importFrom(utils,packageVersion)
 importFrom(utils,read.table)
+importFrom(utils,tail)
 importFrom(utils,write.table)
 importFrom(yaml,as.yaml)
 importFrom(yaml,read_yaml)

diff --git a/R/meta.R b/R/meta.R
@@ -36,9 +36,7 @@ meta <- function(x, ...) {
 #' @export
 #' @rdname meta
 #' @importFrom assertthat assert_that is.string noNA
-meta.character <- function(
-  x, na = "NA", optimize = TRUE, description = character(0), ...
-) {
+meta.character <- function(x, na = "NA", optimize = TRUE, ...) {
   assert_that(is.string(na), noNA(na), no_whitespace(na))
   assert_that(is.flag(optimize), noNA(optimize))
   x <- enc2utf8(x)
@@ -50,40 +48,23 @@ Please use a different NA string or consider using a factor.", call. = FALSE)
   to_escape <- grepl(ifelse(optimize, "(\"|\t|\n)", "(\"|,|\n)"), x)
   x[to_escape] <- paste0("\"", x[to_escape], "\"")
   x[is.na(x)] <- na
-  list(class = "character", na_string = na) |>
-    meta_desc(description = description) -> m
+  list(class = "character", na_string = na) -> m
   class(m) <- "meta_detail"
   attr(x, "meta") <- m
   return(x)
 }
 
-#' @importFrom assertthat assert_that is.string
-meta_desc <- function(meta, description) {
-  assert_that(is.character(description), is.list(meta))
-  if (length(description) == 0) {
-    return(meta)
-  }
-  assert_that(is.string(description))
-  if (is.na(description)) {
-    return(meta)
-  } else {
-    return(c(meta, description = unname(description)))
-  }
-}
-
 #' @export
-meta.integer <- function(x, description = character(0), ...) {
-  list(class = "integer") |>
-    meta_desc(description = description) -> m
+meta.integer <- function(x, ...) {
+  list(class = "integer") -> m
   class(m) <- "meta_detail"
   attr(x, "meta") <- m
   return(x)
 }
 
 #' @export
-meta.numeric <- function(x, description = character(0), ...) {
-  list(class = "numeric") |>
-    meta_desc(description = description) -> m
+meta.numeric <- function(x, ...) {
+  list(class = "numeric") -> m
   class(m) <- "meta_detail"
   attr(x, "meta") <- m
   return(x)
@@ -105,8 +86,7 @@ meta.numeric <- function(x, description = character(0), ...) {
 #' `meta()` ignores, with a warning, any change in the order of factor levels.
 #' Add `strict = FALSE` to enforce the new order of factor levels.
 meta.factor <- function(
-  x, optimize = TRUE, na = "NA", index, strict = TRUE,
-  description = character(0), ...
+  x, optimize = TRUE, na = "NA", index, strict = TRUE, ...
 ) {
   assert_that(is.flag(optimize), noNA(optimize), is.flag(strict), noNA(strict))
   levels(x) <- enc2utf8(levels(x))
@@ -154,8 +134,7 @@ Please use a different NA string or use optimize = TRUE")
   list(
     class = "factor", na_string = na, optimize = optimize,
     labels = names(index), index = unname(index), ordered = is.ordered(x)
-  ) |>
-    meta_desc(description = description) -> m
+  ) -> m
   class(m) <- "meta_detail"
   attr(z, "meta") <- m
   return(z)
@@ -164,23 +143,20 @@ Please use a different NA string or use optimize = TRUE")
 #' @export
 #' @rdname meta
 #' @importFrom assertthat assert_that is.flag noNA
-meta.logical <- function(x, optimize = TRUE, description = character(0), ...) {
+meta.logical <- function(x, optimize = TRUE, ...) {
   assert_that(is.flag(optimize), noNA(optimize))
   if (optimize) {
     x <- as.integer(x)
   }
-  list(class = "logical", optimize = optimize) |>
-    meta_desc(description = description) -> m
+  list(class = "logical", optimize = optimize) -> m
   class(m) <- "meta_detail"
   attr(x, "meta") <- m
   return(x)
 }
 
 #' @export
-meta.complex <- function(x, description = character(0), ...) {
-  assert_that(is.character(description), length(description) <= 1)
-  list(class = "complex") |>
-    meta_desc(description = description) -> m
+meta.complex <- function(x, ...) {
+  list(class = "complex") -> m
   class(m) <- "meta_detail"
   attr(x, "meta") <- m
   return(x)
@@ -189,22 +165,20 @@ meta.complex <- function(x, description = character(0), ...) {
 #' @export
 #' @rdname meta
 #' @importFrom assertthat assert_that is.flag noNA
-meta.POSIXct <- function(x, optimize = TRUE, description = character(0), ...) {
+meta.POSIXct <- function(x, optimize = TRUE, ...) {
   assert_that(is.flag(optimize), noNA(optimize))
   if (optimize) {
     z <- unclass(x)
     list(
       class = "POSIXct", optimize = TRUE, origin = "1970-01-01 00:00:00",
       timezone = "UTC"
-    ) |>
-      meta_desc(description = description) -> m
+    ) -> m
   } else {
     z <- format(x, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
     list(
       class = "POSIXct", optimize = FALSE, format = "%Y-%m-%dT%H:%M:%SZ",
       timezone = "UTC"
-    ) |>
-      meta_desc(description = description) -> m
+    ) -> m
   }
   class(m) <- "meta_detail"
   attr(z, "meta") <- m
@@ -214,16 +188,14 @@ meta.POSIXct <- function(x, optimize = TRUE, description = character(0), ...) {
 #' @export
 #' @rdname meta
 #' @importFrom assertthat assert_that is.flag noNA
-meta.Date <- function(x, optimize = TRUE, description = character(0), ...) {
+meta.Date <- function(x, optimize = TRUE, ...) {
   assert_that(is.flag(optimize), noNA(optimize))
   if (optimize) {
     z <- as.integer(x)
-    list(class = "Date", optimize = TRUE, origin = "1970-01-01") |>
-      meta_desc(description = description) -> m
+    list(class = "Date", optimize = TRUE, origin = "1970-01-01") -> m
   } else {
     z <- format(x, format = "%Y-%m-%d")
-    list(class = "Date", optimize = FALSE, format = "%Y-%m-%d") |>
-      meta_desc(description = description) -> m
+    list(class = "Date", optimize = FALSE, format = "%Y-%m-%d") -> m
   }
   class(m) <- "meta_detail"
   attr(z, "meta") <- m
@@ -246,7 +218,7 @@ meta.Date <- function(x, optimize = TRUE, description = character(0), ...) {
 #' @inheritParams write_vc
 meta.data.frame <- function(# nolint
   x, optimize = TRUE, na = "NA", sorting, strict = TRUE,
-  split_by = character(0), description = character(0), ...
+  split_by = character(0), ...
 ) {
   assert_that(
     !has_name(x, "..generic"),
@@ -263,11 +235,6 @@ meta.data.frame <- function(# nolint
     any(!colnames(x) %in% split_by),
     msg = "No remaining variables after splitting"
   )
-  assert_that(is.character(description))
-  stopifnot(
-    "All names in `description` must match an existing variable in `x`" =
-      all(names(description) %in% colnames(x))
-  )
 
   dots <- list(...)
   if (has_name(dots, "old")) {
@@ -308,29 +275,26 @@ Add extra sorting variables to ensure small diffs.", sorted)
   if (!has_name(dots, "old")) {
     z <- lapply(
       colnames(x),
-      function(id, optimize, na, description) {
-        meta(
-          x[[id]], optimize = optimize, na = na, description = description[id]
-        )
+      function(id, optimize, na) {
+        meta(x[[id]], optimize = optimize, na = na)
       },
-      optimize = optimize, na = na, description = description
+      optimize = optimize, na = na
     )
     names(z) <- colnames(x)
   } else {
     common <- names(old)[names(old) %in% colnames(x)]
     if (length(common)) {
       z_common <- lapply(
         common,
-        function(id, optimize, na, strict, description) {
+        function(id, optimize, na, strict) {
           meta(
             x[[id]], optimize = optimize, na = na,
             index = setNames(old[[id]][["index"]], old[[id]][["labels"]]),
-            strict = strict, description = description[id]
+            strict = strict
           )
         },
         optimize = old[["..generic"]][["optimize"]],
-        na = old[["..generic"]][["NA string"]],
-        strict = strict, description = description
+        na = old[["..generic"]][["NA string"]], strict = strict
       )
       names(z_common) <- common
     } else {
@@ -340,13 +304,10 @@ Add extra sorting variables to ensure small diffs.", sorted)
     if (length(new)) {
       z_new <- lapply(
         new,
-        function(id, optimize, na, description) {
-          meta(
-            x[[id]], optimize = optimize, na = na,
-            description = description[id]
-          )
+        function(id, optimize, na) {
+          meta(x[[id]], optimize = optimize, na = na)
         },
-        optimize = optimize, na = na, description = description
+        optimize = optimize, na = na
       )
       names(z_new) <- new
     } else {

diff --git a/R/print.R b/R/print.R
@@ -3,10 +3,21 @@
 #' Prints the data and the description of the columns when available.
 #' @param x a `git2rdata` object
 #' @param ... additional arguments passed to `print`
+#' @family internal
 #' @export
+#' @importFrom utils tail
 print.git2rdata <- function(x, ...) {
   class(x) <- tail(class(x), -1)
   print(x, ...)
+  if (has_attr(x, "table name")) {
+    cat("\nTable name: ", attr(x, "table name"))
+  }
+  if (has_attr(x, "title")) {
+    cat("\nTitle: ", attr(x, "title"))
+  }
+  if (has_attr(x, "description")) {
+    cat("\nDescription: ", attr(x, "description"))
+  }
   vapply(colnames(x), display_description, character(1), x = x) |>
     cat()
   return(invisible(NULL))
@@ -26,11 +37,22 @@ display_description <- function(x, colname) {
 #' available.
 #' @param object a `git2rdata` object
 #' @param ... additional arguments passed to `summary`
+#' @family internal
 #' @export
+#' @importFrom utils tail
 summary.git2rdata <- function(object, ...) {
   class(object) <- tail(class(object), -1)
   summary(object, ...) |>
     print()
+  if (has_attr(object, "table name")) {
+    cat("\nTable name: ", attr(object, "table name"))
+  }
+  if (has_attr(object, "title")) {
+    cat("\nTitle: ", attr(object, "title"))
+  }
+  if (has_attr(object, "description")) {
+    cat("\nDescription: ", attr(object, "description"))
+  }
   vapply(colnames(object), display_description, character(1), x = object) |>
     cat()
   return(invisible(NULL))

diff --git a/R/read_vc.R b/R/read_vc.R
@@ -142,10 +142,20 @@ read_vc.character <- function(file, root = ".") {
     }
   )
   has_description <- names(has_description)[has_description]
-  if (length(has_description) > 0) {
-    for (desc in has_description) {
-      attr(raw_data[[desc]], "description") <- details[[desc]]$description
-    }
+  for (desc in has_description) {
+    attr(raw_data[[desc]], "description") <- details[[desc]]$description
+  }
+
+  if (has_name(meta_data[["..generic"]], "name")) {
+    attr(raw_data, "table name") <- meta_data[["..generic"]][["name"]]
+  }
+
+  if (has_name(meta_data[["..generic"]], "title")) {
+    attr(raw_data, "title") <- meta_data[["..generic"]][["title"]]
+  }
+
+  if (has_name(meta_data[["..generic"]], "description")) {
+    attr(raw_data, "description") <- meta_data[["..generic"]][["description"]]
   }
 
   class(raw_data) <- c("git2rdata", class(raw_data))

diff --git a/R/update_description.R b/R/update_description.R
@@ -0,0 +1,71 @@
+#' Update the description of a `git2rdata` object
+#'
+#' Allows to update the description of the fields, the table name, the title,
+#' and the description of a `git2rdata` object.
+#' All arguments are optional.
+#' Setting an argument to `NA` or an empty string will remove the corresponding
+#' field from the metadata.
+#'
+#' @inheritParams is_git2rmeta
+#' @param field_description a named character vector with the new descriptions
+#' for the fields.
+#' The names of the vector must match the variable names.
+#' @param name a character string with the new table name of the object.
+#' @param title a character string with the new title of the object.
+#' @param description a character string with the new description of the object.
+#' @family storage
+#' @export
+#' @importFrom assertthat assert_that has_name
+update_description <- function(
+  file, root = ".", field_description, name, title, description
+) {
+  root <- normalizePath(root, winslash = "/", mustWork = TRUE)
+  file <- clean_data_path(root = root, file = file)
+  is_git2rmeta(
+    file = remove_root(file = file["meta_file"], root = root), root = root,
+    message = "error"
+  )
+  old <- read_yaml(file["meta_file"])
+  class(old) <- "meta_list"
+  if (!missing(field_description)) {
+    assert_that(
+      is.character(field_description), length(field_description) > 0,
+      !has_name(field_description, "..generic")
+    )
+    stopifnot(
+      "names in `field_description` don't match variable names" =
+        all(names(field_description) %in% names(old))
+    )
+    for (name in names(field_description)) {
+      old[[name]][["description"]] <- update_or_drop(field_description[[name]])
+    }
+  }
+
+  if (!missing(name)) {
+    old[["..generic"]][["name"]] <- update_or_drop(name)
+  }
+
+  if (!missing(title)) {
+    old[["..generic"]][["title"]] <- update_or_drop(title)
+  }
+
+  if (!missing(description)) {
+    old[["..generic"]][["description"]] <- update_or_drop(description)
+  }
+
+  packageVersion("git2rdata") |>
+    as.character() -> old[["..generic"]][["git2rdata"]]
+  metadata_hash(old) -> old[["..generic"]][["hash"]]
+  write_yaml(old, file["meta_file"])
+  return(invisible(NULL))
+}
+
+#' @importFrom assertthat assert_that is.string
+update_or_drop <- function(x) {
+  assert_that(is.string(x))
+  if (is.na(x) || x == "") {
+    return(NULL)
+  } else {
+    return(x)
+  }
+}