labelled() and labelled_spss() now support the label attribute (#…

…384)

The constructor functions `labelled()` and `labelled_spss()` now support
adding the `label` attribute to the resulting object. The `label` is a
short, human-readable description of the object, and is now also used
when printing, and can be easily removed using the new `zap_label()`
function. Fixes #362.

Previously, the `label` attribute was supported both when reading
and writing SPSS files, but it was not possible to actually create
objects in R having the `label` attribute using the constructors
`labelled()` or `labelled_spss()`.

NAMESPACE

@@ -11,6 +11,9 @@ S3method(print,labelled_spss)
 S3method(type_sum,labelled)
 S3method(zap_formats,data.frame)
 S3method(zap_formats,default)
+S3method(zap_label,data.frame)
+S3method(zap_label,default)
+S3method(zap_label,labelled)
 S3method(zap_labels,data.frame)
 S3method(zap_labels,default)
 S3method(zap_labels,labelled)
@@ -44,6 +47,7 @@ export(write_sav)
 export(write_xpt)
 export(zap_empty)
 export(zap_formats)
+export(zap_label)
 export(zap_labels)
 export(zap_missing)
 export(zap_widths)

NEWS.md

@@ -1,5 +1,17 @@
 # haven 1.1.2.9000
 
+
+* `labelled()` and `labelled_spss()` now support adding the `label`
+  attribute to the resulting object. The `label` is a short,
+  human-readable description of the object, and is now also used
+  when printing, and can be easily removed using the new `zap_label()`
+  function. (#362, @huftis)
+
+  Previously, the `label` attribute was supported both when reading
+  and writing SPSS files, but it was not possible to actually create
+  objects in R having the `label` attribute using the constructors
+  `labelled()` or `labelled_spss()`.
+
 # haven 1.1.2
 
 * haven can read and write non-ASCII paths in R 3.5 (#371).

R/labelled.R

@@ -12,11 +12,13 @@
 #' @param labels A named vector. The vector should be the same type as
 #'   `x`. Unlike factors, labels don't need to be exhaustive: only a fraction
 #'   of the values might be labelled.
-#' @param ... Ignored
+#' @param label A short, human-readable description of the vector.
 #' @export
 #' @examples
 #' s1 <- labelled(c("M", "M", "F"), c(Male = "M", Female = "F"))
 #' s2 <- labelled(c(1, 1, 2), c(Male = 1, Female = 2))
+#' s3 <- labelled(c(1, 1, 2), c(Male = 1, Female = 2),
+#'                label="Assigned sex at birth")
 #'
 #' # Unfortunately it's not possible to make as.factor work for labelled objects
 #' # so instead use as_factor. This works for all types of labelled vectors.
@@ -36,7 +38,7 @@
 #' # values
 #' x <- labelled(c(1, 2, 1, 2, 10, 9), c(Unknown = 9, Refused = 10))
 #' zap_labels(x)
-labelled <- function(x, labels) {
+labelled <- function(x, labels, label = NULL) {
   if (!is.numeric(x) && !is.character(x)) {
     stop("`x` must be a numeric or a character vector", call. = FALSE)
   }
@@ -46,8 +48,12 @@ labelled <- function(x, labels) {
   if (is.null(names(labels))) {
     stop("`labels` must have names", call. = FALSE)
   }
+  if (!is.null(label) && (!is.character(label) || length(label) != 1)) {
+    stop("`label` must be a character vector of length one", call. = FALSE)
+  }
 
   structure(x,
+    label = label,
     labels = labels,
     class = "labelled"
   )
@@ -71,12 +77,12 @@ is.labelled <- function(x) inherits(x, "labelled")
 
 #' @export
 `[.labelled` <- function(x, ...) {
-  labelled(NextMethod(), attr(x, "labels"))
+  labelled(NextMethod(), attr(x, "labels"), attr(x, "label", exact = TRUE))
 }
 
 #' @export
 print.labelled <- function(x, ..., digits = getOption("digits")) {
-  cat("<Labelled ", typeof(x), ">\n", sep = "")
+  cat("<Labelled ", typeof(x), ">", get_labeltext(x), "\n", sep = "")
 
   if (is.double(x)) {
     print_tagged_na(x, digits = digits)
@@ -147,3 +153,13 @@ label_length <- function(x) {
 type_sum.labelled <- function(x) {
   paste0(tibble::type_sum(unclass(x)), "+lbl")
 }
+
+# Convenience function for getting the label with
+# with a prefix (if label is not empty), used for
+# printing 'label' and 'labelled_spss' vectors
+get_labeltext <- function(x, prefix=": ") {
+  label = attr(x, "label", exact = TRUE)
+  if(!is.null(label)) {
+    paste0(prefix, label)
+  }
+}

R/labelled_spss.R

@@ -15,9 +15,13 @@
 #' x1 <- labelled_spss(1:10, c(Good = 1, Bad = 8), na_values = c(9, 10))
 #' is.na(x1)
 #'
-#' x2 <- labelled_spss(1:10, c(Good = 1, Bad = 8), na_range = c(9, Inf))
+#' x2 <- labelled_spss(1:10, c(Good = 1, Bad = 8), na_range = c(9, Inf),
+#'                     label = "Quality rating")
 #' is.na(x2)
-labelled_spss <- function(x, labels, na_values = NULL, na_range = NULL) {
+#'
+#' # Print data and metadata
+#' x2
+labelled_spss <- function(x, labels, na_values = NULL, na_range = NULL, label = NULL) {
   if (!is.null(na_values)) {
     if (!is_coercible(x, na_values)) {
       stop("`x` and `na_values` must be same type", call. = FALSE)
@@ -33,7 +37,7 @@ labelled_spss <- function(x, labels, na_values = NULL, na_range = NULL) {
   }
 
   structure(
-    labelled(x, labels),
+    labelled(x, labels, label = label),
     na_values = na_values,
     na_range = na_range,
     class = c("labelled_spss", "labelled")
@@ -45,14 +49,15 @@ labelled_spss <- function(x, labels, na_values = NULL, na_range = NULL) {
   labelled_spss(
     NextMethod(),
     labels = attr(x, "labels"),
+    label = attr(x, "label", exact = TRUE),
     na_values = attr(x, "na_values"),
     na_range = attr(x, "na_range")
   )
 }
 
 #' @export
 print.labelled_spss <- function(x, ...) {
-  cat("<Labelled SPSS ", typeof(x), ">\n", sep = "")
+  cat("<Labelled SPSS ", typeof(x), ">", get_labeltext(x), "\n", sep = "")
 
   xx <- x
   attributes(xx) <- NULL

R/zap_label.R

@@ -0,0 +1,41 @@
+#' Zap label
+#'
+#' Removes label, leaving unlabelled vectors as is. Use this if you want to
+#' simply drop all `label` attributes from a data frame.
+#'
+#' @param x A vector or data frame
+#' @family zappers
+#' @export
+#' @examples
+#' x1 <- labelled(1:5, c(good = 1, bad = 5))
+#' x1
+#' zap_label(x1)
+#'
+#' x2 <- labelled_spss(c(1:4, 9), c(good = 1, bad = 5), na_values = 9)
+#' x2
+#' zap_label(x2)
+#'
+#' # zap_label also works with data frames
+#' df <- tibble::data_frame(x1, x2)
+#' df
+#' zap_label(df)
+zap_label <- function(x) {
+  UseMethod("zap_label")
+}
+
+#' @export
+zap_label.default <- function(x) {
+  x
+}
+
+#' @export
+zap_label.labelled <- function(x) {
+  attr(x, "label") <- NULL
+  x
+}
+
+#' @export
+zap_label.data.frame <- function(x) {
+  x[] <- lapply(x, zap_label)
+  x
+}

R/zap_labels.R

@@ -1,13 +1,16 @@
 #' Zap labels
 #'
 #' Removes labels, leaving unlabelled vectors as is. Use this if you want to
-#' simply drop all labelling from a data frame. Zapping labels from
+#' simply drop all `labels` from a data frame. Zapping labels from
 #' [labelled_spss()] also removes user-defined missing values,
 #' replacing all with `NA`s.
 #'
 #' @param x A vector or data frame
 #' @family zappers
 #' @export
+#' @note This function doesn't remove any `label` attribute(s),
+#'       just the `labels` attribute(s). Use \code{\link{zap_label}}
+#'       to remove `label` attribute(s).
 #' @examples
 #' x1 <- labelled(1:5, c(good = 1, bad = 5))
 #' x1

src/RcppExports.cpp

@@ -202,9 +202,9 @@ static const R_CallMethodDef CallEntries[] = {
     {"_haven_write_dta_", (DL_FUNC) &_haven_write_dta_, 3},
     {"_haven_write_sas_", (DL_FUNC) &_haven_write_sas_, 2},
     {"_haven_write_xpt_", (DL_FUNC) &_haven_write_xpt_, 4},
-    {"is_tagged_na_", (DL_FUNC) &is_tagged_na_, 2},
-    {"na_tag_",       (DL_FUNC) &na_tag_,       1},
-    {"tagged_na_",    (DL_FUNC) &tagged_na_,    1},
+    {"is_tagged_na_",            (DL_FUNC) &is_tagged_na_,            2},
+    {"na_tag_",                  (DL_FUNC) &na_tag_,                  1},
+    {"tagged_na_",               (DL_FUNC) &tagged_na_,               1},
     {NULL, NULL, 0}
 };
 

tests/testthat/test-labelled.R

@@ -14,6 +14,15 @@ test_that("labels must have names", {
   expect_error(labelled(1, 1), "must have names")
 })
 
+test_that("label must be length 1 character or missing", {
+  expect_error(labelled(1, c(female=1)), NA)
+    expect_error(labelled(1, c(female=1), label = "foo"), NA)
+  expect_error(labelled(1, c(female=1), label = 1),
+               "character vector of length one")
+  expect_error(labelled(1, c(female=1), label = c("foo", "bar")),
+               "character vector of length one")
+})
+
 # methods -----------------------------------------------------------------
 
 test_that("printed output is stable", {

tests/testthat/test-labelled_spss.R

@@ -26,7 +26,8 @@ test_that("subsetting preserves attributes", {
   x <- labelled_spss(
     1:5, c("Good" = 1, "Bad" = 5),
     na_value = c(1, 2),
-    na_range = c(3, Inf)
+    na_range = c(3, Inf),
+    label = "Rating"
   )
   expect_identical(x, x[])
 })