Merge pull request #18 from jamesdunham/no-rcpp

remove Rcpp dependency by rewriting dichotomize() in R

Author: jamesdunham

DESCRIPTION

@@ -27,16 +27,13 @@ Imports:
     lubridate,
     methods,
     R6,
-    Rcpp (>= 0.12.10),
     survey
 Suggests:
     knitr,
     rmarkdown,
     testthat
-LinkingTo: Rcpp (>= 0.12.10)
 NeedsCompilation: yes
 Collate: 
-    'RcppExports.R'
     'aggregate_item_responses.r'
     'assertions.r'
     'class-control.r'

NAMESPACE

@@ -21,7 +21,6 @@ exportMethods(show)
 exportMethods(summarize)
 exportMethods(summary)
 import(R6)
-import(Rcpp)
 import(data.table)
 import(dgodata)
 import(ggplot2)
@@ -43,4 +42,3 @@ importFrom(stats,weights)
 importFrom(utils,capture.output)
 importFrom(utils,packageVersion)
 importFrom(utils,type.convert)
-useDynLib(dgo)

R/RcppExports.R

@@ -18,7 +18,7 @@ dichotomize <- function(item_data, ctrl) {
 
   for (k in ctrl@item_names) {
     stopifnot(is.numeric(item_data[[k]]))
-    gt_cols <- dichotomize_cpp(item_data[[k]])
+    gt_cols <- dichotomize_r(item_data[[k]])
     cn <- paste0(k, sub("^X", "", names(gt_cols)))
     item_data[, c(cn) := gt_cols]
     data.table::setattr(item_data, "gt_items", c(attr(item_data, "gt_items"),
@@ -27,6 +27,16 @@ dichotomize <- function(item_data, ctrl) {
   invisible(item_data)
 }
 
+dichotomize_r <- function(vec) {
+  vec <- as.numeric(vec)
+  uniques <- sort(unique(na.omit(vec)))
+  ret <- data.table::data.table("X_gt1" = rep(NA, length(vec)))
+  for (i in seq.int(0, max(0, length(uniques) - 2))) {
+    ret[, paste0("X_gt", i + 1) := as.integer(vec > uniques[i + 1])]
+  }
+  ret[]
+}
+
 coerce_item_types <- function(item_data, ctrl) {
   # Coerce item response variables to numeric
   # 

R/dichotomize_item_responses.r

@@ -7,7 +7,6 @@
 #'
 #' @docType package
 #' @name dgo
-#' @import Rcpp
 #' @import data.table
 #' @import dgodata
 #' @import ggplot2
@@ -16,5 +15,4 @@
 #' @importFrom stats as.formula formula model.frame model.matrix na.fail na.omit
 #'   quantile sd setNames weighted.mean weights
 #' @importFrom utils capture.output type.convert packageVersion
-#' @useDynLib dgo
 NULL

R/package.R

@@ -1,26 +1,26 @@
 context("dichotomizing item responses")
 
 test_that("dichotomizing item responses works", {
-  expect_equal(dichotomize_cpp(0:1), data.frame(X_gt1 = 0:1))
-  expect_equal(dichotomize_cpp(NA), data.frame(X_gt1 = as.numeric(NA)))
-  expect_equal(dichotomize_cpp(c(1:2, NA)), data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(c(0:1, NA)), data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(c(0, 2, NA)), data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(1:3), data.frame(X_gt1 = c(0, 1, 1),
+  expect_equal(dichotomize_r(0:1), data.table::data.table(X_gt1 = 0:1))
+  expect_equal(dichotomize_r(NA), data.table::data.table(X_gt1 = as.numeric(NA)))
+  expect_equal(dichotomize_r(c(1:2, NA)), data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(c(0:1, NA)), data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(c(0, 2, NA)), data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(1:3), data.table::data.table(X_gt1 = c(0, 1, 1),
                                            X_gt2 = c(0, 0, 1)))
-  expect_equal(dichotomize_cpp(as.factor(0:1)), data.frame(X_gt1 = 0:1))
-  expect_equal(dichotomize_cpp(as.factor(NA)), data.frame(X_gt1 = as.numeric(NA)))
-  expect_equal(dichotomize_cpp(as.factor(c(1:2, NA))), data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(as.factor(c(0:1, NA))),
-               data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(as.factor(c(0, 2, NA))),
-               data.frame(X_gt1 = c(0, 1, NA)))
-  expect_equal(dichotomize_cpp(as.factor(1:3)), data.frame(X_gt1 = c(0, 1, 1),
+  expect_equal(dichotomize_r(as.factor(0:1)), data.table::data.table(X_gt1 = 0:1))
+  expect_equal(dichotomize_r(as.factor(NA)), data.table::data.table(X_gt1 = as.numeric(NA)))
+  expect_equal(dichotomize_r(as.factor(c(1:2, NA))), data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(as.factor(c(0:1, NA))),
+               data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(as.factor(c(0, 2, NA))),
+               data.table::data.table(X_gt1 = c(0, 1, NA)))
+  expect_equal(dichotomize_r(as.factor(1:3)), data.table::data.table(X_gt1 = c(0, 1, 1),
                                            X_gt2 = c(0, 0, 1)))
 
-  expect_equal(dichotomize_cpp(as.ordered(c("a", "b"))), data.frame(X_gt1 = 0:1))
-  expect_equal(dichotomize_cpp(ordered(c("a", "b"),levels = c("b", "a"))),
-               data.frame(X_gt1 = c(1, 0)))
+  expect_equal(dichotomize_r(as.ordered(c("a", "b"))), data.table::data.table(X_gt1 = 0:1))
+  expect_equal(dichotomize_r(ordered(c("a", "b"),levels = c("b", "a"))),
+               data.table::data.table(X_gt1 = c(1, 0)))
 
-  expect_error(dichotomize_cpp("a"), "not compatible", ignore.case = TRUE)
+  expect_warning(dichotomize_r("a"), "NAs introduced by coercion", ignore.case = TRUE)
 })