--- a +++ b/tests/testthat/test-singleSimDetails.R @@ -0,0 +1,128 @@ +context("singlesimdetails") + +test_that("simplecase",{ + data(event.data) + + data <- EventData(data=event.data, + subject="subject", rand.date="randDate", + has.event="hasEvent", withdrawn="withdrawn", + time="time", site="site") + + my.fit <- fit(data) + + res <- simulate(my.fit,Nsim=500,seed=123) + ssD <- res@singleSimDetails + + #Corret dimensions + expect_equal(500,ncol(ssD@event.type)) + expect_equal(979,nrow(ssD@event.times)) + + #No dropouts or withdrawn + expect_true(all(ssD@event.type==0)) + + #First 699 rows are subjects who had events + expect_equal(1,length(unique(ssD@event.times[1,]))) + expect_equal(1,length(unique(ssD@event.times[698,]))) + expect_equal(1,length(unique(ssD@event.times[699,]))) + + expect_equal(ssD@event.times[1:699,1],as.numeric(LastDate(data@subject.data)[1:699],origin="1970-01-01") ) + + #All simulated event times are after Last Date for other subjects + expect_true(all(ssD@event.times[700:979,1] >= as.numeric(LastDate(data@subject.data)[700:979],origin="1970-01-01") )) + expect_true(all(ssD@event.times[700:979,41] >= as.numeric(LastDate(data@subject.data)[700:979],origin="1970-01-01") )) + expect_true(all(ssD@event.times[700:979,401] >= as.numeric(LastDate(data@subject.data)[700:979],origin="1970-01-01") )) + expect_true(all(ssD@event.times[700:979,500] >= as.numeric(LastDate(data@subject.data)[700:979],origin="1970-01-01") )) + +}) + +test_that("subject_withdrawn_and_accrual",{ + + data(event.data) + e <- event.data + e$hasEvent[1:4] <- 0 + e$withdrawn[1:4] <- 1 + + data <- EventData(data=e, + subject="subject", rand.date="randDate", + has.event="hasEvent", withdrawn="withdrawn", + time="time", site="site") + + my.fit <- fit(data) + + Naccrual <- 21 + my.accrual <- Generate.PoissonAccrual("2015-11-29",rate=1) + + res <- simulate(my.fit,Nsim=500,seed=123,Naccrual=Naccrual,accrualGenerator=my.accrual) + ssD <- res@singleSimDetails + + + #Corret dimensions + expect_equal(500,ncol(ssD@event.type)) + expect_equal(1000,nrow(ssD@event.times)) + + #correct withdrawn + expect_true(all(ssD@event.type[5:1000,]==0)) + expect_true(all(ssD@event.type[1:4,]==1)) + + +}) + +test_that("fixed_follow_up",{ + data(event.data) + e <- event.data + + expect_warning(data <- EventData(data=e, + subject="subject", rand.date="randDate", + has.event="hasEvent", withdrawn="withdrawn", + time="time", site="site",followup=50)) + + my.fit <- fit(data) + + res <- simulate(my.fit,Nsim=500,seed=123) + ssD <- res@singleSimDetails + + timematrix <- matrix(rep(as.numeric(data@subject.data$rand.date,origin="1970-01-01"),500),ncol=500) + timematrix <- ssD@event.times - timematrix + 1 + + expect_true(all(ssD@event.type[700:979,]==2 | timematrix[700:979,]<=50 )) + expect_true(all(ssD@event.type[700:979,]==0 | timematrix[700:979,]==50 )) + +}) + +test_that("dropout",{ + + my.data <- EmptyEventData() + + Naccrual <- 1000 + + + f <- function(N){ + return(rep(as.Date("2015-01-01"),N)) + } + + my.a <- new("AccrualGenerator",f=f,model="temp",text="temp") + + #small enough rate so no events with this seed + res <- simulate(data=my.data,Nsim=500,seed=123,Naccrual=Naccrual,accrualGenerator=my.a, + SimParams=FromDataParam(type="weibull",rate=0.00000002,shape=1), + dropout=list(proportion=0.5,time=10)) + ssD <- res@singleSimDetails + + expect_true(all(ssD@event.type==1)) + +}) + + +test_that("calculate.at.risk",{ + + rec.times <- matrix(c(rep(16436,4),rep(16500,4),17000,17025,17050,17025),nrow=3,byrow=TRUE) + event.times <- matrix(c(rep(16750,4),17000,16750,16750,17250,18000,17400,17600,17125),nrow=3,byrow=TRUE) + event.type <- matrix(c(rep(0,4),1,2,0,0,1,2,0,0),nrow=3,byrow=TRUE) + ssD <- SingleSimDetails(event.type,event.times,rec.times) + + retVal <- CalculateDaysAtRisk(ssD,c(16000,16436,16437,16500,16750,16751,17020,17030,18000,20000)) + answer <- c(0,1,2,66,566,566.5,701,709.5,1142,1142) + + expect_equal(retVal,answer) + +})