Utils.c

Go to the documentation of this file.
00001 
00009 #include "party.h"
00010                 
00011                 
00023 void C_kronecker (const double *A, const int m, const int n,
00024                   const double *B, const int r, const int s,
00025                   double *ans) {
00026 
00027     int i, j, k, l, mr, js, ir;
00028     double y;
00029 
00030     mr = m * r;
00031     for (i = 0; i < m; i++) {
00032         ir = i * r;
00033         for (j = 0; j < n; j++) {
00034             js = j * s;
00035             y = A[j*m + i];
00036             for (k = 0; k < r; k++) {
00037                 for (l = 0; l < s; l++) {
00038                     ans[(js + l) * mr + ir + k] = y * B[l * r + k];
00039                 }
00040             }
00041         }
00042     }
00043 }  
00044 
00045 
00052 SEXP R_kronecker (SEXP A, SEXP B) {
00053 
00054     /*  The Kronecker product, a real (mr x ns) matrix */
00055     SEXP ans; 
00056     int *adim, *bdim;
00057 
00058     if (!isReal(A) || !isReal(B)) 
00059         error("R_kronecker: A and B are not of type REALSXP");
00060 
00061     if (isMatrix(A)) {
00062         adim = INTEGER(getAttrib(A, R_DimSymbol));
00063     } else {
00064         /* assume row vectors */
00065         adim = Calloc(2, int);
00066         adim[0] = 1;
00067         adim[1] = LENGTH(A);
00068     }
00069     
00070     if (isMatrix(B)) {
00071         bdim = INTEGER(getAttrib(B, R_DimSymbol));
00072     } else {
00073         /* assume row vectors */
00074         bdim = Calloc(2, int);
00075         bdim[0] = 1;
00076         bdim[1] = LENGTH(B);
00077     }
00078 
00079     PROTECT(ans = allocMatrix(REALSXP, 
00080                               adim[0] * bdim[0], 
00081                               adim[1] * bdim[1]));
00082     C_kronecker(REAL(A), adim[0], adim[1], 
00083                 REAL(B), bdim[0], bdim[1], REAL(ans));
00084     if (!isMatrix(A)) Free(adim); 
00085     if (!isMatrix(B)) Free(bdim);
00086     UNPROTECT(1);
00087     return(ans);
00088 }
00089 
00090 
00103 void CR_La_svd(SEXP jobu, SEXP jobv, SEXP x, SEXP s, SEXP u, SEXP v,
00104                SEXP method, SEXP val)
00105 {
00106     int *xdims, n, p, lwork, info = 0;
00107     double *work, *xvals, tmp;
00108     char *meth;
00109 
00110     if (!(isString(jobu) && isString(jobv)))
00111         error(("'jobu' and 'jobv' must be character strings"));
00112     if (!isString(method))
00113         error(("'method' must be a character string"));
00114     meth = CHAR(STRING_ELT(method, 0));
00115     xdims = INTEGER(coerceVector(getAttrib(x, R_DimSymbol), INTSXP));
00116     n = xdims[0]; p = xdims[1];
00117     xvals = (double *) R_alloc(n * p, sizeof(double));
00118     /* work on a copy of x */
00119     Memcpy(xvals, REAL(x), (size_t) (n * p));
00120 
00121     {
00122         int ldu = INTEGER(getAttrib(u, R_DimSymbol))[0],
00123             ldvt = INTEGER(getAttrib(v, R_DimSymbol))[0];
00124         int *iwork= (int *) R_alloc(8*(n<p ? n : p), sizeof(int));
00125 
00126         /* ask for optimal size of work array */
00127         lwork = -1;
00128         F77_CALL(dgesdd)(CHAR(STRING_ELT(jobu, 0)),
00129                          &n, &p, xvals, &n, REAL(s),
00130                          REAL(u), &ldu,
00131                          REAL(v), &ldvt,
00132                          &tmp, &lwork, iwork, &info);
00133         if (info != 0)
00134             error(("error code %d from Lapack routine '%s'"), info, "dgesdd");
00135         lwork = (int) tmp;
00136         work = (double *) R_alloc(lwork, sizeof(double));
00137         F77_CALL(dgesdd)(CHAR(STRING_ELT(jobu, 0)),
00138                          &n, &p, xvals, &n, REAL(s),
00139                          REAL(u), &ldu,
00140                          REAL(v), &ldvt,
00141                          work, &lwork, iwork, &info);
00142         if (info != 0)
00143             error(("error code %d from Lapack routine '%s'"), info, "dgesdd");
00144     }
00145 
00146     SET_VECTOR_ELT(val, 0, s);
00147     SET_VECTOR_ELT(val, 1, u);
00148     SET_VECTOR_ELT(val, 2, v);
00149 }
00150 
00157 SEXP CR_svd (SEXP x, SEXP svdmem) {
00158 
00159     int p, i;
00160     double *du, *dv;
00161 
00162     if (!isMatrix(x) || !isReal(x))
00163         error("x is not a real matrix");
00164 
00165     du = REAL(GET_SLOT(svdmem, PL2_uSym));
00166     dv = REAL(GET_SLOT(svdmem, PL2_vSym));
00167     p = INTEGER(GET_SLOT(svdmem, PL2_pSym))[0];
00168     for (i = 0; i < p*p; i++) {
00169         du[i] = 0.0;
00170         dv[i] = 0.0;
00171     }
00172     CR_La_svd(GET_SLOT(svdmem, PL2_jobuSym), 
00173         GET_SLOT(svdmem, PL2_jobvSym), x, GET_SLOT(svdmem, PL2_sSym), 
00174         GET_SLOT(svdmem, PL2_uSym), GET_SLOT(svdmem, PL2_vSym), 
00175         GET_SLOT(svdmem, PL2_methodSym), GET_SLOT(svdmem, PL2_svdSym));
00176     return(R_NilValue);
00177 }
00178 
00179 
00188 void C_MPinv (SEXP x, double tol, SEXP svdmem, SEXP ans) {
00189 
00190     SEXP svdx, d, u, vt, dummy;
00191     int i, j, p, k, *positive;
00192     double *dd, *du, *dvt, *dMPinv;
00193     double *drank;
00194     
00195     drank = REAL(GET_SLOT(ans, PL2_rankSym));
00196     dMPinv = REAL(GET_SLOT(ans, PL2_MPinvSym));
00197 
00198     dummy = CR_svd(x, svdmem);
00199     svdx = GET_SLOT(svdmem, PL2_svdSym);
00200     d = VECTOR_ELT(svdx, 0);
00201     dd = REAL(d);
00202     u = VECTOR_ELT(svdx, 1);
00203     du = REAL(u);
00204     vt = VECTOR_ELT(svdx, 2);
00205     dvt = REAL(vt);
00206     p = LENGTH(d);
00207 
00208     if (tol * dd[0] > tol) tol = tol * dd[0];
00209 
00210     positive = Calloc(p, int); 
00211     
00212     drank[0] = 0.0;
00213     for (i = 0; i < p; i++) {
00214         if (dd[i] > tol) {
00215             positive[i] = 1;
00216             drank[0] += 1.0;
00217         } 
00218     }
00219     
00220     for (j = 0; j < p; j++) {
00221         if (positive[j]) {
00222             for (i = 0; i < p; i++)
00223                 du[j * p + i] *= (1 / dd[j]);
00224         }
00225     }
00226     
00227     for (i = 0; i < p; i++) {
00228         for (j = 0; j < p; j++) {
00229             dMPinv[j * p + i] = 0.0;
00230             for (k = 0; k < p; k++) {
00231                 if (positive[k])
00232                     dMPinv[j * p + i] += dvt[i * p + k] * du[p * k + j]; 
00233             }
00234         }
00235     }
00236 
00237     Free(positive);
00238 }
00239 
00247 SEXP R_MPinv (SEXP x, SEXP tol, SEXP svdmem) {
00248 
00249     SEXP ans;
00250     int p;
00251 
00252     if (!isMatrix(x) || !isReal(x))
00253         error("R_MPinv: x is not a real matrix");
00254 
00255     if (nrow(x) != ncol(x)) 
00256         error("R_MPinv: x is not a square matrix");
00257 
00258     if (!isReal(tol) || LENGTH(tol) != 1)
00259         error("R_MPinv: tol is not a scalar real");
00260     
00261     p = nrow(x);
00262     if (p != INTEGER(GET_SLOT(svdmem, PL2_pSym))[0])
00263         error("R_MPinv: dimensions don't match");
00264 
00265     PROTECT(ans = NEW_OBJECT(MAKE_CLASS("LinStatExpectCovarMPinv")));
00266     SET_SLOT(ans, PL2_MPinvSym, PROTECT(allocMatrix(REALSXP, p, p)));
00267     SET_SLOT(ans, PL2_rankSym, PROTECT(allocVector(REALSXP, 1)));
00268     
00269     C_MPinv(x, REAL(tol)[0], svdmem, ans);
00270     
00271     UNPROTECT(3);
00272     return(ans);
00273 }
00274 
00282 double C_max(const double *x, const int n) {
00283    double tmp = 0.0;
00284    int i;
00285    
00286    for (i = 0; i < n; i++) {
00287        if (x[i] > tmp) tmp = x[i];
00288    }
00289    return(tmp);
00290 }
00291 
00292 
00298 SEXP R_max(SEXP x) {
00299 
00300     SEXP ans;
00301     int n;
00302     
00303     if (!isReal(x)) 
00304         error("R_max: x is not of type REALSXP");
00305     n = LENGTH(x);
00306     PROTECT(ans = allocVector(REALSXP, 1));
00307     REAL(ans)[0] = C_max(REAL(x), n);
00308     UNPROTECT(1);
00309     return(ans);
00310 }
00311 
00312 
00319 void C_abs(double *x, int n) {
00320 
00321     int i;
00322     for (i = 0; i < n; i++) x[i] = fabs(x[i]);
00323 }
00324 
00325 
00331 SEXP R_abs(SEXP x) {
00332 
00333     SEXP ans;
00334     int n;
00335     
00336     if (!isReal(x)) 
00337         error("R_max: x is not of type REALSXP");
00338     n = LENGTH(x);
00339     PROTECT(ans = duplicate(x));
00340     C_abs(REAL(ans), n);
00341     UNPROTECT(1);
00342     return(ans);
00343 }
00344 
00345 
00357 void C_matprod(double *x, int nrx, int ncx,
00358                double *y, int nry, int ncy, double *z)
00359 {
00360     char *transa = "N", *transb = "N";
00361     double one = 1.0, zero = 0.0;
00362     int i;
00363 
00364     if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
00365         F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one,
00366                         x, &nrx, y, &nry, &zero, z, &nrx);
00367     } else /* zero-extent operations should return zeroes */
00368         for(i = 0; i < nrx*ncy; i++) z[i] = 0;
00369 }
00370 
00371 
00378 SEXP R_matprod(SEXP x, SEXP y) {
00379 
00380     SEXP ans;
00381     
00382     int nrx, ncx, nry, ncy;
00383     
00384     nrx = nrow(x);
00385     ncx = ncol(x);
00386     nry = nrow(y);
00387     ncy = ncol(y);
00388 
00389     if (ncx != nry)
00390         error("R_matprod: dimensions don't match");
00391     PROTECT(ans = allocMatrix(REALSXP, nrx, ncy));
00392     C_matprod(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans));
00393     UNPROTECT(1);
00394     return(ans);
00395 }
00396 
00397 
00409 void C_matprodT(double *x, int nrx, int ncx,
00410                 double *y, int nry, int ncy, double *z)
00411 {
00412     char *transa = "N", *transb = "T";
00413     double one = 1.0, zero = 0.0;
00414     int i;
00415 
00416     if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
00417         F77_CALL(dgemm)(transa, transb, &nrx, &nry, &ncy, &one,
00418                         x, &nrx, y, &nry, &zero, z, &nrx);
00419     } else /* zero-extent operations should return zeroes */
00420         for(i = 0; i < nrx*nry; i++) z[i] = 0;
00421 }
00422 
00423 
00430 SEXP R_matprodT(SEXP x, SEXP y) {
00431 
00432     SEXP ans;
00433     int nrx, ncx, nry, ncy;
00434     
00435     nrx = nrow(x);
00436     ncx = ncol(x);
00437     nry = nrow(y);
00438     ncy = ncol(y);
00439 
00440     if (ncx != ncy)
00441         error("R_matprod: dimensions don't match");
00442     PROTECT(ans = allocMatrix(REALSXP, nrx, nry));
00443     C_matprodT(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans));
00444     UNPROTECT(1);
00445     return(ans);
00446 }
00447 
00448 
00457 void C_SampleNoReplace(int *x, int m, int k, int *ans) {
00458      
00459     int i, j, n = m;
00460 
00461     for (i = 0; i < m; i++)
00462         x[i] = i;
00463     for (i = 0; i < k; i++) {
00464         j = n * unif_rand(); 
00465         ans[i] = x[j];
00466         x[j] = x[--n];  
00467     }
00468 }
00469 
00470 
00476 SEXP R_permute(SEXP m) {
00477     
00478     SEXP x, ans;
00479     int n;
00480     
00481     n = INTEGER(m)[0];
00482     PROTECT(x = allocVector(INTSXP, n));
00483     PROTECT(ans = allocVector(INTSXP, n));
00484     C_SampleNoReplace(INTEGER(x), n, n, INTEGER(ans));
00485     UNPROTECT(2);
00486     return(ans);
00487 }
00488 
00489 
00496 SEXP R_rsubset(SEXP m, SEXP k) {
00497     
00498     SEXP x, ans;
00499     int n, j;
00500     
00501     n = INTEGER(m)[0];
00502     j = INTEGER(k)[0];
00503     PROTECT(x = allocVector(INTSXP, n));
00504     PROTECT(ans = allocVector(INTSXP, j));
00505     C_SampleNoReplace(INTEGER(x), n, j, INTEGER(ans));
00506     UNPROTECT(2);
00507     return(ans);
00508 }
00509 
00510 /* Unequal probability sampling; without-replacement case */
00511 
00512 void C_ProbSampleNoReplace(int n, double *p, int *perm,
00513                            int nans, int *ans)
00514 {
00515     double rT, mass, totalmass;
00516     int i, j, k, n1;
00517 
00518     /* Record element identities */
00519     for (i = 0; i < n; i++)
00520         perm[i] = i + 1;
00521 
00522     /* Sort probabilities into descending order */
00523     /* Order element identities in parallel */
00524     revsort(p, perm, n);
00525 
00526     /* Compute the sample */
00527     totalmass = 1;
00528     for (i = 0, n1 = n-1; i < nans; i++, n1--) {
00529         rT = totalmass * unif_rand();
00530         mass = 0;
00531         for (j = 0; j < n1; j++) {
00532             mass += p[j];
00533             if (rT <= mass)
00534                 break;
00535         }
00536         ans[i] = perm[j];
00537         totalmass -= p[j];
00538         for(k = j; k < n1; k++) {
00539             p[k] = p[k + 1];
00540             perm[k] = perm[k + 1];
00541         }
00542     }
00543 }
00544 
00545 
00553 int i_in_set(int i, int *iset, int p) {
00554 
00555     int j, is = 0;
00556         
00557     if (p == 0) return(0);
00558                     
00559     for (j = 0; j < p; j++) {
00560         if (iset[j] == i) {  
00561             is = 1;
00562             break; 
00563         }
00564     }
00565     return(is);
00566 }
00567 
00568 int C_i_in_set(int i, SEXP set) {
00569     if (LENGTH(set) > 0)
00570         return(i_in_set(i, INTEGER(set), LENGTH(set)));
00571     else 
00572         return(0);
00573 }
00574     
00575 int nrow(SEXP x) {
00576     return(INTEGER(getAttrib(x, R_DimSymbol))[0]);
00577 }
00578 
00579 int ncol(SEXP x) {
00580     return(INTEGER(getAttrib(x, R_DimSymbol))[1]);
00581 }
00582 
00583 /* compute index of variable with smallest p-value 
00584    (and largest test statistic in case two or more p-values coincide -- 
00585     should not happen anymore since we use 1 - (1 - p)^k for Bonferroni adjustment)
00586 */
00587 int C_whichmax(double *pvalue, double *teststat, int ninputs) {
00588 
00589     int ans = -1, j;
00590     double tmppval = 0.0, tmptstat = 0.0;
00591        
00592     /* <FIXME> can we switch to the log scale here? </FIXME> */
00593 
00594     tmppval = 0.0;
00595     tmptstat = 0.0;
00596     for (j = 0; j < ninputs; j++) {
00597         if (pvalue[j] > tmppval) {
00598             ans = j;
00599             tmppval = pvalue[j];
00600             tmptstat = teststat[j];
00601         } else {
00602             if (pvalue[j] == tmppval && teststat[j] > tmptstat) {  
00603                 ans = j;
00604                 tmppval = pvalue[j];
00605                 tmptstat = teststat[j];
00606             }
00607         }
00608     }
00609     return(ans);
00610 }
00611 
00612 SEXP R_whichmax(SEXP x, SEXP y) {
00613     SEXP ans;
00614     
00615     if (LENGTH(x) != LENGTH(y)) error("different length");
00616     PROTECT(ans = allocVector(INTSXP, 1));
00617     INTEGER(ans)[0] = C_whichmax(REAL(x), REAL(y), LENGTH(x));
00618     UNPROTECT(1);
00619     return(ans);
00620 }
00621 
00622 SEXP R_listplus(SEXP a, SEXP b, SEXP which) {
00623 
00624     int na, nb, i, j, *iwhich;
00625     double *dae, *dbe;
00626     SEXP ae, be;
00627 
00628     na = LENGTH(a);
00629     nb = LENGTH(b);
00630     if (na != nb) error("a and b are of different length");
00631     
00632     iwhich = LOGICAL(which);
00633     
00634     for (i = 0; i < na; i++) {
00635         if (iwhich[i]) continue;
00636         
00637         ae = VECTOR_ELT(a, i);
00638         be = VECTOR_ELT(b, i);
00639 
00640         if (LENGTH(ae) != LENGTH(be)) 
00641             error("elements %d are of different length", i);
00642             
00643         if (!isReal(ae) || !isReal(be))
00644             error("elements %d are not of type double", i);
00645             
00646         dae = REAL(ae);
00647         dbe = REAL(be);
00648         for (j = 0; j < LENGTH(ae); j++) 
00649             dae[j] += dbe[j];
00650     }
00651     return(a);
00652 }
00653 
00654 SEXP R_modify_response(SEXP x, SEXP vf) {
00655 
00656     double *src, *tar;
00657     int i, n;
00658     
00659     src = REAL(x);
00660     n = LENGTH(x);
00661 
00662     tar = REAL(get_transformation(vf, 1));
00663     for (i = 0; i < n; i++)
00664         tar[i] = src[i];
00665 
00666     tar = REAL(get_test_trafo(vf));
00667     for (i = 0; i < n; i++)
00668         tar[i] = src[i];
00669 
00670     tar = REAL(get_predict_trafo(vf));
00671     for (i = 0; i < n; i++)
00672         tar[i] = src[i];
00673 
00674     tar = REAL(get_variable(vf, 1));
00675     for (i = 0; i < n; i++)
00676         tar[i] = src[i];
00677                                           
00678     return(R_NilValue);
00679 }
00680 
00681 double F77_SUB(unifrnd)(void) { return unif_rand(); }
00682 
00683 void C_SampleSplitting(int n, double *prob, int *weights, int k) {
00684 
00685     int i;
00686     double *tmpprob;
00687     int *ans, *perm;
00688 
00689     tmpprob = Calloc(n, double);
00690     perm = Calloc(n, int);
00691     ans = Calloc(k, int);
00692     for (i = 0; i < n; i++) tmpprob[i] = prob[i];
00693 
00694     C_ProbSampleNoReplace(n, tmpprob, perm, k, ans);
00695     for (i = 0; i < n; i++) weights[i] = 0;
00696     for (i = 0; i < k; i++)
00697         weights[ans[i] - 1] = 1;
00698     Free(tmpprob); Free(perm); Free(ans);
00699 }

Generated on Wed Jun 20 15:55:33 2007 for party by  doxygen 1.4.6