Merge pull request #259 from Crunch-io/siunitx

Siunitx

.github/.gitignore

@@ -0,0 +1 @@
+*.html

.github/workflows/check-standard.yaml

@@ -0,0 +1,92 @@
+# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag.
+# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions
+on:
+  push:
+    branches:
+      - main
+      - master
+  pull_request:
+    branches:
+      - main
+      - master
+
+name: R-CMD-check
+
+jobs:
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
+
+    env:
+      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
+      RSPM: ${{ matrix.config.rspm }}
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v2
+
+      - uses: r-lib/actions/setup-r@v1
+        with:
+          r-version: ${{ matrix.config.r }}
+
+      - uses: r-lib/actions/setup-pandoc@v1
+
+      - name: Query dependencies
+        run: |
+          install.packages('remotes')
+          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
+          writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
+        shell: Rscript {0}
+
+      - name: Restore R package cache
+        if: runner.os != 'Windows'
+        uses: actions/cache@v2
+        with:
+          path: ${{ env.R_LIBS_USER }}
+          key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
+          restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
+
+      - name: Install system dependencies
+        if: runner.os == 'Linux'
+        run: |
+          while read -r cmd
+          do
+            eval sudo $cmd
+          done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))')
+
+      - name: Install dependencies
+        run: |
+          remotes::install_deps(dependencies = TRUE)
+          remotes::install_cran("rcmdcheck")
+        shell: Rscript {0}
+
+      - name: Install tinytex
+        run: |
+          tinytex::install_tinytex()
+        shell: Rscript {0}
+
+      - name: Check
+        env:
+          _R_CHECK_CRAN_INCOMING_REMOTE_: false
+        run: |
+          options(crayon.enabled = TRUE)
+          rcmdcheck::rcmdcheck(args = c("--no-manual", "--no-build-vignettes", "--no-tests"), build_args = c("--no-build-vignettes", "--ignore-vignettes", "--no-manual"), error_on = "error", check_dir = "check")
+        shell: Rscript {0}
+
+      - name: Coverage
+        run: |
+          Rscript -e 'covr::codecov(token = "${{ secrets.CODECOV_TOKEN }}")'
+
+      - name: Upload check results
+        if: failure()
+        uses: actions/upload-artifact@main
+        with:
+          name: results
+          path: check

DESCRIPTION

@@ -6,7 +6,7 @@ Description: In order to generate custom survey reports, this package provides
     'banners' (cross-tabulations) and codebooks of datasets in the Crunch
     (<https://crunch.io/>) web service. Reports can be written in 'PDF' format
     using 'LaTeX' or in Microsoft Excel '.xlsx' files.
-Version: 1.4.1
+Version: 1.4.2
 Authors@R: c(
     person("Persephone", "Tsebelis", role="aut"),
     person("Kamil", "Sedrowicz", role="aut"),
@@ -20,15 +20,18 @@ Depends:
     crunch,
 Imports:
     digest,
+    dplyr,
     httr,
     jsonlite,
     kableExtra (>= 1.1.0.9000),
     magrittr,
     methods,
     openxlsx,
     rlang,
+    stringi,
     tinytex
 Suggests:
+    arrow,
     covr,
     knitr,
     mockery, 

NAMESPACE

@@ -106,7 +106,10 @@ importFrom(stats,median)
 importFrom(stats,pnorm)
 importFrom(stats,quantile)
 importFrom(stats,weighted.mean)
+importFrom(utils,capture.output)
+importFrom(utils,head)
 importFrom(utils,installed.packages)
 importFrom(utils,modifyList)
 importFrom(utils,stack)
+importFrom(utils,tail)
 importFrom(utils,type.convert)

NEWS.md

@@ -1,6 +1,7 @@
 ## crunchtabs 1.4.2
 
 - INNOV-326 writeCodeBookLatex should not open by default. Add function argument open = FALSE. This avoids a situation in non-interactive sessions where the process would otherwise be stuck as it attempts to open a GTK program from a bash session. 
+- Small change in how appendices are automatically identified. Previous iterations prepared long tables with the longtabu package. However, this tex package overwrote numeric presentation options from siunitx. This has been changed to longtable, which respects siunitx. Now appendix long tables are identified by the length of lines in their tex (20 or more).
 
 ## crunchtabs 1.4.1
 

R/codeBookGeneric.R

@@ -34,6 +34,7 @@
 #' @param logging Leave logs in the working directory, defaults to FALSE
 #' @param filename A string. The desired basename of the resulting file with no extension
 #' (i.e, "mycodebook")
+#' @param open Should the resulting PDF be opened? Defaults to FALSE
 #' @param ... Additional arguments passed to \link[kableExtra]{kable_styling} Unused.
 #' @md
 #'
@@ -42,7 +43,7 @@ writeCodeBookLatexGeneric <- function(
   table_of_contents = FALSE, sample_desc = NULL, field_period = NULL,
   preamble = NULL, suppress_zero_counts = FALSE, appendix = TRUE,
   logo = NULL, position = NULL, path = NULL, filename = NULL,
-  logging = FALSE, ...) {
+  logging = FALSE, open = FALSE, ...) {
 
   options("crunchtabs.codebook.suppress.zeros" = suppress_zero_counts)
 
@@ -118,7 +119,7 @@ writeCodeBookLatexGeneric <- function(
     body <- codeBookItemBody(x, meta = meta[meta$alias == nm,], ...) # A kable
 
     if (appendix & !is.list(body)) {
-      if (grepl("longtabu", body)) {
+      if (length(capture.output(body)) > 20) {
         appendices[[nm]] <- list()
 
         description <- codeBookItemTxtDescriptionGeneral(x, nm, meta)
@@ -266,6 +267,7 @@ writeCodeBookLatexGeneric <- function(
 #' @param x An R vector
 #' @param nm The alias of the current codeBookItem
 #' @param meta A specifically formatted data.frame with meta data.
+#' @param ... Further arguments, not used.
 #'
 #' @export
 codeBookItemTxtHeaderGeneral <- function(x, nm, meta, ...) {
@@ -372,3 +374,28 @@ codeBookItemTxtDescriptionGeneral <- function(x, nm, meta, ...) {
 
   tex
 }
+
+#' Get class name from arrow variable
+#'
+#' Arrow does not provide a method for class on it's variables. This function prints out
+#' the schema and captures the appropriate output.
+#'
+#' @param ds An arrow dataset
+#' @param variable A string identifying the variable
+get_class <- function(ds, variable) {
+  # nocov start
+  r <- utils::capture.output(ds$schema[[variable]])
+  r <- r[2]
+  r <- gsub(variable, "", r)
+  r <- gsub(": ", "", r)
+
+  if (r %in% c("string"))
+    return("character")
+  if (r %in% c("int32"))
+    return("integer")
+  if (r %in% c("float", "double"))
+    return("numeric")
+  if (grepl("dictionary", r))
+    return("factor")
+  # nocov end
+}

R/codeBookItemBody.R

@@ -3,6 +3,7 @@
 #' Create codebook item body.
 #'
 #' @param x A crunch dataset object
+#' @param meta A data.frame containing meta data. Must be provided for non-crunch datasets.
 #' @param ... Further arguments, not used.
 #' @export
 codeBookItemBody <- function(x, meta = NULL, ...) {
@@ -76,14 +77,25 @@ codeBookItemBody.CategoricalVariable <- function(x, meta = NULL, ...) { # nolint
     midrule_strip <- function(x) gsub("\\midrule", "", x, fixed = TRUE)
 
     alignment <- c("d", "l", "d", "c", "d", "l", "d")
-    names(k) <- curlyWrap(names(k))
+    # names(k) <- curlyWrap(names(k)) # al
+    # kableExtra::kable(
+    #   k, "latex",
+    #   booktabs = TRUE, align = scolumnAlign(k, alignment),
+    #   longtable = TRUE, linesep = "", escape = FALSE
+    # ) %>%
+    #   kable_styling_defaults(full_width = TRUE, ...) %>%
+    #   kableExtra::column_spec(c(2, 6), width = "1.75in", latex_column_spec = NULL) %>%
+    #   kableExtra::row_spec(
+    #     0,
+    #     extra_latex_after = "\\cmidrule(l){1-3}\\cmidrule(l){5-7}" # nolint
+    #   ) %>%
+    #   midrule_strip()
+
     kableExtra::kable(
       k, "latex",
-      booktabs = TRUE, align = scolumnAlign(k, alignment),
-      longtable = TRUE, linesep = "", escape = FALSE
+      booktabs = TRUE, longtable = TRUE, align = scolumnAlign(k, alignment),
+      linesep = "", escape = FALSE
     ) %>%
-      kable_styling_defaults(full_width = TRUE, ...) %>%
-      kableExtra::column_spec(c(2, 6), width = "1.75in", latex_column_spec = NULL) %>%
       kableExtra::row_spec(
         0,
         extra_latex_after = "\\cmidrule(l){1-3}\\cmidrule(l){5-7}" # nolint
@@ -92,7 +104,8 @@ codeBookItemBody.CategoricalVariable <- function(x, meta = NULL, ...) { # nolint
   } else {
     alignment <- c("d", "l", "d")
     names(k) <- curlyWrap(names(k))
-    kab <- kableExtra::kable(
+
+  kab <- kableExtra::kable(
       k, "latex",
       booktabs = TRUE, longtable = TRUE, align = scolumnAlign(k, alignment),
       linesep = "", escape = FALSE

R/codeBookLatex.R

@@ -210,7 +210,7 @@ scolumnAlign <- function(k, alignment) {
       if (maxnchar > 6) {
         alignment[i] <- sprintf("S[table-format=%s]", maxnchar)
       } else {
-        alignment[i] <- c("J", "K", "d", "M", "N", "O")[maxnchar]
+        alignment[i] <- c("J", "K", "d", "M", "N", "O", "L", "M", "N")[maxnchar]
       }
     }
   }

R/crunchtabs-package.R

@@ -1,6 +1,7 @@
 #' @importFrom kableExtra column_spec kable_styling
 #' @importFrom magrittr `%>%`
 #' @importFrom rlang .data
+#' @importFrom utils capture.output head tail
 #' @keywords internal
 "_PACKAGE"
 

R/relabel.R

@@ -7,10 +7,10 @@
 #' There are two important warnings to consider:
 #'
 #' * Relabeling should always occur before applying any kind of sorting using the
-#' \link{\code{sortAlias}} function to avoid situations where labels could be applied
+#' \link{sortAliases} function to avoid situations where labels could be applied
 #' inappropriately.
 #' * If your results object is a tracking report or recontact it is strongly recommended that you
-#' set your wave labels in the \link{\code{recontact_toplines}} or \link{\code{trackingReport}}.
+#' set your wave labels in the \link{recontact_toplines} or \link{trackingReport}.
 #' However, if you must set it here options would be the categories and items would be the wave
 #' names. We cannot account for aliases with only partial data (n-1 waves), you must set the
 #' wave names in order.
@@ -36,9 +36,9 @@
 #' }
 #'
 #' @md
-#' @param ct An object from \link{\code{crosstabs}}, \link{\code{recontact_report}},
-#' or \link{\code{trackingReport}}
-#' @param ... One or more relabel objects. See \link{\code{relabelApply}}
+#' @param ct An object from \link{crosstabs}, \link{recontact_toplines},
+#' or \link{trackingReport}
+#' @param ... One or more relabel objects. See \link{relabelSet}
 #' @export
 relabel <- function(ct, ...) {
   message("Relabeling should always occur before sorting")
@@ -68,7 +68,7 @@ relabelApply <- function(results, labs) {
 #' Given a results object, adjust the question description. This will display as the question
 #' text in crunchtabs.
 #' @param obj A results object for a specific alias
-#' @param labs A list of labels, typically passed to \link{\code{relabel}}
+#' @param labs A list of labels, typically passed to \link{relabel}
 relabelDescription <- function(obj, labs) {
   if(length(labs$description) > 0) {
     obj$description <- labs$description
@@ -81,7 +81,7 @@ relabelDescription <- function(obj, labs) {
 #' Given a results object, adjust the note. This will display as the text below
 #' the question text in crunchtabs.
 #' @param obj A results object for a specific alias
-#' @param labs A list of labels, typically passed to \link{\code{relabel}}
+#' @param labs A list of labels, typically passed to \link{relabel}
 relabelNotes <- function(obj, labs) {
   if(length(labs$notes) > 0) {
     obj$notes <- labs$notes
@@ -93,7 +93,7 @@ relabelNotes <- function(obj, labs) {
 #' Set relabels
 #'
 #' An S3 method for applying updated text values to a result object in crunchtabs
-#' @param obj An inner object under the results list of a \link{\code{crosstabs}} object.
+#' @param obj An inner object under the results list of a \link{crosstabs} object.
 #' @param labs A list including at least one of the following: description, notes, items, or options
 relabelSet <- function(obj, labs) {
   UseMethod("relabelSet", obj)
@@ -104,7 +104,7 @@ relabelSet <- function(obj, labs) {
 #'
 #' Relabel a ToplineVar result object.
 #' @param obj A results object for a specific alias
-#' @param labs A list of labels, typically passed to \link{\code{relabel}}
+#' @param labs A list of labels, typically passed to \link{relabel}
 relabelSet.ToplineVar <- function(obj, labs) {
   current_options <- dimnames(obj$crosstabs$Results$`___total___`$base)[[1]]
   if(length(labs$options) > 0) {
@@ -128,7 +128,7 @@ relabelSet.ToplineVar <- function(obj, labs) {
 #'
 #' Relabel a ToplineCategoricalArray result object.
 #' @param obj A results object for a specific alias
-#' @param labs A list of labels, typically passed to \link{\code{relabel}}
+#' @param labs A list of labels, typically passed to \link{relabel}
 relabelSet.ToplineCategoricalArray <- function(obj, labs) { # nolint
 
   if(length(labs$options) > 0) {
@@ -180,7 +180,6 @@ setResultObj <- function(results, alias, obj) {
 #'
 #' @param results A list of results
 #' @param alias A character identifying the alias
-#' @param obj A result object
 getResultObj <- function(results, alias) {
   stopifnot(alias %in% names(results))
   results[[alias]]