Main Page   File List   File Members   Related Pages  

cexpcov.c

Go to the documentation of this file.
00001                                                                    
00002 #include <R.h>
00003 #include <Rmath.h>
00004 #include <Rinternals.h>
00005 #include "party.h"
00006 
00007 SEXP kronecker (SEXP A, SEXP B) {
00008 
00009     /* 
00010     *
00011     *    Kronecker Product of the 
00012     *    real (m x n) matrix A and the 
00013     *    real (r x s) matrix B
00014     *
00015     */ 
00016 
00017     /*  The Kronecker product, a real (mr x ns) matrix */
00018     
00019     SEXP ans; 
00020 
00021     int i, m, j, n, k, r, l, s, mr, ns, x = 0;
00022     double y, z;
00023 
00024     if (!isReal(A) || !isReal(B)) 
00025         error("A and B are not of type REAL");
00026 
00027     if (isMatrix(A)) {
00028         m = INTEGER(getAttrib(A, R_DimSymbol))[0];
00029         n = INTEGER(getAttrib(A, R_DimSymbol))[1];
00030     } else {
00031         m = LENGTH(A);
00032         n = 1;
00033     }
00034     
00035     if (isMatrix(B)) {
00036         r = INTEGER(getAttrib(B, R_DimSymbol))[0];
00037         s = INTEGER(getAttrib(B, R_DimSymbol))[1];
00038     } else {
00039         r = LENGTH(B);
00040         s = 1;
00041     }
00042 
00043     mr = m*r;
00044     ns = n*s;
00045   
00046     PROTECT(ans = allocMatrix(REALSXP, mr, ns));
00047 
00048     for (i = 0; i < m; i++) {
00049         for (j = 0; j < n; j++) {
00050       
00051             y = REAL(A)[aindx(i, j, m)];
00052 
00053             for (k = 0; k < r; k++) {
00054                 for (l = 0; l < s; l++) {
00055                 
00056                     x = aindx(i*r + k, j*s + l, mr);
00057                     z = REAL(B)[aindx(k, l, r)];
00058                     REAL(ans)[x] = y * z;
00059                     
00060                 }
00061             }
00062         }
00063     }
00064     UNPROTECT(1);
00065     return(ans);
00066 }  
00067 
00068 void setAllZero(SEXP A) {
00069 
00070     int n, m, i, j;
00071     SEXP tmp;
00072     
00073     n = LENGTH(A);
00074     for (i = 0; i < n; i++) {
00075         tmp = VECTOR_ELT(A, i);
00076         m = LENGTH(tmp);
00077         for (j = 0; j < m; j++) REAL(tmp)[j] = 0.0;
00078     }
00079 }
00080 
00081 SEXP ec(SEXP Weights, SEXP Scores, SEXP cweights) {
00082 
00083     /*
00084     *
00085     *   Conditional Expectation and Covariance of 
00086     *   Linear Statistics of the form
00087     *
00088     *       L = vec(W %*% diag(cw) %*% S)
00089     *
00090     */
00091     
00092     /*  (p x nobs) matrix of weights  */
00093 
00094     SEXP W;             
00095     
00096     /*  (nobs x q) matrix of scores   */
00097 
00098     SEXP S;
00099     
00100     /*  nobs vector of case weights   */
00101 
00102     SEXP cw;
00103     
00104     /*  list of two return values: conditional expectation and covariance  */
00105 
00106     SEXP ans, expL, covL;
00107     
00108     /*  dimensions of W and S and corresponding loop variables  */
00109 
00110     int nobs, i;
00111     int p, k;
00112     int q, j; 
00113     int pq;
00114     
00115     /*  sum of case weights  */
00116 
00117     double scw;
00118     
00119     /*  mothers little helpers  */
00120 
00121     double f1, f2;
00122     SEXP ES, VS, VT1, VT2;
00123     SEXP wi, wiT, swi, swiT, wi_k_VS, VTp, wi_k_wiT;
00124     SEXP helpers;
00125     
00126     /* coerce the inputs to REALSXPs */
00127     
00128     PROTECT(W  = coerceVector(Weights, REALSXP));
00129     PROTECT(S  = coerceVector(Scores, REALSXP));
00130     PROTECT(cw = coerceVector(cweights, REALSXP));
00131 
00132     /* determine the dimensions and some checks */
00133 
00134     nobs = INTEGER(getAttrib(W, R_DimSymbol))[1];
00135     p    = INTEGER(getAttrib(W, R_DimSymbol))[0];
00136     q    = INTEGER(getAttrib(S, R_DimSymbol))[1];
00137     pq   = p * q;
00138     
00139     if (INTEGER(getAttrib(S, R_DimSymbol))[0] != nobs)
00140         error("score matrix does not have %d rows", nobs);
00141     if (LENGTH(cw) != nobs) 
00142         error("vector of case weights does not have %d elements", nobs);
00143 
00144     /*  compute the sum of the case weights */
00145         
00146     scw = 0;
00147     for (i = 0; i < nobs; i++) scw = scw + REAL(cw)[i];
00148 
00149     /*  allocate storage: the list of return values */
00150 
00151     PROTECT(ans = allocVector(VECSXP, 2));
00152     SET_VECTOR_ELT(ans, 0, expL = allocVector(REALSXP, pq));
00153     SET_VECTOR_ELT(ans, 1, covL = allocMatrix(REALSXP, pq, pq));
00154 
00155     /* allocate storage: all helpers */
00156     
00157     PROTECT(helpers = allocVector(VECSXP, 7));
00158     SET_VECTOR_ELT(helpers, 0, ES = allocMatrix(REALSXP, 1, q));
00159     SET_VECTOR_ELT(helpers, 1, VS = allocMatrix(REALSXP, q, q));
00160     SET_VECTOR_ELT(helpers, 2, wi = allocMatrix(REALSXP, p, 1));
00161     SET_VECTOR_ELT(helpers, 3, wiT = allocMatrix(REALSXP, 1, p));
00162     SET_VECTOR_ELT(helpers, 4, swi = allocMatrix(REALSXP, p, 1));
00163     SET_VECTOR_ELT(helpers, 5, swiT = allocMatrix(REALSXP, 1, p));
00164     SET_VECTOR_ELT(helpers, 6, VTp = allocMatrix(REALSXP, p, p));
00165 
00166     /* make sure the helpers are initially zero */
00167 
00168     setAllZero(helpers);
00169 
00170     /* 
00171     *   ES:  the expectation of the scores 
00172     *   swi: row sums of the weights
00173     */
00174     
00175 
00176     for (i = 0; i < nobs; i++) {
00177 
00178         /*  observations with zero case weights do not contribute */
00179     
00180         if (REAL(cw)[i] == 0.0) continue;
00181     
00182         for (j = 0; j < q; j++) {
00183             REAL(ES)[j] = REAL(ES)[j] 
00184                           + REAL(cw)[i] * REAL(S)[aindx(i, j, nobs)];
00185         } 
00186         for (k = 0; k < p; k++) {
00187             REAL(swi)[k] = REAL(swi)[k] 
00188                            + REAL(cw)[i] * REAL(W)[aindx(k, i, p)];
00189         }
00190     }
00191 
00192     for (j = 0; j < q; j++) {
00193         REAL(ES)[j] = REAL(ES)[j] / scw;
00194     }
00195 
00196     /*
00197     *   expL: expectation of the linear statistic L
00198     *   swiT: transpose of the row sum of the weights
00199     */
00200 
00201     for (k = 0; k < p; k++) {
00202         REAL(swiT)[k] = REAL(swi)[k];
00203         for (j = 0; j < q; j++) {
00204             REAL(expL)[aindx(k,j,p)] = REAL(swi)[k] * REAL(ES)[j];
00205         }
00206     }
00207 
00208     /*
00209     *   VS:  covariance of the scores
00210     */ 
00211 
00212     for (i = 0; i < nobs; i++) {
00213 
00214         if (REAL(cw)[i] == 0.0) continue;
00215      
00216         for (j = 0; j < q; j++) {
00217             for (k = 0; k < q; k++) {
00218                 REAL(VS)[aindx(k, j, q)] = REAL(VS)[aindx(k, j, q)] + 
00219                     REAL(cw)[i] * (REAL(S)[aindx(i, k, nobs)] - REAL(ES)[k]) * 
00220                                   (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]);
00221             }
00222         }
00223     }
00224 
00225     for (j = 0; j < q*q; j++) {
00226         REAL(VS)[j] = REAL(VS)[j] / scw;
00227     }
00228     
00229     /* 
00230     *   covL:  covariance of the linear statistic L
00231     */
00232     
00233     for (i = 0; i < nobs; i++) {
00234 
00235         if (REAL(cw)[i] == 0.0) continue;
00236         
00237         for (k = 0; k < p; k++) {
00238             REAL(wi)[k] = REAL(W)[aindx(k, i, p)];
00239             REAL(wiT)[k] = REAL(W)[aindx(k, i, p)];
00240         } 
00241 
00242         wi_k_wiT = kronecker(wi, wiT);
00243 
00244         for (k = 0; k < p*p; k++) {
00245             REAL(VTp)[k] = REAL(VTp)[k] + REAL(cw)[i] * REAL(wi_k_wiT)[k];
00246         }
00247     }
00248     
00249     VT1 = kronecker(VS, VTp);
00250 
00251     wi_k_VS = kronecker(VS, swi);
00252     VT2 = kronecker(wi_k_VS, swiT);
00253 
00254     f1 = scw/(scw - 1);
00255     f2 = (1/(scw - 1));
00256 
00257     for (k = 0; k < (pq * pq); k++) {
00258         REAL(covL)[k] = f1 * REAL(VT1)[k] - f2 * REAL(VT2)[k];
00259     }
00260 
00261     UNPROTECT(5);
00262     return(ans);
00263 }
00264 
00265 
00266 SEXP evS(SEXP Scores, SEXP cweights) {
00267 
00268     /*
00269     *    expectation and variance (!) of the scores only
00270     */
00271 
00272 
00273     SEXP S;
00274     
00275     /*  nobs vector of case weights   */
00276 
00277     SEXP cw;
00278     
00279     /*  list of two return values: conditional expectation and variance  */
00280 
00281     SEXP ans, ES, VS, scw;
00282     
00283     /*  dimensions of W and S and corresponding loop variables  */
00284 
00285     int nobs, i;
00286     int k;
00287     int q, j; 
00288     
00289     /* coerce the inputs to REALSXPs */
00290     
00291     PROTECT(S  = coerceVector(Scores, REALSXP));
00292     PROTECT(cw = coerceVector(cweights, REALSXP));
00293 
00294     /* determine the dimensions and some checks */
00295 
00296     nobs = INTEGER(getAttrib(S, R_DimSymbol))[0];
00297     q    = INTEGER(getAttrib(S, R_DimSymbol))[1];
00298     
00299     if (LENGTH(cw) != nobs) 
00300         error("vector of case weights does not have %d elements", nobs);
00301 
00302     /*  allocate storage: the list of return values */
00303 
00304     PROTECT(ans = allocVector(VECSXP, 3));
00305     SET_VECTOR_ELT(ans, 0, ES = allocVector(REALSXP, q));
00306     SET_VECTOR_ELT(ans, 1, VS = allocVector(REALSXP, q));
00307     SET_VECTOR_ELT(ans, 2, scw = allocVector(REALSXP, 1));
00308     
00309     setAllZero(ans);
00310 
00311     for (i = 0; i < nobs; i++) {
00312 
00313         if (REAL(cw)[i] == 0.0) continue;
00314 
00315         REAL(scw)[0] = REAL(scw)[0] + REAL(cw)[i];
00316 
00317         for (k = 0; k < q; k++) {
00318             REAL(ES)[k] = REAL(ES)[k] 
00319                           + REAL(cw)[i] * REAL(S)[aindx(i, k, nobs)];
00320         }
00321 
00322     }
00323 
00324     for (k = 0; k < q; k++) {
00325         REAL(ES)[k] = REAL(ES)[k] / REAL(scw)[0];
00326     }
00327 
00328     for (i = 0; i < nobs; i++) {
00329         
00330         if (REAL(cw)[i] == 0.0) continue;
00331     
00332         for (j = 0; j < q; j++) {
00333                 REAL(VS)[j] = REAL(VS)[j] + 
00334                     REAL(cw)[i] * (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]) * 
00335                                   (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]);
00336         }
00337     }
00338     
00339     for (k = 0; k < q; k++) {
00340         REAL(VS)[k] = REAL(VS)[k] / REAL(scw)[0];
00341     }
00342 
00343     UNPROTECT(3);
00344     return(ans);
00345 }
00346 
00347 
00348 SEXP evL(SEXP Weights, SEXP Scores, SEXP cweights, SEXP evSans) {
00349 
00350     /*
00351      *
00352      *   Conditional Expectation and Variance of
00353      *   Linear Statistics of the form
00354      *
00355      *       L = vec(W %*% diag(cw) %*% S)
00356      *
00357      */
00358                                 
00359     /*  (p x nobs) matrix of weights  */
00360 
00361     SEXP W;     
00362     
00363     /*  (nobs x q) matrix of scores   */
00364 
00365     SEXP S;
00366     
00367     /*  nobs vector of case weights   */
00368 
00369     SEXP cw;
00370     
00371     
00372     /*  list of two return values: conditional expectation and variance  */
00373 
00374     SEXP ans, expL, varL;
00375     
00376     /*  dimensions of W and S and corresponding loop variables  */
00377 
00378     int nobs, i;
00379     int p, k;
00380     int q, j; 
00381     int pq;
00382     
00383     double scw;
00384     
00385     /*  mothers little helpers  */
00386 
00387     double f1, f2;
00388     SEXP helpers, ES, VS, wi, wii;
00389     
00390     /* coerce the inputs to REALSXPs */
00391     
00392     PROTECT(W  = coerceVector(Weights, REALSXP));
00393     PROTECT(S  = coerceVector(Scores, REALSXP));
00394     PROTECT(cw = coerceVector(cweights, REALSXP));
00395 
00396     /* determine the dimensions and some checks */
00397 
00398     nobs = INTEGER(getAttrib(W, R_DimSymbol))[1];
00399     p    = INTEGER(getAttrib(W, R_DimSymbol))[0];
00400     q    = INTEGER(getAttrib(S, R_DimSymbol))[1];
00401     pq   = p * q;
00402     
00403     if (INTEGER(getAttrib(S, R_DimSymbol))[0] != nobs)
00404         error("score matrix does not have %d rows", nobs);
00405     if (LENGTH(cw) != nobs) 
00406         error("vector of case weights does not have %d elements", nobs);
00407 
00408     /*  compute the sum of the case weights */
00409         
00410     scw = REAL(VECTOR_ELT(evSans, 2))[0];
00411     ES = VECTOR_ELT(evSans, 0);
00412     VS = VECTOR_ELT(evSans, 1);
00413     
00414     /*  allocate storage: the list of return values */
00415 
00416     PROTECT(ans = allocVector(VECSXP, 2));
00417     SET_VECTOR_ELT(ans, 0, expL = allocVector(REALSXP, pq));
00418     SET_VECTOR_ELT(ans, 1, varL = allocVector(REALSXP, pq));
00419     
00420     PROTECT(helpers = allocVector(VECSXP, 2));
00421     SET_VECTOR_ELT(helpers, 0, wi = allocVector(REALSXP, p));
00422     SET_VECTOR_ELT(helpers, 1, wii = allocVector(REALSXP, p));
00423 
00424     setAllZero(helpers);
00425 
00426     for (i = 0; i < nobs; i++) {
00427 
00428         if (REAL(cw)[i] == 0.0) continue;
00429 
00430         for (k = 0; k < p; k++) {
00431             REAL(wi)[k] = REAL(wi)[k] 
00432                           + REAL(cw)[i] * REAL(W)[aindx(k, i, p)];
00433         }
00434 
00435         for (k = 0; k < p; k++) {
00436             REAL(wii)[k] = REAL(wii)[k] 
00437                          + REAL(cw)[i] * REAL(W)[aindx(k, i, p)] 
00438                            * REAL(W)[aindx(k, i, p)];
00439         }
00440     }
00441 
00442     f1 = scw/(scw - 1);
00443     f2 = (1/(scw - 1));
00444     for (k = 0; k < p; k++) {
00445         for (j = 0; j < q; j++) {
00446             REAL(expL)[j*p + k] = REAL(ES)[j] * REAL(wi)[k];
00447             REAL(varL)[j*p + k] = f1*REAL(VS)[j] * REAL(wii)[k] 
00448                                 - f2*REAL(VS)[j] * REAL(wi)[k]*REAL(wi)[k];
00449         }
00450     }
00451     UNPROTECT(5);
00452     return(ans);
00453 }
00454 
00455 SEXP ev(SEXP Weights, SEXP Scores, SEXP cweights) {
00456 
00457     /*
00458      *
00459      *   Conditional Expectation and Variance of
00460      *   Linear Statistics of the form
00461      *
00462      *       L = vec(W %*% diag(cw) %*% S)
00463      *
00464      */
00465                                 
00466 
00467     SEXP evSans, ans;
00468     
00469     evSans = evS(Scores, cweights);
00470     ans = evL(Weights, Scores, cweights, evSans);
00471     return(ans);
00472 
00473 }

Generated on Thu Apr 14 11:34:01 2005 for party by doxygen1.2.15