# Helpers.c

Go to the documentation of this file.

    00001
    00009 #include "coin_common.h"
    00010
    00011 int nrow(SEXP x) {
    00012     SEXP a;
    00013
    00014     a = getAttrib(x, R_DimSymbol);
    00015     if (a == R_NilValue) {
    00016         return(LENGTH(x));
    00017     } else {
    00018         return(INTEGER(getAttrib(x, R_DimSymbol))[0]);
    00019     }
    00020 }
    00021
    00022 int ncol(SEXP x) {
    00023     SEXP a;
    00024
    00025     a = getAttrib(x, R_DimSymbol);
    00026     if (a == R_NilValue) {
    00027         return(1);
    00028     } else {
    00029         return(INTEGER(getAttrib(x, R_DimSymbol))[1]);
    00030     }
    00031 }
    00032
    00033
    00042 void C_SampleNoReplace(int *x, int m, int k, int *ans) {
    00043
    00044     int i, j, n = m;
    00045
    00046     for (i = 0; i < m; i++)
    00047         x[i] = i;
    00048     for (i = 0; i < k; i++) {
    00049         j = n * unif_rand();
    00050         ans[i] = x[j];
    00051         x[j] = x[--n];
    00052     }
    00053 }
    00054
    00055
    00056 SEXP R_blocksetup (SEXP block) {
    00057
    00058     int n, nlev, nlevels, i, j, *iblock, l;
    00059     SEXP ans, dims, indices, dummies, pindices, lindex;
    00060
    00061     n = LENGTH(block);
    00062     iblock = INTEGER(block);
    00063     nlevels = 1;
    00064     for (i = 0; i < n; i++) {
    00065         if (iblock[i] > nlevels) nlevels++;
    00066     }
    00067
    00068     PROTECT(ans = allocVector(VECSXP, 4));
    00069     SET_VECTOR_ELT(ans, 0, dims = allocVector(INTSXP, 2));
    00070     SET_VECTOR_ELT(ans, 1, indices = allocVector(VECSXP, nlevels));
    00071     SET_VECTOR_ELT(ans, 2, dummies = allocVector(VECSXP, nlevels));
    00072     SET_VECTOR_ELT(ans, 3, pindices = allocVector(VECSXP, nlevels));
    00073
    00074     INTEGER(dims)[0] = n;
    00075     INTEGER(dims)[1] = nlevels;
    00076
    00077     for (l = 1; l <= nlevels; l++) {
    00078
    00079         /* number of elements in block `l' */
    00080         nlev = 0;
    00081         for (i = 0; i < n; i++) {
    00082             if (iblock[i] == l) nlev++;
    00083         }
    00084
    00085         /* which(block == l) and memory setup */
    00086         SET_VECTOR_ELT(indices, l - 1, lindex = allocVector(INTSXP, nlev));
    00087         SET_VECTOR_ELT(dummies, l - 1, allocVector(INTSXP, nlev));
    00088         SET_VECTOR_ELT(pindices, l - 1, allocVector(INTSXP, nlev));
    00089
    00090         j = 0;
    00091         for (i = 0; i < n; i++) {
    00092             if (iblock[i] == l) {
    00093                 INTEGER(lindex)[j] = i;
    00094                 j++;
    00095             }
    00096         }
    00097     }
    00098
    00099     UNPROTECT(1);
    00100     return(ans);
    00101 }
    00102
    00103
    00110 void C_blockperm (SEXP blocksetup, int *ans) {
    00111
    00112     int n, nlevels, l, nlev, j, *iindex, *ipindex;
    00113     SEXP indices, dummies, pindices, index, dummy, pindex;
    00114
    00115     n = INTEGER(VECTOR_ELT(blocksetup, 0))[0];
    00116     nlevels = INTEGER(VECTOR_ELT(blocksetup, 0))[1];
    00117     indices = VECTOR_ELT(blocksetup, 1);
    00118     dummies = VECTOR_ELT(blocksetup, 2);
    00119     pindices = VECTOR_ELT(blocksetup, 3);
    00120
    00121     for (l = 1; l <= nlevels; l++) {
    00122
    00123         /* number of elements in block `l' */
    00124         index = VECTOR_ELT(indices, l - 1);
    00125         dummy = VECTOR_ELT(dummies, l - 1);
    00126         pindex = VECTOR_ELT(pindices, l - 1);
    00127         nlev = LENGTH(index);
    00128         iindex = INTEGER(index);
    00129         ipindex = INTEGER(pindex);
    00130
    00131         C_SampleNoReplace(INTEGER(dummy), nlev, nlev, ipindex);
    00132
    00133         for (j = 0; j < nlev; j++) {
    00134             ans[iindex[j]] = iindex[ipindex[j]];
    00135         }
    00136     }
    00137 }
    00138
    00139 SEXP R_blockperm (SEXP block) {
    00140
    00141     SEXP blocksetup, ans;
    00142
    00143     blocksetup = R_blocksetup(block);
    00144     PROTECT(ans = allocVector(INTSXP, LENGTH(block)));
    00145     GetRNGstate();
    00146     C_blockperm(blocksetup, INTEGER(ans));
    00147     PutRNGstate();
    00148     UNPROTECT(1);
    00149     return(ans);
    00150 }
    00151
    00152 SEXP R_MonteCarloIndependenceTest (SEXP x, SEXP y, SEXP block, SEXP B) {
    00153
    00154     int n, p, q, pq, i, *index, *permindex, b, Bsim;
    00155     SEXP ans, blocksetup, linstat;
    00156     double *dans, *dlinstat, *dx, *dy, f = 0.1;
    00157
    00158     n = nrow(x);
    00159     p = ncol(x);
    00160     q = ncol(y);
    00161     pq = p*q;
    00162     Bsim = INTEGER(B)[0];
    00163     dx = REAL(x);
    00164     dy = REAL(y);
    00165
    00166     index = Calloc(n, int);
    00167     permindex = Calloc(n, int);
    00168
    00169     PROTECT(blocksetup = R_blocksetup(block));
    00170
    00171     PROTECT(ans = allocMatrix(REALSXP, pq, Bsim));
    00172     dans = REAL(ans);
    00173     PROTECT(linstat = allocVector(REALSXP, pq));
    00174     dlinstat = REAL(linstat);
    00175
    00176     for (i = 0; i < n; i++)
    00177         index[i] = i;
    00178
    00179     GetRNGstate();
    00180
    00181     for (b = 0; b < Bsim; b++) {
    00182
    00183         C_blockperm(blocksetup, permindex);
    00184         C_PermutedLinearStatistic(dx, p, dy, q, n, n, index, permindex, dlinstat);
    00185
    00186         for (i = 0; i < pq; i++) dans[b*pq + i] = dlinstat[i];
    00187
    00188         /* check user interrupts */
    00189         if (b > Bsim * f) {
    00190             R_CheckUserInterrupt();
    00191             f += 0.1;
    00192         }
    00193     }
    00194
    00195     PutRNGstate();
    00196
    00197     Free(index); Free(permindex);
    00198
    00199     UNPROTECT(3);
    00200     return(ans);
    00201 }
    00202
    00203
    00204 SEXP R_maxstattrafo(SEXP x, SEXP cutpoints) {
    00205
    00206     int i, j, n, nc, jn;
    00207     SEXP ans;
    00208     double *dans, *dx, *dcutpoints, cj;
    00209
    00210     if (!isReal(x) || !isReal(cutpoints))
    00211         error("x or cutpoints are not of type REALSXP");
    00212
    00213     n = LENGTH(x);
    00214     nc = LENGTH(cutpoints);
    00215     PROTECT(ans = allocMatrix(REALSXP, n, nc));
    00216     dans = REAL(ans);
    00217     dx = REAL(x);
    00218     dcutpoints = REAL(cutpoints);
    00219
    00220     for (j = 0; j < nc; j++) {
    00221         jn = j * n;
    00222         cj = dcutpoints[j];
    00223         for (i = 0; i < n; i++) {
    00224             if (dx[i] > cj) {
    00225                 dans[jn + i] = 0.0;
    00226             } else {
    00227                 dans[jn + i] = 1.0;
    00228             }
    00229         }
    00230     }
    00231     UNPROTECT(1);
    00232     return(ans);
    00233 }