Nothing
library("testthat")
library("bit")
context("merge")
# expect_identical <- function(x, y, ...){
# stopifnot(identical(x,y))
# }
# map NAs to position 1
NAtab <- function(x, nbins=max(1L, x, na.rm = TRUE)){
force(nbins)
x <- x + 1L
x[is.na(x)] <- 1L
tabulate(x, nbins+1L)
}
test_that("positive merging is OK with NAs", {
xs <- lapply(list(
rep(3:7, rep(1,5))
, rep(3:7, rep(2,5))
, rep(c(3,5,7), rep(1,3))
, rep(c(3,5,7), rep(2,3))
), as.integer)
ys <- lapply(list(
rep(1:9, rep(1,9))
, rep(1:9, rep(2,9))
, rep(2:8, rep(1,7))
, rep(2:8, rep(2,7))
, rep(3:7, rep(1,5))
, rep(3:7, rep(2,5))
, rep(c(3,5,7), rep(1,3))
, rep(c(3,5,7), rep(2,3))
, rep(4:6, rep(1,3))
, rep(4:6, rep(2,3))
, rep(5L, 1)
, rep(5L, 2)
, rep(5L, 3)
, rep(1L, 1)
, rep(1L, 1)
, rep(1L, 2)
, rep(1:2, rep(1,2))
, rep(1:2, rep(2,2))
, rep(1:3, rep(1,3))
, rep(1:3, rep(2,3))
, rep(1:4, rep(1,4))
, rep(1:4, rep(2,4))
, rep(1:5, rep(1,5))
, rep(1:5, rep(2,5))
, rep(5:9, rep(1,5))
, rep(5:9, rep(2,5))
, rep(6:9, rep(1,4))
, rep(6:9, rep(2,4))
, rep(7:9, rep(1,3))
, rep(7:9, rep(2,3))
, rep(8:9, rep(1,2))
, rep(8:9, rep(2,2))
, rep(9L, 1)
, rep(9L, 1)
, rep(9L, 2)
), as.integer)
for (xi in seq_along(xs))
for (yi in seq_along(ys)){
x <- sort.int(xs[[xi]], na.last=FALSE, method="quick")
y <- sort.int(ys[[yi]], na.last=FALSE, method="quick")
eval(substitute(expect_identical(
merge_union(x,y, method="all")
, sort.int(c(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_union(x,y, method="exact")
, rep(c(NA, 1:9), pmax(NAtab(x,9), NAtab(y,9)))
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_intersect(x,y, method="exact")
, rep(c(NA, 1:9), pmin(NAtab(x,9), NAtab(y,9)))
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_setdiff(x,y, method="exact")
, rep(c(NA, 1:9), pmax(0L, NAtab(x,9) - NAtab(y,9)))
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_symdiff(x,y, method="exact")
, rep(c(NA, 1:9), abs(NAtab(x,9) - NAtab(y,9)))
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_union(x,y)
, sort.int(union(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_intersect(x,y)
, sort.int(intersect(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_setdiff(x,y)
, sort.int(setdiff(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y)))
eval(substitute(expect_identical(
merge_symdiff(x,y)
, sort.int(union(setdiff(x,y),setdiff(y,x)), na.last=FALSE, method="quick")
), list(x=x, y=y)))
}
})
test_that("reversed merging is OK (without NAs)", {
set.seed(1)
for (i in 1:24){
x <- sort.int(sample(9, replace=TRUE), na.last=FALSE, method="quick")
y <- sort.int(sample(9, replace=TRUE), na.last=FALSE, method="quick")
for (revx in c(FALSE,TRUE)){
if (revx)
rx <- rev(-x)
else
rx <- x
for (revy in c(FALSE,TRUE)){
if (revy)
ry <- rev(-y)
else
ry <- y
eval(substitute(expect_identical(
merge_union(rx,ry,revx=revx, revy=revy, method="all")
, sort.int(c(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_union(rx,ry,revx=revx, revy=revy, method="exact")
, rep(c(NA, 1:9), pmax(NAtab(x,9), NAtab(y,9)))
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_intersect(rx,ry,revx=revx, revy=revy, method="exact")
, rep(c(NA, 1:9), pmin(NAtab(x,9), NAtab(y,9)))
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_setdiff(rx,ry,revx=revx, revy=revy, method="exact")
, rep(c(NA, 1:9), pmax(0L, NAtab(x,9) - NAtab(y,9)))
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_symdiff(rx,ry,revx=revx, revy=revy, method="exact")
, rep(c(NA, 1:9), abs(NAtab(x,9) - NAtab(y,9)))
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_union(rx,ry,revx=revx, revy=revy)
, sort.int(union(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_intersect(rx,ry,revx=revx, revy=revy)
, sort.int(intersect(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_setdiff(rx,ry,revx=revx, revy=revy)
, sort.int(setdiff(x,y), na.last=FALSE, method="quick")
), list(x=x, y=y, revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_symdiff(rx,ry,revx=revx, revy=revy)
, sort.int(union(setdiff(x,y),setdiff(y,x)), na.last=FALSE, method="quick")
), list(x=x, y=y, revx=revx, revy=revy)))
}
}
}
})
test_that("for-looped merging is OK (without NAs)", {
nx <- 9
x <- 1:nx
set.seed(1)
for (i in 1:12){
y <- sort.int(sample(nx, replace=TRUE), na.last=FALSE, method="quick")
for (revx in c(FALSE,TRUE)){
if (revx){
rx <- rev(-x)
rnx <- c(-nx, -1L)
}else{
rx <- x
rnx <- c(1L,nx)
}
for (revy in c(FALSE,TRUE)){
if (revy){
ry <- rev(-y)
}else{
ry <- y
}
eval(substitute(expect_identical(
merge_rangesect(rnx,ry,revx=revx, revy=revy)
, merge_intersect(rx,ry,revx=revx, revy=revy)
), list(rnx=rnx, rx=rx, ry=ry,revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_rangediff(rnx,ry,revx=revx, revy=revy)
, merge_setdiff(rx,ry,revx=revx, revy=revy)
), list(rnx=rnx, rx=rx, ry=ry,revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_rangein(rnx,ry,revx=revx, revy=revy)
, copy_vector(rx,revx=revx) %in% copy_vector(ry, revx=revy)
), list(rnx=rnx, rx=rx, ry=ry,revx=revx, revy=revy)))
eval(substitute(expect_identical(
merge_rangenotin(rnx,ry,revx=revx, revy=revy)
, ! ( copy_vector(rx,revx=revx) %in% copy_vector(ry, revx=revy) )
), list(rnx=rnx, rx=rx, ry=ry,revx=revx, revy=revy)))
}
}
}
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.