- added new vignettes

- bugfixes

Author: rubenarslan

DESCRIPTION

@@ -32,7 +32,6 @@ Imports:
     DT,
     future,
     haven,
-    readr,
     mice (>= 3.2.0),
     tibble,
     purrr,
@@ -47,9 +46,10 @@ Suggests:
   testthat,
   shinytest,
   lme4,
-  roxygen2
+  roxygen2,
+  qualtRics
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 6.0.1
+RoxygenNote: 6.1.0
 Roxygen: list(markdown = TRUE) 
 VignetteBuilder: knitr

NAMESPACE

@@ -1,10 +1,16 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_factor,default)
 S3method(print,knit_asis)
 S3method(summary,labelled)
 S3method(summary,labelled_spss)
 S3method(zap_attributes,data.frame)
 S3method(zap_attributes,default)
+S3method(zap_label,data.frame)
+S3method(zap_label,default)
+S3method(zap_labelled,data.frame)
+S3method(zap_labelled,labelled)
+export("var_label<-")
 export(aggregate_and_document_scale)
 export(as_factor)
 export(asis_knit_child)
@@ -21,6 +27,8 @@ export(detect_missings)
 export(detect_scales)
 export(ended)
 export(expired)
+export(has_label)
+export(has_labels)
 export(knit_print.alpha)
 export(knit_print.htest)
 export(knit_print.multilevel)
@@ -36,9 +44,13 @@ export(paste.knit_asis)
 export(plot_labelled)
 export(rescue_attributes)
 export(reverse_labelled_values)
+export(var_label)
 export(zap_attributes)
 export(zap_label)
+export(zap_labelled)
 import(miniUI)
 import(rstudioapi)
 import(shiny)
 importFrom(haven,as_factor)
+importFrom(labelled,"var_label<-")
+importFrom(labelled,var_label)

NEWS.md

@@ -1,4 +1,24 @@
-# codebook 0.6.0
+# codebook 0.6.3
+## Additions
+- Vignettes for
+  - documenting the expected attribute structure, how to add metadata in R
+  - importing metadata from SPSS or Stata files
+  - importing metadata from Qualtrics as made available by `qualtRics` package
+- Importing some functions from labelled package to add metadata
+- Default method for haven::as_factor when labelled class is absent
+  
+## Changes
+- Changed the scale summary, so that Likert plots and distributions are shown
+  on the first tab. Reliability now hidden under "Reliability details".
+- removed unnecessary `readr` dependency.
+
+## Bugfixes
+- summarising factors in a table
+- turning off components of the codebook without empty strings being echoed
+- allow using variable and value labels in the absence of the labelled class
+  (as imported by rio for example)
+
+# codebook 0.6.2
 ## Additions
 - Three RStudio Addin Shinyapps to browse variable labels and codebook. 
 

R/codebook.R

@@ -435,7 +435,16 @@ attribute_summary <- function(var) {
       }
     }
   }
-  if (exists("labels", x)) {
+  if (exists("levels", x)) {
+    x$value_labels <- paste(paste0(seq_len(length(x$levels)), ". ", x$levels),
+                              collapse = ",\n")
+    x$levels <- NULL
+    # remove extremely deep qualtrics choices attributes
+    if (exists("item", x) && exists("choices", x$item)
+        && exists("variableName", x$item$choices[[1]])) {
+      x$item$choices <- NULL
+    }
+  } else if (exists("labels", x)) {
     if (!is.null(names(x$labels))) {
       x$value_labels <- paste(paste0(x$labels, ". ", names(x$labels)),
                               collapse = ",\n")

R/correct_attributes.R

@@ -262,63 +262,55 @@ zap_attributes.data.frame <- function(x, attributes = NULL) {
 #' Modelled on [haven::zap_labels()], zaps variable labels (not value labels).
 #'
 #' @param x the data frame or variable
+#'
 #' @export
+#' @examples
+#' x <- haven::labelled(rep(1:5, each = 1), c(Bad = 1, Good = 5))
+#' zap_label(x)
 zap_label <- function(x) {
   UseMethod("zap_label")
 }
+
+#' @export
 zap_label.data.frame <- function(x) {
   x[] <- lapply(x, zap_label)
   x
 }
+
+#' @export
 zap_label.default <- function(x) {
   attr(x, "label") <- NULL
   x
 }
 
 
-
-#' Aggregate variables and remember which variables this were
+#' Zap labelled class
 #'
-#' The resulting variables will have the attribute `scale_item_names` containing
-#' the basis for aggregation. Its `label` attribute will refer to the common stem of the
-#' aggregated variable names (if any), the number of variables, and the
-#' aggregation function.
+#' Modelled on [haven::zap_labels()], zaps labelled class (not other attributes).
 #'
-#' @param items data.frame of the items that should be aggregated
-#' @param fun aggregation function, defaults to rowMeans with na.rm = FALSE
-#' @param stem common stem for the variables, specify if it should not be auto-detected
-#' as the longest common stem of the variable names
+#' @param x the data frame or variable
 #' @export
-#' @examples
-#' testdf <- data.frame(bfi_neuro_1 = rnorm(20), bfi_neuro_2 = rnorm(20),
-#'                     bfi_neuro_3R = rnorm(20), age = rpois(20, 30))
-#' item_names <- c('bfi_neuro_1', 'bfi_neuro_2', 'bfi_neuro_3R')
-#' testdf$bfi_neuro <- aggregate_and_document_scale(testdf[, item_names])
-#' testdf$bfi_neuro
-aggregate_and_document_scale <- function(items, fun = rowMeans, stem = NULL) {
-  new_scale <- fun(items)
-  item_names <- names(items)
-  attributes(new_scale)$scale_item_names <- item_names
+zap_labelled <- function(x) {
+  UseMethod("zap_labelled")
+}
 
-  # find longest common stem
-  if (is.null(stem)) {
-    max_len <- min(nchar(item_names))
-    for (l in max_len:0) {
-      stem <- unique(stringr::str_sub(item_names, 1, l))
-      if (length(stem) == 1) break
-    }
-  }
-  # string trimming for idiots
-  if (nchar(stem)) {
-    stem <- stringr::str_match(stem, "^(.+?)_?$")[, 2]
-  }
+#' @export
+zap_labelled.data.frame <- function(x) {
+  x[] <- lapply(x, zap_labelled)
+  x
+}
 
-  attributes(new_scale)$label <- paste(ncol(items), stem, "items aggregated by",
-                                      deparse(substitute(fun)))
-  new_scale
+#' @export
+zap_labelled.labelled <- function(x) {
+  if (inherits(x, "labelled")) {
+    unclass(x)
+  } else {
+    x
+  }
 }
 
 
+
 #' Reverse labelled values
 #' reverse the underlying valus for a numeric [haven::labelled()] vector while keeping the labels correct
 #'
@@ -333,6 +325,14 @@ reverse_labelled_values <- function(x) {
   labels <- attributes(x)$labels
   values <- unname(labels)
   labels <- names(labels)
+  if (
+    sum(!is.na(values)) == 0 ||
+    (any(x > max(values, na.rm = TRUE) |
+          x < min(values, na.rm = TRUE), na.rm = TRUE))) {
+    warning(deparse(substitute(x)), ": There are values outside the ",
+            "labelled range. Reversion will only work if both the minimum ",
+            "and maximum of the range are part of the responses.")
+  }
   if (length(values) < length(unique(x)) ) {
     # if only some values have labels (e.g. extremes), make sure we include all
     possible_replies <- union(values, unique(x))
@@ -349,6 +349,7 @@ reverse_labelled_values <- function(x) {
         length(range)) {
       possible_replies <- range
     }
+
     possible_replies <- sort(possible_replies)
     recode_replies <- stats::setNames(
       as.list(possible_replies), rev(possible_replies))

R/create_metadata.R

@@ -2,3 +2,54 @@
 #' @export
 haven::as_factor
 
+#' @importFrom labelled var_label
+#' @export
+labelled::var_label
+
+#' @importFrom labelled var_label<-
+#' @export
+labelled::`var_label<-`
+
+
+
+#' Aggregate variables and remember which variables this were
+#'
+#' The resulting variables will have the attribute `scale_item_names` containing
+#' the basis for aggregation. Its `label` attribute will refer to the common stem of the
+#' aggregated variable names (if any), the number of variables, and the
+#' aggregation function.
+#'
+#' @param items data.frame of the items that should be aggregated
+#' @param fun aggregation function, defaults to rowMeans with na.rm = FALSE
+#' @param stem common stem for the variables, specify if it should not be auto-detected
+#' as the longest common stem of the variable names
+#' @export
+#' @examples
+#' testdf <- data.frame(bfi_neuro_1 = rnorm(20), bfi_neuro_2 = rnorm(20),
+#'                     bfi_neuro_3R = rnorm(20), age = rpois(20, 30))
+#' item_names <- c('bfi_neuro_1', 'bfi_neuro_2', 'bfi_neuro_3R')
+#' testdf$bfi_neuro <- aggregate_and_document_scale(testdf[, item_names])
+#' testdf$bfi_neuro
+aggregate_and_document_scale <- function(items, fun = rowMeans, stem = NULL) {
+  new_scale <- fun(items)
+  item_names <- names(items)
+  attributes(new_scale)$scale_item_names <- item_names
+
+  # find longest common stem
+  if (is.null(stem)) {
+    max_len <- min(nchar(item_names))
+    for (l in max_len:0) {
+      stem <- unique(stringr::str_sub(item_names, 1, l))
+      if (length(stem) == 1) break
+    }
+  }
+  # string trimming for idiots
+  if (nchar(stem)) {
+    stem <- stringr::str_match(stem, "^(.+?)_?$")[, 2]
+  }
+
+  attributes(new_scale)$label <- paste(ncol(items), stem, "items aggregated by",
+                                       deparse(substitute(fun)))
+  new_scale
+}
+

R/misc.R

@@ -167,3 +167,43 @@ summary.labelled <- function(object, ...) {
 summary.labelled_spss <- function(object, ...) {
   summary(haven::as_factor(object, levels = "both"), ...)
 }
+
+
+
+#' Has label
+#'
+#'
+#' @param x a vector
+#'
+#' @export
+#' @examples
+#' example("labelled", "haven")
+#' has_label(x)
+has_label <- function(x) {
+  haven::is.labelled(x) ||
+    !is.null(attr(x, 'label')) ||
+    !is.null(attr(x, 'labels'))
+}
+
+
+#' Has labels
+#'
+#'
+#' @param x a vector
+#'
+#' @export
+#' @examples
+#' example("labelled", "haven")
+#' has_labels(x)
+has_labels <- function(x) {
+  haven::is.labelled(x) ||
+    !is.null(attr(x, 'labels'))
+}
+
+#' @export
+as_factor.default <- function(x,
+          levels = c("default", "labels", "values", "both"),
+          ordered = FALSE, ...) {
+  class(x) <- c("labelled", class(x))
+  haven::as_factor(x, levels, ordered, ...)
+}

R/plot_helpers.R

@@ -71,8 +71,8 @@ plot_labelled <- function(item, item_name = NULL,
     nonmissing_choices <- attributes(item_nomiss)[["labels"]]
   has_labelled_missings <- length(nonmissing_choices) < length(choices)
   if (all(is.na(item_nomiss))) {
-    if (haven::is.labelled(item)) {
-      item <- haven::as_factor(item, "both")
+    if (has_labels(item)) {
+      item <- as_factor(item, "both")
     } else {
       item <- factor(item, exclude = NULL)
     }
@@ -88,7 +88,7 @@ plot_labelled <- function(item, item_name = NULL,
   # * factor -> discrete
   # * double/integer -> continuous, with binning
 
-  if (haven::is.labelled(item)) {
+  if (has_labels(item)) {
     # for labelled values, make labels look proper
     label_how <- "both"
     if (length(choices)) {
@@ -142,7 +142,7 @@ plot_labelled <- function(item, item_name = NULL,
       if (any(names(choices) != choices)) {
         label_how <- "both"
       }
-      item <- haven::as_factor(item, levels = label_how)
+      item <- as_factor(item, levels = label_how)
 
       dist_plot <- ggplot2::ggplot(mapping = ggplot2::aes(x = item)) +
         ggplot2::geom_bar() +

_pkgdown.yml

@@ -28,11 +28,14 @@ reference:
   - '`rescue_attributes`'
   - '`aggregate_and_document_scale`'
   - '`reverse_labelled_values`'
+  - '`has_label`'
+  - '`has_labels`'
 - title: Prepare data for non-codebook stuff
   desc: Functions to remove attributes that might confuse other packages
   contents:
   - '`zap_attributes`'
   - '`zap_label`'
+  - '`zap_labelled`'
 - title: Functions for rmarkdown partials
   desc: Make rmarkdown partials whether in interactive mode or not
   contents: