void prodlim_clustersurv(double *y,
int *status,
int *cluster,
int *NC,
double *time,
double *nrisk,
double *cluster_nrisk,
int *nevent,
int *lost,
int *ncluster_with_event,
int *ncluster_lost,
int *sizeof_cluster,
int *nevent_in_cluster,
double *surv,
double *hazard,
double *varhazard,
double *adj1,
double *adj2,
double *adjvarhazard,
int *t,
int start,
int stop){
int s,i,l,k;
double surv_step, hazard_step, V1, V2, atrisk, cluster_atrisk;
/* Rprintf("Call clustersurv\n\n"); */
/* initialize the time counter */
s = (*t);
/*
cluster is an indicator of the cluster number.
for example if the individual (tooth) 'i'
belongs to patient 'k' then 'cluster[i]=k'
First we need to re-initialize sizeof_cluster, nevent_in_cluster, etc
are set to zero.
*/
for (k=0;k<*NC;k++) {
sizeof_cluster[k]=0;
nevent_in_cluster[k]=0;
adj1[k]=0;
adj2[k]=0;
}
/*
Then, the vector "sizeof_cluster" is
initialized with the current number of individuals
in the cluster.
*/
for (i=start;i<stop;i++) sizeof_cluster[cluster[i]-1]++;
/* initialize */
surv_step=1; hazard_step=0; V1=0; V2=0;
atrisk=(double) stop-start;
cluster_atrisk= (double) *NC;
nevent[s] = status[start];
ncluster_with_event[s] = status[start];
ncluster_lost[s] = 0;
nevent_in_cluster[cluster[start]-1] = status[start];
lost[s] = (1-status[start]);
for(i=(1+start);i <=stop;i++){
/*
start at i=1 to deal with ties.
first check if current time is equal
to the previous time.
*/
if (i<stop && y[i]==y[i-1]){
nevent[s] += status[i];
lost[s] += (1 - status[i]);
nevent_in_cluster[cluster[i]-1] += status[i];
if (cluster[i]!=cluster[i-1]){
ncluster_with_event[s]+= status[i];
}
}
else {
time[s] = y[i-1];
nrisk[s] = atrisk;
cluster_nrisk[s] = cluster_atrisk;
/* marginal Kaplan-Meier and naive variance estimator */
pl_step(&surv_step, &hazard_step, &V1, atrisk, nevent[s],0);
surv[s]=surv_step;
hazard[s]=hazard_step;
varhazard[s] = V1;
/* adjusted variance estimator of Ying and Wei (1994) */
V2=0;
for (k=0;k<*NC;k++) {
adj1[k] += nevent_in_cluster[k] / (double) atrisk;
adj2[k] += sizeof_cluster[k] * nevent[s] / (double) (atrisk * atrisk);
V2 += (adj1[k]-adj2[k]) * (adj1[k]-adj2[k]);
}
/* collect the results for unique time points */
surv[s] = surv_step;
varhazard[s]=V1;
adjvarhazard[s]=V2;
/* initialize the next time point */
if (i < stop) {
atrisk-=(nevent[s]+lost[s]);
/*
looking back at the individuals with tie at time s
this makes sense as presently: y[i]!=y[i-1]
*/
for (l=1;l<=(nevent[s]+lost[s]);l++) {
/*
decrease the size of corresponding clusters
*/
sizeof_cluster[cluster[i-l]-1]--;
/*
if the last obs in a cluster is gone, then
the number of clusters at risk is decreased
by 1.
*/
if (sizeof_cluster[(cluster[i-l]-1)]==0) {
cluster_atrisk--;
ncluster_lost[s] += (1-status[i-l]);
}
nevent_in_cluster[cluster[i-l]-1]=0; /* reset for next time point */
}
s++;
nevent_in_cluster[cluster[i]-1] = status[i];
nevent[s] = status[i];
ncluster_with_event[s] = status[i];
lost[s] = (1-status[i]);
}
}
}
*t=(s+1); /* for the next stratum and finally for R */
}
void prodlim_comprisk(double* y,
int* status,
int* cause,
int* NS, /* number of causes (states) */
double* time,
double* nrisk,
int* event,
int* loss,
double* surv,
double* cuminc,
double* cause_hazard,
double* varcuminc,
double* I, /* current cumulative incidence */
double*I_lag, /* time lagged cumulative incidence */
double* v1,
double* v2,
int *t,
int start,
int stop) {
int i,j,s,d,d1,d2;
double S,S_lag,H,varH,n;
/* }}} */
/* {{{ initialization */
s=(*t);
S=1;
H=0;
for(j=0; j < (*NS); ++j) {
I[j]=0;
I_lag[j]=0;
v1[j]=0;
v2[j]=0;
}
varH=0;
n=(double) stop-start; /* (sub-)sample size */
if (status[start]>0)
event[s *(*NS) + cause[start]]=1;
else
loss[s]=1;
/* }}} */
for (i=(1+start);i<=stop;i++){
/* {{{ if tie then wait */
if (i<stop && y[i]==y[i-1]){
if (status[i]>0)
event[s * (*NS) + cause[i]] +=1;
else
loss[s]+=1;
}
/* }}} */
else {
/* {{{ at s: set time, atrisk; reset d */
time[s]=y[i-1];
nrisk[s]=n;
d = 0;
/* }}} */
/* {{{ loop over causes: compute cuminc */
for(j=0; j < (*NS); ++j) {
cause_hazard[s * (*NS) + j] = (double) (event[s * (*NS) + j] / n);
I_lag[j] = I[j];
I[j] += S * cause_hazard[s * (*NS) + j];
cuminc[s * (*NS) + j] = I[j];
d += (double) event[s * (*NS) + j];
}
/* }}} */
/* {{{ compute survival */
S_lag = S;
pl_step(&S, &H, &varH, n, d, 0);
surv[s] = S;
/* }}} */
/* {{{ variance estimate Marubini & Valsecchi (1995), Wiley, chapter 10, page 341 */
for (j=0; j < (*NS); ++j){
d1 = event[s * (*NS) + j];
d2 = d - d1;
v1[j] += I[j] * (d / (n * (n - d))) + (S_lag * d1) / (n * n);
v2[j] += (I[j] * I[j]) * (d / (n * (n - d)))
+ ((S_lag * S_lag) * (n - d1) * d1) / (n * n * n)
+ (2 * I[j] * S_lag * d1) / (n * n);
varcuminc[s * (*NS) + j] = (I[j] * I[j]) * varH - 2 * I[j] * v1[j] + v2[j];
/* varH is greenwood's formula */
/* variance estimate Korn & Dorey (1992), Stat in Med, Vol 11, page 815 */
/* I1 = (I[j] - I_lag[j]) / 2; */
}
/* }}} */
/* {{{ update atrisk, set n.event, loss, for the next time point */
if (i<stop){
n -= (d + loss[s]);
s++;
if (status[i]>0){
event[s *(*NS) + cause[i]]=1;
}
else
loss[s]=1;
}
/* }}} */
}
}
*t=(s+1); /* for the next strata */
}
void prodlimCompriskPlus(double* y,
double* status,
int* cause,
double *entrytime,
double *caseweights,
int* NS, /* number of causes (states) */
double* time,
double* nrisk,
double* event,
double* loss,
double* surv,
double* cuminc,
double* cause_hazard,
double* varcuminc,
double* I, /* current cumulative incidence */
double* I_lag, /* time lagged cumulative incidence */
double* v1,
double* v2,
int *t,
int start,
int stop,
int *delayed,
int *weighted
) {
int i,e,j,s,d,d1,entered;
double S,S_lag,H,varH,atrisk;
/* }}} */
/* {{{ initialization */
s=(*t);
e=0;
S=1;
S_lag=1;
H=0;
for(j=0; j < (*NS); ++j) {
I[j]=0;
I_lag[j]=0;
v1[j]=0;
v2[j]=0;
}
varH=0;
if (*weighted==1){
atrisk=0;
for (i=start;i<stop;i++) atrisk += caseweights[i];
} else{
if (*delayed==1){
atrisk=0;
/* do not initialize with those that have entry times=0 because by convention in case of ties
entry happens after events and after censoring */
/* sort the delayed entry times */
qsort(entrytime+start,
(stop-start),
(size_t) sizeof(double),
(int (*)(const void *, const void *))(doubleNewOrder));
e=start; /* index for delayed entry */
/* initialize the number at risk */
}else{
atrisk=(double) stop-start; /* (sub-)sample size */
}
}
if (*weighted==1){
if (status[start]>0){
event[s *(*NS) + cause[start]]=caseweights[start];
} else{
loss[s]=caseweights[start];
}
}
else{
if (status[start]>0){
event[s *(*NS) + cause[start]]=1;
} else{
loss[s]=1;
}
}
/* }}} */
for (i=(1+start);i<=stop;i++){
/* {{{ if tie then wait */
if (i<stop && y[i]==y[i-1]){
if (*weighted==1){
if (status[i]>0)
event[s * (*NS) + cause[i]] +=caseweights[i];
else
loss[s]+=caseweights[i];
}
else{
if (status[i]>0)
event[s * (*NS) + cause[i]] ++;
else
loss[s]++;
}
}
/* }}} */
else{
/* {{{ at s: set time, atrisk; reset d */
if (*delayed==1){
/* delayed entry: find number of subjects that
entered at time[s] */
entered=0;
while(e<stop && entrytime[e]< y[i-1]){ /*entry happens at t+ and events at t*/
entered++;
if (e==start || entrytime[e]>entrytime[e-1]){
/* unless there is a tie between the current
and the next entry-time, add time to list of times, increase s
and move the values of event, loss etc. to the next event time */
nrisk[s]=atrisk+entered;
if (s==0 || entrytime[e]!=time[s-1]){
/* if entrytime[e]==time[s-1] then only increase
the number at risk (done two lines above)
but dont change the time counter or the values
of event, etc.
*/
for(j=0; j < (*NS); ++j) {
event[(s+1) * (*NS) + j]=event[s * (*NS) + j];
event[s * (*NS) + j]=0;
}
loss[s+1]=loss[s];
loss[s]=0;
if (entrytime[e]<y[start]){
surv[s]=1;
for(j=0; j < (*NS); ++j) {
cuminc[s * (*NS) + j]=0;
varcuminc[s * (*NS) + j]=0;
}
} else{
surv[s]=S_lag;
for(j=0; j < (*NS); ++j) {
cuminc[s * (*NS) + j]=cuminc[(s-1) * (*NS) + j];
varcuminc[s * (*NS) + j]=varcuminc[(s-1) * (*NS) + j];
}
}
time[s]=entrytime[e];
s++;
}
}
e++;/* increase cumulative counter */
}
atrisk += (double) entered;
}
time[s]=y[i-1];
nrisk[s]=atrisk;
d = 0;
/* }}} */
/* {{{ loop over causes: compute cuminc */
for(j=0; j < (*NS); ++j) {
cause_hazard[s * (*NS) + j] = (event[s * (*NS) + j] / atrisk);
I_lag[j] = I[j];
I[j] += S * cause_hazard[s * (*NS) + j];
cuminc[s * (*NS) + j] = I[j];
d += event[s * (*NS) + j];
}
/* }}} */
/* {{{ compute survival */
S_lag = S;
pl_step(&S, &H, &varH, atrisk, d, 0);
surv[s] = S;
/* }}} */
/* {{{ variance estimate Marubini & Valsecchi (1995), Wiley, chapter 10, page 341 */
for (j=0; j < (*NS); ++j){
d1 = event[s * (*NS) + j];
/* d2 = d - d1; */
v1[j] += I[j] * (d / (atrisk * (atrisk - d))) + (S_lag * d1) / (atrisk * atrisk);
v2[j] += (I[j] * I[j]) * (d / (atrisk * (atrisk - d)))
+ ((S_lag * S_lag) * (atrisk - d1) * d1) / (atrisk * atrisk * atrisk)
+ (2 * I[j] * S_lag * d1) / (atrisk * atrisk);
varcuminc[s * (*NS) + j] = (I[j] * I[j]) * varH - 2 * I[j] * v1[j] + v2[j];
/* varH is greenwood's formula */
/* variance estimate Korn & Dorey (1992), Stat in Med, Vol 11, page 815 */
/* I1 = (I[j] - I_lag[j]) / 2; */
}
/* }}} */
/* {{{ update atrisk, set n.event, loss, for the next time point */
if (i<stop){
atrisk -= (d + loss[s]);
s++;
if (*weighted==1){
if (status[i]>0){
event[s *(*NS) + cause[i]]=caseweights[i];
}
else
loss[s]=caseweights[i];
}
else{
if (status[i]>0){
event[s *(*NS) + cause[i]]=1;
}
else
loss[s]=1;
}
}
/* }}} */
}
}
*t=(s+1); /* for the next strata */
}
