tests/testthat/test-followup_dropout_atrisk.R

In scientific-computing-solutions/eventPrediction: Event Prediction in Clinical Trials with Time-to-Event Outcomes

#Predict from parameters
context("followup")

test_that("no_follow_up_and_lag_for_now",{
 
  l1 <- LagEffect(Lag.T=5,L.Ctr.median=3)
  expect_error(SingleArmCRGIStudy(N=100,study.duration=100,ctrl.time=12,ctrl.prop=0.5,k=1,acc.period=10,shape=1,
                             followup=12,lag.settings=l1))
  
  
})


test_that("CRGI_follow_up_non_finite",{
  crgi <- SingleArmCRGIStudy(N=100,study.duration=100,ctrl.time=12,ctrl.prop=0.5,k=1,acc.period=10,shape=1,
                             followup=12)
  
  prediction <- predict(crgi,time.pred=c(22,100),step.size=1)
  expect_equal(c(50,50),prediction@predict.data$events.tot)
  
  crgi <- CRGIStudy(N=100,study.duration=100,ctrl.time=10,ctrl.prop=0.65,k=1,acc.period=10,shape=1.2,
                    alpha=0.05,power=0.6,two.sided=TRUE,HR=0.5,r=1,followup=12)
  
  prediction <- predict(crgi,time.pred=c(22,100),step.size=1)
  rate <- (-log(0.35))^(1/1.2)/10
  prop <- 1-exp(-(12*rate)^1.2)
  ans <- prop*50+50*(1-(1-prop)^0.5) #control + active arm
  
  expect_equal(c(ans,ans),prediction@predict.data$events.tot) #same answer for time=22 and time =100
  
})

test_that("CRGI_inf_followup_isOncology",{
  
  l1 <- LagEffect(Lag.T=5,L.Ctr.median=3,L.HazardRatio=0.4)
  onco <- Study(N=100,study.duration=100,ctrl.median=10,k=1.5,acc.period=10.5,shape=1.2,
                alpha=0.05,power=0.6,two.sided=TRUE,HR=0.5,r=1.3,lag.settings=l1)
  
  
  crgi <- CRGIStudy(N=100,study.duration=100,ctrl.time=10,ctrl.prop=0.5,k=1.5,acc.period=10.5,shape=1.2,
                    alpha=0.05,power=0.6,two.sided=TRUE,HR=0.5,r=1.3,followup=Inf,lag.settings=l1)
  
  
  predict.onco <- predict(onco,step.size=1)
  predict.crgi <- predict(crgi,step.size=1)
  
  expect_equal(predict.onco@grid,predict.crgi@grid)
  
})

context("dropout")

test_that("half_dropout",{
  crgi <- SingleArmCRGIStudy(N=100,study.duration=1000,ctrl.time=12,ctrl.prop=0.5,k=1,acc.period=10,shape=2.1,
                             followup=Inf,dropout=list(time=12,proportion=0.5,shape=2.1))
  
  pred <- predict(crgi,step.size=10,time.pred=1000)
  
  expect_equal(50,pred@predict.data$events.tot[1],tol=1e-7)
  
})

test_that("correct_proportion_dropout",{
  crgi <- SingleArmCRGIStudy(N=100,study.duration=1000,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=10,shape=2.1,
                             followup=Inf,dropout=list(time=12,proportion=0.5,shape=2.1))
  
  lambda <- log(2)^(1/2.1)/6
  dropout.lambda <- log(2)^(1/2.1)/12
  
  pred <- predict(crgi,step.size=10,time.pred=1000)
  expect_equal(pred@sfns[[1]]@lambda,lambda)
  expect_equal(pred@sfns[[1]]@dropout.lambda,dropout.lambda)
  
  expect_equal(100/(1+(dropout.lambda/lambda)^2.1), pred@predict.data$events.tot[1],tol=1e-7)
  
  
})

test_that("correct_proportion_2_arm",{
  crgi <- CRGIStudy(N=100,study.duration=1000,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=10,shape=0.8,
                             followup=Inf,dropout=list(time=12,proportion=c(0.5,0.5),shape=0.8),two.sided=TRUE,
                    alpha=0.4,power=0.5,HR=0.75,r=1)
  
  lambda <- log(2)^(1/0.8)/6
  dropout.lambda <- log(2)^(1/0.8)/12
  active.lambda <- log(2)^(1/0.8)/6*0.75^(1/0.8)
  pred <- predict(crgi,step.size=10,time.pred=1000)
  
  expect_equal(pred@sfns[[1]]@lambda,lambda)
  expect_equal(pred@sfns[[1]]@dropout.lambda,dropout.lambda)
  expect_equal(pred@sfns[[2]]@lambda,active.lambda)
  expect_equal(pred@sfns[[2]]@dropout.lambda,dropout.lambda)
  expect_equal(pred@sfns[[2]]@shape,0.8)
  
  expect_equal(50/(1+(dropout.lambda/lambda)^0.8), pred@predict.data$events1[1],tol=1e-7)
  expect_equal(50/(1+(dropout.lambda/active.lambda)^0.8), pred@predict.data$events2[1],tol=1e-7)
  
})

test_that("add_lag",{
  l1 <- LagEffect(Lag.T=5,L.Ctr.median=6)
  crgi <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=12,k=1,acc.period=10,shape=1.2,
                             dropout=list(time=12,proportion=0.85),lag.settings=l1)
  
  
  pred <- predict(crgi,step.size=10,time.pred=c(5,1000))
  
  
  crgi_no_lag <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=6,k=1,acc.period=10,shape=1.2,
                                dropout=list(time=12,proportion=0.85))
  
  pred_no_lag <- predict(crgi_no_lag,step.size=10,time.pred=c(5,1000))
  
  expect_equal(pred@predict.data[1,],pred_no_lag@predict.data[1,])
  expect_false(pred@predict.data[2,"events.tot"]==pred_no_lag@predict.data[2,"events.tot"])
  
  #next try with tiny lag
  l2 <- LagEffect(Lag.T=1e-5,L.Ctr.median=6)
  crgi <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=12,k=1,acc.period=10,shape=1.2,
                         dropout=list(time=12,proportion=0.85),lag.settings=l2)
  pred <- predict(crgi,step.size=10,time.pred=1000)
  pred_no_lag <-  pred <- predict(crgi,step.size=10,time.pred=1000)
  expect_equal(pred@predict.data[1,],pred_no_lag@predict.data[1,])
  
  #and compare with no drop outs
  crgi <- SingleArmStudy(N=100,study.duration=50,ctrl.median=2,k=1,acc.period=1,shape=1.2,lag.settings=l1)
  pred <- predict(crgi,step.size=10,time.pred=50)
  crgi_no_drop <- SingleArmStudy(N=100,study.duration=50,ctrl.median=2,k=1,acc.period=1,shape=1.2,
                         dropout=list(time=12000,proportion=0.0001),lag.settings=l1)
  pred_no_drop <- predict(crgi_no_drop,step.size=10,time.pred=50)
  expect_equal(pred@predict.data[1,]$events1,pred_no_drop@predict.data[1,]$events1,tol=3e-4)
})

test_that("droput_sanity_checks",{
  
  #increase dropout probability decreases number of events
  dropout.prop <- seq(0.05,0.95,0.1)
  
  ans <- unlist(lapply(dropout.prop,
         function(x){
      crgi <- SingleArmCRGIStudy(N=100,study.duration=25,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=10,shape=2.1,
                             followup=12,dropout=list(time=12,proportion=x,shape=2.1))

         pred <- predict(crgi,step.size=10,time.pred=25)
         return(pred@predict.data[1,]$events1)
         }
  ))
  
  expect_equal(sort(ans,decreasing=TRUE),ans)
  
  #accrual period does not affect dropouts v events within follow up period
  ans2 <- unlist(lapply(dropout.prop,
              function(x){
               crgi <- SingleArmCRGIStudy(N=100,study.duration=25,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=1,shape=2.1,
                      followup=12,dropout=list(time=12,proportion=x,shape=2.1))
               pred <- predict(crgi,step.size=10,time.pred=25)
              return(pred@predict.data[1,]$events1)
          }
  ))
    
  expect_equal(ans,ans2)
  
  #number of events doesn't decrease
  crgi <- SingleArmCRGIStudy(N=100,study.duration=25,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=1,shape=2.1,
                             followup=12,dropout=list(time=12,proportion=0.5,shape=12.1))
  pred <- predict(crgi)
  expect_equal(sort(pred@grid$events1),pred@grid$events1)
  
})


test_that("check_sfn",{
  crgi <- SingleArmCRGIStudy(N=100,study.duration=25,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=10,shape=2.5,
                             followup=12,dropout=list(time=12,proportion=0.5,shape=1.5))
  
  pred <- predict(crgi,step.size=10)
  
  #wolfram alpha:
  #integrate exp(-(x*0.143939150100)^2.5-(x*0.065268314085)^1.5)*2.5*0.143939150100^2.5*x^1.5 dx, 
  #from x=0 to x=5
  expect_equal(1-0.318725,pred@sfns[[1]]@sfn(5),1e-6)
  expect_equal(1-0.625953,pred@sfns[[1]]@sfn(8),1e-6)
  expect_equal(1-0.762519,pred@sfns[[1]]@sfn(20),2e-6) #only as far as 12
  expect_equal(1-0.762519,pred@sfns[[1]]@sfn(200),2e-6)
  
})

test_that("correct_proportion_integral",{
  
  crgi <- SingleArmCRGIStudy(N=100,study.duration=1000,ctrl.time=6,ctrl.prop=0.5,k=1,acc.period=10,shape=1.1,
                             followup=Inf,dropout=list(time=12,proportion=0.5,shape=0.8))
  
  pred <- predict(crgi,step.size=10,time.pred=1000)
  #wolfram alpha integral
  #integrate exp(-(x*0.119438577760)^1.1-(x*0.052704849831)^0.8)*1.1*0.119438577760^1.1*x^0.1 dx,
  #from x=0 to x=1000
  
  expect_equal(100*0.655972,pred@predict.data$events1,tol=1e-6)
})


context("atrisk")

test_that("no_events_or_dropout",{
  crgi <- CRGIStudy(N=100,study.duration=100,ctrl.time=1000,ctrl.prop=0.01,k=1.42,acc.period=10,shape=1,
                    followup=1,two.sided=TRUE,alpha=0.4,power=0.5,HR=0.75,r=1)
  
  #From 11 months onwards everyone should have been on the trial for exactly 1 month 
  #excluding the minor event probabilities  
  pred <- predict(crgi,step.size=10,time.pred=c(11,25,100))
  
  expect_equal(rep(50,3),pred@predict.data$at.risk1,tol=1e-4)
  expect_equal(rep(50,3),pred@predict.data$at.risk2,tol=1e-4)
  expect_equal(pred@predict.data$at.risk1+pred@predict.data$at.risk2,pred@predict.data$atrisk.tot)
})

test_that("no_events_no_followup",{
  crgi <- CRGIStudy(N=100,study.duration=100,ctrl.time=1000,ctrl.prop=0.001,k=1,acc.period=0.01,shape=1,
                    followup=Inf,two.sided=TRUE,alpha=0.4,power=0.5,HR=0.75,r=1)

  pred <- predict(crgi,step.size=10,time.pred=c(10,20,100))
  #Total at risk should be 100*time.pred
  expect_equal(pred@predict.data$atrisk.tot,c(1000,2000,10000),tol=2e-4)
  
})


test_that("all_events",{
  crgi <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=log(2),k=1,acc.period=1,shape=1)
  
  pred <- predict(crgi,step.size=10,time.pred=1000)
  
  #Expected time on treatment E(X) where X is gamma(100,1) = 100
  expect_equal(100,pred@predict.data$atrisk.tot,tol=1e-7)
  
})

test_that("all_dropout_equal_all_event",{
  
  crgi <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=log(2),k=1,acc.period=1,shape=1.5)
  
  pred <- predict(crgi,step.size=10,time.pred=1000)
  
  crgi.dropout <- SingleArmStudy(N=100,study.duration=1000,ctrl.median=10000000,k=1,acc.period=1,shape=1,
                                 dropout=list(time=log(2),proportion=0.5,shape=1.5))
  
  pred.dropout <- predict(crgi.dropout,step.size=10,time.pred=1000)
  
  expect_equal(pred@predict.data$at.risk1,pred.dropout@predict.data$at.risk1,tol=1e-6)
  #at risk should equal 100*mean of the appropriate Weibull distribution
  expect_equal(pred@predict.data$at.risk1,100*gamma(1+1/1.5)/log(2)^(-1/3))
})