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
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
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
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
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
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
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
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
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
00515 for (i = 0; i < n; i++)
00516 perm[i] = i + 1;
00517
00518
00519
00520 revsort(p, perm, n);
00521
00522
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
00580
00581
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
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 }