Main Page | Alphabetical List | Class List | Directories | File List | Class Members | File Members

CIstuff.c

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

Generated on Thu Jul 28 17:05:21 2005 for coin by  doxygen 1.4.2