tests/testthat/test-fromParametersSystem.R

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

context("fromParam_systemlevel")

test_that("lag.should.equal.non.lag.in.these.cases",{
  
  l1 <- LagEffect(Lag.T=5,L.Ctr.median=3,L.HazardRatio=0.8)
  l2 <- LagEffect(Lag.T=20,L.Ctr.median=3,L.HazardRatio=0.8)
  
  s1 <- Study(N=1000,study.duration=10,ctrl.median=3,k=1.2,acc.period=5,shape=2,
                       power=0.9,alpha=0.05,r=1,HR=0.8,two.sided=TRUE,
              lag.settings=l1)
  
  s1.nolag <- Study(N=1000,study.duration=10,ctrl.median=3,k=1.2,acc.period=5,shape=2,
              power=0.9,alpha=0.05,r=1,HR=0.8,two.sided=TRUE)
  
  s2 <- Study(N=1000,study.duration=10,ctrl.median=6,k=1.2,acc.period=5,shape=2,
              power=0.9,alpha=0.05,r=1,HR=0.75,two.sided=TRUE,
              lag.settings=l2)
  
  a1 <- predict(s1.nolag,time.pred=c(5,8,10),event.pred=c(10,15))
  
  
  
  a2 <- predict(s1,time.pred=c(5,8,10),event.pred=c(10,15))
  a3 <- predict(s2,time.pred=c(5,8,10),event.pred=c(10,15))
  
  #remove atrisk columns for check:
  p1 <- a1@predict.data
  p2 <- a2@predict.data
  
  p1$at.risk1 <- NULL
  p1$at.risk2 <- NULL
  p1$atrisk.tot <- NULL
  p2$at.risk1 <- NULL
  p2$at.risk2 <- NULL
  p2$atrisk.tot <- NULL
  
  expect_equal(p1,p2) 
  
  #Then check atrisk columns
  expect_equal(a1@predict.data$at.risk1,a2@predict.data$at.risk1,tol=1e-7)
  expect_equal(a1@predict.data$at.risk2,a2@predict.data$at.risk2,tol=1e-7)
  expect_equal(a1@predict.data$atrisk.tot,a2@predict.data$atrisk.tot,tol=1e-7)
  
  expect_equal(a1@grid,a2@grid)
  
  expect_equal(a1@av.hr,a2@av.hr)
  expect_equal(a1@critical.events.req,a2@critical.events.req)
  
  
  
  expect_equal(a1@critical.data$at.risk1,a2@critical.data$at.risk1,tol=1e-7)
  expect_equal(a1@critical.data$at.risk2,a2@critical.data$at.risk2,tol=1e-7)
  expect_equal(a1@critical.data$atrisk.tot,a2@critical.data$atrisk.tot,tol=1e-7)
  
  
  
  expect_equal(a1@sfns[[1]]@lambda,a2@sfns[[1]]@lambda)
  expect_equal(a1@sfns[[2]]@lambda,a2@sfns[[2]]@lambda)
  expect_equal(a2@sfns[[1]]@lambda,a2@sfns[[1]]@lambdaot)
  expect_equal(a2@sfns[[2]]@lambda,a2@sfns[[2]]@lambdaot)
  
  #remove atrisk columns for check:
  p1 <- a1@predict.data
  p2 <- a3@predict.data
  
  p1$at.risk1 <- NULL
  p1$at.risk2 <- NULL
  p1$atrisk.tot <- NULL
  p2$at.risk1 <- NULL
  p2$at.risk2 <- NULL
  p2$atrisk.tot <- NULL
  
  expect_equal(p1,p2) 
  
  #Then check atrisk columns
  expect_equal(a1@predict.data$at.risk1,a3@predict.data$at.risk1,tol=1e-7)
  expect_equal(a1@predict.data$at.risk2,a3@predict.data$at.risk2,tol=1e-7)
  expect_equal(a1@predict.data$atrisk.tot,a3@predict.data$atrisk.tot,tol=1e-7)
  
  expect_equal(a1@grid,a3@grid)
  expect_equal(a1@av.hr,a3@av.hr)
  expect_equal(a1@critical.events.req,a3@critical.events.req)
  expect_equal(a1@critical.data,a3@critical.data)
  
  expect_equal(a1@sfns[[1]]@lambda,a3@sfns[[1]]@lambdaot)
  expect_equal(a1@sfns[[2]]@lambda,a3@sfns[[2]]@lambdaot)
})

test_that("event.and.time.pred.have.symmetry",{
  #Note due to rounding of events the 'symmetry' only works one way...
  
  s1 <- Study(N=1000,study.duration=10,ctrl.median=3,k=1.2,acc.period=5,shape=2,
              power=0.9,alpha=0.05,r=1,HR=0.8,two.sided=TRUE)
  
  a1 <- predict(s1,event.pred=c(100,200,300,400))
  
  time.pred <- a1@predict.data[,"time"]
  
  a2 <- predict(s1,time.pred=time.pred)
  
  expect_true(all(a2@predict.data[,"time.pred"]))
  expect_false(any(a1@predict.data[,"time.pred"]))
  
  a1@predict.data$time.pred <- rep(TRUE,4)
  
  expect_equal(a1@predict.data,a2@predict.data)  
  
})


test_that("recruit",{
  
  k <- c(0.5,1,2)
  
  lapply(k,function(x){
    s <- SingleArmStudy(N=1000,study.duration=10,ctrl.median=3,k=x,acc.period=5,shape=1.2)
    a <- predict(s,time.pred=5/(2^(1/x)))
    expect_equal(1/(2^x)*1000,a@grid[a@grid$time==2.5,]$recruit.tot)
    expect_equal(500,a@predict.data[1,]$recruit.tot)
  })
  
  lapply(k,function(x){
    s <- Study(N=1000,study.duration=10,ctrl.median=3,k=x,acc.period=6,
               shape=1.2,power=0.8,alpha=0.05,two.sided=TRUE,r=1.2,HR=0.8)
    a <- predict(s,time.pred=6/(2^(1/x)))
    expect_equal(1/(2^x)*1000,a@grid[a@grid$time==3,]$recruit.tot)
    expect_equal(500,a@predict.data[1,]$recruit.tot)
  })
  
})


#this fails on versions < 1.0
test_that("max.num.events",{
  l <- LagEffect(Lag.T=5,L.Ctr.median=1,L.HazardRatio=0.5)
  
  s <- Study(N=800,study.duration=36,ctrl.median=3,k=1,acc.period=20,
             shape=1,power=0.8,alpha=0.05,two.sided=TRUE,r=1.2,HR=0.5,lag.settings=l)
  
  a <- predict(s)
  
  expect_true(all(a@grid$events.tot <= 800))
  
  
})

test_that("median",{
  
  ctrl.median <- c(1:5)
  lapply(ctrl.median,function(x){
    s1 <- SingleArmStudy(N=2000,study.duration=20,ctrl.median=x,k=0.01,acc.period=0.000001,shape=1.5)
    a <- predict(s1,event.pred=1000)
    expect_equal(x,a@predict.data[1,]$time)
    
    })
})

test_that("single.arm.matches.2.arm",{
   
  s1 <- Study(N=2000,study.duration=10,ctrl.median=3,k=1.2,acc.period=5,shape=2,
              power=0.9,alpha=0.05,r=1,HR=0.8,two.sided=TRUE)
  
  s2 <- SingleArmStudy(N=1000,study.duration=10,ctrl.median=3,k=1.2,acc.period=5,shape=2)
  
  s3 <- Study(N=2000,study.duration=10,ctrl.median=3*sqrt(0.8),k=1.2,acc.period=5,shape=2,
              power=0.9,alpha=0.05,r=1,HR=0.8,two.sided=TRUE)
  
  a1 <- predict(s1)
  a2 <- predict(s2)
  a3 <- predict(s3)
  
  expect_equal(a1@grid$events1,a2@grid$events.tot)
  expect_equal(a3@grid$events2,a2@grid$events.tot)
})


str1 <- "800 patients recruited, ratio nE/nC=1, 20 months accrual (non-uniform\naccrual, k=2). Lag time: T=4 months, Control for [0,T] median=3 months and\nfor [T,S] Control median=2 months. Exponential survival function.\nHR([0,T])=1 and HR([T,S])=0.5, which gives an average HR=0.77. For a study\nwith no lag and this HR: critical HR value=0.83, alpha(2-sided)=5%,\npower=80%, 466 events required and using the given lag settings: expected\nat time 18.9 months (Experimental/Control: 225/241)."
str2 <- "120 patients recruited, ratio nE/nC=0.5, 20 months accrual (uniform\naccrual, k=1). Control median=2.5 months (lambda=0.29). Experimental\nmedian=4.11 months (lambda=0.18). Weibull survival function shape=1.2.\nHR(Experimental:Control)=0.55, critical HR value=0.71, alpha(1-sided)=5%,\npower=90%, 108 events required expected at time 22.6 months\n(Experimental/Control: 33/75). At (10, 3.2) months the predicted number of\nevents is (37, 5) [Experimental/Control: (10, 1)/(27, 4)]."
str3 <- "100 patients recruited, 5 months accrual (non-uniform accrual, k=1.5). Lag\ntime: T=4 months, Control for [0,T] median=2.5 months and for [T,S]\nControl median=3 months. Weibull survival function shape=2.  At 10 months\nthe predicted number of events is 97."

summary_check <- function(study,time.pred,event.pred,stringoutput){
  prediction <- predict(study,time.pred=time.pred, event.pred=event.pred)
  x <- eventPrediction:::getFromParameterText(prediction,DisplayOptions(text.width=75))
  expect_equal(x,stringoutput)
}

test_that("summary_output",{
  
  lagged <- LagEffect(Lag.T = 4,L.Ctr.median = 3,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.8,
    HR = 0.5, r = 1,N = 800,
    study.duration = 30,ctrl.median = 2,
    k = 2,acc.period = 20,two.sided = TRUE,lag.settings=lagged)
  
  
  summary_check(study,NULL,NULL,str1) 
  
  study <- Study(alpha = 0.05,power = 0.9,
                 HR = 0.55, r = 0.5,N = 120,
                 study.duration = 25,ctrl.median = 2.5,
                 k = 1,acc.period = 20,two.sided = FALSE,shape=1.2)
  
  summary_check(study,10,5,str2)
  lagged <- LagEffect(Lag.T = 4,L.Ctr.median = 2.5)
  study <- SingleArmStudy(N=100,study.duration=10,ctrl.median=3,k=1.5,
                          acc.period=5,shape=2,lag.settings=lagged)
 
  summary_check(study,10,NULL,str3)
})


test_that("critical_hr",{
  # this compares to the output from non-proportional hazards package
  #there are slight differences in the rounding 
  lagged <- LagEffect(Lag.T = 4,L.Ctr.median = 11,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.8036576,
                 HR = 0.6, r =1,N = 780,
                 study.duration = 25.5,ctrl.median = 11,
                 k = 2,acc.period = 18,two.sided = TRUE,shape=1,lag.settings=lagged)
  
  
  prediction <- predict(study)
  
  nph.answer <- 0.8198656
  
  expect_equal(nph.answer,prediction@critical.HR,tol=5e-3)
  
  lagged <- LagEffect(Lag.T = 6,L.Ctr.median = 8,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.9829889,
                 HR = 0.5, r =1.5,N = 800,
                 study.duration = 30,ctrl.median = 8,
                 k = 0.5,acc.period = 18,two.sided = TRUE,shape=1,lag.settings=lagged)
 
  
  prediction <- predict(study)
  
  
  nph.answer <- 0.8534732
  expect_equal(nph.answer,prediction@critical.HR,tol=5e-3)
  
  lagged <- LagEffect(Lag.T = 5,L.Ctr.median = 8,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.9989243,
                 HR = 0.5, r =1.5,N = 800,
                 study.duration = 30,ctrl.median = 8,
                 k = 0.5,acc.period = 6,two.sided = TRUE,shape=1,lag.settings=lagged)
  
  
  prediction <- predict(study)
  
  
  nph.answer <- 0.8572458
  expect_equal(nph.answer,prediction@critical.HR,tol=5e-3)
  
})

test_that("average hazard ratio",{
  # this compares to the output from non-proportional hazards package
  #results do not match exactly: nph uses interval bisection to some tolerance
  #whereas eventPrediction calculates the exact integral and is accruate up to 
  #R's integrate functions accruacy  
  #Also there are slight differences in the rounding of w1 and w2 (see eventPrediction vignette)
  #which will cause small differences to the average HR
  
  lagged <- LagEffect(Lag.T = 4,L.Ctr.median = 11,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.9,
                 HR = 0.6, r =1,N = 780,
                 study.duration = 25.5,ctrl.median = 11,
                 k = 2,acc.period = 18,two.sided = FALSE,shape=1,lag.settings=lagged)
 
  
  prediction <- predict(study)
  
  nph.answer <- 0.7518394
  expect_equal(nph.answer,prediction@av.hr,tol=1.1e-3)
  
  lagged <- LagEffect(Lag.T = 6,L.Ctr.median = 8,  
                      L.HazardRatio=1 )
  
  study <- Study(alpha = 0.05,power = 0.9,
                 HR = 0.5, r =1.5,N = 800,
                 study.duration = 30,ctrl.median = 8,
                 k = 0.5,acc.period = 18,two.sided = FALSE,shape=1,lag.settings=lagged)
  
  
  prediction <- predict(study)
  
  
  nph.answer <- 0.7190647
  expect_equal(nph.answer,prediction@av.hr,tol=1.1e-3)
  
  lagged <- LagEffect(Lag.T = 5,L.Ctr.median = 8,  
                      L.HazardRatio=1 )
  study <- Study(alpha = 0.05,power = 0.5,
                 HR = 0.75, r =1.5,N = 800,
                 study.duration = 30,ctrl.median = 8,
                 k = 0.5,acc.period = 6,two.sided = FALSE,shape=1,lag.settings=lagged)
  
  
  prediction <- predict(study)
  
   
  nph.answer <- 0.8417572
  expect_equal(nph.answer,prediction@av.hr,tol=1.1e-3)
  
})