tests/testthat/test-fromParametersInternal.R

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

context("fromParametersInternal")

test_that("getNS",{
  expect_equal(c(10,0),getNs(TRUE,r=1,N=10))
  expect_equal(c(6,0),getNs(TRUE,r=0,N=6))
  
  expect_equal(c(50,50),getNs(FALSE,r=1,N=100))
  expect_equal(c(25,75),getNs(FALSE,r=3,N=100))
  expect_equal(c(150,50),getNs(FALSE,r=1/3,N=200))
  
  expect_equal(c(44,56),getNs(FALSE,r=1.3,N=100))
  
  expect_equal(c(134,266),getNs(FALSE,r=2,N=400))
  expect_equal(c(267,133),getNs(FALSE,r=1/2,N=400))
  
  
  expect_error(getNS(FALSE,r=1/9, N=6))
  
})

test_that("events_required",{
  
  expect_true(abs(RequiredEvents(1,0.05,0.9,0.9,3086)-3085.838 ) < 1e-3)
  expect_warning(RequiredEvents(1,0.05,0.9,0.9,1000))
  expect_warning(RequiredEvents(1,0.05,0.9,0.9,3085))

  
  expect_true(abs(RequiredEvents(3,0.05,0.9,0.4,10000)-54.40027 ) < 1e-3)
  
  expect_equal(RequiredEvents(2,0.1,0.95,0.9,10000),RequiredEvents(2,0.05,0.9,0.9,10000))
  
  expect_true(abs(RequiredEvents(4,pnorm(0.1),pnorm(0.9),exp(-2/5),100)-25.0) < 1e-3)
  
})

test_that("lambda.calc",{
  
  l1 <- lambda.calc(1,NA,1)
  expect_true(is.na(l1[2]))
  expect_equal(log(2),l1[1])
  
  expect_error(lambda.calc(c(1,2),NA,1))
  expect_error(lambda.calc(1,c(1,2),1))
  
  expect_equal( c(log(2)^0.5/4,0.8^0.5*log(2)^0.5/4 ),lambda.calc(4,0.8,2) )
})

          
test_that("event.integrate",{
  
  #events.integ <- function( SurvFn, B, k, t) 
  s <- GetSurvivalFunctions(2,NA,lag.T=0,isSingleArm=TRUE,shape=1,followup=Inf,dropout.shape=1,dropout.lambda=0)
  
  expect_equal(0,events.integ(s[[2]],1,1,2))
  
  #first k=1 with B=1
  
  #have m/B - [exp(m*lambda)-1]*[exp(-lambda*t)]/[B*lambda]
  ans <- 1-exp(-2*2)*(exp(2)-1)/2
  expect_equal(ans,events.integ(s[[1]],B=1,k=1,t=2))
  ans2 <-0.5-exp(-1)*(exp(1)-1)/2
  expect_equal(c(ans,ans2),events.integ(s[[1]],B=1,k=1,t=c(2,0.5)))
  
  #next keep k=1 and set B=2.5
  ans <- 2/2.5-exp(-2*2)*(exp(2*2)-1)/(2*2.5)
  ans2 <-1-exp(-2*3)*(exp(2.5*2)-1)/(2*2.5)
  
  expect_equal(c(ans,ans2),events.integ(s[[1]],B=2.5,k=1,t=c(2,3)))
  
  #Next have a go with k=3, shape=1
  k_equal_three <- function(m,B,lambda,t){
    (m/B)^3 - 3*exp(-lambda*t)*(exp(lambda*m)*(lambda*m*(lambda*m-2)+2)-2)/(B^3*lambda^3)
  }
  
  ans <- k_equal_three(1,4,2,1)
  ans2 <- k_equal_three(4,4,2,5)
  expect_equal(c(ans,ans2),events.integ(s[[1]],B=4,k=3,t=c(1,5)))
  
  #Try k=2, shape =2 just because we can
  erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
  integral_val_yes_really <- function(m,B,l,t){
    (m/B)^2-(sqrt(pi)*l*t*(erf(l*(m-t))+erf(l*t))-exp(-l^2*(m-t)^2)+exp(-l^2*t^2) )/(B^2*l^2)
  }
  
  
  s <- GetSurvivalFunctions(2,NA,lag.T=0,isSingleArm=TRUE,shape=2,followup=Inf,dropout.shape=1,dropout.lambda=0)
  ans <-  integral_val_yes_really(1,4,2,1)
  ans2 <-  integral_val_yes_really(4,4,2,5)
  
  expect_equal(c(ans,ans2),events.integ(s[[1]],B=4,k=2,t=c(1,5)))
  
  #Simple case k=1 with a lag
  s <- GetSurvivalFunctions(2,4,lag.T=1,isSingleArm=TRUE,shape=2,followup=Inf,dropout.shape=1,dropout.lambda=0)
  
  expect_equal(c(0,1),events.integ(s[[1]],B=4,k=2,t=c(0,Inf)))
  
  
  
})          
          
          
test_that("surivalfunctions_with_followup",{
  isSingleArm <- TRUE
  lag.T <- 0
  shape <- 1.2
  
  s <- GetSurvivalFunctions(0.02,NA,lag.T,isSingleArm,shape,followup=12,dropout.shape=1,dropout.lambda=0)
  
  expect_equal(s[[1]]@sfn(c(12,14,100,Inf)),rep(exp(-(12*0.02)^shape),4))
  expect_false(s[[1]]@sfn(11.9)==exp(-(12*0.02)^shape))  
  s.n.follow <- GetSurvivalFunctions(0.02,NA,lag.T,isSingleArm,shape,followup=Inf,dropout.shape=1,dropout.lambda=0)
  expect_equal(s.n.follow[[1]]@sfn(c(1,4,12)),s[[1]]@sfn(c(1,4,12)))
  
  
})          
          
          
          
test_that("get_survival_functions_no_lag",{

  isSingleArm <- TRUE
  lag.T <- 0
  shape <- 1.2
  
  s <- GetSurvivalFunctions(4,NA,lag.T,isSingleArm,shape,followup=Inf,dropout.shape=1,dropout.lambda=c(0,0))
  
  expect_true(is.vector(s))
  expect_equal(2,length(s))
   
  expect_equal(s[[2]],NullSfn())
  
  e1 <- as.list(environment(s[[1]]@sfn))
  expect_equal(4,e1$lambda)
  expect_equal(shape,e1$shape)
  
  x <- seq(0,20,0.1)
  y1 <- s[[1]]@sfn(x)
  y2 <- exp(-(4*x)^shape)
  
  expect_equal(y2,y1)
  
  shape <- 1
  isSingleArm <- FALSE
  s2 <- GetSurvivalFunctions(c(4,2),NA,lag.T,isSingleArm,shape,followup=Inf,dropout.shape=1,dropout.lambda=c(0,0))
  
  expect_true(is.vector(s))
  expect_equal(2,length(s))

  
  y1 <- s2[[1]]@sfn(x) 
  y2 <- exp(-(4*x)^shape)
  expect_equal(y1,y2)
  
  y1 <- s2[[2]]@sfn(x) 
  y2 <- exp(-(2*x)^shape)
  expect_equal(y1,y2)
  
  
})


test_that("get_survival_functions_with_lag",{
  
  isSingleArm <- TRUE
  lag.T <- 5
  shape <- 1.2
  
  s <- GetSurvivalFunctions(4,3,lag.T,isSingleArm,shape,followup=Inf,dropout.shape=1,dropout.lambda=c(0,0))
  
  expect_true(is.vector(s))
  expect_equal(2,length(s))
  expect_equal(s[[2]],NullSfn())
  
  e1 <- as.list(environment(s[[1]]@sfn))
  expect_equal(4,e1$lambda)
  expect_equal(shape,e1$shape)
  expect_equal(lag.T,e1$lag.T)
  expect_equal(3,e1$lambdaot)
  
  x <- seq(0,20,0.1)
  y1 <- s[[1]]@sfn(x)
  y2 <- ifelse(x<lag.T, exp(-(3*x)^shape),exp(-(4*x)^shape+(3^shape-4^shape)*lag.T^shape)) 
    
  
  expect_equal(y2,y1)
  
  lag.T <- 3
  isSingleArm <- FALSE
  shape <- 1.32
  s <- GetSurvivalFunctions(c(4,2),c(3,1),lag.T,isSingleArm,shape,followup=Inf,dropout.shape=1,dropout.lambda=c(0,0))
  y1 <- s[[1]]@sfn(x)
  y2 <- ifelse(x<lag.T, exp(-(3*x)^shape),exp(-(4*x)^shape+(4^shape-3^shape)*lag.T^shape)) 
  expect_equal(y1,y2)
  
  y1 <- s[[2]]@sfn(x)
  y2 <- ifelse(x<lag.T, exp(-(x)^shape),exp(-(2*x)^shape+(2^shape-1)*lag.T^shape)) 
  expect_equal(y1,y2)
  
})