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 
00102 void CR_La_svd(SEXP jobu, SEXP jobv, SEXP x, SEXP s, SEXP u, SEXP v,
00103                SEXP method)
00104 {
00105     int *xdims, n, p, lwork, info = 0;
00106     double *work, *xvals, tmp;
00107     const char * meth;
00108 
00109     if (!(isString(jobu) && isString(jobv)))
00110         error(("'jobu' and 'jobv' must be character strings"));
00111     if (!isString(method))
00112         error(("'method' must be a character string"));
00113     meth = CHAR(STRING_ELT(method, 0));
00114     xdims = INTEGER(coerceVector(getAttrib(x, R_DimSymbol), INTSXP));
00115     n = xdims[0]; p = xdims[1];
00116     xvals = Calloc(n * p, double);
00117     /* work on a copy of x */
00118     Memcpy(xvals, REAL(x), (size_t) (n * p));
00119 
00120     {
00121         int ldu = INTEGER(getAttrib(u, R_DimSymbol))[0],
00122             ldvt = INTEGER(getAttrib(v, R_DimSymbol))[0];
00123         int *iwork= (int *) R_alloc(8*(n<p ? n : p), sizeof(int));
00124 
00125         /* ask for optimal size of work array */
00126         lwork = -1;
00127         F77_CALL(dgesdd)(CHAR(STRING_ELT(jobu, 0)),
00128                          &n, &p, xvals, &n, REAL(s),
00129                          REAL(u), &ldu,
00130                          REAL(v), &ldvt,
00131                          &tmp, &lwork, iwork, &info);
00132         if (info != 0)
00133             error(("error code %d from Lapack routine '%s'"), info, "dgesdd");
00134         lwork = (int) tmp;
00135         work = Calloc(lwork, double);
00136         F77_CALL(dgesdd)(CHAR(STRING_ELT(jobu, 0)),
00137                          &n, &p, xvals, &n, REAL(s),
00138                          REAL(u), &ldu,
00139                          REAL(v), &ldvt,
00140                          work, &lwork, iwork, &info);
00141         if (info != 0)
00142             error(("error code %d from Lapack routine '%s'"), info, "dgesdd");
00143     }
00144     Free(work); Free(xvals);
00145 }
00146 
00153 SEXP CR_svd (SEXP x, SEXP svdmem) {
00154 
00155     int p, i;
00156     double *du, *dv;
00157 
00158     if (!isMatrix(x) || !isReal(x))
00159         error("x is not a real matrix");
00160 
00161     du = REAL(GET_SLOT(svdmem, PL2_uSym));
00162     dv = REAL(GET_SLOT(svdmem, PL2_vSym));
00163     p = INTEGER(GET_SLOT(svdmem, PL2_pSym))[0];
00164     if (nrow(x) != p) error("svd p x error");
00165     for (i = 0; i < p*p; i++) {
00166         du[i] = 0.0;
00167         dv[i] = 0.0;
00168     }
00169     CR_La_svd(GET_SLOT(svdmem, PL2_jobuSym), 
00170         GET_SLOT(svdmem, PL2_jobvSym), x, GET_SLOT(svdmem, PL2_sSym), 
00171         GET_SLOT(svdmem, PL2_uSym), GET_SLOT(svdmem, PL2_vSym), 
00172         GET_SLOT(svdmem, PL2_methodSym));
00173     return(R_NilValue);
00174 }
00175 
00176 
00185 void C_MPinv (SEXP x, double tol, SEXP svdmem, SEXP ans) {
00186 
00187     SEXP svdx, d, u, vt, dummy;
00188     int i, j, p, k, *positive;
00189     double *dd, *du, *dvt, *dMPinv;
00190     double *drank;
00191     
00192     drank = REAL(GET_SLOT(ans, PL2_rankSym));
00193     dMPinv = REAL(GET_SLOT(ans, PL2_MPinvSym));
00194 
00195     dummy = CR_svd(x, svdmem);
00196     d = GET_SLOT(svdmem, PL2_sSym);
00197     dd = REAL(d);
00198     u = GET_SLOT(svdmem, PL2_uSym);
00199     du = REAL(u);
00200     vt = GET_SLOT(svdmem, PL2_vSym);
00201     dvt = REAL(vt);
00202     p = LENGTH(d);
00203 
00204     if (tol * dd[0] > tol) tol = tol * dd[0];
00205 
00206     positive = Calloc(p, int); 
00207     
00208     drank[0] = 0.0;
00209     for (i = 0; i < p; i++) {
00210         if (dd[i] > tol) {
00211             positive[i] = 1;
00212             drank[0] += 1.0;
00213         } 
00214     }
00215     
00216     for (j = 0; j < p; j++) {
00217         if (positive[j]) {
00218             for (i = 0; i < p; i++)
00219                 du[j * p + i] *= (1 / dd[j]);
00220         }
00221     }
00222     
00223     for (i = 0; i < p; i++) {
00224         for (j = 0; j < p; j++) {
00225             dMPinv[j * p + i] = 0.0;
00226             for (k = 0; k < p; k++) {
00227                 if (positive[k])
00228                     dMPinv[j * p + i] += dvt[i * p + k] * du[p * k + j]; 
00229             }
00230         }
00231     }
00232 
00233     Free(positive);
00234 }
00235 
00243 SEXP R_MPinv (SEXP x, SEXP tol, SEXP svdmem) {
00244 
00245     SEXP ans;
00246     int p;
00247 
00248     if (!isMatrix(x) || !isReal(x))
00249         error("R_MPinv: x is not a real matrix");
00250 
00251     if (nrow(x) != ncol(x)) 
00252         error("R_MPinv: x is not a square matrix");
00253 
00254     if (!isReal(tol) || LENGTH(tol) != 1)
00255         error("R_MPinv: tol is not a scalar real");
00256     
00257     p = nrow(x);
00258     if (p != INTEGER(GET_SLOT(svdmem, PL2_pSym))[0])
00259         error("R_MPinv: dimensions don't match");
00260 
00261     PROTECT(ans = NEW_OBJECT(MAKE_CLASS("LinStatExpectCovarMPinv")));
00262     SET_SLOT(ans, PL2_MPinvSym, PROTECT(allocMatrix(REALSXP, p, p)));
00263     SET_SLOT(ans, PL2_rankSym, PROTECT(allocVector(REALSXP, 1)));
00264     
00265     C_MPinv(x, REAL(tol)[0], svdmem, ans);
00266     
00267     UNPROTECT(3);
00268     return(ans);
00269 }
00270 
00278 double C_max(const double *x, const int n) {
00279    double tmp = 0.0;
00280    int i;
00281    
00282    for (i = 0; i < n; i++) {
00283        if (x[i] > tmp) tmp = x[i];
00284    }
00285    return(tmp);
00286 }
00287 
00288 
00294 SEXP R_max(SEXP x) {
00295 
00296     SEXP ans;
00297     int n;
00298     
00299     if (!isReal(x)) 
00300         error("R_max: x is not of type REALSXP");
00301     n = LENGTH(x);
00302     PROTECT(ans = allocVector(REALSXP, 1));
00303     REAL(ans)[0] = C_max(REAL(x), n);
00304     UNPROTECT(1);
00305     return(ans);
00306 }
00307 
00308 
00315 void C_abs(double *x, int n) {
00316 
00317     int i;
00318     for (i = 0; i < n; i++) x[i] = fabs(x[i]);
00319 }
00320 
00321 
00327 SEXP R_abs(SEXP x) {
00328 
00329     SEXP ans;
00330     int n;
00331     
00332     if (!isReal(x)) 
00333         error("R_max: x is not of type REALSXP");
00334     n = LENGTH(x);
00335     PROTECT(ans = duplicate(x));
00336     C_abs(REAL(ans), n);
00337     UNPROTECT(1);
00338     return(ans);
00339 }
00340 
00341 
00353 void C_matprod(double *x, int nrx, int ncx,
00354                double *y, int nry, int ncy, double *z)
00355 {
00356     char *transa = "N", *transb = "N";
00357     double one = 1.0, zero = 0.0;
00358     int i;
00359 
00360     if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
00361         F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one,
00362                         x, &nrx, y, &nry, &zero, z, &nrx);
00363     } else /* zero-extent operations should return zeroes */
00364         for(i = 0; i < nrx*ncy; i++) z[i] = 0;
00365 }
00366 
00367 
00374 SEXP R_matprod(SEXP x, SEXP y) {
00375 
00376     SEXP ans;
00377     
00378     int nrx, ncx, nry, ncy;
00379     
00380     nrx = nrow(x);
00381     ncx = ncol(x);
00382     nry = nrow(y);
00383     ncy = ncol(y);
00384 
00385     if (ncx != nry)
00386         error("R_matprod: dimensions don't match");
00387     PROTECT(ans = allocMatrix(REALSXP, nrx, ncy));
00388     C_matprod(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans));
00389     UNPROTECT(1);
00390     return(ans);
00391 }
00392 
00393 
00405 void C_matprodT(double *x, int nrx, int ncx,
00406                 double *y, int nry, int ncy, double *z)
00407 {
00408     char *transa = "N", *transb = "T";
00409     double one = 1.0, zero = 0.0;
00410     int i;
00411 
00412     if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
00413         F77_CALL(dgemm)(transa, transb, &nrx, &nry, &ncy, &one,
00414                         x, &nrx, y, &nry, &zero, z, &nrx);
00415     } else /* zero-extent operations should return zeroes */
00416         for(i = 0; i < nrx*nry; i++) z[i] = 0;
00417 }
00418 
00419 
00426 SEXP R_matprodT(SEXP x, SEXP y) {
00427 
00428     SEXP ans;
00429     int nrx, ncx, nry, ncy;
00430     
00431     nrx = nrow(x);
00432     ncx = ncol(x);
00433     nry = nrow(y);
00434     ncy = ncol(y);
00435 
00436     if (ncx != ncy)
00437         error("R_matprod: dimensions don't match");
00438     PROTECT(ans = allocMatrix(REALSXP, nrx, nry));
00439     C_matprodT(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans));
00440     UNPROTECT(1);
00441     return(ans);
00442 }
00443 
00444 
00453 void C_SampleNoReplace(int *x, int m, int k, int *ans) {
00454      
00455     int i, j, n = m;
00456 
00457     for (i = 0; i < m; i++)
00458         x[i] = i;
00459     for (i = 0; i < k; i++) {
00460         j = n * unif_rand(); 
00461         ans[i] = x[j];
00462         x[j] = x[--n];  
00463     }
00464 }
00465 
00466 
00472 SEXP R_permute(SEXP m) {
00473     
00474     SEXP x, ans;
00475     int n;
00476     
00477     n = INTEGER(m)[0];
00478     PROTECT(x = allocVector(INTSXP, n));
00479     PROTECT(ans = allocVector(INTSXP, n));
00480     C_SampleNoReplace(INTEGER(x), n, n, INTEGER(ans));
00481     UNPROTECT(2);
00482     return(ans);
00483 }
00484 
00485 
00492 SEXP R_rsubset(SEXP m, SEXP k) {
00493     
00494     SEXP x, ans;
00495     int n, j;
00496     
00497     n = INTEGER(m)[0];
00498     j = INTEGER(k)[0];
00499     PROTECT(x = allocVector(INTSXP, n));
00500     PROTECT(ans = allocVector(INTSXP, j));
00501     C_SampleNoReplace(INTEGER(x), n, j, INTEGER(ans));
00502     UNPROTECT(2);
00503     return(ans);
00504 }
00505 
00506 /* Unequal probability sampling; without-replacement case */
00507 
00508 void C_ProbSampleNoReplace(int n, double *p, int *perm,
00509                            int nans, int *ans)
00510 {
00511     double rT, mass, totalmass;
00512     int i, j, k, n1;
00513 
00514     /* Record element identities */
00515     for (i = 0; i < n; i++)
00516         perm[i] = i + 1;
00517 
00518     /* Sort probabilities into descending order */
00519     /* Order element identities in parallel */
00520     revsort(p, perm, n);
00521 
00522     /* Compute the sample */
00523     totalmass = 1;
00524     for (i = 0, n1 = n-1; i < nans; i++, n1--) {
00525         rT = totalmass * unif_rand();
00526         mass = 0;
00527         for (j = 0; j < n1; j++) {
00528             mass += p[j];
00529             if (rT <= mass)
00530                 break;
00531         }
00532         ans[i] = perm[j];
00533         totalmass -= p[j];
00534         for(k = j; k < n1; k++) {
00535             p[k] = p[k + 1];
00536             perm[k] = perm[k + 1];
00537         }
00538     }
00539 }
00540 
00541 
00549 int i_in_set(int i, int *iset, int p) {
00550 
00551     int j, is = 0;
00552         
00553     if (p == 0) return(0);
00554                     
00555     for (j = 0; j < p; j++) {
00556         if (iset[j] == i) {  
00557             is = 1;
00558             break; 
00559         }
00560     }
00561     return(is);
00562 }
00563 
00564 int C_i_in_set(int i, SEXP set) {
00565     if (LENGTH(set) > 0)
00566         return(i_in_set(i, INTEGER(set), LENGTH(set)));
00567     else 
00568         return(0);
00569 }
00570     
00571 int nrow(SEXP x) {
00572     return(INTEGER(getAttrib(x, R_DimSymbol))[0]);
00573 }
00574 
00575 int ncol(SEXP x) {
00576     return(INTEGER(getAttrib(x, R_DimSymbol))[1]);
00577 }
00578 
00579 /* compute index of variable with smallest p-value 
00580    (and largest test statistic in case two or more p-values coincide -- 
00581     should not happen anymore since we use 1 - (1 - p)^k for Bonferroni adjustment)
00582 */
00583 int C_whichmax(double *pvalue, double *teststat, int ninputs) {
00584 
00585     int ans = -1, j;
00586     double tmppval = 0.0, tmptstat = 0.0;
00587        
00588     /* <FIXME> can we switch to the log scale here? </FIXME> */
00589 
00590     tmppval = 0.0;
00591     tmptstat = 0.0;
00592     for (j = 0; j < ninputs; j++) {
00593         if (pvalue[j] > tmppval) {
00594             ans = j;
00595             tmppval = pvalue[j];
00596             tmptstat = teststat[j];
00597         } else {
00598             if (pvalue[j] == tmppval && teststat[j] > tmptstat) {  
00599                 ans = j;
00600                 tmppval = pvalue[j];
00601                 tmptstat = teststat[j];
00602             }
00603         }
00604     }
00605     return(ans);
00606 }
00607 
00608 SEXP R_whichmax(SEXP x, SEXP y) {
00609     SEXP ans;
00610     
00611     if (LENGTH(x) != LENGTH(y)) error("different length");
00612     PROTECT(ans = allocVector(INTSXP, 1));
00613     INTEGER(ans)[0] = C_whichmax(REAL(x), REAL(y), LENGTH(x));
00614     UNPROTECT(1);
00615     return(ans);
00616 }
00617 
00618 SEXP R_listplus(SEXP a, SEXP b, SEXP which) {
00619 
00620     int na, nb, i, j, *iwhich;
00621     double *dae, *dbe;
00622     SEXP ae, be;
00623 
00624     na = LENGTH(a);
00625     nb = LENGTH(b);
00626     if (na != nb) error("a and b are of different length");
00627     
00628     iwhich = LOGICAL(which);
00629     
00630     for (i = 0; i < na; i++) {
00631         if (iwhich[i]) continue;
00632         
00633         ae = VECTOR_ELT(a, i);
00634         be = VECTOR_ELT(b, i);
00635 
00636         if (LENGTH(ae) != LENGTH(be)) 
00637             error("elements %d are of different length", i);
00638             
00639         if (!isReal(ae) || !isReal(be))
00640             error("elements %d are not of type double", i);
00641             
00642         dae = REAL(ae);
00643         dbe = REAL(be);
00644         for (j = 0; j < LENGTH(ae); j++) 
00645             dae[j] += dbe[j];
00646     }
00647     return(a);
00648 }
00649 
00650 SEXP R_modify_response(SEXP x, SEXP vf) {
00651 
00652     double *src, *tar;
00653     int i, n;
00654     
00655     src = REAL(x);
00656     n = LENGTH(x);
00657 
00658     tar = REAL(get_transformation(vf, 1));
00659     for (i = 0; i < n; i++)
00660         tar[i] = src[i];
00661 
00662     tar = REAL(get_test_trafo(vf));
00663     for (i = 0; i < n; i++)
00664         tar[i] = src[i];
00665 
00666     tar = REAL(get_predict_trafo(vf));
00667     for (i = 0; i < n; i++)
00668         tar[i] = src[i];
00669 
00670     tar = REAL(get_variable(vf, 1));
00671     for (i = 0; i < n; i++)
00672         tar[i] = src[i];
00673                                           
00674     return(R_NilValue);
00675 }
00676 
00677 double F77_SUB(unifrnd)(void) { return unif_rand(); }
00678 
00679 void C_SampleSplitting(int n, double *prob, int *weights, int k) {
00680 
00681     int i;
00682     double *tmpprob;
00683     int *ans, *perm;
00684 
00685     tmpprob = Calloc(n, double);
00686     perm = Calloc(n, int);
00687     ans = Calloc(k, int);
00688     for (i = 0; i < n; i++) tmpprob[i] = prob[i];
00689 
00690     C_ProbSampleNoReplace(n, tmpprob, perm, k, ans);
00691     for (i = 0; i < n; i++) weights[i] = 0;
00692     for (i = 0; i < k; i++)
00693         weights[ans[i] - 1] = 1;
00694     Free(tmpprob); Free(perm); Free(ans);
00695 }
00696 
00702 void C_remove_weights(SEXP subtree) {
00703 
00704     SET_VECTOR_ELT(subtree, S3_WEIGHTS, R_NilValue);
00705     
00706     if (!S3get_nodeterminal(subtree)) {
00707         C_remove_weights(S3get_leftnode(subtree));
00708         C_remove_weights(S3get_rightnode(subtree));
00709     }
00710 }
00711 
00712 double* C_tempweights(int j, SEXP weights, SEXP fitmem, SEXP inputs) {
00713 
00714     int nobs, *iNAs, i, k;
00715     double *dw, *dweights;
00716     SEXP NAs;
00717     
00718     dw = REAL(get_weights(fitmem));
00719     nobs = LENGTH(weights);
00720     dweights = REAL(weights);
00721     NAs = get_missings(inputs, j);
00722     iNAs = INTEGER(NAs);
00723     if (length(NAs) == 0) return(dw);
00724     for (i = 0; i < nobs; i++) dw[i] = dweights[i];
00725     for (k = 0; k < LENGTH(NAs); k++)
00726         dw[iNAs[k] - 1] = 0.0;
00727     
00728     return(dw);
00729 }

Generated on Thu Jun 26 11:36:23 2008 for party by  doxygen 1.5.5