work on test suite

Author: leeper

R/branch.R

@@ -45,24 +45,44 @@
 #' @seealso \code{\link{mergeNA}}
 #' @importFrom stats model.matrix
 #' @export 
-branch <- function(x, f, .fill = 0){
+branch <- function(x, f = x, .fill = 0){
+    if (length(.fill) > 1L) {
+        stop("'.fill' must be a length-1 vector")
+    }
+    if (is.numeric(x) && (!is.numeric(.fill) & !is.na(.fill))) {
+        warning("'.fill' must be a length-1 numeric vector; coercion attempted")
+        .fill <- as.numeric(.fill)
+    }
     if (is.list(f)) {
         f <- interaction(f)
-    } else if (!is.factor(f)) {
+    }
+    if (!is.factor(f)) {
         f <- as.factor(f)
     }
-    out <- x * model.matrix(~ 0 + f)
+    if (!is.numeric(x)) {
+        x1 <- as.factor(x)
+        x <- as.integer(x1)
+        out <- x * model.matrix(~ 0 + f)
+        out[] <- c(.fill,levels(x1))[out+1L]
+    } else {
+        out <- x * model.matrix(~ 0 + f)
+    }
     attr(out,'assign') <- NULL
     attr(out,'contrasts') <- NULL
-    if (!is.na(.fill) && .fill == 0) {
-        return(out)
-    } else if(is.na(.fill)) {
-        out[out == 0] <- NA
-        return(out)
-    } else {
-        out[out == 0] <- .fill
-        return(out)
+    if (is.na(.fill)) {
+        if (is.character(out)) {
+            out[out == "0"] <- NA_character_
+        } else {
+            out[out == 0] <- NA_real_
+        }
+    } else if (.fill == 0) {
+        if (is.character(out)) {
+            out[out == "0"] <- .fill
+        } else {
+            out[out == 0] <- .fill
+        }
     }
+    return(out)
 }
 
 #' @rdname branch
@@ -71,6 +91,9 @@ branch <- function(x, f, .fill = 0){
 #' @param \dots Two or more vectors of equal length, which are to be combined into one new vector. If any two vectors have values at the same index that are not specified in \code{.ignore}, the function will report an error. It is also possible to pass one or more data frames and/or matrices (which will be coerced to a list of column vectors).
 #' @export
 unbranch <- function(..., .ignore = 0, .fill = 0, .factors = c("character", "numeric")){
+    if (length(.fill) > 1L) {
+        stop("'.fill' must be a length-1 vector")
+    }
     vars <- list(...)
     ismat <- sapply(vars, is.matrix)
     for (i in which(ismat)) {
@@ -96,7 +119,7 @@ unbranch <- function(..., .ignore = 0, .fill = 0, .factors = c("character", "num
             vars[classes] <- lapply(vars[classes], as.numeric)
         }
     }
-    lengths <- sapply(vars, length)
+    lengths <- lengths(vars)
     if (any(lengths > lengths[1] | lengths < lengths[1])) {
         stop("Vectors specified have different lengths")
     }

R/mcode.R

@@ -56,7 +56,7 @@
 #' @seealso \code{\link{mergeNA}}
 #' @importFrom stats median
 #' @export 
-mcode <- function(..., recodes, .fill = NA, .result = c("numeric", "character", "factor"), .factors = c("character", "numeric")){
+mcode <- function(..., recodes, .fill = NA, .result, .factors = c("character", "numeric")){
 
     # process variables
     vars <- list(...)
@@ -70,6 +70,7 @@ mcode <- function(..., recodes, .fill = NA, .result = c("numeric", "character",
             vars[classes] <- lapply(vars[classes], as.numeric)
         }
     }
+    
     ## check variable lengths
     lengths <- sapply(vars, FUN = length)
     if (any(lengths > lengths[1L] | lengths < lengths[1L])) {
@@ -83,7 +84,18 @@ mcode <- function(..., recodes, .fill = NA, .result = c("numeric", "character",
     parsed <- parse_recodes(recodes = recodes, vars = vars)
 
     # create new variable to return
-    .result <- match.arg(.result)
+    classes <- sapply(vars, FUN = class)
+    if (missing(.result)) {
+        if (all(classes == "integer")) {
+            .result <- "integer"
+        } else if (all(classes == "numeric")) {
+            .result <- "numeric"
+        } else if (all(classes == "logical")) {
+            .result <- "logical"
+        } else {
+            .result <- "character"
+        }
+    }
     newvar <- vector(mode = .result, length = nrow(oldvar))
 
     # function to check values
@@ -148,14 +160,29 @@ parse_recodes.list <- function(recodes, vars, ...) {
 }
 
 parse_recodes.character <- function(recodes, vars, ...) {
-    
     # car::recode()-style argument
 
-    splitrecodes <- strsplit(gsub("\n|\t", "", recodes), split = ";")[[1]]
-    x <- t(sapply(splitrecodes, function(x) strsplit(x, split = "=")[[1]]))
-    outval <- unname(x[,2])
-    inval1 <- gsub("[c()]", "", unname(x[,1])) # ignore bracketing
-    inval <- unname(sapply(inval1, strsplit, split = ","))
+    splitrecodes <- strsplit(gsub("\n|\t", "", recodes), split = "[[:space:]]*;[[:space:]]*")[[1]]
+    
+    cleanup_recodes <- function(x) {
+        if (any(grepl("^c*(\\()", x))) {
+            x <- gsub("\\)*$", "", gsub("^c*\\(*", "", x))
+        }
+        if (any(grepl("^['\\\"]", x))) {
+            x <- gsub("^['\\\"]", "", x)
+        }
+        if (any(grepl("['\\\"]$", x))) {
+            x <- gsub("['\\\"]$", "", x)
+        }
+        x
+    }
+    
+    x <- t(sapply(splitrecodes, function(x) strsplit(x, split = "[[:space:]]*=[[:space:]]*")[[1]]))
+    # generate `inval`, ignoring bracketing
+    inval <- cleanup_recodes(unname(x[,1]))
+    inval <- unname(sapply(inval, strsplit, split = ","))
+    # generate `outval`
+    outval <- cleanup_recodes(unname(x[,2]))
 
     # check recode lengths
     rlengths <- sapply(inval, length)
@@ -173,45 +200,25 @@ parse_recodes.character <- function(recodes, vars, ...) {
     }
 
     return(list(inval = inval, outval = outval))
-    
-    
+}
+
+parse_specials <- function(x, specials) {
+
     # parse special symbols
-    parse_specials <- function(specials, var) {
-        ## * - wildcard
-        specials[specials == "*"] <- "*"
-        ## NA - NA value
-        specials[specials == "NA"] <- NA
-        ## min - minimum of that variable
-        specials[specials == "min"] <- min(var, na.rm = TRUE)
-        ## max - maximum of that variable
-        specials[specials == "max"] <- max(var, na.rm = TRUE)
-        ## mean - mean of that variable
-        specials[specials == "mean"] <- mean(var, na.rm = TRUE)
-        ## median - median of that variable
-        specials[specials == "median"] <- median(var, na.rm = TRUE)
-        ## : - range of values
-        
-        return(specials)
-    }
+
+    ## * - wildcard
+    specials[specials == "*"] <- "*"
+    ## NA - NA value
+    specials[specials == "NA"] <- NA
+    ## min - minimum of that variable
+    specials[specials == "min"] <- min(x, na.rm = TRUE)
+    ## max - maximum of that variable
+    specials[specials == "max"] <- max(x, na.rm = TRUE)
+    ## mean - mean of that variable
+    specials[specials == "mean"] <- mean(x, na.rm = TRUE)
+    ## median - median of that variable
+    specials[specials == "median"] <- median(x, na.rm = TRUE)
+    ## : - range of values
 
-    if (FALSE) {
-        invalmat <- matrix(character(), nrow = length(inval), ncol = rlengths[1])
-        for(i in 1:ncol(invalmat)) {
-            invalmat[,i] <- parse_specials(sapply(inval, `[`, i), vars[[i]])
-        }
-        
-        
-        sapply(seq_along(newvar), function(x) {
-            v <- sapply(vars, `[`, x)
-            
-            
-            #ranged <- grepl(":", , fixed = TRUE)
-            return(x)
-        })
-        
-        
-        apply(oldvar, 1, function(x) {
-            
-        })
-    }
+    return(specials)
 }

man/branch.Rd

@@ -1,36 +1,70 @@
-context("Test branch")
+context("Test branch()")
 
-test_that("Output as expected from branch", {
-    set.seed(1)
+test_that("Output as expected from numeric branch()", {
     a <- c(5L, 2L, 3L, 2L, 4L)
     b1 <- c(1L, 1L, 2L, 1L, 2L)
     b2 <- c(1L, 2L, 1L, 1L, 1L)
-    expect_equivalent(branch(a, b1), matrix(c(5, 2, 0, 2, 0, 0, 0, 3, 0, 4), nrow = 5))
-    expect_equivalent(branch(a, list(b1, b2)), matrix(c(5, 0, 0, 2, 0, 0, 0, 3, 0, 4, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0), nrow = 5))
+    expect_equivalent(branch(a), matrix(c(0,2,0,2,0, 0,0,3,0,0, 0,0,0,0,4, 5,0,0,0,0), nrow = 5))
+    expect_equivalent(branch(a, b1), matrix(c(5,2,0,2,0, 0,0,3,0,4), nrow = 5))
+    expect_equivalent(branch(a, list(b1, b2)), matrix(c(5,0,0,2,0, 0,0,3,0,4, 0,2,0,0,0, 0,0,0,0,0), nrow = 5))
 })
 
-context("Test unbranch")
+test_that("Output as expected from character branch()", {
+    a <- letters[1:5]
+    b1 <- c(1L, 1L, 2L, 1L, 2L)
+    b2 <- c(1L, 2L, 1L, 1L, 1L)
+    expect_equivalent(branch(a), matrix(c("a",0,0,0,0, 0,"b",0,0,0, 0,0,"c",0,0, 0,0,0,"d",0, 0,0,0,0,"e"), nrow = 5))
+    expect_equivalent(branch(a, b1), matrix(c("a","b",0,"d",0, 0,0,"c",0,"e"), nrow = 5))
+    expect_equivalent(branch(a, list(b1, b2)), matrix(c("a",0,0,"d",0, 0,0,"c",0,"e", 0,"b",0,0,0, 0,0,0,0,0), nrow = 5))
+})
+
+test_that("Errors as expected from branch()", {
+    expect_error(branch(1:5, .fill = c(1,2)))
+    expect_error(branch(1:5, .fill = "foo"))
+})
+
+context("Test unbranch()")
 
-test_that("Output as expected from unbranch", {
-    x <- c(NA,2,3,NA,NA,6,NA,NA,NA,10)
+test_that("Output as expected from unbranch()", {
+    x <- c(NA, 2, 3,NA,NA, 6,NA,NA,NA,10)
     y <- c(NA,NA,NA,14,NA,NA,17,18,19,NA)
     z <- c(NA,NA,NA,NA,25,NA,NA,NA,NA,NA)
-    expect_equal(unbranch(x,y, .ignore = NA, .fill = NA), c(NA, 2, 3, 14, NA, 6, 17, 18, 19, 10))
+    
+    expect_equal(unbranch(x), x)
     expect_equal(unbranch(x,y, .ignore = NA, .fill = NA), mergeNA(x,y))
-    expect_equal(unbranch(x,z, .ignore = NA, .fill = NA), c(NA, 2, 3, NA, 25, 6, NA, NA, NA, 10))
-    expect_equal(unbranch(x,z, .ignore = NA, .fill = NA), mergeNA(x,z))
+    expect_equal(unbranch(x,y, .ignore = NA, .fill = NA), c(NA, 2, 3, 14, NA, 6, 17, 18, 19, 10))
+    expect_equal(unbranch(x,y, .ignore = NA, .fill = 99), c(99, 2, 3, 14, 99, 6, 17, 18, 19, 10))
+    expect_equal(unbranch(cbind(x,y), .ignore = NA, .fill = NA), c(NA, 2, 3, 14, NA, 6, 17, 18, 19, 10))
+    expect_equal(unbranch(cbind.data.frame(x,y), .ignore = NA, .fill = NA), c(NA, 2, 3, 14, NA, 6, 17, 18, 19, 10))
+    
     expect_equal(unbranch(x,y,z, .ignore = NA, .fill = NA), c(NA, 2, 3, 14, 25, 6, 17, 18, 19, 10))
     expect_equal(unbranch(x,y,z, .ignore = NA, .fill = NA), mergeNA(x,y,z))
 })
 
-test_that("Non-mutually exclusive ignore values errors unbranch", {
+test_that("Errors as expected from branch()", {
+    expect_error(unbranch(1:5, .fill = c(99,100)))
+})
+
+test_that("Non-mutually exclusive ignore values errors unbranch()", {
     x <- c(NA,1,2,NA,NA,2,NA,NA,NA,1)
     w <- c(NA,3,3,NA,1,NA,NA,NA,NA,NA)
     expect_error(unbranch(x,w, .ignore = NA))
     expect_equal(unbranch(x,w, .ignore = c(3,NA)), c(0, 1, 2, 0, 1, 2, 0, 0, 0, 1))
 })
 
-test_that("Factors coerced correctly in unbranch", {
+test_that("Test branch(unbranch())", {
+    a <- c(5L, 2L, 3L, 2L, 4L)
+    expect_equivalent(unbranch(branch(a, .fill = NA), .ignore = NA, .fill = NA), a)
+    expect_equivalent(unbranch(branch(a, .fill = 0), .ignore = 0, .fill = 0), a)
+})
+
+test_that("Test unbranch(branch())", {
+    x <- c(NA, 2, 3,NA,NA, 6,NA,NA,NA,10)
+    y <- c(NA,NA,NA,14,NA,NA,17,18,19,NA)
+    #branch(unbranch(x,y, .ignore = NA), list(is.na(x), is.na(y)), .fill = NA)
+})
+
+test_that("Factors coerced correctly in unbranch()", {
     # need to write this
 })
 

man/mcode.Rd

@@ -1,6 +1,42 @@
 context("Test mcode")
 
-test_that("Output as expected from mcode", {
+test_that("Output as expected from univariate numeric mcode()", {
+    x <- c(1,3,5,4,2)
+    expect_equivalent(mcode(x, recodes = "5=1;4=2;3=3;2=4;1=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "(5)=1;(4)=2;(3)=3;(2)=4;(1)=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "c(5)=1;c(4)=2;c(3)=3;c(2)=4;c(1)=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "5=1;4=2;3=3;2=   4;1=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "5=1;4=2;3=3;   2=4;1=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "5=1;4=2;3=3;2   =4;1=5"), c(5,3,1,2,4))
+    expect_equivalent(mcode(x, recodes = "5=1;4=2;3=3;2 =  4;1=5"), c(5,3,1,2,4))
+})
+
+test_that("Output as expected from univariate character mcode()", {
+    x <- letters[1:5]
+    expect_equivalent(mcode(x, recodes = "a=d;b=e;c=a;d=x;e=y"), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = "'a'='d';'b'='e';'c'='a';'d'='x';'e'='y'"), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = '"a"="d";"b"="e";"c"="a";"d"="x";"e"="y"'), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = "c('a')='d';c('b')='e';c('c')='a';c('d')='x';c('e')='y'"), c("d","e","a","x","y"))
+    
+    expect_equivalent(mcode(x, recodes = '"a" ="d";"b"="e";"c"="a";"d"="x";"e"="y"'), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = '"a"= "d";"b"="e";"c"="a";"d"="x";"e"="y"'), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = '"a"="d" ;"b"="e";"c"="a";"d"="x";"e"="y"'), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = '"a"="d"; "b"="e";"c"="a";"d"="x";"e"="y"'), c("d","e","a","x","y"))
+    expect_equivalent(mcode(x, recodes = '"a"=" d";"b"="e";"c"="a";"d"="x";"e"="y"'), c(" d","e","a","x","y"))
+})
+
+test_that("Output as expected from multivariate numeric mcode()", {
+    x <- c(1,3,5,4,2)
+    y <- c(1,1,1,0,0)
+    R <- "(5,0)=1;(4,0)=2;(3,0)=3;(2,0)=4;(1,0)=5;(5,1)=95;(4,1)=96;(3,1)=97;(2,1)=98;(1,1)=99"
+    expect_equivalent(mcode(x, y, recodes = R), c(99,97,95,2,4))
+})
+
+test_that("Output as expected from multivariate character mcode()", {
+
+})
+
+test_that("Output as expected from mixed multivariate mcode()", {
 
 })
 

tests/testthat/tests-branch.R

@@ -1,6 +1,6 @@
 context("Test mergeNA")
 
-test_that("Output as expected from mergeNA", {
+test_that("Output as expected from mergeNA()", {
     x <- c(NA,2,3,NA,NA,6,NA,NA,NA,10)
     y <- c(NA,NA,NA,14,NA,NA,17,18,19,NA)
     z <- c(NA,NA,NA,NA,25,NA,NA,NA,NA,NA)
@@ -9,13 +9,13 @@ test_that("Output as expected from mergeNA", {
     expect_equal(mergeNA(x,y,z), c(NA, 2, 3, 14, 25, 6, 17, 18, 19, 10))
 })
 
-test_that("Non-mutually exclusive missingness errors mergeNA", {
+test_that("Non-mutually exclusive missingness errors mergeNA()", {
     x <- c(NA,2,3,NA,NA,6,NA,NA,NA,10)
     w <- c(NA,42,43,NA,25,NA,NA,NA,NA,NA)
     expect_error(mergeNA(x,w))
 })
 
-test_that("Factors coerced correctly in mergeNA", {
+test_that("Factors coerced correctly in mergeNA()", {
     expect_equal(mergeNA(c(1,NA,NA,NA), factor(c(NA,'a','b',NA))), c("1", "a", "b", NA))
     expect_equal(mergeNA(c(1,NA,NA,NA), factor(c(NA,'a','b',NA)), .factors = "character"), c("1", "a", "b", NA))
     expect_equal(mergeNA(c(1,NA,NA,NA), factor(c(NA,'a','b',NA)), .factors = "numeric"), c(1, 1, 2, NA))