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
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
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
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
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
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
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
00519 for (i = 0; i < n; i++)
00520 perm[i] = i + 1;
00521
00522
00523
00524 revsort(p, perm, n);
00525
00526
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
00584
00585
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
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 }