static void RLM_SE_Method_2(double residvar, double *W, int p, double *se_estimates,double *varcov){
int i,j; /* l,k; */
double *Winv = Calloc(p*p,double);
double *work = Calloc(p*p,double);
if (!Choleski_inverse(W,Winv,work,p,1)){
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*Winv[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
} else {
/* printf("Using a G-inverse\n"); */
SVD_inverse(W, Winv,p);
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*Winv[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
}
if (varcov != NULL)
for (i =0; i < p; i++){
for (j = i; j < p; j++){
varcov[j*p +i]= residvar*Winv[j*p +i];
}
}
Free(work);
Free(Winv);
}
static void RLM_SE_Method_2_anova(double residvar, double *W, int y_rows,int y_cols, double *se_estimates,double *varcov){
int i,j; /* l,k; */
int p = y_rows + y_cols -1;
double *Winv = Calloc(p*p,double);
double *work = Calloc(p*p,double);
if (!Choleski_inverse(W,Winv,work,p,1)){
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*Winv[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
/*for (i =0; i < y_rows-1; i++){
se_estimates[i] = sqrt(residvar*Winv[(i+y_cols)*p + (i+y_cols)]);
}
for (i =0; i < y_cols; i++){
se_estimates[i+(y_rows -1)] = sqrt(residvar*Winv[i*p + i]);
} */
} else {
/* printf("Using a G-inverse\n"); */
SVD_inverse(W, Winv,p);
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*Winv[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
/* for (i =0; i < y_rows-1; i++){
se_estimates[i] = sqrt(residvar*Winv[(i+y_cols)*p + (i+y_cols)]);
}
for (i =0; i < y_cols; i++){
se_estimates[i+(y_rows -1)] = sqrt(residvar*Winv[i*p + i]);
} */
}
if (varcov != NULL)
for (i =0; i < p; i++){
for (j = i; j < p; j++){
varcov[j*p +i]= residvar*Winv[j*p +i];
}
}
/** if (varcov != NULL){
copy across varcov matrix in right order
for (i = 0; i < y_rows-1; i++)
for (j = i; j < y_rows-1; j++)
varcov[j*p + i] = residvar*Winv[(j+y_cols)*p + (i+y_cols)];
for (i = 0; i < y_cols; i++)
for (j = i; j < y_cols; j++)
varcov[(j+(y_rows-1))*p + (i+(y_rows -1))] = residvar*Winv[j*p + i];
for (i = 0; i < y_cols; i++)
for (j = y_cols; j < p; j++)
varcov[(i+ y_rows -1)*p + (j - y_cols)] = residvar*Winv[j*p + i];
} **/
Free(work);
Free(Winv);
}
void mat_inverse(double* mat, double* mat_inv, int_t y_rows)
{
double* work = (double*)calloc(y_rows*y_rows,sizeof(double));
int err = Choleski_inverse(mat, mat_inv, work, (int)y_rows, 0);
if(err) printf("\nCholeski error code = %d\n", err);
free(work);
}
static void RLM_SE_Method_1(double residvar, double *XTX, int p, double *se_estimates,double *varcov){
int i,j;
double *XTXinv = Calloc(p*p,double);
double *work = Calloc(p*p,double);
if (!Choleski_inverse(XTX,XTXinv,work,p,1)){
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*XTXinv[i*p + i]);
}
} else {
Rprintf("Singular matrix in SE inverse calculation");
}
if (varcov != NULL)
for (i =0; i < p; i++){
for (j = i; j < p; j++){
varcov[j*p +i]= residvar*XTXinv[j*p +i];
}
}
Free(work);
Free(XTXinv);
}
void rlm_compute_se(double *X,double *Y, int n, int p, double *beta, double *resids,double *weights,double *se_estimates, double *varcov, double *residSE, int method,double (* PsiFn)(double, double, int), double psi_k){
int i,j,k; /* counter/indexing variables */
double k1 = psi_k; /* was 1.345; */
double sumpsi2=0.0; /* sum of psi(r_i)^2 */
/* double sumpsi=0.0; */
double sumderivpsi=0.0; /* sum of psi'(r_i) */
double Kappa=0.0; /* A correction factor */
double scale=0.0;
double *XTX = Calloc(p*p,double);
double *W = Calloc(p*p,double);
double *work = Calloc(p*p,double);
double RMSEw = 0.0;
double vs=0.0,m,varderivpsi=0.0;
/* Initialize Lapack library */
/* if(!Lapack_initialized) Lapack_Init(); */
if (method == 4){
for (i=0; i < n; i++){
RMSEw+= weights[i]*resids[i]*resids[i];
}
RMSEw = sqrt(RMSEw/(double)(n-p));
residSE[0] = RMSEw;
for (j =0; j < p;j++){
for (k=0; k < p; k++){
W[k*p + j] = 0.0;
for (i=0; i < n; i++){
W[k*p + j]+= weights[i]*X[j*n +i]*X[k*n + i];
}
}
}
if (!Choleski_inverse(W, XTX, work, p,1)){
for (i =0; i < p; i++){
se_estimates[i] = RMSEw*sqrt(XTX[i*p + i]);
}
} else {
Rprintf("Singular matrix in SE inverse: Method 4\n");
}
if (varcov != NULL)
for (i = 0; i < p; i++)
for (j = i; j < p; j++)
varcov[j*p + i] = RMSEw*RMSEw*XTX[j*p + i];
} else {
scale = med_abs(resids,n)/0.6745;
residSE[0] = scale;
/* compute most of what we will need to do each of the different standard error methods */
for (i =0; i < n; i++){
sumpsi2+= PsiFn(resids[i]/scale,k1,2)*PsiFn(resids[i]/scale,k1,2);
/* sumpsi += psi_huber(resids[i]/scale,k1,2); */
sumderivpsi+= PsiFn(resids[i]/scale,k1,1);
}
m = (sumderivpsi/(double) n);
for (i = 0; i < n; i++){
varderivpsi+=(PsiFn(resids[i]/scale,k1,1) - m)*(PsiFn(resids[i]/scale,k1,1) - m);
}
varderivpsi/=(double)(n);
/* Kappa = 1.0 + (double)p/(double)n * (1.0-m)/(m); */
Kappa = 1.0 + ((double)p/(double)n) *varderivpsi/(m*m);
/* prepare XtX and W matrices */
for (j =0; j < p;j++){
for (k=0; k < p; k++){
for (i = 0; i < n; i++){
XTX[k*p+j]+= X[j*n +i]*X[k*n + i];
W[k*p + j]+= PsiFn(resids[i]/scale,k1,1)*X[j*n +i]*X[k*n + i];
}
}
}
if (method==1) {
Kappa = Kappa*Kappa;
vs = scale*scale*sumpsi2/(double)(n-p);
Kappa = Kappa*vs/(m*m);
RLM_SE_Method_1(Kappa, XTX, p, se_estimates,varcov);
} else if (method==2){
vs = scale*scale*sumpsi2/(double)(n-p);
Kappa = Kappa*vs/m;
RLM_SE_Method_2(Kappa, W, p, se_estimates,varcov);
} else if (method==3){
vs = scale*scale*sumpsi2/(double)(n-p);
Kappa = 1.0/Kappa*vs;
i = RLM_SE_Method_3(Kappa, XTX, W, p, se_estimates,varcov);
if (i){
for (i=0; i <n; i++){
Rprintf("%2.1f ", PsiFn(resids[i]/scale,k1,1));
}
Rprintf("\n");
}
}
}
Free(work);
Free(XTX);
Free(W);
}
static int RLM_SE_Method_3(double residvar, double *XTX, double *W, int p, double *se_estimates,double *varcov){
int i,j,k; /* l; */
int rv;
double *Winv = Calloc(p*p,double);
double *work = Calloc(p*p,double);
/*****************
double *Wcopy = Calloc(p*p,double);
for (i=0; i <p; i++){
for (j=0; j < p; j++){
Wcopy[j*p + i] = W[j*p+i];
}
} **********************/
if(Choleski_inverse(W,Winv,work,p,1)){
SVD_inverse(W, Winv,p);
}
/*** want W^(-1)*(XtX)*W^(-1) ***/
/*** first Winv*(XtX) ***/
for (i=0; i <p; i++){
for (j=0; j < p; j++){
work[j*p + i] = 0.0;
for (k = 0; k < p; k++){
work[j*p+i]+= Winv[k*p +i] * XTX[j*p + k];
}
}
}
/* now again by W^(-1) */
for (i=0; i <p; i++){
for (j=0; j < p; j++){
W[j*p + i] =0.0;
for (k = 0; k < p; k++){
W[j*p+i]+= work[k*p +i] * Winv[j*p + k];
}
}
}
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*W[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
rv = 0;
if (varcov != NULL)
for (i =0; i < p; i++){
for (j = i; j < p; j++){
varcov[j*p +i]= residvar*W[j*p +i];
}
}
Free(work);
Free(Winv);
return rv;
}
void XTWXinv(int_t y_rows, int_t y_cols,double *xtwx){
int_t i,j,k;
int_t Msize = y_cols +y_rows-1;
double *P= (double *)calloc(y_cols,sizeof(double));
double *RP = (double *)calloc(y_cols*(y_rows-1),sizeof(double));
double *RPQ = (double *)calloc((y_rows-1)*(y_rows-1),sizeof(double));
double *S = (double *)calloc((y_rows-1)*(y_rows-1),sizeof(double));
double *work = (double *)calloc((y_rows-1)*(y_rows-1),sizeof(double));
for (j=0;j < y_cols;j++){
for (i=0; i < y_rows -1; i++){
RP[j*(y_rows-1) + i] = xtwx[j*Msize + (y_cols + i)]*(1.0/xtwx[j*Msize+j]);
}
}
for (i=0; i < y_rows -1; i++){
for (j=i;j < y_rows -1; j++){
for (k=0; k < y_cols;k++){
RPQ[j*(y_rows-1) + i] += RP[k*(y_rows-1) + j]*xtwx[k*Msize + (y_cols + i)];
}
RPQ[i*(y_rows-1) + j] = RPQ[j*(y_rows-1) + i];
}
}
for (j=0; j < y_rows-1;j++){
for (i=j; i < y_rows-1;i++){
RPQ[i*(y_rows-1) + j] = RPQ[j*(y_rows-1)+i] = xtwx[(y_cols + j)*Msize + (y_cols + i)] - RPQ[j*(y_rows-1) + i];
}
}
/*for (i =0; i< y_rows-1; i++){
for (j=0; j < y_cols; j++){
printf("%4.4f ",RP[j*(y_rows-1) + i]);
}
printf("\n");
}
for (j=0;j < y_rows -1; j++){
for (i=0; i < y_rows -1; i++){
printf("%4.4f ",RPQ[j*(y_rows-1) + i]);
}
printf("\n");
}
for (i=0; i < y_rows -1; i++){
for (j=0;j < y_rows -1; j++){
printf("%4.4f ",S[j*(y_rows-1) + i]);
}
printf("\n");
}
*/
/* Lets start making the inverse */
Choleski_inverse(RPQ, S, work, (int)(y_rows-1), 0);
for (j=0; j< y_cols;j++){
for (i=0; i < y_rows -1; i++){
xtwx[j*Msize + (y_cols + i)] = 0.0;
for (k=0; k < y_rows -1; k++){
xtwx[j*Msize + (y_cols + i)]+= -1.0*(S[i*(y_rows-1) + k])*RP[j*(y_rows-1) + k];
}
xtwx[(y_cols + i)*Msize + j]=xtwx[j*Msize + (y_cols + i)];
}
}
for (j=0;j < y_cols;j++){
P[j] = 1.0/xtwx[j*Msize+j];
}
for (j=0; j < y_cols; j++){
for (i=j; i < y_cols;i++){
xtwx[i*Msize + j]=0.0;
for (k=0;k < y_rows-1; k++){
xtwx[i*Msize + j]+= RP[i*(y_rows-1) + k]*xtwx[j*Msize + (y_cols + k)];
}
xtwx[i*Msize + j]*=-1.0;
xtwx[j*Msize + i] = xtwx[i*Msize + j];
}
xtwx[j*Msize + j]+=P[j];
}
for (j=0; j < y_rows-1;j++){
for (i=0; i < y_rows-1;i++){
xtwx[(y_cols + j)*Msize + (y_cols + i)] = S[j*(y_rows-1)+i];
}
}
free(P);
free(work);
free(RP);
free(RPQ);
free(S);
}
static int RLM_SE_Method_3_anova(double residvar, double *XTX, double *W, int y_rows,int y_cols, double *se_estimates,double *varcov){
int i,j,k; /* l; */
int rv;
int p = y_rows + y_cols -1;
double *Winv = Calloc(p*p,double);
double *work = Calloc(p*p,double);
/*****************
double *Wcopy = Calloc(p*p,double);
for (i=0; i <p; i++){
for (j=0; j < p; j++){
Wcopy[j*p + i] = W[j*p+i];
}
} **********************/
if(Choleski_inverse(W,Winv,work,p,1)){
SVD_inverse(W, Winv,p);
}
/*** want W^(-1)*(XtX)*W^(-1) ***/
/*** first Winv*(XtX) ***/
for (i=0; i <p; i++){
for (j=0; j < p; j++){
work[j*p + i] = 0.0;
for (k = 0; k < p; k++){
work[j*p+i]+= Winv[k*p +i] * XTX[j*p + k];
}
}
}
/* now again by W^(-1) */
for (i=0; i <p; i++){
for (j=0; j < p; j++){
W[j*p + i] =0.0;
for (k = 0; k < p; k++){
W[j*p+i]+= work[k*p +i] * Winv[j*p + k];
}
}
}
/* make sure in right order */
/* for (i =0; i < y_rows-1; i++){
se_estimates[i] = sqrt(residvar*W[(i+y_cols)*p + (i+y_cols)]);
}
for (i =0; i < y_cols; i++){
se_estimates[i+(y_rows -1)] = sqrt(residvar*W[i*p + i]);
}*/
for (i =0; i < p; i++){
se_estimates[i] = sqrt(residvar*W[i*p + i]);
/* printf("%f ", se_estimates[i]); */
}
rv = 0;
if (varcov != NULL)
for (i =0; i < p; i++){
for (j = i; j < p; j++){
varcov[j*p +i]= residvar*W[j*p +i];
}
}
/* if (varcov != NULL){
copy across varcov matrix in right order
for (i = 0; i < y_rows-1; i++)
for (j = i; j < y_rows-1; j++)
varcov[j*p + i] = residvar*W[(j+y_cols)*p + (i+y_cols)];
for (i = 0; i < y_cols; i++)
for (j = i; j < y_cols; j++)
varcov[(j+(y_rows-1))*p + (i+(y_rows -1))] = residvar*W[j*p + i];
for (i = 0; i < y_cols; i++)
for (j = y_cols; j < p; j++)
varcov[(i+ y_rows -1)*p + (j - y_cols)] = residvar*W[j*p + i];
} */
Free(work);
Free(Winv);
return rv;
}
