#library(rpsftm)
#library(survival)
context("Test the rpsftm() function")
full_immdef <- immdef
n <- 200
set.seed(1355)
immdef <- immdef[sample(1:nrow(immdef),size=n),]
test_that("first basict fit with mixed data sources",{
propX <- with(immdef,1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX),immdef, censyrs)
expect_is(fit$psi, "numeric")
})
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs)
fit_coxph <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
test=coxph)
fit_survreg <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
test=survreg)
test_that("print method",{
expect_output(print(fit),"exp\\(psi\\):")
expect_output(print(fit_coxph),"exp\\(psi\\):")
expect_output(print(fit_survreg),"exp\\(psi\\):")
#this is a test that the end of file is valid witha new line - a warning is issued from readLines()
expect_failure(expect_warning(
{
file <- tempfile()
sink(file)
print(fit)
sink()
readLines(file, warn=TRUE)
}))
})
test_that("summary method",{
# fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
# low_psi=-1, hi_psi=1)
# fit_coxph <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
# test=coxph)
# fit_survreg <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
# test=survreg)
expect_output(summary(fit),"Confidence Interval")
expect_output(summary(fit_coxph),"Confidence Interval")
expect_output(summary(fit_survreg),"Confidence Interval")
#this is a test that the end of file is valid witha new line - a warning is issued from readLines()
expect_failure(expect_warning(
{
file <- tempfile()
sink(file)
summary(fit)
sink()
readLines(file, warn=TRUE)
}))
})
context("Placemarker for end of end-of-line tests")
test_that("detailed print.coxph test",{
x <- list(fail="yes")
class(x) <- "rpsftm"
expect_output(print(x),"Fitting failed")
class(x) <- "coxph"
expect_output(print(x),"Coxph failed")
site <- rep(1:10,length.out=n)
fit_coxph <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+cluster(site)+entry,immdef, censor_time = censyrs,
test=coxph)
expect_output(print(fit_coxph),"robust")
}
)
test_that("detailed print.summary.coxph test",{
site <- rep(1:10,length.out=n)
fit_coxph <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+entry,immdef, censor_time = censyrs,
test=coxph)
expect_output(summary(fit_coxph),"coef")
fit_coxph$fail <- "yes"
expect_output(summary(fit_coxph),"Coxreg failed")
}
)
fit_coxph$fail <- NULL
test_that("detailed print.survreg test",{
x <- list(fail="yes")
class(x) <- "survreg"
expect_output(print(x),"Survreg failed")
site <- rep(1:5,length.out=n)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+entry,immdef, censor_time = censyrs,
test=survreg, scale=1)
expect_output(print(fit),"Scale fixed at")
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+strata(site),immdef, censor_time = censyrs,
test=survreg)
expect_output(print(fit),"Scale:")
}
)
test_that("detailed print.summary.survreg test",{
site <- rep(1:5,length.out=n)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+entry,immdef, censor_time = censyrs,
test=survreg, scale=1)
expect_output(print(fit),"Scale fixed at")
fit$fail <- "yes"
expect_output(summary(fit),"Survreg failed")
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs)+strata(site),immdef, censor_time = censyrs,
test=survreg)
expect_output(summary(fit),"Scale:")
expect_output(summary(fit,correlation=TRUE),"Correlation of Coefficients")
}
)
test_that("plot method",{
#fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
# low_psi=-1, hi_psi=1)
fig <- plot(fit)
expect_s3_class(fig, class="ggplot")
})
test_that("first basic fit with the arm as a factor",{
myArm <- factor(immdef$imm, labels=c("Control","Exper"))
fit <- rpsftm(Surv(progyrs, prog)~rand(myArm,1-xoyrs/progyrs),immdef, censor_time = censyrs,#formula=~1,
low_psi=-1, hi_psi=1)
expect_is(fit$psi, class="numeric")
})
test_that("with no data argument at all",{
propX <- with(immdef, 1-xoyrs/progyrs)
fit <- rpsftm(Surv(immdef$progyrs, immdef$prog)~rand(immdef$imm, propX)+immdef$entry,
censor_time = immdef$censyrs, test=coxph,
low_psi=-1, hi_psi=1
)
expect_is(fit$psi, class="numeric")
}
)
test_that("fit with treatment weights",{
propX <- with(immdef,1-xoyrs/progyrs)
weight <- with(immdef, ifelse(imm==1, 1, 0.5))
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX),immdef, censor_time = censyrs,treat_modifier=weight,
low_psi=-1, hi_psi=1)
expect_is(fit$psi, class="numeric")
})
test_that("Values from a basic fit match up with the Stata output",
{
propX <- with(full_immdef, 1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), full_immdef, censor_time = censyrs ,
low_psi=-1, hi_psi=1)
psivalue <- -0.1816406 <=fit$psi & fit$psi<= -.1806641
ciLower <- -0.3505859<=fit$CI[1] & fit$CI[1]<= -0.3496094
ciUpper <- 0.0019531<=fit$CI[2] & fit$CI[2]<= 0.0029297
expect_true(psivalue)
expect_true(ciLower)
expect_true(ciUpper)
})
test_that("Try it with Censoring off",
{
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef,
low_psi=-1, hi_psi=1)
expect_s3_class(fit, class="rpsftm")
}
)
test_that("Try it with autoswitch off",
{
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1, autoswitch = FALSE)
expect_s3_class(fit, class="rpsftm")
}
)
##Check that swapping the definitions of arm has no effect (on point estimates), and that 1-rx reverses the estimates and CIs
test_that("swapping the definition of arm",
{ propX <- with(immdef, 1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1)
propX <- with(immdef, 1-xoyrs/progyrs)
fitInv <- rpsftm(Surv(progyrs, prog)~rand(1-imm,propX), immdef, censor_time = censyrs,test=survdiff,
low_psi=-1, hi_psi=1)
expect_true( abs(fit$psi-fitInv$psi)<1e-4)}
)
test_that("swapping the definition of rx",
{ propX <- with(immdef, 1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1)
propXInv <- 1-with(immdef, 1-xoyrs/progyrs)
fitInv2 <- rpsftm(Surv(progyrs, prog)~rand(imm,propXInv), immdef, censor_time = censyrs,test=survdiff,
low_psi=-1, hi_psi=1)
expect_true( abs(fit$psi+fitInv2$psi)<1e-4)}
)
test_that("swapping the definition of arm and rx",
{ propX <- with(immdef, 1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1)
propXInv <- 1-with(immdef, 1-xoyrs/progyrs)
fitInv3 <- rpsftm(Surv(progyrs, prog)~rand(1-imm,propXInv), immdef, censor_time = censyrs,test=survdiff,
low_psi=-1, hi_psi=1)
expect_true( abs(fit$psi+fitInv3$psi)<1e-4)
expect_true( abs(fit$CI[1]+fitInv3$CI[2])<1e-4)
expect_true( abs(fit$CI[2]+fitInv3$CI[1])<1e-4)
}
)
test_that( "no t-test comparison avaialable",
{propX <- with(immdef,1-xoyrs/progyrs)
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1)
expect_error( update(fit, test=t.test))}
)
test_that( "check variants on fitting",
{propX <- with(immdef,1-xoyrs/progyrs)
# fit <- rpsftm(Surv(progyrs, prog)~rand(imm,propX), immdef, censor_time = censyrs,
# low_psi=-1, hi_psi=1)
f0 <- fit
f1 <- update(fit, test=coxph)
f2 <- update(fit, test=survreg, dist="weibull")
f3 <- update(fit, test=survreg, dist="exponential")
f4 <- update(fit, test=survreg, dist="loglogistic")
f5 <- update(fit, test=survreg, dist="gaussian")
f6 <- update(fit, test=survreg, dist="lognormal")
fits <- list(f0,f1,f2,f3,f4,f5,f6)
for( obj in fits){
expect_s3_class(obj, class="rpsftm")
}
#lapply(fits, expect_s3_class, class="rpsftm")
}
)
## need to create some data for strata cluster, covariates.
##These may need to be specific to different fit, ie. adjustment is different for survdiff and coxph.
test_that("Check that a strata and cluster fits",
{
f0 <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs), immdef, censor_time = censyrs,
low_psi=-1, hi_psi=1
#formula=~1
)
immdef$category <- rep(c("A","B","C","D"),length.out=n)
immdef$covar <- rnorm(n)
immdef$clusterId <- rep(1:100,length.out=n)
f0 <- update(f0, data=immdef)
f0.strata <- update(f0,~.+strata(category))
f1 <- update(f0, test=coxph)
f1.All <- update(f1,~.+strata(category)+covar+cluster(clusterId))
expect_s3_class(f0.strata, class="rpsftm")
expect_s3_class(f1.All, class="rpsftm")
})
test_that("subset argument check",
{fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef,
censor_time = censyrs, entry<1)
expect_is(fit$psi, class="numeric")
}
)
test_that("subset update check",
{fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef,
censor_time = censyrs, entry<1)
fit <- update(fit, .~., subset=NULL)
expect_is(fit$psi, class="numeric")
}
)
test_that("updating of data argument",
{
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),subset(immdef, entry<1))
fit <- update(fit, data= subset(immdef, entry>=1))
expect_is(fit$psi, class="numeric")
}
)
test_that("eval_z output",
{
fit <- rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),
data=immdef, censor_time = censyrs, n_eval_z=40)
expect_equal(dim(fit$eval_z)[1],40)
}
)
test_that("check it works when arm=rx",
{fit <- rpsftm(Surv(progyrs, prog)~rand(imm, imm), immdef, censor_time = censyrs)
expect_is(fit$psi, class="numeric")
}
)
test_that("symbolic covariates",
{immdef$sqrent <- with(immdef, sqrt(entry))
fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+sqrent,
data=immdef, censor_time=censyrs, test=coxph)
fit2 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+sqrt(entry),
data=immdef, censor_time=censyrs, test=coxph)
expect_equal(fit1$psi,fit2$psi)
}
)
test_that("symbolic covariates log transform",
{immdef$logentr <- with(immdef, log(entry+1))
fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+logentr,
data=immdef, censor_time=censyrs, test=coxph)
fit2 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+log(entry+1),
data=immdef,censyrs, test=coxph)
expect_equal(fit1$psi, fit2$psi)
}
)
test_that("survfit",{
# fit0 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+entry,
# data=immdef, censor_time=censyrs, test=coxph)
# fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs),
# data=immdef, censor_time=censyrs, test=survdiff)
# fit2 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+entry,
# data=immdef, censor_time=censyrs, test=survreg)
expect_s3_class(survfit(fit_coxph), class="survfit")
expect_error(survfit(fit),"No applicable method")
expect_error(survfit(fit_survreg),"No applicable method")
}
)
test_that("residual",{
fit0 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+entry,
data=immdef, censor_time=censyrs, test=coxph)
fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1-xoyrs/progyrs)+entry,
data=immdef, censor_time=censyrs, test=survreg)
expect_is(residuals(fit0), class="numeric")
expect_is(residuals(fit1, "dfbetas"), class="matrix")
expect_s3_class(cox.zph(fit0, transform="rank"), "cox.zph")
expect_error(cox.zph(fit1),"This model did not use coxph within g-estimation")
})
test_that("extract_z",{
expect_warning(
rpsftm(Surv(progyrs, prog)~rand(imm,1-xoyrs/progyrs),immdef[1:2,], censor_time = censyrs),
"Multiple Roots found"
)
})
test_that("print.summary.rpsftm",{
immdef2 <- immdef
for( i in 1:nrow(immdef2)){
if( i%%2==0) immdef2[i,] <- NA
}
fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1 -xoyrs/progyrs), immdef2, censor_time=censyrs, test= coxph)
expect_output(summary(fit1),"observations deleted due to missingness")
fit3 <- rpsftm(Surv(progyrs,prog)~rand(imm,1 -xoyrs/progyrs), immdef2, censor_time=censyrs, test= survreg,scale=0.5)
#this is just toget coverage of line 109 in summary.rpsftm.R
expect_output(print(summary(fit3), digits=NULL), "Scale fixed")
expect_output(summary(fit3), "observations deleted due to missingness")
}
)
test_that("print.rpsftm",{
immdef2 <- immdef
for( i in 1:nrow(immdef2)){
if( i%%2==0) immdef2[i,] <- NA
}
fit1 <- rpsftm(Surv(progyrs,prog)~rand(imm,1 -xoyrs/progyrs), immdef2, censor_time=censyrs, test= coxph)
fit3 <- rpsftm(Surv(progyrs,prog)~rand(imm,1 -xoyrs/progyrs), immdef2, censor_time=censyrs, test= survreg,scale=0.5)
expect_error(print.rpsftm.coxph(NULL),"Input is not valid")
expect_output(print(fit1),"observations deleted due to missingness")
expect_output(print(fit3),"observations deleted due to missingness")
})
#CHECK that each line of code has been called somehow in this testing process??
#DONE:
#> #install.packages("covr")
#> library(covr)
#> cov <- package_coverage()
#> cov
#> zero_coverage(cov)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.