Major adjustments

R/codeBookSummary.R

@@ -0,0 +1,163 @@
+#' Summarize crunch variables for codeBooks
+#'
+#' This group of functions creates a summarized data.frame that can be cnoverted
+#' into either a kable or manually glued into a latex.
+#'
+#' @param x A single variable from a crunch dataset
+#' @param ... Additional arguments, unused.
+#' @export
+codeBookSummary <- function(x, ...) {
+  UseMethod("codeBookSummary", x)
+}
+
+#' @describeIn codeBookSummary The default, throws out anything that does not match expected crunch variable classes
+#' @export
+codeBookSummary.default <- function(x, ...) {
+  wrong_class_error(x,
+                    c("CategoricalVariable",
+                      "CategoricalArrayVariable",
+                      "MultipleResponseVariable",
+                      "TextVariable",
+                      "NumericVariable",
+                      "DatetimeVariable"),
+                    "codebookItem")
+}
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a CategoricalVariable
+#' @export
+codeBookSummary.CategoricalVariable <- function(x, multiple = FALSE, ...) {
+  cats <- crunch::categories(x)
+  responses <- suppressWarnings(do.call(rbind, cats@.Data))
+  l <- list()
+  for (i in 1:nrow(responses)) {
+
+    if (is.null(responses[i, ]$numeric_value)) {
+      # CategoricalVariable within MultipleResponseVariable
+      if (responses[i, ]$name %in% c("not selected", "selected")) {
+        responses[i,]$numeric_value <- ifelse(
+          responses[i, ]$name == "selected",
+          1L,
+          2L
+        )
+      } else {
+        responses[i,]$numeric_value <- NA_integer_
+      }
+    }
+
+    l[[i]] <- as.data.frame(
+      matrix(
+        unlist(responses[i,]),
+        ncol = dim(responses)[2]
+      )
+    )
+  }
+
+  l <- do.call(rbind, l)
+  # CategoricalVariable
+  if (ncol(l) == 4) {
+    names(l) <- c("id", "missing", "name", "value")
+  }
+
+  # CategoricalVariable within MultipleResponseVariable
+  if (ncol(l) == 5) {
+    names(l) <- c("id", "missing", "name", "value", "drop")
+
+  }
+
+  for (i in 1:ncol(l)) { l[[i]] <- type.convert(l[[i]], as.is = T) }
+
+  smry <- data.frame(crunch::table(x, useNA = "ifany"))
+  names(smry) <- c("name", "n")
+
+  res <- merge(l, smry)
+
+  if (multiple) {
+    res[with(res, order(value)),]
+  } else {
+    ln <- length(res$name)
+
+    matrix(c(
+      rep("", ln),
+      res$value,
+      res$name,
+      rep("", ln),
+      res$n,
+      rep("", ln)
+    ), ncol = 6)
+  }
+
+}
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a MultipleResponseVariable
+#' @export
+codeBookSummary.MultipleResponseVariable <- function(x, ...) {
+  responses <- list()
+  subvars <- names(subvariables(x))
+  for (i in 1:length(names(x))) {
+    responses[[i]] <- codeBookSummary(x[[i]], multiple = TRUE)
+  }
+
+  names(responses) <- subvars
+  nms <- c("", "", paste(responses[[1]]$value, responses[[1]]$name))
+  rws <- length(responses)
+  cols <- nrow(responses[[1]])
+  m <- matrix(rep(NA, (rws)*(cols + 2)), ncol = cols + 2, nrow = rws)
+
+
+  for (i in 1:rws) {
+    m[i,3:length(nms)] <- responses[[i]]$n
+  }
+
+  r <- data.frame(m)
+  r$X1 <- names(x)
+  r$X2 <- subvars
+  names(r) <- nms
+  r
+}
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a CategoricalArrayVariable
+#' @export
+codeBookSummary.CategoricalArrayVariable <- function(x, ...) codeBookSummary.MultipleResponseVariable(x, ...)
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a NumericVariable
+#' @export
+codeBookSummary.NumericVariable <- function(x, ...) {
+  minima <- round(min(x, na.rm = T), 2)
+  maxima <- round(max(x, na.rm = T), 2)
+  missings <- sum(is.na(as.vector(x)))
+
+  type_row <- c("", "Type", "Numeric", "")
+  range_row <- c("", "Range", paste0("[", minima,", ", maxima,"]"), "")
+
+  if (missings > 0) {
+    missings_row <- c("", "Missing", missings, "")
+    r <- rbind(
+      type_row, missings_row, range_row
+    )
+  } else {
+    r <- rbind(
+      type_row, range_row
+    )
+  }
+
+  rownames(r) <- NULL
+  r
+
+}
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a TextVariable
+#' @export
+codeBookSummary.TextVariable <- function(x, ...) {
+
+  filled <- sum(as.vector(x) != "" | !is.na(as.vector(x)))
+  type_row <- c("", "Type", "Text", "")
+  filled <- c("", "Filled", filled, "")
+
+  r <- rbind(type_row, filled)
+  rownames(r) <- NULL
+  r
+}
+
+#' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a DatetimeVaraible
+#' @export
+codeBookSummary.DatetimeVariable <- codeBookSummary.NumericVariable

R/codebook_v2.R

@@ -0,0 +1,161 @@
+# Txt Elements -----
+
+#' Extract basic question information
+#'
+#' Extracts the following:
+#'
+#' * alias
+#' * description or question text
+#' * notes or filter text
+#'
+#' @param x A dataset variable
+#' @md
+#' @importFrom glue glue
+#' @export
+bcodeBookItemTxtDescription <- function(x, ...) {
+  txt <- list()
+  txt$description <- crunch::description(x)
+  question_align = c("l", "X", "X", "r")
+  question <- c("", txt$description, "", "")
+
+  k = matrix(question, ncol = 4)
+
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = question_align) %>%
+    kable_styling_defaults(...)
+}
+
+bcodeBookItemTxtNotes <- function(x, ...) {
+  txt <- list()
+  txt$notes <- crunch::notes(x)
+  notes_align <- c("l", "l", "l", "r")
+  notetxt <- c("", "Notes", txt$notes, "")
+
+  k = matrix(notetxt, ncol = 4)
+
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = notes_align) %>%
+    kable_styling_defaults(...)
+}
+
+bcodeBookItemTxtHeader <- function(x, ...)  {
+  txt <- list()
+  txt$name <- crunch::name(x)
+  txt$alias <- crunch::alias(x)
+  heading_align <- "lXXr"
+  heading_align <- c("l", "X", "X", "r")
+
+  heading <- c(paste0("[", txt$alias, "]", collapse = ""), "", "", txt$name)
+  k = matrix(heading, ncol = 4)
+
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = heading_align) %>%
+    kable_styling_defaults(...)
+}
+
+
+# Item Header ----
+
+bcodeBookItemHeader <- function(x, ...) {
+  header_k <- bcodeBookItemTxtHeader(x, ...)
+  description_k <- bcodeBookItemTxtDescription(x, ...)
+
+  has_notes <- crunch::notes(x) != ""
+
+  if (has_notes) {
+    notes_k <- bcodeBookItemTxtNotes(x, ...)
+  } else {
+    notes_k = NULL
+  }
+
+
+  cat(
+    header_k,
+    description_k,
+    notes_k
+  )
+}
+
+# Item Body ----
+
+#' @export
+bcodeBookItemBody <- function(x, ...) {
+  UseMethod("bcodeBookItemBody")
+}
+
+bcodeBookItemBody.default <- function(x, ...) {
+  wrong_class_error(x, c("CategoricalVariable", "CategoricalArrayVariable", "MultipleResponseVariable", "TextVariable", "NumericVariable", "DatetimeVariable"), "codebookItem")
+}
+bcodeBookItemBody.CategoricalVariable <- function(x, ...) {
+  k = codeBookSummary(x)
+  alignment = c("l","l","c","X","r","r")
+  kableExtra::kable(
+    k, "latex", booktabs = TRUE,
+    align = alignment
+  ) %>%
+    kable_styling_defaults(...)
+}
+bcodeBookItemBody.CategoricalArrayVariable <- function(x, ...) {
+  k = codeBookSummary(x)
+  alignment <- c(rep("l",2),"X",rep("c", ncol(k) - 2))
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = alignment) %>%
+    kable_styling_defaults(...)
+}
+bcodeBookItemBody.MultipleResponseVariable <- function(x, ...) {
+  k = codeBookSummary(x)
+  alignment <- c(rep("l",2),"X",rep("c", ncol(k) - 2))
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = alignment) %>%
+    kable_styling_defaults(...)
+}
+bcodeBookItemBody.DatetimeVariable <- function(x, ...) {
+  k = codeBookSummary(x)
+}
+bcodeBookItemBody.NumericVariable <- function(x, ...) {
+  k = codeBookSummary(x)
+  kableExtra::kable(k, "latex", booktabs = TRUE, align = heading_align) %>%
+    kable_styling_defaults(...)
+}
+
+#' Create a codebook
+#'
+#' @param ds A crunch dataset
+#' @param ... Additional arguments. Unused.
+#' @export
+bwriteCodeBook <- function(x, ...) {
+
+}
+
+# utils ----
+
+#' Defaults for kableExtra
+#'
+#' Default styling for kable extra
+#'
+#' @param x A kable object
+#' @param ... Additional arguments passed to \link[kableExtra]{kable_styling}
+kable_styling_defaults <- function(x, ...) {
+  kableExtra::kable_styling(x, full_width = TRUE, ...)
+}
+
+#' Strip rules
+#'
+#' Strip horizontal lines (also called rules) from
+#' codebooks generated for latex
+#'
+#' @param x A character string
+#' @export
+kable_strip_rules <- function(x) {
+  x <- gsub("\\toprule", "", x)
+  x <- gsub("\\bottomrule", "", x)
+  x
+}
+
+
+bcodeBookTemplate <- function(x) {
+
+  txt = '```{r}
+  bcodeBookItemTxtHeader(%s)
+  bcodeBookItemTxTDecsription(%s)
+  bcodeBookItemTxtNotes(%s)
+  bcodeBookItemBody(%s)
+  ```'
+
+  sprintf(trimws(txt), rep(x, 4))
+}