Refactor/final fixes

DESCRIPTION

@@ -63,7 +63,7 @@ Depends:
 Imports:
     RANN,
     stringr,
-    lme4,
+    lme4 (>= 2.1-0),
     dplyr,
     tibble,
     purrr,

R/corDS.R

@@ -30,17 +30,17 @@ corDS <- function(x=NULL, y=NULL){
   #############################################################
 
   x.val <- .loadServersideObject(x)
-  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame"))
 
   if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){
     y.val <- .loadServersideObject(y)
-    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
 
-  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer", "factor"))) {
     stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
   }
 

R/covDS.R

@@ -39,17 +39,17 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
   #############################################################
 
   x.val <- .loadServersideObject(x)
-  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame"))
 
   if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){
     y.val <- .loadServersideObject(y)
-    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
 
-  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer", "factor"))) {
     stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
   }
 

R/glmSLMADS.assign.R

@@ -27,10 +27,10 @@ glmSLMADS.assign <- function(formula, family, offsetName, weightsName, dataName)
 
   # Correctly name offset, weights and data objects in function call
   # (to allow glmPredict to work correctly later)
-  calltext <- paste0("mg<-glm(formula,family=",family,",offset=",
+  calltext <- paste0("glm(formula,family=",family,",offset=",
              offsetName,",weights=",weightsName,",data=", dataName,",x=TRUE)")
 
-  eval(parse(text=calltext))
+  mg <- eval(parse(text=calltext), envir = list(formula = formula), enclos = parent.frame())
 
   # update the call object to include the actual formula
   mg$call$formula <- formula

inst/DATASHIELD

@@ -1,6 +1,5 @@
 AggregateMethods:
     asFactorDS1,
-    asListDS,
     aucDS,
     boxPlotGGDS,
     checkNegValueDS,

tests/testthat/test-smk-corDS.R

@@ -764,6 +764,16 @@ test_that("corDS gives the same result for a matrix as for a data.frame", {
     expect_equal(res.matrix[names(res.matrix) != "class"], res.df[names(res.df) != "class"])
 })
 
+test_that("corDS accepts a factor x, correlating on its level codes", {
+    fvar <- factor(c("m", "f", "m", "f", "m", "f", "m", "f", "m", "f"))
+    yvar <- c(1.0, 5.0, 2.0, 6.0, 3.0, 7.0, 2.0, 8.0, 1.0, 9.0)
+
+    res <- corDS("fvar", "yvar")
+
+    expect_equal(res$class, "factor")
+    expect_equal(res$sums[1, 2], sum(as.integer(fvar)))
+})
+
 #
 # Done
 #

tests/testthat/test-smk-covDS.R

@@ -278,6 +278,16 @@ test_that("covDS gives the same result for a matrix as for a data.frame", {
     expect_equal(res.matrix[names(res.matrix) != "class"], res.df[names(res.df) != "class"])
 })
 
+test_that("covDS accepts a factor x, using its level codes", {
+    fvar <- factor(c("m", "f", "m", "f", "m", "f", "m", "f", "m", "f"))
+    yvar <- c(1.0, 5.0, 2.0, 6.0, 3.0, 7.0, 2.0, 8.0, 1.0, 9.0)
+
+    res <- covDS("fvar", "yvar", "pairwise.complete")
+
+    expect_equal(res$class, "factor")
+    expect_equal(res$sums[1, 2], sum(as.integer(fvar)))
+})
+
 #
 # Done
 #

tests/testthat/test-smk-glmerSLMADS.assign.R

@@ -29,10 +29,10 @@ test_that("simple glmerSLMADS.assign, binomial random intercept", {
 
     expect_true(methods::is(res, "glmerMod"))
     expect_equal(nobs(res), 50)
-    expect_equal(as.numeric(lme4::fixef(res)), c(-1.4299523, 0.2248647), tolerance = 1e-5)
+    expect_equal(as.numeric(lme4::fixef(res)), c(-1.4340652, 0.2255225), tolerance = 1e-5)
 
     vc <- as.data.frame(lme4::VarCorr(res))
-    expect_equal(vc$vcov, 2.7451347, tolerance = 1e-5)
+    expect_equal(vc$vcov, 2.7493590, tolerance = 1e-5)
 })
 
 test_that("glmerSLMADS.assign throws error when dataName does not exist", {

tests/testthat/test-smk-glmerSLMADS2.R

@@ -35,7 +35,7 @@ test_that("simple glmerSLMADS2, binomial random intercept", {
     expect_equal(res$Nmissing, 0)
     expect_equal(dim(res$coefficients), c(2, 4))
     expect_equal(res$coefficients[, "Estimate"],
-                 c(`(Intercept)` = -1.4299523, x = 0.2248647), tolerance = 1e-5)
+                 c(`(Intercept)` = -1.4340652, x = 0.2255225), tolerance = 1e-5)
     expect_equal(res$family, "binomial")
 })