Main Page | Alphabetical List | Class List | Directories | File List | Class Members | File Members

LinearStatistic.c

Go to the documentation of this file.
00001 
00009 #include "CI_common.h"
00010 
00022 void C_kronecker (const double *A, const int m, const int n,
00023                   const double *B, const int r, const int s,
00024                   double *ans) {
00025 
00026     int i, j, k, l, mr, js, ir;
00027     double y;
00028 
00029     mr = m * r;
00030     for (i = 0; i < m; i++) {
00031         ir = i * r;
00032         for (j = 0; j < n; j++) {
00033             js = j * s;
00034             y = A[j*m + i];
00035             for (k = 0; k < r; k++) {
00036                 for (l = 0; l < s; l++) {
00037                     ans[(js + l) * mr + ir + k] = y * B[l * r + k];
00038                 }
00039             }
00040         }
00041     }
00042 }  
00043 
00044 
00054 void C_ExpectCovarInfluence(const double* y, const int q,
00055                             const double* weights, const int n, 
00056                             SEXP ans) {
00057 
00058     int i, j, k, jq;
00059     
00060     /* pointers to the slots of object ans */
00061     double *dExp_y, *dCov_y, *dsweights, tmp;
00062     
00063     /*  return values: set to zero initially */
00064     dExp_y = REAL(GET_SLOT(ans, CI_expectationSym));
00065     for (j = 0; j < q; j++) dExp_y[j] = 0.0;
00066     
00067     dCov_y = REAL(GET_SLOT(ans, CI_covarianceSym));
00068     for (j = 0; j < q*q; j++) dCov_y[j] = 0.0;
00069     
00070     dsweights = REAL(GET_SLOT(ans, CI_sumweightsSym));
00071 
00072     /*  compute the sum of the weights */
00073         
00074     dsweights[0] = 0;
00075     for (i = 0; i < n; i++) dsweights[0] += weights[i];
00076     if (dsweights[0] <= 1) 
00077         error("C_ExpectCovarInfluence: sum of weights is less than one");
00078 
00079     /*
00080      *    Expectation of the influence function
00081      */
00082 
00083     for (i = 0; i < n; i++) {
00084 
00085         /*  observations with zero case weights do not contribute */
00086     
00087         if (weights[i] == 0.0) continue;
00088     
00089         for (j = 0; j < q; j++)
00090             dExp_y[j] += weights[i] * y[j * n + i];
00091     }
00092 
00093     for (j = 0; j < q; j++)
00094         dExp_y[j] = dExp_y[j] / dsweights[0];
00095 
00096 
00097     /*
00098      *    Covariance of the influence function
00099      */
00100 
00101     for (i = 0; i < n; i++) {
00102 
00103         if (weights[i] == 0.0) continue;
00104      
00105         for (j = 0; j < q; j++) {
00106             tmp = weights[i] * (y[j * n + i] - dExp_y[j]);
00107             jq = j * q;
00108             for (k = 0; k < q; k++)
00109                 dCov_y[jq + k] += tmp * (y[k * n + i] - dExp_y[k]);
00110         }
00111     }
00112 
00113     for (j = 0; j < q*q; j++)
00114         dCov_y[j] = dCov_y[j] / dsweights[0];
00115 }
00116 
00117 
00124 SEXP R_ExpectCovarInfluence(SEXP y, SEXP weights) {
00125 
00126     SEXP ans;
00127     int q, n;
00128     
00129     if (!isReal(y) || !isReal(weights))
00130         error("R_ExpectCovarInfluence: arguments are not of type REALSXP");
00131     
00132     n = nrow(y);
00133     q = ncol(y);
00134     
00135     if (LENGTH(weights) != n) 
00136         error("R_ExpectCovarInfluence: vector of case weights does not have %d elements", n);
00137 
00138     /*  allocate storage for return values */
00139     PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovarInfluence")));
00140     SET_SLOT(ans, CI_expectationSym, 
00141              PROTECT(allocVector(REALSXP, q)));
00142     SET_SLOT(ans, CI_covarianceSym, 
00143              PROTECT(allocMatrix(REALSXP, q, q)));
00144     SET_SLOT(ans, CI_sumweightsSym, 
00145              PROTECT(allocVector(REALSXP, 1)));
00146 
00147     C_ExpectCovarInfluence(REAL(y), q, REAL(weights), n, ans);
00148     
00149     UNPROTECT(4);
00150     return(ans);
00151 }
00152 
00153 
00166 void C_ExpectCovarLinearStatistic(const double* x, const int p, 
00167                                   const double* y, const int q,
00168                                   const double* weights, const int n,
00169                                   const SEXP expcovinf, SEXP ans) {
00170 
00171     int i, j, k, pq, ip;
00172     double sweights = 0.0, f1, f2, tmp;
00173     double *swx, *CT1, *CT2, *Covy_x_swx, 
00174            *dExp_y, *dCov_y, *dExp_T, *dCov_T;
00175     
00176     pq   = p * q;
00177     
00178     /* the expectation and covariance of the influence function */
00179     dExp_y = REAL(GET_SLOT(expcovinf, CI_expectationSym));
00180     dCov_y = REAL(GET_SLOT(expcovinf, CI_covarianceSym));
00181     sweights = REAL(GET_SLOT(expcovinf, CI_sumweightsSym))[0];
00182 
00183     if (sweights <= 1.0) 
00184         error("C_ExpectCovarLinearStatistic: sum of weights is less than one");
00185 
00186     /* prepare for storing the results */
00187     dExp_T = REAL(GET_SLOT(ans, CI_expectationSym));
00188     dCov_T = REAL(GET_SLOT(ans, CI_covarianceSym));
00189 
00190     /* allocate storage: all helpers, initially zero */
00191     swx = Calloc(p, double);               /* p x 1  */
00192     CT1 = Calloc(p * p, double);           /* p x p  */
00193 
00194     for (i = 0; i < n; i++) {
00195 
00196         /*  observations with zero case weights do not contribute */
00197         if (weights[i] == 0.0) continue;
00198     
00199         ip = i*p;
00200         for (k = 0; k < p; k++) {
00201             tmp = weights[i] * x[k * n + i];
00202             swx[k] += tmp;
00203 
00204             /* covariance part */
00205             for (j = 0; j < p; j++) {
00206                 CT1[j * p + k] += tmp * x[j * n + i];
00207             }
00208         }
00209     }
00210 
00211     /*
00212     *   dExp_T: expectation of the linear statistic T
00213     */
00214 
00215     for (k = 0; k < p; k++) {
00216         for (j = 0; j < q; j++)
00217             dExp_T[j * p + k] = swx[k] * dExp_y[j];
00218     }
00219 
00220     /* 
00221     *   dCov_T:  covariance of the linear statistic T
00222     */
00223 
00224     f1 = sweights/(sweights - 1);
00225     f2 = (1/(sweights - 1));
00226 
00227     if (pq == 1) {
00228         dCov_T[0] = f1 * dCov_y[0] * CT1[0];
00229         dCov_T[0] -= f2 * dCov_y[0] * swx[0] * swx[0];
00230     } else {
00231         /* two more helpers needed */
00232         CT2 = Calloc(pq * pq, double);            /* pq x pq */
00233         Covy_x_swx = Calloc(pq * q, double);      /* pq x q  */
00234         
00235         C_kronecker(dCov_y, q, q, CT1, p, p, dCov_T);
00236         C_kronecker(dCov_y, q, q, swx, p, 1, Covy_x_swx);
00237         C_kronecker(Covy_x_swx, pq, q, swx, 1, p, CT2);
00238 
00239         for (k = 0; k < (pq * pq); k++)
00240             dCov_T[k] = f1 * dCov_T[k] - f2 * CT2[k];
00241 
00242         /* clean up */
00243         Free(CT2); Free(Covy_x_swx);
00244     }
00245 
00246     /* clean up */
00247     Free(swx); Free(CT1); 
00248 }
00249 
00250 
00259 SEXP R_ExpectCovarLinearStatistic(SEXP x, SEXP y, SEXP weights, 
00260                                   SEXP expcovinf) {
00261     
00262     SEXP ans;
00263     int n, p, q, pq;
00264 
00265     /* determine the dimensions and some checks */
00266 
00267     n  = nrow(x);
00268     p  = ncol(x);
00269     q  = ncol(y);
00270     pq = p * q;
00271     
00272     if (nrow(y) != n)
00273         error("y does not have %d rows", n);
00274     if (LENGTH(weights) != n) 
00275         error("vector of case weights does not have %d elements", n);
00276 
00277     PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovar")));
00278     SET_SLOT(ans, CI_expectationSym, 
00279              PROTECT(allocVector(REALSXP, pq)));
00280     SET_SLOT(ans, CI_covarianceSym, 
00281              PROTECT(allocMatrix(REALSXP, pq, pq)));
00282 
00283     C_ExpectCovarLinearStatistic(REAL(x), p, REAL(y), q, 
00284         REAL(weights), n, expcovinf, ans);
00285     
00286     UNPROTECT(3);
00287     return(ans);
00288 }
00289 
00301 void C_LinearStatistic (const double *x, const int p,
00302                         const double *y, const int q,
00303                         const double *weights, const int n,
00304                         double *ans) {
00305               
00306     int i, j, k, kp, kn, ip;
00307     double tmp;
00308 
00309     for (k = 0; k < q; k++) {
00310 
00311         kn = k * n;
00312         kp = k * p;
00313         for (j = 0; j < p; j++) ans[kp + j] = 0.0;
00314             
00315         for (i = 0; i < n; i++) {
00316                 
00317             /* optimization: weights are often zero */
00318             if (weights[i] == 0.0) continue;
00319                 
00320             tmp = y[kn + i] * weights[i];
00321                 
00322             ip = i * p;
00323             for (j = 0; j < p; j++)
00324                  ans[kp + j] += x[j*n + i] * tmp;
00325         }
00326     }
00327 }
00328 
00329 
00337 SEXP R_LinearStatistic(SEXP x, SEXP y, SEXP weights) {
00338 
00339     /* the return value; a vector of type REALSXP */
00340     SEXP ans;
00341 
00342     /* dimensions */
00343     int n, p, q;
00344 
00345     /* 
00346      *    only a basic check: we do not coerce objects since this
00347      *    function is for internal use only
00348      */
00349     
00350     if (!isReal(x) || !isReal(y) || !isReal(weights))
00351         error("LinStat: arguments are not of type REALSXP");
00352     
00353     n = nrow(y);
00354     if (nrow(x) != n || LENGTH(weights) != n)
00355         error("LinStat: dimensions don't match");
00356 
00357     q    = ncol(y);
00358     p    = ncol(x);
00359            
00360     PROTECT(ans = allocVector(REALSXP, p*q));
00361  
00362     C_LinearStatistic(REAL(x), p, REAL(y), q, REAL(weights), n, 
00363                       REAL(ans));
00364 
00365     UNPROTECT(1);
00366     return(ans);
00367 }
00368 
00369 
00383 void C_PermutedLinearStatistic(const double *x, const int p,
00384                                const double *y, const int q,
00385                                const int n, const int nperm,
00386                                const int *indx, const int *perm, 
00387                                double *ans) {
00388 
00389     int i, j, k, kp, kn, knpi;
00390 
00391     for (k = 0; k < q; k++) {
00392 
00393         kn = k * n;
00394         kp = k * p;
00395         for (j = 0; j < p; j++) ans[kp + j] = 0.0;
00396             
00397         for (i = 0; i < nperm; i++) {
00398                 
00399             knpi = kn + perm[i];
00400 
00401             for (j = 0; j < p; j++)
00402                 ans[kp + j] += x[j*n + indx[i]] * y[knpi];
00403         }
00404     }
00405 }
00406 
00407 
00416 SEXP R_PermutedLinearStatistic(SEXP x, SEXP y, SEXP indx, SEXP perm) {
00417 
00418     SEXP ans;
00419     int n, nperm, p, q, i, *iperm, *iindx;
00420 
00421     /* 
00422        only a basic check
00423     */
00424 
00425     if (!isReal(x) || !isReal(y))
00426         error("R_PermutedLinearStatistic: arguments are not of type REALSXP");
00427     
00428     if (!isInteger(perm))
00429         error("R_PermutedLinearStatistic: perm is not of type INTSXP");
00430     if (!isInteger(indx))
00431         error("R_PermutedLinearStatistic: indx is not of type INTSXP");
00432     
00433     n = nrow(y);
00434     nperm = LENGTH(perm);
00435     iperm = INTEGER(perm);
00436     if (LENGTH(indx)  != nperm)
00437         error("R_PermutedLinearStatistic: dimensions don't match");
00438     iindx = INTEGER(indx);
00439 
00440     if (nrow(x) != n)
00441         error("R_PermutedLinearStatistic: dimensions don't match");
00442 
00443     for (i = 0; i < nperm; i++) {
00444         if (iperm[i] < 0 || iperm[i] > (n - 1) )
00445             error("R_PermutedLinearStatistic: perm is not between 1 and nobs");
00446         if (iindx[i] < 0 || iindx[i] > (n - 1) )
00447             error("R_PermutedLinearStatistic: indx is not between 1 and nobs");
00448     }
00449 
00450     q    = ncol(y);
00451     p    = ncol(x);
00452            
00453     PROTECT(ans = allocVector(REALSXP, p*q));
00454     
00455     C_PermutedLinearStatistic(REAL(x), p, REAL(y), q, n, nperm,
00456                  iindx, iperm, REAL(ans));
00457     
00458     UNPROTECT(1);
00459     return(ans);
00460 }
00461 
00462 
00472 void C_scmatleft(const double *x, const int p, 
00473                  const int q, double *ans) {
00474 
00475     /*
00476      *
00477      *    The basic difficulty is that the statistic itself is
00478      *    L ~ (p, q) but we only look at vec(L)
00479      *    
00480      *    The function creates a score matrix A in order to
00481      *    compute A %*% vec(L) == x %*% L
00482      *
00483      *    pq is the length of vec(L) (and p is determined from 
00484      *    the length of x)
00485      */
00486     
00487     int k, j, pq;
00488     
00489     pq = p * q;
00490     for (j = 0; j < q; j++) {
00491             for (k = 0; k < p; k++) {
00492                 ans[pq * j + q*k +  j] = x[k];
00493             }
00494     }
00495 }
00496 
00497 
00504 SEXP R_scmatleft(SEXP x, SEXP pq) {
00505 
00506     SEXP ans;
00507     double *dans, *dx;
00508     int p, q, i;
00509     
00510     if (!isReal(x)) error("R_scmatleft: x not of type REALSXP");
00511     if (!isInteger(pq)) error("R_scmatleft: pq not of type INTSXP");
00512     
00513     dx = REAL(x);
00514     p = LENGTH(x);
00515     q = INTEGER(pq)[0] / p;
00516     
00517     PROTECT(ans = allocMatrix(REALSXP, q, p*q));
00518     dans = REAL(ans);
00519     for (i = 0; i < q*p*q; i++) dans[i] = 0.0;
00520     
00521     C_scmatleft(dx, p, q, dans);
00522     
00523     UNPROTECT(1);
00524     return(ans);
00525 }
00526 
00527 
00537 void C_scmatright(const double *x, const int p, 
00538                  const int q, double *ans) { 
00539 
00540     /* 
00541      *
00542      *    The basic difficulty is that the statistic itself is
00543      *    L ~ (p, q) but we only look at vec(L)
00544      *    
00545      *    The function creates a score matrix A in order to
00546      *    compute A %*% vec(L) == L %*% x
00547      *
00548      *    pq is the length of vec(L) (and q is determined from 
00549      *    the length of x)
00550      *
00551      */ 
00552 
00553     int i, k, pp;
00554     
00555     pp = p * p;
00556     for (k = 0; k < q; k++) {
00557         for (i = 0; i < p; i++) {
00558             ans[pp * k + i * p   + i] = x[k];
00559         }
00560     }
00561 }
00562 
00569 SEXP R_scmatright(SEXP x, SEXP pq) {
00570 
00571     SEXP ans;
00572     double *dans, *dx;
00573     int p, q, i;
00574     
00575     if (!isReal(x)) error("R_scmatright: x not of type REALSXP");
00576     if (!isInteger(pq)) error("R_scmatright: pq not of type INTSXP");
00577     
00578     dx = REAL(x);
00579     q = LENGTH(x);
00580     p = INTEGER(pq)[0] / q;
00581     
00582     PROTECT(ans = allocMatrix(REALSXP, p, p*q));
00583     dans = REAL(ans);
00584     
00585     for (i = 0; i < p*p*q; i++) dans[i] = 0.0;
00586     
00587     C_scmatright(dx, p, q, dans);
00588 
00589     UNPROTECT(1);
00590     return(ans);
00591 }

Generated on Thu Jul 28 17:05:21 2005 for coin by  doxygen 1.4.2