tests/testthat/test-datastep.R
In dbosak01/libr: Libraries, Data Dictionaries, and a Data Step for R
context("Datastep Tests")
base_path <- "c:\\packages\\libr\\tests\\testthat\\data"
base_path <- "./data"
options("logr.output" = FALSE)
dev <- FALSE
test_that("ds1: datastep() function works as expected with mtcars.", {
d1 <- datastep(mtcars, {
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
})
d1
expect_equal("mpgcat" %in% names(d1), TRUE)
})
test_that("ds2: datastep() function works as expected with demo_studya.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, {
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal("sexc" %in% names(d1), TRUE)
})
test_that("ds3: datastep() keep parameter works as expected.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, keep = c("usubjid", "sexc", "race"), {
usubjid <- paste0(study, "-", inv, "-", patient)
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal(names(d1), c("usubjid", "sexc", "race"))
})
test_that("ds4: datastep() drop parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, drop = c("visit", "screendate", "sex"), {
usubjid <- paste0(study, "-", inv, "-", patient)
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal(names(d1), c("study", "inv", "patient", "race",
"dob", "treatment", "usubjid", "sexc"))
})
test_that("ds5: datastep() by parameter first and last works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, by = c("treatment"), {
f1 <- first.
l1 <- last.
})
d1
expect_equal(sum(d1$f1), 2)
expect_equal(sum(d1$l1), 2)
})
test_that("ds6: datastep() summary functions works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, {
pmean <- mean(data$patient)
if (patient > pmean)
pind <- TRUE
else
pind <- FALSE
rownum <- n.
})
d1
expect_equal(sum(d1$pind), 5)
})
test_that("ds7: datastep() calculate parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya,
calculate = {
pmean <- mean(patient)
},{
if (patient > pmean)
pind <- TRUE
else
pind <- FALSE
rownum <- n.
})
d1
expect_equal(sum(d1$pind), 5)
})
test_that("ds8: datastep() auto-group-by works as expected.", {
if (TRUE) {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- dat.demo_studya %>% group_by(treatment) %>%
datastep({
p1 <- first.
p2 <- last.
rownum <- n.
})
d1
expect_equal(sum(d1$p1), 2)
expect_equal(sum(d1$p2), 2)
expect_equal(sum(d1$rownum), 55)
lib_unload(dat)
} else
expect_equal(TRUE, TRUE)
})
test_that("ds9: datastep() by parameter sort check works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, by = c("treatment"), {
f1 <- first.
l1 <- last.
})
expect_equal(sum(d1$f1), 2)
expect_equal(sum(d1$l1), 2)
d2 <- dat.demo_studya[order(dat.demo_studya$dob), ]
expect_error(datastep(d2, by = c("treatment"), {
f1 <- first.
l1 <- last.
}))
d3 <- datastep(d2, by = c("treatment"), sort_check = FALSE, {
f1 <- first.
l1 <- last.
})
expect_equal(sum(d3$f1), 5)
expect_equal(sum(d3$l1), 5)
})
test_that("ds10: datastep() retain parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, retain = list("fork" = 0, bork = ""), {
fork <- fork + 1
if (first.)
bork <- "begin"
else if (last.)
bork <- "end"
else
bork <- paste("middle", n.)
})
d1
expect_equal(d1$fork[10], 10)
expect_equal(d1$bork[1], "begin")
expect_equal(d1$bork[2], "middle 2")
expect_equal(d1$bork[10], "end")
})
test_that("ds11: datastep() retain class check works as expected", {
expect_error(datastep(mtcars, retain = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds12: datastep() array class check works as expected", {
expect_error(datastep(mtcars, array = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds13: datastep() attrib class check works as expected", {
expect_error(datastep(mtcars, attrib = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds14: Rename works as expected", {
df <- datastep(mtcars[1:10, ],
drop = c("disp", "hp", "drat", "qsec",
"vs", "am", "gear", "carb"),
retain = list(cumwt = 0 ),
rename = c(mpg = "MPG", cyl = "Cylinders", wt = "Wgt",
cumwt = "Cumulative Wgt"),
{
cumwt <- cumwt + wt
})
df
expect_equal("MPG" %in% names(df), TRUE)
expect_equal("Cylinders" %in% names(df), TRUE)
expect_equal("Wgt" %in% names(df), TRUE)
expect_equal("Cumulative Wgt" %in% names(df), TRUE)
})
test_that("ds15: datastep() attributes on data are maintained.", {
library(dplyr)
library(common)
libname(dat, file.path(base_path, "SDTM"), "sas7bdat")
attributes(dat$dm$USUBJID)
prep <- dat$dm %>%
left_join(dat$vs, by = c("USUBJID" = "USUBJID")) %>%
select(USUBJID, VSTESTCD, VISIT, VISITNUM, VSSTRESN, ARM, VSBLFL) %>%
filter(VSTESTCD %in% c("PULSE", "RESP", "TEMP", "DIABP", "SYSBP"),
!(VISIT == "SCREENING" & VSBLFL != "Y")) %>%
arrange(USUBJID, VSTESTCD, VISITNUM) %>%
group_by(USUBJID, VSTESTCD) %>%
datastep(retain = list(BSTRESN = 0), {
# Combine treatment groups
# And distingish baseline time points
if (ARM == "ARM A") {
if (VSBLFL %eq% "Y") {
GRP <- "A_BASE"
} else {
GRP <- "A_TRT"
}
} else {
if (VSBLFL %eq% "Y") {
GRP <- "O_BASE"
} else {
GRP <- "O_TRT"
}
}
# Populate baseline value
if (first.)
BSTRESN = VSSTRESN
})
expect_equal(attr(prep$USUBJID, "label"), "Unique Subject Identifier")
})
test_that("ds16: datastep retains class attributes.", {
s1 <- 1:3
dt1 <- c(Sys.Date(), Sys.Date() - 1, Sys.Date() - 2)
df1 <- data.frame(s1, dt1, stringsAsFactors = FALSE)
df2 <- datastep(df1, rename = c(dt1 = "dt2"), {
csum <- 1
})
df2
expect_equal(class(df2$s1), "integer")
expect_equal(class(df2$dt2), "Date")
expect_equal(class(df2$csum), "numeric")
})
test_that("ds17: datastep works on single column data frame.", {
df <- data.frame(a = 1:10, stringsAsFactors = FALSE)
df2 <- datastep(df, {
if (a > 5)
status <- "High"
else
status <- "Low"
})
df2
expect_equal(ncol(df2), 2)
expect_equal(nrow(df2), 10)
expect_equal(class(df2), "data.frame")
})
test_that("ds18: datastep works on single column tibble.", {
df <- tibble(a = 1:10)
df2 <- datastep(df, {
if (a > 5)
status <- "High"
else
status <- "Low"
})
df2
expect_equal(ncol(df2), 2)
expect_equal(nrow(df2), 10)
expect_equal(class(df2), c("tbl_df", "tbl", "data.frame"))
})
test_that("ds19: datastep() attributes on data are maintained on base dataframe.", {
dat <- mtcars
attr(dat$mpg, "label") <- "Miles Per Gallon"
dat2 <- datastep(dat, {
fork <- "Hello"
})
dat2
expect_equal(attr(dat2$mpg, "label"), "Miles Per Gallon")
})
test_that("ds20: datastep works on tibble.", {
library(tibble)
l <- 1000
df <- tibble(C1 = seq_len(l), C2 = runif(l),
C3 = runif(l), C4 = runif(l))
res <- datastep(df, attrib = list(C5 = 0, C6 = 0),
{
C5 <- C2 + C3 + C4
C6 <- max(C2, C3, C4)
})
res
expect_equal("C5" %in% names(res), TRUE)
expect_equal("C6" %in% names(res), TRUE)
expect_equal(nrow(res), 1000)
})
test_that("ds21: datastep works on data.table", {
library(data.table)
l <- 1000
df <- data.table(C1 = seq_len(l), C2 = runif(l),
C3 = runif(l), C4 = runif(l))
res <- datastep(df, attrib = list(C5 = 0, C6 = 0),
{
C5 <- C2 + C3 + C4
C6 <- max(C2, C3, C4)
})
res
expect_equal("C5" %in% names(res), TRUE)
expect_equal("C6" %in% names(res), TRUE)
expect_equal(nrow(res), 1000)
})
test_that("ds22: datastep() works on a dataframe with a factor.", {
dat <- iris
dat2 <- datastep(dat, {
fork <- Petal.Length + Petal.Width
})
dat2
expect_equal("fork" %in% names(dat2), TRUE)
expect_equal(class(dat2$Species), "factor")
})
test_that("ds23: assign_attributes() works as expected.", {
dat <- mtcars
lst <- list(mpg = "hello", cyl = "goodbye")
dat2 <- assign_attributes(dat, lst, "label")
expect_equal(attr(dat2$mpg, "label"), "hello")
expect_equal(attr(dat2$cyl, "label"), "goodbye")
})
test_that("ds24: label parameter on datastep works as expected.", {
dat <- mtcars
lst <- list(mpg = "hello", cyl = "goodbye")
dat2 <- datastep(dat, label = lst, {})
expect_equal(attr(dat2$mpg, "label"), "hello")
expect_equal(attr(dat2$cyl, "label"), "goodbye")
})
test_that("ds25: format parameter on datastep works as expected.", {
dat <- mtcars
lst <- list(mpg = "%1.1f", cyl = "%1.2f")
dat2 <- datastep(dat, format = lst, {})
expect_equal(attr(dat2$mpg, "format"), "%1.1f")
expect_equal(attr(dat2$cyl, "format"), "%1.2f")
})
test_that("ds26: Attributes on datastep input is retained inside datastep.", {
library(common)
dat <- mtcars
labels(dat) <- list(mpg = "here", cyl = "there")
attr(dat$mpg, "label")
dat2 <- datastep(dat, format = list(cyl = "%1.1f"), {
mpgf <- attr(mpg, "label")
mpgf2 <- "Hello"
cylf <- attr(cyl, "format")
})
dat2
expect_equal("mpgf" %in% names(dat2), TRUE)
expect_equal(dat2[1, "mpgf"], "here")
expect_equal("cylf" %in% names(dat2), TRUE)
expect_equal(dat2[1, "cylf"], "%1.1f")
})
test_that("ds27: date variables are retained as dates.", {
ind <- mtcars
ind$mydate <- Sys.Date()
df <- datastep(ind, {
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
a1 <- attributes(df$recdt)
a2 <- attributes(df$mydate)
expect_equal(a1$class, "Date")
expect_equal(a2$class, "Date")
})
test_that("ds28: where clause works.", {
df <- datastep(mtcars,
where = expression(cyl == 8),
{
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
expect_equal(mean(df$cyl), 8)
})
test_that("ds29: attributes are retained with keep statement.", {
ind <- mtcars
ind$mydate <- Sys.Date()
df <- datastep(ind,
format = list(cyl = "%.1f",
mydate = "%b %m %Y",
recdt = "%b %m %y"),
keep = c("mpg", "cyl", "recdt", "mydate"), {
recdt <- as.Date("1974-06-10")
})
df
a1 <- attributes(df$recdt)
a2 <- attributes(df$mydate)
a3 <- attributes(df$cyl)
expect_equal(a1$class, "Date")
expect_equal(a2$class, "Date")
expect_equal(a1$format, "%b %m %y")
expect_equal(a2$format, "%b %m %Y")
expect_equal(a3$format, "%.1f")
})
test_that("ds30: datastep() keep parameter with one variable works.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, keep = c("study"), {})
d1
expect_equal("data.frame" %in% class(d1), TRUE)
expect_equal(names(d1), c("study"))
})
# test_that("output variable on datastep works as expected.", {
#
#
# dat <- datastep(mtcars, {if (cyl == 8) output = TRUE})
#
#
# expect_equal("output" %in% names(dat), FALSE)
# expect_equal(nrow(dat), 14)
# })
test_that("ds31: Single value NSE works on datastep().", {
d1 <- datastep(mtcars,
drop = am,
keep = v(mpg, cyl, disp, cylgrp),
by = cyl,
sort_check = FALSE, {
if (first.)
cylgrp <- "begin"
else
cylgrp <- "-"
})
d1
expect_equal(ncol(d1), 4)
d2 <- datastep(d1, keep = cylgrp, {})
expect_equal(ncol(d2), 1)
})
test_that("ds32: Delete function works on datastep().", {
d1 <- datastep(mtcars,
keep = v(mpg, cyl, disp, cylgrp),
by = cyl,
sort_check = FALSE, {
if (first.)
cylgrp <- "begin"
else
delete()
})
d1
expect_equal(ncol(d1), 4)
expect_equal(nrow(d1), 16)
# Should get no errors
d2 <- datastep(mtcars,
{delete()})
d2
expect_equal(nrow(d2), 0)
expect_equal(ncol(d2), 11)
})
test_that("ds33: Output function works as expected.", {
d1 <- datastep(mtcars,
{
if (cyl == 4)
output()
})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 11)
})
test_that("ds34: has_output() function works.", {
str1 <- "if (cyl == 4) output()"
res1 <- has_output(str1)
res1
expect_equal(res1, TRUE)
str2 <- "if (cyl == 4) delete()"
res2 <- has_output(str2)
res2
expect_equal(res2, FALSE)
})
test_that("ds35: Output function can output multiple rows per obs.", {
d1 <- datastep(mtcars,
{
fork <- "hello"
bork <- "sammy"
if (cyl == 4) {
seq <- 1
output()
seq <- 2
output()
}
# Never executed
andalso <- "here"
})
d1
expect_equal(nrow(d1), 22)
expect_equal(ncol(d1), 14)
})
test_that("ds35: delete and output can be used together.", {
d1 <- datastep(mtcars,
{
if (cyl == 4) {
delete()
}
output()
})
d1
expect_equal(nrow(d1), 21)
expect_equal(ncol(d1), 11)
})
test_that("ds36: output works with empty dataset.", {
d1 <- datastep(data.frame(), {
bork <- 1
fork <- "one"
output()
bork <- 2
fork <- "two"
output()
})
# print(d1)
# print(attributes(d1))
# print(attributes(d1$fork))
d1
expect_equal(nrow(d1), 2)
expect_equal(ncol(d1), 2)
expect_equal(names(d1), c("bork", "fork"))
expect_equal(d1[[1, 1]], 1)
# if ("factor" %in% class(d1[[2, 2]]))
# expect_equal(d1[[2, 2]], 2)
# else
# expect_equal(d1[[2, 2]], "two")
})
test_that("ds37: datastep strips and restores extra classes.", {
d2 <- mtcars
class(d2) <- c("fork", class(d2))
d1 <- datastep(d2,
{
if (cyl == 4) {
delete()
}
})
d1
class(d1)
expect_equal(class(d1), c("fork", "data.frame"))
})
test_that("ds38: no row data frame works with output.", {
d1 <- subset(mtcars, mtcars$cyl == 10)
d2 <- datastep(d1, {
bork <- 1
fork <- "one"
output()
bork <- 2
fork <- "two"
output()
})
d2
expect_equal(nrow(d2), 2)
expect_equal(ncol(d2), 13)
})
test_that("ds39: no row warning works.", {
d1 <- subset(mtcars, mtcars$cyl == 10)
expect_warning(datastep(d1, {
bork <- 1
}))
})
# Works interactively but not during test_that run
# Not sure what is going on. Datastep can't find dslst.
# test_that("ds40: output works in loop", {
#
#
# dslst <- list("mtcars" = mtcars, "beaver1" = beaver1, "iris" = iris)
#
# # Create metadata
# res3 <- datastep(data.frame(), {
#
#
# for (name in names(dslst)) {
# rows <- nrow(dslst[[name]])
# cols <- ncol(dslst[[name]])
# output()
# }
#
#
# })
#
#
# res3
#
# expect_equal(nrow(res3), 3)
# expect_equal(ncol(res3), 3)
#
# })
test_that("ds41: perform_set function works.", {
dat1 <- mtcars[1:10, 1:10]
dat2 <- mtcars[11:20, 2:11]
res1 <- perform_set(dat1, dat2)
res1
expect_equal(nrow(res1), 20)
expect_equal(ncol(res1), 11)
dat1$char <- "top"
dat2$char <- "middle"
dat3 <- dat2
dat3$char <- "bottom"
res2 <- perform_set(dat1, list(dat2, dat3))
res2
expect_equal(nrow(res2), 30)
expect_equal(ncol(res2), 12)
dat1$char <- as.factor(dat1$char)
dat2$char <- as.factor(dat2$char)
dat3$char <- as.factor(dat3$char)
res3 <- perform_set(dat1, list(dat2, dat3))
res3
expect_equal(nrow(res3), 30)
expect_equal(ncol(res3), 12)
expect_equal(levels(res3$char), c("top", "middle", "bottom"))
})
test_that("ds42: perform_merge function works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
A05 KAY
A10 JIM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- perform_merge(dat1, dat2, "ID", NULL)
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 4)
res2 <- perform_merge(dat1, dat2, "ID", c("INA", "INB"))
res2
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 6)
dat3 <- read.table(header = TRUE, text = '
ID STATUS
A02 ACTIVE
')
res3 <- perform_merge(dat1, list(dat2, dat3), "ID", c("INA", "INB", "INC"))
res3
expect_equal(nrow(res3), 5)
expect_equal(ncol(res3), 8)
dat4 <- read.table(header = TRUE, text = '
ID WEIGHT
A05 23
')
res4 <- perform_merge(dat1, list(dat2, dat3, dat4),
c("ID"),
c("INA", "INB", "INC", "IND"))
res4
expect_equal(nrow(res4), 5)
expect_equal(ncol(res4), 10)
res5 <- perform_merge(dat1, list(dat2, dat3, dat4),
c("ID"),
c("INA", "INB", "INC"))
res5
expect_equal(nrow(res5), 5)
expect_equal(ncol(res5), 9)
})
test_that("ds43: datastep with merge works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
A05 KAY
A10 JIM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 4)
res2 <- datastep(dat1, merge = dat2, merge_by = "ID",
merge_in = c("INA", "INB"),
where = expression(INA == 1), {})
res2
expect_equal(nrow(res2), 4)
expect_equal(ncol(res2), 6)
res3 <- datastep(dat1, merge = dat2, merge_by = "ID",
merge_in = c("INA", "INB"),
where = expression(INA == 0 & INB == 1), {})
res3
expect_equal(nrow(res3), 1)
expect_equal(ncol(res3), 6)
dat4 <- read.table(header = TRUE, text = '
NO AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat4
res4 <- datastep(dat1, merge = dat4, merge_by = c("ID" = "NO"), {})
res4
expect_equal(nrow(res4), 5)
expect_equal(ncol(res4), 4)
expect_error( datastep(dat1, merge = dat4, merge_by = c("IDS" = "NO"), {}))
expect_error( datastep(dat1, merge = dat4, merge_by = c("ID" = "NUM"), {}))
})
test_that("ds44: datastep with set works.", {
dat1 <- mtcars[1:10, 1:10]
dat2 <- mtcars[11:20, 2:11]
res1 <- datastep(dat1, set = dat2, {})
res1
expect_equal(nrow(res1), 20)
expect_equal(ncol(res1), 11)
})
test_that("ds45: keep and drop checks work.", {
res1 <- datastep(mtcars, keep = c("mpg", "cyl", "fork"), {})
expect_equal(ncol(res1), 2)
res2 <- datastep(mtcars, drop = c("mpg", "cyl", "fork"), {})
expect_equal(ncol(res2), 9)
})
test_that("ds44: Make sure cols not dropped.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
})
test_that("ds46: fix_names works as expected.", {
v1 <- c("A", "B", "C", "D")
v2 <- c("A", "E", "B", "F")
ky <- "A"
sfx <- c(".1", ".2")
res <- fix_names(v1, v2, ky, sfx)
res
expect_equal(res, c("A", "B.1", "C", "D", "E", "B.2", "F"))
})
test_that("ds47: column append with no merge_by works equal rows.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal(nrow(res1), 4)
expect_equal(ncol(res1), 6)
expect_equal(names(res1), c("NAME", "ID.1", "SEX.1", "ID.2", "AGE", "SEX.2"))
})
test_that("ds48: column append with no merge_by works unequal rows.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal(nrow(res1), 4)
expect_equal(ncol(res1), 6)
expect_equal(names(res1), c("NAME", "ID.1", "SEX.1", "ID.2", "AGE", "SEX.2"))
})
test_that("ds49: fill_missing() works as expected.", {
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
')
res1 <- fill_missing(dat2, 4)
res1
expect_equal(nrow(res1), 4)
res2 <- fill_missing(dat2, 10)
res2
expect_equal(nrow(res2), 10)
res3 <- fill_missing(dat2, 2)
res3
expect_equal(nrow(res3), 3)
})
test_that("ds50: copy_df_attributes works as expected.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- mtcars[11:25, c("mpg", "cyl", "disp")]
res1 <- copy_df_attributes(dat1, dat2)
res1
expect_equal(rownames(res1)[1], "Merc 280C")
expect_equal("tbl_df" %in% class(res1), TRUE)
})
test_that("ds51: Set keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- as_tibble(mtcars[11:20, c("mpg", "cyl", "disp")])
res1 <- datastep(dat1, set = dat2, {})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
})
test_that("ds52: Merge append keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- as_tibble(mtcars[11:20, c("hp", "drat", "wt")])
labels(dat2) <- list(hp = "Horsepower",
wt = "Weight")
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
lbls
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
})
test_that("ds53: Merge by keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- tibble(cyl = c(4, 6, 8),
lbl = c("4 Cylinders",
"6 Cylinders",
"8 Cylinders"),
disp = rep(1, 2, 3))
labels(dat2) <- list(cyl = "Cylinders",
lbl = "Label",
disp = "Displacement 2")
res1 <- datastep(dat1, merge = dat2, merge_by = cyl,{
sammy <- mpg * 2
})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
lbls
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
expect_equal(lbls[[4]], "Label")
expect_equal(lbls[[5]], "Displacement 2")
})
test_that("ds43: datastep join works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX CODE
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
res2 <- datastep(dat1, merge = dat2, merge_by = c(ID = "CODE"), {})
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 5)
})
test_that("ds44: datastep multiple renames works.", {
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX CODE
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
')
dat2
res2 <- datastep(dat2,
rename = c(AGE = "TITLE", SEX = "FORK"),{})
res2
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 4)
expect_equal(names(res2), c("ID", "TITLE", "FORK", "CODE"))
})
test_that("ds43: Merge dataset names are not 'fixed' when using tibbles.", {
library(tibble)
dat1 <- read.table(header = TRUE, text = '
ID2 NAME
A01 SUE
A02 TOM
')
dat2 <- read.table(header = TRUE, text = '
ID "AGE 1" "SEX 2" "CODE 4"
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
', check.names = FALSE)
dat1 <- as_tibble(dat1)
dat2 <- as_tibble(dat2)
res1 <- datastep(dat2, merge = dat1, merge_by = c("ID" = "ID2"), {},
log = FALSE)
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
expect_equal(names(res1), c("ID", "AGE 1", "SEX 2", "CODE 4", "NAME"))
})
test_that("ds44: Merge works with factors.", {
# Create sample data
grp1 <- read.table(header = TRUE, text = '
GROUP NAME
G01 Group1
G02 Group2
', stringsAsFactors = TRUE)
grp2 <- read.table(header = TRUE, text = '
GROUP NAME
G03 Group3
G04 Group4
', stringsAsFactors = TRUE)
dat <- read.table(header = TRUE, text = '
ID AGE SEX GROUP
A01 58 F G01
A02 20 M G02
A03 47 F G05
A04 11 M G03
A05 23 F G01
', stringsAsFactors = TRUE)
# Set operation
grps <- datastep(grp1, set = grp2, {})
grps
# Merge operation - Outer Join
res <- datastep(dat, merge = grps,
merge_by = "GROUP",
merge_in = c("inA", "inB"), {})
expect_equal(nrow(res), 6)
expect_equal(ncol(res), 7)
})
test_that("ds45: Output function works as expected when the names have spaces.", {
dat <- mtcars[ , c("mpg", "cyl")]
rownames(dat) <- NULL
names(dat) <- c("miles per gallon", "cylinders")
d1 <- datastep(dat,
{
if (cylinders == 4) {
output()
#fork <- 1
}
})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 2)
})
test_that("ds46: Skip loop when there is no code.", {
dat <- mtcars[ , c("mpg", "cyl")]
d1 <- datastep(dat, where = expression(cyl == 4),
{})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 2)
})
test_that("ds47: Multiple group bys works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
dt <- sort(dat.demo_studya, by = c("treatment", "sex"))
d1 <- datastep(dt, by = c("treatment", "sex"), {
f1 <- first.
l1 <- last.
f2 <- first.treatment
l2 <- last.treatment
f3 <- first.sex
l3 <- last.sex
}, sort_check = TRUE)
d1
expect_equal(sum(d1$f1), 4)
expect_equal(sum(d1$l1), 4)
expect_equal(sum(d1$f2), 2)
expect_equal(sum(d1$l2), 2)
expect_equal(sum(d1$f2), 2)
expect_equal(sum(d1$l2), 2)
})
test_that("ds48: labels retained with where clause.", {
dat <- mtcars
labels(dat) <- list(mpg = "Miles", cyl = "Cylinders")
df <- datastep(dat,
where = expression(cyl == 8),
{
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
lbls <- labels(df)
expect_equal(length(lbls), 2)
})
test_that("ds49: works as expected with local variable.", {
library(fmtr)
myfmt <- value(condition(x >= 20, "High"),
condition(x < 20, "Low"))
# format = list(mpg=myfmt),
d1 <- datastep(mtcars, {
mpgcat <- fapply(mpg, myfmt)
})
d1
expect_equal("mpgcat" %in% names(d1), TRUE)
expect_equal(d1$mpgcat[1], "High")
})
test_that("ds50: works as expected with source.all().", {
if (dev) {
pth <- file.path(dirname(base_path), "programs")
res <- common::source.all(pth)
expect_equal(res$Status, 0)
} else {
expect_equal(TRUE, TRUE)
}
})
dbosak01/libr documentation built on March 19, 2024, 5:50 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context("Datastep Tests")
base_path <- "c:\\packages\\libr\\tests\\testthat\\data"
base_path <- "./data"
options("logr.output" = FALSE)
dev <- FALSE
test_that("ds1: datastep() function works as expected with mtcars.", {
d1 <- datastep(mtcars, {
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
})
d1
expect_equal("mpgcat" %in% names(d1), TRUE)
})
test_that("ds2: datastep() function works as expected with demo_studya.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, {
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal("sexc" %in% names(d1), TRUE)
})
test_that("ds3: datastep() keep parameter works as expected.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, keep = c("usubjid", "sexc", "race"), {
usubjid <- paste0(study, "-", inv, "-", patient)
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal(names(d1), c("usubjid", "sexc", "race"))
})
test_that("ds4: datastep() drop parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, drop = c("visit", "screendate", "sex"), {
usubjid <- paste0(study, "-", inv, "-", patient)
if (sex == "M")
sexc <- "Male"
else if(sex == "F")
sexc <- "Female"
else
sexc <- "Other"
})
d1
expect_equal(names(d1), c("study", "inv", "patient", "race",
"dob", "treatment", "usubjid", "sexc"))
})
test_that("ds5: datastep() by parameter first and last works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, by = c("treatment"), {
f1 <- first.
l1 <- last.
})
d1
expect_equal(sum(d1$f1), 2)
expect_equal(sum(d1$l1), 2)
})
test_that("ds6: datastep() summary functions works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, {
pmean <- mean(data$patient)
if (patient > pmean)
pind <- TRUE
else
pind <- FALSE
rownum <- n.
})
d1
expect_equal(sum(d1$pind), 5)
})
test_that("ds7: datastep() calculate parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya,
calculate = {
pmean <- mean(patient)
},{
if (patient > pmean)
pind <- TRUE
else
pind <- FALSE
rownum <- n.
})
d1
expect_equal(sum(d1$pind), 5)
})
test_that("ds8: datastep() auto-group-by works as expected.", {
if (TRUE) {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- dat.demo_studya %>% group_by(treatment) %>%
datastep({
p1 <- first.
p2 <- last.
rownum <- n.
})
d1
expect_equal(sum(d1$p1), 2)
expect_equal(sum(d1$p2), 2)
expect_equal(sum(d1$rownum), 55)
lib_unload(dat)
} else
expect_equal(TRUE, TRUE)
})
test_that("ds9: datastep() by parameter sort check works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, by = c("treatment"), {
f1 <- first.
l1 <- last.
})
expect_equal(sum(d1$f1), 2)
expect_equal(sum(d1$l1), 2)
d2 <- dat.demo_studya[order(dat.demo_studya$dob), ]
expect_error(datastep(d2, by = c("treatment"), {
f1 <- first.
l1 <- last.
}))
d3 <- datastep(d2, by = c("treatment"), sort_check = FALSE, {
f1 <- first.
l1 <- last.
})
expect_equal(sum(d3$f1), 5)
expect_equal(sum(d3$l1), 5)
})
test_that("ds10: datastep() retain parameter works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
d1 <- datastep(dat.demo_studya, retain = list("fork" = 0, bork = ""), {
fork <- fork + 1
if (first.)
bork <- "begin"
else if (last.)
bork <- "end"
else
bork <- paste("middle", n.)
})
d1
expect_equal(d1$fork[10], 10)
expect_equal(d1$bork[1], "begin")
expect_equal(d1$bork[2], "middle 2")
expect_equal(d1$bork[10], "end")
})
test_that("ds11: datastep() retain class check works as expected", {
expect_error(datastep(mtcars, retain = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds12: datastep() array class check works as expected", {
expect_error(datastep(mtcars, array = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds13: datastep() attrib class check works as expected", {
expect_error(datastep(mtcars, attrib = c(fork = 0), {fork <- fork + 1}))
})
test_that("ds14: Rename works as expected", {
df <- datastep(mtcars[1:10, ],
drop = c("disp", "hp", "drat", "qsec",
"vs", "am", "gear", "carb"),
retain = list(cumwt = 0 ),
rename = c(mpg = "MPG", cyl = "Cylinders", wt = "Wgt",
cumwt = "Cumulative Wgt"),
{
cumwt <- cumwt + wt
})
df
expect_equal("MPG" %in% names(df), TRUE)
expect_equal("Cylinders" %in% names(df), TRUE)
expect_equal("Wgt" %in% names(df), TRUE)
expect_equal("Cumulative Wgt" %in% names(df), TRUE)
})
test_that("ds15: datastep() attributes on data are maintained.", {
library(dplyr)
library(common)
libname(dat, file.path(base_path, "SDTM"), "sas7bdat")
attributes(dat$dm$USUBJID)
prep <- dat$dm %>%
left_join(dat$vs, by = c("USUBJID" = "USUBJID")) %>%
select(USUBJID, VSTESTCD, VISIT, VISITNUM, VSSTRESN, ARM, VSBLFL) %>%
filter(VSTESTCD %in% c("PULSE", "RESP", "TEMP", "DIABP", "SYSBP"),
!(VISIT == "SCREENING" & VSBLFL != "Y")) %>%
arrange(USUBJID, VSTESTCD, VISITNUM) %>%
group_by(USUBJID, VSTESTCD) %>%
datastep(retain = list(BSTRESN = 0), {
# Combine treatment groups
# And distingish baseline time points
if (ARM == "ARM A") {
if (VSBLFL %eq% "Y") {
GRP <- "A_BASE"
} else {
GRP <- "A_TRT"
}
} else {
if (VSBLFL %eq% "Y") {
GRP <- "O_BASE"
} else {
GRP <- "O_TRT"
}
}
# Populate baseline value
if (first.)
BSTRESN = VSSTRESN
})
expect_equal(attr(prep$USUBJID, "label"), "Unique Subject Identifier")
})
test_that("ds16: datastep retains class attributes.", {
s1 <- 1:3
dt1 <- c(Sys.Date(), Sys.Date() - 1, Sys.Date() - 2)
df1 <- data.frame(s1, dt1, stringsAsFactors = FALSE)
df2 <- datastep(df1, rename = c(dt1 = "dt2"), {
csum <- 1
})
df2
expect_equal(class(df2$s1), "integer")
expect_equal(class(df2$dt2), "Date")
expect_equal(class(df2$csum), "numeric")
})
test_that("ds17: datastep works on single column data frame.", {
df <- data.frame(a = 1:10, stringsAsFactors = FALSE)
df2 <- datastep(df, {
if (a > 5)
status <- "High"
else
status <- "Low"
})
df2
expect_equal(ncol(df2), 2)
expect_equal(nrow(df2), 10)
expect_equal(class(df2), "data.frame")
})
test_that("ds18: datastep works on single column tibble.", {
df <- tibble(a = 1:10)
df2 <- datastep(df, {
if (a > 5)
status <- "High"
else
status <- "Low"
})
df2
expect_equal(ncol(df2), 2)
expect_equal(nrow(df2), 10)
expect_equal(class(df2), c("tbl_df", "tbl", "data.frame"))
})
test_that("ds19: datastep() attributes on data are maintained on base dataframe.", {
dat <- mtcars
attr(dat$mpg, "label") <- "Miles Per Gallon"
dat2 <- datastep(dat, {
fork <- "Hello"
})
dat2
expect_equal(attr(dat2$mpg, "label"), "Miles Per Gallon")
})
test_that("ds20: datastep works on tibble.", {
library(tibble)
l <- 1000
df <- tibble(C1 = seq_len(l), C2 = runif(l),
C3 = runif(l), C4 = runif(l))
res <- datastep(df, attrib = list(C5 = 0, C6 = 0),
{
C5 <- C2 + C3 + C4
C6 <- max(C2, C3, C4)
})
res
expect_equal("C5" %in% names(res), TRUE)
expect_equal("C6" %in% names(res), TRUE)
expect_equal(nrow(res), 1000)
})
test_that("ds21: datastep works on data.table", {
library(data.table)
l <- 1000
df <- data.table(C1 = seq_len(l), C2 = runif(l),
C3 = runif(l), C4 = runif(l))
res <- datastep(df, attrib = list(C5 = 0, C6 = 0),
{
C5 <- C2 + C3 + C4
C6 <- max(C2, C3, C4)
})
res
expect_equal("C5" %in% names(res), TRUE)
expect_equal("C6" %in% names(res), TRUE)
expect_equal(nrow(res), 1000)
})
test_that("ds22: datastep() works on a dataframe with a factor.", {
dat <- iris
dat2 <- datastep(dat, {
fork <- Petal.Length + Petal.Width
})
dat2
expect_equal("fork" %in% names(dat2), TRUE)
expect_equal(class(dat2$Species), "factor")
})
test_that("ds23: assign_attributes() works as expected.", {
dat <- mtcars
lst <- list(mpg = "hello", cyl = "goodbye")
dat2 <- assign_attributes(dat, lst, "label")
expect_equal(attr(dat2$mpg, "label"), "hello")
expect_equal(attr(dat2$cyl, "label"), "goodbye")
})
test_that("ds24: label parameter on datastep works as expected.", {
dat <- mtcars
lst <- list(mpg = "hello", cyl = "goodbye")
dat2 <- datastep(dat, label = lst, {})
expect_equal(attr(dat2$mpg, "label"), "hello")
expect_equal(attr(dat2$cyl, "label"), "goodbye")
})
test_that("ds25: format parameter on datastep works as expected.", {
dat <- mtcars
lst <- list(mpg = "%1.1f", cyl = "%1.2f")
dat2 <- datastep(dat, format = lst, {})
expect_equal(attr(dat2$mpg, "format"), "%1.1f")
expect_equal(attr(dat2$cyl, "format"), "%1.2f")
})
test_that("ds26: Attributes on datastep input is retained inside datastep.", {
library(common)
dat <- mtcars
labels(dat) <- list(mpg = "here", cyl = "there")
attr(dat$mpg, "label")
dat2 <- datastep(dat, format = list(cyl = "%1.1f"), {
mpgf <- attr(mpg, "label")
mpgf2 <- "Hello"
cylf <- attr(cyl, "format")
})
dat2
expect_equal("mpgf" %in% names(dat2), TRUE)
expect_equal(dat2[1, "mpgf"], "here")
expect_equal("cylf" %in% names(dat2), TRUE)
expect_equal(dat2[1, "cylf"], "%1.1f")
})
test_that("ds27: date variables are retained as dates.", {
ind <- mtcars
ind$mydate <- Sys.Date()
df <- datastep(ind, {
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
a1 <- attributes(df$recdt)
a2 <- attributes(df$mydate)
expect_equal(a1$class, "Date")
expect_equal(a2$class, "Date")
})
test_that("ds28: where clause works.", {
df <- datastep(mtcars,
where = expression(cyl == 8),
{
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
expect_equal(mean(df$cyl), 8)
})
test_that("ds29: attributes are retained with keep statement.", {
ind <- mtcars
ind$mydate <- Sys.Date()
df <- datastep(ind,
format = list(cyl = "%.1f",
mydate = "%b %m %Y",
recdt = "%b %m %y"),
keep = c("mpg", "cyl", "recdt", "mydate"), {
recdt <- as.Date("1974-06-10")
})
df
a1 <- attributes(df$recdt)
a2 <- attributes(df$mydate)
a3 <- attributes(df$cyl)
expect_equal(a1$class, "Date")
expect_equal(a2$class, "Date")
expect_equal(a1$format, "%b %m %y")
expect_equal(a2$format, "%b %m %Y")
expect_equal(a3$format, "%.1f")
})
test_that("ds30: datastep() keep parameter with one variable works.", {
libname(dat, base_path, "csv")
lib_load(dat)
d1 <- datastep(dat.demo_studya, keep = c("study"), {})
d1
expect_equal("data.frame" %in% class(d1), TRUE)
expect_equal(names(d1), c("study"))
})
# test_that("output variable on datastep works as expected.", {
#
#
# dat <- datastep(mtcars, {if (cyl == 8) output = TRUE})
#
#
# expect_equal("output" %in% names(dat), FALSE)
# expect_equal(nrow(dat), 14)
# })
test_that("ds31: Single value NSE works on datastep().", {
d1 <- datastep(mtcars,
drop = am,
keep = v(mpg, cyl, disp, cylgrp),
by = cyl,
sort_check = FALSE, {
if (first.)
cylgrp <- "begin"
else
cylgrp <- "-"
})
d1
expect_equal(ncol(d1), 4)
d2 <- datastep(d1, keep = cylgrp, {})
expect_equal(ncol(d2), 1)
})
test_that("ds32: Delete function works on datastep().", {
d1 <- datastep(mtcars,
keep = v(mpg, cyl, disp, cylgrp),
by = cyl,
sort_check = FALSE, {
if (first.)
cylgrp <- "begin"
else
delete()
})
d1
expect_equal(ncol(d1), 4)
expect_equal(nrow(d1), 16)
# Should get no errors
d2 <- datastep(mtcars,
{delete()})
d2
expect_equal(nrow(d2), 0)
expect_equal(ncol(d2), 11)
})
test_that("ds33: Output function works as expected.", {
d1 <- datastep(mtcars,
{
if (cyl == 4)
output()
})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 11)
})
test_that("ds34: has_output() function works.", {
str1 <- "if (cyl == 4) output()"
res1 <- has_output(str1)
res1
expect_equal(res1, TRUE)
str2 <- "if (cyl == 4) delete()"
res2 <- has_output(str2)
res2
expect_equal(res2, FALSE)
})
test_that("ds35: Output function can output multiple rows per obs.", {
d1 <- datastep(mtcars,
{
fork <- "hello"
bork <- "sammy"
if (cyl == 4) {
seq <- 1
output()
seq <- 2
output()
}
# Never executed
andalso <- "here"
})
d1
expect_equal(nrow(d1), 22)
expect_equal(ncol(d1), 14)
})
test_that("ds35: delete and output can be used together.", {
d1 <- datastep(mtcars,
{
if (cyl == 4) {
delete()
}
output()
})
d1
expect_equal(nrow(d1), 21)
expect_equal(ncol(d1), 11)
})
test_that("ds36: output works with empty dataset.", {
d1 <- datastep(data.frame(), {
bork <- 1
fork <- "one"
output()
bork <- 2
fork <- "two"
output()
})
# print(d1)
# print(attributes(d1))
# print(attributes(d1$fork))
d1
expect_equal(nrow(d1), 2)
expect_equal(ncol(d1), 2)
expect_equal(names(d1), c("bork", "fork"))
expect_equal(d1[[1, 1]], 1)
# if ("factor" %in% class(d1[[2, 2]]))
# expect_equal(d1[[2, 2]], 2)
# else
# expect_equal(d1[[2, 2]], "two")
})
test_that("ds37: datastep strips and restores extra classes.", {
d2 <- mtcars
class(d2) <- c("fork", class(d2))
d1 <- datastep(d2,
{
if (cyl == 4) {
delete()
}
})
d1
class(d1)
expect_equal(class(d1), c("fork", "data.frame"))
})
test_that("ds38: no row data frame works with output.", {
d1 <- subset(mtcars, mtcars$cyl == 10)
d2 <- datastep(d1, {
bork <- 1
fork <- "one"
output()
bork <- 2
fork <- "two"
output()
})
d2
expect_equal(nrow(d2), 2)
expect_equal(ncol(d2), 13)
})
test_that("ds39: no row warning works.", {
d1 <- subset(mtcars, mtcars$cyl == 10)
expect_warning(datastep(d1, {
bork <- 1
}))
})
# Works interactively but not during test_that run
# Not sure what is going on. Datastep can't find dslst.
# test_that("ds40: output works in loop", {
#
#
# dslst <- list("mtcars" = mtcars, "beaver1" = beaver1, "iris" = iris)
#
# # Create metadata
# res3 <- datastep(data.frame(), {
#
#
# for (name in names(dslst)) {
# rows <- nrow(dslst[[name]])
# cols <- ncol(dslst[[name]])
# output()
# }
#
#
# })
#
#
# res3
#
# expect_equal(nrow(res3), 3)
# expect_equal(ncol(res3), 3)
#
# })
test_that("ds41: perform_set function works.", {
dat1 <- mtcars[1:10, 1:10]
dat2 <- mtcars[11:20, 2:11]
res1 <- perform_set(dat1, dat2)
res1
expect_equal(nrow(res1), 20)
expect_equal(ncol(res1), 11)
dat1$char <- "top"
dat2$char <- "middle"
dat3 <- dat2
dat3$char <- "bottom"
res2 <- perform_set(dat1, list(dat2, dat3))
res2
expect_equal(nrow(res2), 30)
expect_equal(ncol(res2), 12)
dat1$char <- as.factor(dat1$char)
dat2$char <- as.factor(dat2$char)
dat3$char <- as.factor(dat3$char)
res3 <- perform_set(dat1, list(dat2, dat3))
res3
expect_equal(nrow(res3), 30)
expect_equal(ncol(res3), 12)
expect_equal(levels(res3$char), c("top", "middle", "bottom"))
})
test_that("ds42: perform_merge function works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
A05 KAY
A10 JIM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- perform_merge(dat1, dat2, "ID", NULL)
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 4)
res2 <- perform_merge(dat1, dat2, "ID", c("INA", "INB"))
res2
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 6)
dat3 <- read.table(header = TRUE, text = '
ID STATUS
A02 ACTIVE
')
res3 <- perform_merge(dat1, list(dat2, dat3), "ID", c("INA", "INB", "INC"))
res3
expect_equal(nrow(res3), 5)
expect_equal(ncol(res3), 8)
dat4 <- read.table(header = TRUE, text = '
ID WEIGHT
A05 23
')
res4 <- perform_merge(dat1, list(dat2, dat3, dat4),
c("ID"),
c("INA", "INB", "INC", "IND"))
res4
expect_equal(nrow(res4), 5)
expect_equal(ncol(res4), 10)
res5 <- perform_merge(dat1, list(dat2, dat3, dat4),
c("ID"),
c("INA", "INB", "INC"))
res5
expect_equal(nrow(res5), 5)
expect_equal(ncol(res5), 9)
})
test_that("ds43: datastep with merge works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
A05 KAY
A10 JIM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 4)
res2 <- datastep(dat1, merge = dat2, merge_by = "ID",
merge_in = c("INA", "INB"),
where = expression(INA == 1), {})
res2
expect_equal(nrow(res2), 4)
expect_equal(ncol(res2), 6)
res3 <- datastep(dat1, merge = dat2, merge_by = "ID",
merge_in = c("INA", "INB"),
where = expression(INA == 0 & INB == 1), {})
res3
expect_equal(nrow(res3), 1)
expect_equal(ncol(res3), 6)
dat4 <- read.table(header = TRUE, text = '
NO AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat4
res4 <- datastep(dat1, merge = dat4, merge_by = c("ID" = "NO"), {})
res4
expect_equal(nrow(res4), 5)
expect_equal(ncol(res4), 4)
expect_error( datastep(dat1, merge = dat4, merge_by = c("IDS" = "NO"), {}))
expect_error( datastep(dat1, merge = dat4, merge_by = c("ID" = "NUM"), {}))
})
test_that("ds44: datastep with set works.", {
dat1 <- mtcars[1:10, 1:10]
dat2 <- mtcars[11:20, 2:11]
res1 <- datastep(dat1, set = dat2, {})
res1
expect_equal(nrow(res1), 20)
expect_equal(ncol(res1), 11)
})
test_that("ds45: keep and drop checks work.", {
res1 <- datastep(mtcars, keep = c("mpg", "cyl", "fork"), {})
expect_equal(ncol(res1), 2)
res2 <- datastep(mtcars, drop = c("mpg", "cyl", "fork"), {})
expect_equal(ncol(res2), 9)
})
test_that("ds44: Make sure cols not dropped.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
A11 23 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
})
test_that("ds46: fix_names works as expected.", {
v1 <- c("A", "B", "C", "D")
v2 <- c("A", "E", "B", "F")
ky <- "A"
sfx <- c(".1", ".2")
res <- fix_names(v1, v2, ky, sfx)
res
expect_equal(res, c("A", "B.1", "C", "D", "E", "B.2", "F"))
})
test_that("ds47: column append with no merge_by works equal rows.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
A10 11 M
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal(nrow(res1), 4)
expect_equal(ncol(res1), 6)
expect_equal(names(res1), c("NAME", "ID.1", "SEX.1", "ID.2", "AGE", "SEX.2"))
})
test_that("ds48: column append with no merge_by works unequal rows.", {
dat1 <- read.table(header = TRUE, text = '
NAME ID SEX
SUE A01 O
TOM A02 O
KAY A05 O
JIM A10 O
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal(nrow(res1), 4)
expect_equal(ncol(res1), 6)
expect_equal(names(res1), c("NAME", "ID.1", "SEX.1", "ID.2", "AGE", "SEX.2"))
})
test_that("ds49: fill_missing() works as expected.", {
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX
A01 58 F
A02 20 M
A05 47 F
')
res1 <- fill_missing(dat2, 4)
res1
expect_equal(nrow(res1), 4)
res2 <- fill_missing(dat2, 10)
res2
expect_equal(nrow(res2), 10)
res3 <- fill_missing(dat2, 2)
res3
expect_equal(nrow(res3), 3)
})
test_that("ds50: copy_df_attributes works as expected.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- mtcars[11:25, c("mpg", "cyl", "disp")]
res1 <- copy_df_attributes(dat1, dat2)
res1
expect_equal(rownames(res1)[1], "Merc 280C")
expect_equal("tbl_df" %in% class(res1), TRUE)
})
test_that("ds51: Set keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- as_tibble(mtcars[11:20, c("mpg", "cyl", "disp")])
res1 <- datastep(dat1, set = dat2, {})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
})
test_that("ds52: Merge append keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- as_tibble(mtcars[11:20, c("hp", "drat", "wt")])
labels(dat2) <- list(hp = "Horsepower",
wt = "Weight")
res1 <- datastep(dat1, merge = dat2, {})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
lbls
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
})
test_that("ds53: Merge by keeps dataset attributes.", {
library(tibble)
dat1 <- as_tibble(mtcars[1:10, c("mpg", "cyl", "disp")])
labels(dat1) <- list(mpg = "Miles per gallon",
cyl = "Cylinders",
disp = "Displacement")
dat2 <- tibble(cyl = c(4, 6, 8),
lbl = c("4 Cylinders",
"6 Cylinders",
"8 Cylinders"),
disp = rep(1, 2, 3))
labels(dat2) <- list(cyl = "Cylinders",
lbl = "Label",
disp = "Displacement 2")
res1 <- datastep(dat1, merge = dat2, merge_by = cyl,{
sammy <- mpg * 2
})
res1
expect_equal("tbl_df" %in% class(res1), TRUE)
expect_equal(rownames(res1)[1], "1")
lbls <- labels(res1)
lbls
expect_equal(lbls[[1]], "Miles per gallon")
expect_equal(lbls[[2]], "Cylinders")
expect_equal(lbls[[3]], "Displacement")
expect_equal(lbls[[4]], "Label")
expect_equal(lbls[[5]], "Displacement 2")
})
test_that("ds43: datastep join works.", {
dat1 <- read.table(header = TRUE, text = '
ID NAME
A01 SUE
A02 TOM
')
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX CODE
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
')
dat1
dat2
res1 <- datastep(dat1, merge = dat2, merge_by = "ID", {})
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
res2 <- datastep(dat1, merge = dat2, merge_by = c(ID = "CODE"), {})
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 5)
})
test_that("ds44: datastep multiple renames works.", {
dat2 <- read.table(header = TRUE, text = '
ID AGE SEX CODE
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
')
dat2
res2 <- datastep(dat2,
rename = c(AGE = "TITLE", SEX = "FORK"),{})
res2
expect_equal(nrow(res2), 5)
expect_equal(ncol(res2), 4)
expect_equal(names(res2), c("ID", "TITLE", "FORK", "CODE"))
})
test_that("ds43: Merge dataset names are not 'fixed' when using tibbles.", {
library(tibble)
dat1 <- read.table(header = TRUE, text = '
ID2 NAME
A01 SUE
A02 TOM
')
dat2 <- read.table(header = TRUE, text = '
ID "AGE 1" "SEX 2" "CODE 4"
A01 58 F A01
A02 20 M A02
A01 47 F A01
A02 11 M A02
A01 23 F A01
', check.names = FALSE)
dat1 <- as_tibble(dat1)
dat2 <- as_tibble(dat2)
res1 <- datastep(dat2, merge = dat1, merge_by = c("ID" = "ID2"), {},
log = FALSE)
res1
expect_equal(nrow(res1), 5)
expect_equal(ncol(res1), 5)
expect_equal(names(res1), c("ID", "AGE 1", "SEX 2", "CODE 4", "NAME"))
})
test_that("ds44: Merge works with factors.", {
# Create sample data
grp1 <- read.table(header = TRUE, text = '
GROUP NAME
G01 Group1
G02 Group2
', stringsAsFactors = TRUE)
grp2 <- read.table(header = TRUE, text = '
GROUP NAME
G03 Group3
G04 Group4
', stringsAsFactors = TRUE)
dat <- read.table(header = TRUE, text = '
ID AGE SEX GROUP
A01 58 F G01
A02 20 M G02
A03 47 F G05
A04 11 M G03
A05 23 F G01
', stringsAsFactors = TRUE)
# Set operation
grps <- datastep(grp1, set = grp2, {})
grps
# Merge operation - Outer Join
res <- datastep(dat, merge = grps,
merge_by = "GROUP",
merge_in = c("inA", "inB"), {})
expect_equal(nrow(res), 6)
expect_equal(ncol(res), 7)
})
test_that("ds45: Output function works as expected when the names have spaces.", {
dat <- mtcars[ , c("mpg", "cyl")]
rownames(dat) <- NULL
names(dat) <- c("miles per gallon", "cylinders")
d1 <- datastep(dat,
{
if (cylinders == 4) {
output()
#fork <- 1
}
})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 2)
})
test_that("ds46: Skip loop when there is no code.", {
dat <- mtcars[ , c("mpg", "cyl")]
d1 <- datastep(dat, where = expression(cyl == 4),
{})
d1
expect_equal(nrow(d1), 11)
expect_equal(ncol(d1), 2)
})
test_that("ds47: Multiple group bys works as expected.", {
libname(dat, base_path, "rds")
lib_load(dat)
dt <- sort(dat.demo_studya, by = c("treatment", "sex"))
d1 <- datastep(dt, by = c("treatment", "sex"), {
f1 <- first.
l1 <- last.
f2 <- first.treatment
l2 <- last.treatment
f3 <- first.sex
l3 <- last.sex
}, sort_check = TRUE)
d1
expect_equal(sum(d1$f1), 4)
expect_equal(sum(d1$l1), 4)
expect_equal(sum(d1$f2), 2)
expect_equal(sum(d1$l2), 2)
expect_equal(sum(d1$f2), 2)
expect_equal(sum(d1$l2), 2)
})
test_that("ds48: labels retained with where clause.", {
dat <- mtcars
labels(dat) <- list(mpg = "Miles", cyl = "Cylinders")
df <- datastep(dat,
where = expression(cyl == 8),
{
if (mpg >= 20)
mpgcat <- "High"
else
mpgcat <- "Low"
recdt <- as.Date("1974-06-10")
if (cyl == 8)
is8cyl <- TRUE
else
is8cyl <- FALSE
})
df
lbls <- labels(df)
expect_equal(length(lbls), 2)
})
test_that("ds49: works as expected with local variable.", {
library(fmtr)
myfmt <- value(condition(x >= 20, "High"),
condition(x < 20, "Low"))
# format = list(mpg=myfmt),
d1 <- datastep(mtcars, {
mpgcat <- fapply(mpg, myfmt)
})
d1
expect_equal("mpgcat" %in% names(d1), TRUE)
expect_equal(d1$mpgcat[1], "High")
})
test_that("ds50: works as expected with source.all().", {
if (dev) {
pth <- file.path(dirname(base_path), "programs")
res <- common::source.all(pth)
expect_equal(res$Status, 0)
} else {
expect_equal(TRUE, TRUE)
}
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.