if(length(para.marg) > length(margins)){
print("Choose the vectors with the same length with margins!")
para.marg <- para.marg[1:length(margins)]
}
para.list <- argg[para.marg]
}
margs.para.list <- CheckParaList(margins=margins, para.list=para.list)
if(is.null(dependence)){
dependence <- rvinecopulib::bicop_dist(family="indep")
Indep <- TRUE
} else{
Indep <- FALSE
}
npv <- sapply(margs.para.list, length)
np <- sum(npv)
parav <- unlist(margs.para.list)
y <- list(margins=margins, margs.para.list=margs.para.list,
dependence=dependence, Indep=Indep,
npv=npv, np=np, parav=parav)
class(y) <- "LttCmpRsk"
invisible(y)
}
# Gamma is not applicable
CheckParaList <- function(margins=c("weibull", "weibull"), para.list=NULL){
stopifnot(length(margins)>1, !is.null(para.list), class(para.list)=="list", length(para.list)==length(margins))
rmarg <- lapply(paste0("r", margins), get)
margs.para.list <- lapply(rmarg, function(x) as.list(args(x))[-1])
margs.para.list <- lapply(margs.para.list, function(x) x[-length(x)])
for(i in 1:length(para.list)){
marg.parai <- margs.para.list[[i]]
user.parai <- para.list[[i]]
marg.parai.name <- names(marg.parai)
user.parai.name <- names(user.parai)
marg.para.np <- length(marg.parai)
user.para.np <- length(user.parai)
stopifnot(user.para.np > 0)
if(user.para.np > marg.para.np){
print(marg.parai)
print(user.parai)
print(paste(margins[i], "has less parameters than specified. Then choose!"))
user.parai <- user.parai[1:(marg.para.np)]
}
if(user.para.np==marg.para.np){
if(is.null(user.parai.name)){
names(user.parai) <- marg.parai.name
marg.parai <- as.list(user.parai)
}
# To improve this function, consider the case with the existed name and the null name
if(!is.null(user.parai.name) && (any(user.parai.name %in% marg.parai.name))){ #
id <- which(user.parai.name %in% marg.parai.name, arr.ind = TRUE)
user.parai.name[-id] <- marg.parai.name[-id]
names(user.parai) <- user.parai.name
marg.parai <- as.list(user.parai)
}
if(!is.null(user.parai.name) && (!any(user.parai.name %in% marg.parai.name))){ #
names(user.parai) <- marg.parai.name
marg.parai <- as.list(user.parai)
}
}
if(user.para.np < marg.para.np){
if(is.null(user.parai.name)){
marg.parai[1:user.para.np] <- user.parai
names(marg.parai) <- marg.parai.name
}
if(!is.null(user.parai.name) && (length(user.parai.name) < user.para.np)){
stop("Spcify all the vector name of parameters")
}
if(!is.null(user.parai.name) && (length(user.parai.name) == user.para.np) &&
(!all(user.parai.name %in% marg.parai.name))){
stop("Check the distribution and the corresponding parameters")
}
if(!is.null(user.parai.name) && (length(user.parai.name) == user.para.np) &&
all(user.parai.name %in% marg.parai.name)){
marg.parai[user.parai.name] <- as.list(user.parai)
}
}
margs.para.list[[i]] <- marg.parai
}
for(i in 1:length(margs.para.list)){
if(margins[i]=="gamma"){
user.parai <- para.list[[i]]
user.namei <- names(user.parai)
if(is.null(user.namei)){
margs.para.list[[i]] <- margs.para.list[[i]][c("shape", "rate")]
}
if(any(user.namei %in% c("shape", "rate", "scale")) && length(user.namei)==2){
stopifnot("shape" %in% user.namei)
margs.para.list[[i]] <- margs.para.list[[i]][user.namei]
}
if(any(user.namei %in% c("shape", "rate", "scale")) && length(user.namei)==1){
if(user.namei=="shape"){
x <- c(user.namei, "rate")
margs.para.list[[i]] <- margs.para.list[[i]][x]
}
if((user.namei=="rate") || (user.namei=="rate")){
x <- c(user.namei, "shape")
margs.para.list[[i]] <- margs.para.list[[i]][x]
}
}
}
}
names(margs.para.list) <- margins
margs.para.list
}
ParavecToList <- function(para0.vec, np.vec){
stopifnot(sum(np.vec)==length(unlist(para0.vec)))
if(class(para0.vec)=="list"){
para0.list <- para0.vec
} else{
startid <- c(0, np.vec[-length(np.vec)])
para0.list <- lapply(1:length(np.vec), function(x) para0.vec[sum(startid[1:x]) + 1:np.vec[x]])
}
para0.list
}
loglikexi <- function(cmp.data, cmprsk, Rm, Xid=1){
dist.type <- cmprsk$margins
para.list <- cmprsk$margs.para.list
para0 <- para.list[[Xid]]
deltai <- as.numeric(cmp.data$delta==Xid)
dtype.xi <- dist.type[Xid]
fFRt <- Lttcmprsk_Prob(xcmp=cmp.data, cmprsk = cmprsk)$marg.prob
llk <- sum(deltai*(log(fFRt$ftval[,Xid])-log(fFRt$Rtval[,Xid])) +
(1+Rm)*log(fFRt$Rtval[,Xid]))
list(llk=llk, grad.llk=NULL)
}
loglikeAll <- function(para0, cmprsk, cmp.data, Rm, log.para=FALSE, ...){
if(log.para){
para0 <- exp(unlist(para0))
}
# note para0 length should be equal to the total number in margins
np.vec <- sapply(cmprsk$margs.para.list, length)
para0.list <- ParavecToList(para0.vec = para0, np.vec=np.vec)
cmprsk0 <- LttCmpRsk(margins = cmprsk$margins, para.list = para0.list)
# print(cmprsk0$margs.para.list)
# print(para0)
loglike.list <- lapply(1:length(cmprsk0$margins), function(x) loglikexi(cmp.data = cmp.data,
cmprsk = cmprsk0,
Xid=x, Rm=Rm))
# print(sapply(loglike.list, function(x) x$llk))
sum(sapply(loglike.list, function(x) x$llk))
}
loglikeAll.check <- function(para.list, cmprsk, cmp.data, Rm){
d <- length(cmprsk$margins)
np.vec <- sapply(cmprsk$margs.para.list, length)
para.list <- ParavecToList(para0.vec = para.list, np.vec=np.vec)
para.list <- LttCmpRsk(margins = cmprsk$margins, para.list = para.list)$margs.para.list
delta.list <- lapply(1:d, function(x) as.numeric(cmp.data$delta==x))
mi <- sapply(delta.list, sum)
c1 <- sum(sapply(1:d, function(x) mi[x]*log(para.list[[x]]$scale*log(para.list[[x]]$shape))))
c2 <- sum(1+Rm)*sum(sapply(1:d, function(x) log(para.list[[x]]$shape)-log(para.list[[x]]$shape-1)))
ce <- lapply(1:d, function(x) log(para.list[[x]]$shape^(exp((-1)*cmp.data$tmin*para.list[[x]]$scale))-1))
c3 <- sum(sapply(1:d, function(x) sum(delta.list[[x]]*(para.list[[x]]$scale*cmp.data$tmin +ce[[x]]))))
cr <- lapply(1:d, function(x) log(1-para.list[[x]]$shape^((-1)*exp((-1)*cmp.data$tmin*para.list[[x]]$scale))))
c4 <- sum(sapply(1:d, function(x) sum((1+Rm)*cr[[x]])))
c1+c2-c3+c4
}
loglikeAll.gr <- function(para0, cmprsk, cmp.data, Rm, log.para=FALSE){
d <- length(cmprsk$margins)
if(log.para){
para0 <- exp(para0)
dp <- para0
} else{
dp <- rep(1,d)
}
# print(unlist(para.list))
np.vec <- sapply(cmprsk$margs.para.list, length)
para.list <- ParavecToList(para0.vec = para0, np.vec=np.vec)
para.list <- LttCmpRsk(margins = cmprsk$margins, para.list = para.list)$margs.para.list
gr <- unlist(lapply(1:d, function(x) loglikexi.gr(para= para.list[[x]], cmp.data=cmp.data,
Xid=x, Rm=Rm)))
# print(gr)
gr*dp
}
loglikexi.gr <- function(para, cmp.data, Rm,Xid=1){ #=rep(0, nrow(cmp.data)
# shape, scale - gr[1] gr[2]
deltai <- as.numeric(cmp.data$delta==Xid)
mi <- sum(deltai)
gr <- rep(0, length(para))
wi <- para$shape^(exp((-1)*para$scale*cmp.data$tmin))
wis <- wi^(-1)
vi <- exp((-1)*para$scale*cmp.data$tmin)
c1 <- mi/(para$shape*log(para$shape))
c2 <- sum(1+Rm)/(para$shape*(para$shape-1))
c3 <- (1/para$shape)*sum(deltai*vi/(wis-1))
c4 <- (1/para$shape)*sum((1+Rm)*vi/(wi-1))
gr[1] <- c1 - c2 + c3 + c4
c1 <- mi/para$scale
c2 <- sum(deltai*cmp.data$tmin)
c3 <- log(para$shape)*sum((deltai*cmp.data$tmin*vi/(wis-1)))
c4 <- log(para$shape)*sum((1+Rm)*cmp.data$tmin*vi/(wi-1))
gr[2] <- c1 - c2 - c3 - c4
# print(gr)
gr
}
loglikexi.hessian <- function(para, cmp.data, Rm, Xid=1){
deltai <- as.numeric(cmp.data$delta==Xid)
mi <- sum(deltai)
hs <- matrix(0, ncol=length(para), nrow = length(para))
wi <- para$shape^(exp((-1)*para$scale*cmp.data$tmin))
wis <- wi^(-1)
vi <- exp((-1)*para$scale*cmp.data$tmin)
n <- sum(1+Rm)
c1 <- ((-1)/para$shape^2)*(mi*(1+log(para$shape))/(log(para$shape)^2)+
(n*(1-2*para$shape))/(para$shape-1)^2)
c2 <- ((-1)/para$shape^2)*sum(deltai*vi/(wis-1))
c3 <- (1/para$shape^2)*sum(deltai*vi^2/(wi*(wis-1)^2))
c4 <- ((-1)/para$shape^2)*sum((1+Rm)*vi/(wi-1))
c5 <- ((-1)/para$shape^2)*sum((1+Rm)*vi^2/(wis*(wi-1)^2))
hs[1,1] <- c1 + c2 + c3 + c4 + c5
c1 <- (-1)*mi/para$scale^2
c2 <- sum(deltai*cmp.data$tmin^2*log(para$shape)*vi/(wis-1))
c3 <- sum(deltai*cmp.data$tmin^2*log(para$shape)^2*vi^2/(wi*(wis-1)^2))
c4 <- sum((1+Rm)*cmp.data$tmin^2*log(para$shape)*vi/(wi-1))
c5 <- (-1)*sum((1+Rm)*cmp.data$tmin^2*log(para$shape)^2*vi^2/(wis*(wi-1)^2))
hs[2,2] <- c1 + c2 + c3 + c4 + c5
c01 <- 1+(vi*log(para$shape))/(wi*(wis-1))
c02 <- 1-(vi*log(para$shape))/(wis*(wi-1))
c1 <- ((-1)/para$shape)*sum(deltai*(cmp.data$tmin*vi*c01)/(wis-1))
c2 <- ((-1)/para$shape)*sum(cmp.data$tmin*vi*(1+Rm)*c02/(wi-1))
hs[1,2] <- hs[2,1] <- c1 + c2
hs
}
loglikeAll.hessian <- function(para.list, cmprsk, cmp.data, Rm){
d <- length(cmprsk$margins)
np.vec <- sapply(cmprsk$margs.para.list, length)
para.list <- ParavecToList(para0.vec = para.list, np.vec=np.vec)
para.list <- LttCmpRsk(margins = cmprsk$margins, para.list = para.list)$margs.para.list
hs.list <- lapply(1:length(cmprsk$margins),
function(x)  loglikexi.hessian(para=para.list[[x]],
cmp.data=cmp.data, Rm=Rm, Xid=x))
hsmat <- as.matrix(Matrix::bdiag(hs.list))
hsmat
}
loglikeAll.single  <- function(parai, para0, cmprsk, cmp.data, Rm, para.id=1, log.para=FALSE){
paranew <- para0
paranew[para.id] <- parai
y <- loglikeAll(para0=paranew, cmprsk=cmprsk, cmp.data=cmp.data, Rm=Rm, log.para=log.para)
y
}
loglikeAll.single.gr  <- function(parai, para0, cmprsk, cmp.data, Rm, para.id=1, log.para=FALSE){
paranew <- para0
paranew[para.id] <- parai
y <- loglikeAll.gr(para0=paranew, cmprsk=cmprsk, cmp.data=cmp.data, Rm=Rm, log.para=log.para)
y[para.id]
}
loglikeAll.single.pl  <- function(parai, para0, cmprsk, cmp.data, Rm,
varM=diag(length(para0)), parai0=1,
para.id=1, log.para=FALSE){
paranew <- para0
paranew[para.id] <- parai
y <- loglikeAll(para0=paranew, cmprsk=cmprsk, cmp.data=cmp.data, Rm=Rm, log.para=log.para)
if(length(para.id) > 1){
a <- t(as.matrix(parai-parai0))%*%solve(varM[para.id, para.id])%*%(as.matrix(parai-parai0))
} else{
a <- (parai-parai0)^2/varM[para.id, para.id]
}
y - a
}
hpdUniv <- function(para.smp, parai0, alpha=0.05, hpd=TRUE,
quantile.prob=NULL){
N <- length(para.smp)
id.para <- order(para.smp)
para.smp.sort <- para.smp[id.para]
if(hpd){
seg <- round(N*(1-alpha))
N.ws.possible <- round(N*alpha/2)
if(N.ws.possible < 1){
N.ws.possible <- 1
}
hpd.possible <- matrix(0, N.ws.possible, 4)
colnames(hpd.possible) <- c("hpdL", "hpdU", "hpdLength", "cover")
set1 <- 1:N.ws.possible
set2 <- set1 + seg
# print(cbind(set1, set2))
set2[set2 > N] <- N
hpd.possible[, 1:2] <- cbind(para.smp.sort[set1], para.smp.sort[set2])
hpd.possible[, 3] <- hpd.possible[,2] - hpd.possible[,1]
hpd.possible[, 4] <- as.numeric((parai0 >= hpd.possible[, 1]) & ((parai0 <= hpd.possible[, 2])))
cv1.set <- as.matrix(hpd.possible)
cv1.min <- which.min(cv1.set[,3])
hpd.final <- cv1.set[cv1.min, ]
CI <- hpd.final
} else{
id1 <- round(N*(alpha/2))
if(id1==0L){
id1 <- 1
}
seg <- round(N*(1-alpha))
id2 <- seg + id1
if(id2 > N){
id2 <- N
}
IL <- para.smp.sort[id2] - para.smp.sort[id1]
cv <- as.numeric((parai0 >= para.smp.sort[id1]) & ((parai0 <= para.smp.sort[id2])))
CI <- matrix(c(para.smp.sort[id1], para.smp.sort[id2], IL, cv), 1, 4)
if(!is.null(quantile.prob)){
stopifnot(length(quantile.prob)==2L)
yci <- quantile(para.smp.sort, probs=quantile.prob)
IL <- yci[2] - yci[1]
cv <- as.numeric((parai0 >=  yci[1]) & ((parai0 <= yci[2])))
CI <- matrix(c(yci[1], yci[2], IL, cv), 1, 4)
}
}
CI
}
CIscoref <- function(testMat, para0, alpha=0.05){
d <- length(para0)
N <- dim(testMat)[1] #here N is the simulated data sets number
# Id0.list <- apply(testMat[, (1:d)*4], 2, function(x) which(x==0, arr.ind = TRUE))
Iscore <- NULL
for(i in 1:d){
para0i <- para0[i]
Idcur <- (1:4) + (i-1)*4
w1 <- (2/alpha)*(testMat[, Idcur[1]] - para0i)*as.numeric(testMat[, Idcur[1]] > para0i)
w2 <- (2/alpha)*(para0i - testMat[, Idcur[2]])*as.numeric(testMat[, Idcur[2]] < para0i)
temp <- sum(testMat[, Idcur[3]] + w1 + w2 )/N
Iscore <- c(Iscore, temp)
}
Iscore
}
GibbsRwMcmc <- function(N, x0, cmprsk,varmat, Xid=0, cfv=1,...){
x1mat <- matrix(nrow=N+1, ncol=cmprsk$np)
x1mat[1,] <- x0
if(length(cfv)==1L){
cfv <- rep(cfv, length(x0))
}
if(Xid==0L){
paraid <- 1:length(x0)
}
if(Xid==1L){
paraid <- 1:cmprsk$npv[Xid]
}
if(Xid > 1L){
paraid <- 1:cmprsk$npv[Xid]+sum(cmprsk$npv[1:(Xid-1)])
}
acp <- rep(0, cmprsk$np)
for(j in 2:(N+1)){
# print(j)
x0 <- x1mat[j-1,]
for(i in paraid){
cf <- cfv[i]
xstar <- x0
vi <- varmat[i,i]
phy0 <- pnorm(-x1mat[1,i], mean=0, sd=cf*sqrt(vi))
rtnorm <- qnorm(phy0 + runif(1)*(1-phy0), mean = 0, sd=cf*sqrt(vi))
xstar[i] <- x1mat[1,i] + rtnorm
y1 <- JointPosteriorf(para.vec = xstar, cmprsk = cmprsk, ...) +
dnorm(x0[i],xstar[i], sd=cf*sqrt(vi), log = TRUE)
y0 <- JointPosteriorf(para.vec = x0, cmprsk = cmprsk, ...) +
dnorm(xstar[i],x0[i], sd=cf*sqrt(vi), log = TRUE)
u <- runif(1)
ulog <- log(u)
if(ulog < (y1-y0)){
x0[i] <- xstar[i]
acp[i] <- acp[i] + 1
} else{
x0 <- x0
}
}
x1mat[j, ] <- x0
}
# acp/N
x1mat <- x1mat[-1,]
list(mcmc=x1mat[,paraid], acp=acp[paraid]/N)
}
EstAci <- function(param, para0, HmL, p=0.05, lower=NULL){
namepara <- paste0("lambda.", 1:length(param))
#---------ACI-------------
zp <- abs(qnorm(p/2))
var.param <- abs(solve(HmL))
if(any(is.nan(sqrt(diag(var.param))))){
print(param)
print(var.param)
}
ci.L <- param - zp * sqrt(diag(var.param))
if(any(ci.L < lower)){
id <- which(ci.L < lower)
ci.L[id] <- lower[id]
}
ci.U <- param + zp * sqrt(diag(var.param))
CIm <- data.frame(ci_L=ci.L, ci_U=ci.U, ci_length=(ci.U-ci.L), cover=as.numeric(((para0 >= ci.L) & (para0 <= ci.U))))
rownames(CIm) <- namepara
list(para.mle=param, hess=HmL, varM=var.param, Aci=CIm)
}
CmprskPrior <- function(prior.type=rep("noninfm", 2),
hyper.list=rep(list(NA),length(prior.type))){
cmprsk.prior <- LttCmpRsk(margins = prior.type,
para.list = hyper.list)
prior.dcall <- cmprsk.prior$margs.para.list
dprior <- lapply(paste0("d", cmprsk.prior$margins), get)
cmprsk.prior$dprior <- dprior
prior.hyper <- cmprsk.prior$margs.para.list
cmprsk.prior
}
dPriorf <- function(para.vec, cmprsk.prior){
prior.dcall <- cmprsk.prior$margs.para.list
para.vec <- unlist(para.vec)
for(i in 1:length(para.vec)){
prior.dcall[[i]]$x <- para.vec[i]
}
dprior <- cmprsk.prior$dprior
y <-sapply(1:length(para.vec), function(x) do.call(dprior[[x]], args = prior.dcall[[x]]))
y
}
JointPosteriorf <- function(para.vec, cmprsk, cmp.data, Rm,
prior.type=NA, hyper.list=NA){
prior1 <- CmprskPrior(prior.type = prior.type, hyper.list = hyper.list)
y.prior <- dPriorf(para.vec, cmprsk.prior = prior1)
prior1$margs.para.list
y.llk <- loglikeAll(para.vec,cmprsk = cmprsk, cmp.data = cmp.data, Rm=Rm)
sum(log(y.prior))+y.llk
}
PriorFun <- function(para.vec, cmprsk,
prior.type=rep("gamma", length(unlist(para.vec))),
hyper.list=rep(list(c(shape=1,scale=2)),4)){
d <- length(cmprsk$margins)
np.vec <- sapply(cmprsk$margs.para.list, length)
para.list <- ParavecToList(para0.vec = para.vec, np.vec=np.vec)
para.list <- LttCmpRsk(margins = cmprsk$margins, para.list = para.list)$margs.para.list
cmprsk.prior <- LttCmpRsk(margins = prior.type,
para.list = hyper.list)
prior.dcall <- cmprsk.prior$margs.para.list
para.vec <- unlist(para.vec)
for(i in 1:length(para.vec)){
prior.dcall[[i]]$x <- para.vec[i]
}
dprior <- lapply(paste0("d", cmprsk.prior$margins), get)
y <-sapply(1:length(para.vec), function(x) do.call(dprior[[x]], args = prior.dcall[[x]]))
cmprsk.prior$dprior <- dprior
prior.hyper <- cmprsk.prior$margs.para.list
list(y=y, cmprsk.prior=cmprsk.prior)
}
dalphaped <- function(x, shape=2, scale=1, log=FALSE){
if(shape == 1L){
y <- dexp(x=x, rate=scale, log = log)
} else{
n <- length(x)
c1 <- exp(-scale*x)
c2 <- shape^(1-c1)
c3 <- scale*log(shape)/(shape - 1)
if(log){
y <- log(c3*c1*c2)
} else{
y <- c3*c2*c1
}
}
y
}
# cumulative distribution function
palphaped <-  function(q, shape=2, scale=1, log.p=FALSE){
# print(shape)
if(shape==1L){
y <- pexp(q=q, rate=scale, log.p = log.p)
} else{
c1 <- exp(-scale*q)
c2 <- shape^(1-c1)-1
c3 <- shape - 1
if(log.p){
y <- log(c2/c3)
} else{
y <- c2/c3
}
}
y
}
# survival function
salphaped <-  function(q, shape=2, scale=1, log.s=FALSE){
if(shape==1L){
y <- 1 - pexp(q=q, rate=scale)
if(log.s){
y <- log(y)
}
} else{
c1 <- exp(-scale*q)
c2 <- shape^(1-c1)-1
c3 <- shape - 1
if(log.s){
y <- log(1-c2/c3)
} else{
y <- 1-c2/c3
}
}
y
}
# quantile function
qalphaped <- function(p, shape=2, scale=1, log.p=FALSE){
if(log.p){
p <- exp(p)
}
if(shape==1L){
c3 <- qexp(p=p, rate=scale)
} else{
c1 <- log(shape) - log(p*(shape-1)+1)
c2 <- log(shape)
c3 <- (log(c2) - log(c1))/scale
}
c3
}
# random sampling function
ralphaped <- function(n, shape=2, scale=1){
if(shape==1L){
xr <- rexp(n=n, rate=scale)
} else{
u <- runif(n)
xr <- qalphaped(u, shape = shape, scale=scale)
}
xr
}
rualphaped <- function(u, shape=2, scale=1){
xr <- qalphaped(u, shape = shape, scale=scale)
xr
}
