Models:
Joseph Gordon
joseph-gordon/
eventPrediction
0
Downloads: 1
[f2e496]: / tests / testthat / test-fromDataSimParam.R

Download this file

101 lines (73 with data), 3.4 kB 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
context("fromDataSimParam")



test_that("FromDataParam_rate_shape_input",{

  

  expect_error(FromDataParam(type="c",rate=1,shape=1))

  expect_error(FromDataParam(type="weibull",rate=1e-25,shape=1))

  expect_error(FromDataParam(type="weibull",rate=1,shape=c(1,2,3)))

  expect_error(FromDataParam(type="weibull",rate=1,shape=-1))

  expect_error(FromDataParam(type="weibull",rate=1,sigma=matrix(c(0,0,0,0),ncol=2)))

  expect_error(FromDataParam(type="weibull",rate=1,shape=1,sigma=matrix(c(0,0,0,0),ncol=1)))

  expect_error(FromDataParam(type="weibull",rate=1,shape=1,sigma=matrix(c("a","b","a","c"),ncol=2)))

  expect_error(FromDataParam(type="weibull",rate=1,shape=1,sigma=matrix(c(0,4,5,0),ncol=2)))



  x <- FromDataParam(type="weibull",rate=1.4,shape=1)  

  expect_equal("weibull",x@type)

  expect_equal(1.4,x@parameters$rate)

  expect_equal(1,x@parameters$shape)

  expect_equal(matrix(c(0,0,0,0),ncol=2),x@parameters$sigma)

  

  m <- matrix(c(1,5.6,5.6,8),ncol=2)

  x <- FromDataParam(type="weibull",rate=1.4,shape=1,sigma=m)

  expect_equal(m,x@parameters$sigma)

  

  

})



test_that("Weibull_generate_sim_params",{

  

  x <- FromDataParam(type="weibull",rate=1.4,shape=1) 

  

  gPF <- x@generateParameterFunction(10)

  expect_true(is.matrix(gPF))

  expect_equal(10,nrow(gPF))

  expect_equal(c("Id","rate","shape"),colnames(gPF))

  expect_equal(1:10,gPF[,1])

  expect_equal(rep(1.4,10),gPF[,2])

  expect_equal(rep(1,10),gPF[,3])

  

  x <- FromDataParam(type="weibull",rate=4,shape=1,sigma=matrix(c(1,0,0,1),nrow=2)) 

  gPF <- x@generateParameterFunction(8)

  expect_true(all(rep(1.4,8) != gPF[,2]))

})





test_that("weibull_generate_times",{

  x <- FromDataParam(type="weibull",rate=1.4,shape=1.2) 

  

  gPF <- x@generateParameterFunction(1)

  

  set.seed(10)

  times <- x@conditionalFunction(c(1,2,3,4,5),params=gPF[1,],HR=c(1,1,1,1,1) )

  expect_equal(5,length(times))

  expect_true(all( 1:5< times))

  

  set.seed(10)

  times.HR <- x@conditionalFunction(c(1,2,3,4,5),params=gPF[1,],HR=c(1,0.5,0.5,0.5,0.5) )

  expect_equal(times[1],times.HR[1])

  expect_true(all(times <= times.HR))

})



test_that("FromDataSurvreg",{

 

  df <- data.frame(time=rweibull(100,shape=1.1,scale=1.1),has.event=rep(1,100))

  

  model <- survreg(Surv(time,has.event) ~ 1,data=df,dist="weibull")

  #hack to check shape and rate at working properly

  model$coefficients <- log(1/1.2)

  model$scale <- 2

  model$var <- matrix(c(0.01,-0.01,-0.01,0.005),ncol=2)

  

  x <- FromDataParam(model,type="weibull")

  expect_equal(1.2,x@parameters$rate)

  expect_equal(0.5,x@parameters$shape)

  expect_equal(model$var,x@parameters$sigma)

})





test_that("loglogistic",{

  df <- data.frame(time=rweibull(100,shape=1.1,scale=1.1),has.event=rep(1,100))

  

  model <- survreg(Surv(time,has.event) ~ 1,data=df,dist="loglogistic")

  expect_error(FromDataParam(model,type="weibull"))

  

  x <- FromDataParam(model,type="loglogistic")

  expect_equal("loglogistic",x@type)

  

  rloglogis <- function(n,shape,scale){

    u <- runif(n)

    (u/(1-u))^(1/shape)*scale

  }

  set.seed(10)

  x <- rloglogis(n=1000000,shape=1.2,scale=0.5)

  ans <- survreg(Surv(x,rep(TRUE,length(x)))~1,dist="loglogistic")

  a <- FromDataParam(ans,type="loglogistic")

  

  expect_true(abs(a@parameters$rate-2)<1e-2) #stochastic

  expect_true(abs(a@parameters$shape-1.2)<1e-2)#stochastic 

  

})