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; }