httptest is going bye bye.

DESCRIPTION

@@ -17,7 +17,8 @@ BugReports: https://github.com/Crunch-io/crunchtabs/issues
 License: LGPL (>= 3)
 Depends:
     R (>= 3.5.0),
-    crunch
+    crunch,
+    mockery
 Imports:
     kableExtra (>= 1.1.0.9000),
     rlang,

NAMESPACE

@@ -46,6 +46,8 @@ export(kable_strip_rules)
 export(kable_strip_toprules)
 export(prepareExtraSummary)
 export(sortAliases)
+export(tabBookWeightSpec_crunchtabs)
+export(tabBook_crunchtabs)
 export(themeDefaultExcel)
 export(themeDefaultLatex)
 export(themeHuffPoCrosstabs)
@@ -84,6 +86,7 @@ importFrom(crunch,values)
 importFrom(crunch,weight)
 importFrom(crunch,weightVariables)
 importFrom(digest,digest)
+importFrom(jsonlite,fromJSON)
 importFrom(kableExtra,column_spec)
 importFrom(kableExtra,kable_styling)
 importFrom(magrittr,`%>%`)
@@ -96,4 +99,5 @@ importFrom(stats,quantile)
 importFrom(stats,weighted.mean)
 importFrom(utils,installed.packages)
 importFrom(utils,modifyList)
+importFrom(utils,stack)
 importFrom(utils,type.convert)

R/asToplineCategoricalArray.R

@@ -81,7 +81,7 @@ as.ToplineCategoricalArray <- function(questions, question_alias = NULL, labels
 #' Given two or more waves of a categorical array question, convert them into
 #' categoricals for presentation in a tracking report.
 #' 
-#' 
+#' @export
 catArrayToCategoricals <- function(questions, question_alias, labels) {
   obj <- questions[[1]]
   statements <- obj$subnames

R/codeBookSummary.R

@@ -99,7 +99,8 @@ codeBookSummary.CategoricalVariable <- function(x, multiple = FALSE, ...) {
 #' @export
 codeBookSummary.MultipleResponseVariable <- function(x, ...) {
   responses <- list()
-  subvars <- names(subvariables(x))
+  sv <- crunch::subvariables(x)
+  subvars <- names(sv)
   for (i in 1:length(names(x))) {
     responses[[i]] <- codeBookSummary(x[[i]], multiple = TRUE)
   }
@@ -138,6 +139,7 @@ codeBookSummary.CategoricalArrayVariable <- function(x, ...) codeBookSummary.Mul
 #' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a NumericVariable
 #' @export
 codeBookSummary.NumericVariable <- function(x, ...) {
+  x <- as.vector(x)
   mu <- round(mean(x, na.rm = T), 2)
   std <- round(sd(x, na.rm = TRUE))
   minima <- round(min(x, na.rm = T), 2)
@@ -167,7 +169,6 @@ codeBookSummary.NumericVariable <- function(x, ...) {
 #' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a TextVariable
 #' @export
 codeBookSummary.TextVariable <- function(x, ...) {
-
   filled_verbs <- as.vector(x)
   filled_verbs <- filled_verbs[!is.na(filled_verbs)]
   filled_verbs <- filled_verbs[!filled_verbs %in% c("", "__NA__")]
@@ -195,6 +196,7 @@ codeBookSummary.TextVariable <- function(x, ...) {
 #' @describeIn codeBookSummary Prepares a codeBookSummary data.frame for a DatetimeVaraible
 #' @export
 codeBookSummary.DatetimeVariable <- function(x, ...) {
+  x <- as.vector(x)
   minima <- min(x, na.rm = T)
   maxima <- max(x, na.rm = T)
   missings <- sum(is.na(as.vector(x)))

R/getters.R

@@ -98,3 +98,17 @@ getSubNames <- function(x) {
 getSubAliases <- function(x) {
     sapply(x@.Data[[1]]$dimensions[[1]]$references$subreferences, function(xi) xi$alias)
 }
+
+#' Extract counts from a tabbook
+#' @param x A results object or element
+getCounts <- function(x, alias) {
+
+}
+
+#' Extract proportions from a tabbook
+#' @param x A results object or element
+getProportions <- function(x, alias) {
+    UseMethod("getProportions", x)
+}
+
+

R/tabBooks.R

@@ -12,28 +12,28 @@
 #' @param include_original_weighted Logical, if you have specified complex weights
 #' should the original weighted variable be included or only the custom weighted version?
 tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, include_original_weighted = TRUE) {
-
+  
   banner_flatten <- unique(unlist(banner, recursive = FALSE))
   names(banner_flatten) <- sapply(banner_flatten, function(v) v$alias)
   banner_use <- banner
   if (topline) { banner_use$Results[[2]] <- NULL }
-
+  
   multitable <- getMultitable(banner_flatten, dataset)
-
+  
   if (is.null(weight) | is.null(weight(dataset))) {
     default_weight <- NULL
   } else {
     default_weight <- alias(weight(dataset))
   }
-
-
+  
+  
   if (is.list(weight)) {
     tab_frame <- crunch::tabBookWeightSpec(
       dataset, weight,
       append_default_wt = include_original_weighted
     )
     tab_frame <- tab_frame[tab_frame$alias %in% vars,]
-
+    
     book <- suppressWarnings(
       tabBook_crunchtabs(
         multitable,
@@ -42,11 +42,11 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
         output_format = "json"
       )
     )
-
+    
   } else {
-
+    
     tab_frame <- tab_frame_generate(default_weight, vars)
-
+    
     book <- suppressWarnings(
       tabBook_crunchtabs(
         multitable,
@@ -55,70 +55,70 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
         output_format = "json"
       )
     )
-
+    
   }
-
+  
   # Put tab_frame in vars order
   tab_frame <- tab_frame[
     rev(
       order(tab_frame$alias, factor(vars, levels = vars)
-            )
-      ),
+      )
+    ),
   ]
-
+  
   banner_var_names <- sapply(seq_along(book[[1]]), function(ix) {
     crunch::aliases(crunch::variables(book[[1]][[ix]]))[2] })
   banner_var_names[1] <- "___total___"
   # var_nums <- seq_len(nrow(tab_frame))
   var_nums <- setdiff(match(vars, crunch::aliases(book)), NA)
-
+  
   structure(unlist(lapply(seq_along(var_nums), function(tab_frame_pos) {
     vi <- var_nums[tab_frame_pos]
     crunch_cube <- book[[vi]][[1]]
-
+    
     ## Metadata
     cube_variable <- crunch::variables(crunch_cube)[1]
-
+    
     if (all(is.na(tab_frame$weight))) {
       default_weighted <- TRUE
     } else {
       default_weighted <- tab_frame$weight[tab_frame_pos] == default_weight
     }
-
+    
     if (default_weighted) {
       alias <- aliases(cube_variable)
     } else {
       alias <- paste0(aliases(cube_variable), "_", tab_frame$weight[tab_frame_pos])
     }
-
+    
     if (alias == "total") {
       alias <- tab_frame$alias[tab_frame_pos]
       var_type <- type(dataset[[alias]])
     } else {
       var_type <- type(dataset[[aliases(cube_variable)]])
     }
-
+    
     is_mr_type <- var_type == "multiple_response"
     is_cat_type <- var_type %in% c("categorical", "categorical_array")
     is_array_type <- var_type == "categorical_array"
     is_toplines_array <- is_array_type && topline
     is_crosstabs_array <- is_array_type && !topline
-
-
+    
+    
     valiases <- valiases_tabbook_extract(
       is_crosstabs_array, crunch_cube, cube_variable, question_name
     )
-
+    
     if (!default_weighted) valiases <- paste0(valiases, "_", tab_frame$weight[tab_frame_pos])
-
+    
     subnames <- if (is_array_type) getSubNames(crunch_cube)
     var_cats <- categories(cube_variable[[1]])
     inserts <- if (is_cat_type) {
       collateCats <- get("collateCats", envir = asNamespace("crunch"), inherits = FALSE)
       collateCats(crunch::transforms(cube_variable)[[1]]$insertions, var_cats)
     }
     show_mean_median <- is_cat_type && any(!is.na(values(na.omit(var_cats))))
-
+    
     metadata <- list(
       name = names(cube_variable),
       description = crunch::descriptions(cube_variable),
@@ -130,7 +130,7 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
       categories = var_cats,
       inserts_obj = inserts[sapply(inserts, function(x) is.null(x$missing) || !x$missing)]
     )
-
+    
     pbook <- lapply(seq_along(book[[vi]]), function(vix) {
       crunch::prop.table(crunch::noTransforms(book[[vi]][[vix]]), margin = c(2, if (is_array_type) 3))
     })
@@ -143,9 +143,9 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
     wbbook <- lapply(seq_along(book[[vi]]), function(vix) {
       crunch::margin.table(crunch::noTransforms(book[[vi]][[vix]]), margin = c(2, if (is_array_type) 3))
     })
-
+    
     names(pbook) <- names(bbook) <- names(cbook) <- names(wbbook) <- banner_var_names
-
+    
     for (bi in banner_var_names) {
       if (!identical(banner_flatten[[bi]]$categories_out, banner_flatten[[bi]]$categories)) {
         pbook[[bi]] <- bannerDataRecode(pbook[[bi]], banner_flatten[[bi]])
@@ -154,10 +154,10 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
         wbbook[[bi]] <- bannerDataRecode(wbbook[[bi]], banner_flatten[[bi]])
       }
     }
-
+    
     sapply(valiases, function(valias) {
       ri <- which(valiases %in% valias)
-
+      
       pdata <- row_data(pbook, ri, is_crosstabs_array, is_toplines_array, FALSE)
       cdata <- row_data(cbook, ri, is_crosstabs_array, is_toplines_array, FALSE)
       bdata <- row_data(bbook, ri, is_crosstabs_array, is_toplines_array, TRUE)
@@ -168,14 +168,14 @@ tabBooks <- function(dataset, vars, banner, weight = NULL, topline = FALSE, incl
       mddata <- lapply(cdata, function(mbook) {
         if (show_mean_median) { applyInsert(mbook, var_cats, calcTabMedianInsert) }
       })
-
+      
       if (!is_mr_type) {
         bdata <- lapply(bdata, function(xi) {
           matrix(xi, nrow = nrow(pdata[[2]]), ncol = length(xi), byrow = TRUE,
                  dimnames = list(rownames(pdata[[2]]), names(xi)))
         })
       }
-
+      
       structure(c(alias = valias,
                   metadata,
                   subnumber = ri,
@@ -228,14 +228,14 @@ tab_frame_generate <- function(default_weight = NULL, vars) {
 #' @param crunch_cube A sub-cube of a `crunch::tabBook`
 #' @param cube_variable A sub-cube of a `crunch::tabBook`
 valiases_tabbook_extract <- function(is_crosstabs_array, crunch_cube, cube_variable, question_name) {
-    if (is_crosstabs_array) {
-        valiases <- getSubAliases(crunch_cube)
-    } else {
-        valiases <- crunch::aliases(cube_variable)
-      if (valiases == "total") {
-        valiases <- question_name
-      }
+  if (is_crosstabs_array) {
+    valiases <- getSubAliases(crunch_cube)
+  } else {
+    valiases <- crunch::aliases(cube_variable)
+    if (valiases == "total") {
+      valiases <- question_name
     }
+  }
   valiases
 }
 
@@ -318,7 +318,7 @@ row_data <- function(data, row, is_crosstabs_array, is_toplines_array, is_base)
     names(dimnames(dt)) <- NULL
     return(dt)
   })
-
+  
   if (is_crosstabs_array) {
     data <- lapply(data, function(xi) {
       if (length(dim(xi)) == 3) {
@@ -363,15 +363,15 @@ compute_pvals <- function(counts, counts_unweighted) {
   n <- margin.table(counts)
   bases_adj <- counts_unweighted + 1
   n_adj <- margin.table(bases_adj)
-
+  
   nrows <- nrow(counts)
   ncols <- ncol(counts)
-
+  
   R <- margin.table(counts, 1) / n
   C_adj <- margin.table(bases_adj, 2) / n_adj
   Ctbl <- prop.table(counts, margin = 2)
   Ctbl_adj <- prop.table(bases_adj, margin = 2)
-
+  
   observed <- (Ctbl_adj * (1 - Ctbl_adj))
   expected <- observed %*% C_adj
   d.c <- (1 - 2 * C_adj) / C_adj

R/tabbook-additions.R

@@ -348,7 +348,7 @@ tabBookSingle_crunchtabs <- function(
     options = dots
   )
   ## Add this after so that if it is NULL, the "where" key isn't present
-  body$where <- crunch:::variablesFilter(dataset)
+  # body$where <- crunch:::variablesFilter(dataset)
 
   if (use_legacy_endpoint) {
     warning(
@@ -362,11 +362,11 @@ tabBookSingle_crunchtabs <- function(
   ## POST the query, which (after progress polling) returns a URL to download
   result <- crunch::crPOST(tabbook_url,
                    config = httr::add_headers(`Accept` = accept),
-                   body = jsonlite::toJSON(body)
+                   body = jsonlite::toJSON(body, null = "null")
   )
   if (is.null(file)) {
     ## Read in the tab book content and turn it into useful objects
-    out <- crunch::retry(crunch::crGET(result), wait = 0.5) #nocov
+    out <- crunch:::retry(crunch::crGET(result), wait = 0.5) #nocov
     return(crunch:::TabBookResult(out))
   } else {
     file <- crunch::crDownload(result, file)