Main Page | Directories | File List | File Members | Related Pages

CIstuff.c

Go to the documentation of this file.
00001 
00009 #include "PL2_common.h"
00010 
00011 
00012 SEXP R_blocksetup (SEXP block) {
00013 
00014     int n, nlev, nlevels, i, j, *iblock, l;
00015     SEXP ans, dims, indices, dummies, pindices, lindex;
00016     
00017     n = LENGTH(block);
00018     iblock = INTEGER(block);
00019     nlevels = 1;
00020     for (i = 0; i < n; i++) {
00021         if (iblock[i] > nlevels) nlevels++;
00022     }
00023     
00024     PROTECT(ans = allocVector(VECSXP, 4));
00025     SET_VECTOR_ELT(ans, 0, dims = allocVector(INTSXP, 2));
00026     SET_VECTOR_ELT(ans, 1, indices = allocVector(VECSXP, nlevels));
00027     SET_VECTOR_ELT(ans, 2, dummies = allocVector(VECSXP, nlevels));
00028     SET_VECTOR_ELT(ans, 3, pindices = allocVector(VECSXP, nlevels));
00029     
00030     INTEGER(dims)[0] = n;
00031     INTEGER(dims)[1] = nlevels;
00032 
00033     for (l = 1; l <= nlevels; l++) {
00034     
00035         /* number of elements in block `l' */
00036         nlev = 0;   
00037         for (i = 0; i < n; i++) {
00038             if (iblock[i] == l) nlev++;
00039         }
00040                                                 
00041         /* which(block == l) and memory setup */
00042         SET_VECTOR_ELT(indices, l - 1, lindex = allocVector(INTSXP, nlev));
00043         SET_VECTOR_ELT(dummies, l - 1, allocVector(INTSXP, nlev));
00044         SET_VECTOR_ELT(pindices, l - 1, allocVector(INTSXP, nlev));
00045 
00046         j = 0;
00047         for (i = 0; i < n; i++) {   
00048             if (iblock[i] == l) {
00049                 INTEGER(lindex)[j] = i;
00050                 j++; 
00051             }
00052         }
00053     }
00054 
00055     UNPROTECT(1);
00056     return(ans);
00057 }
00058 
00059 
00066 void C_blockperm (SEXP blocksetup, int *ans) {
00067                   
00068     int n, nlevels, l, nlev, j, *iindex, *ipindex;
00069     SEXP indices, dummies, pindices, index, dummy, pindex;
00070 
00071     n = INTEGER(VECTOR_ELT(blocksetup, 0))[0];
00072     nlevels = INTEGER(VECTOR_ELT(blocksetup, 0))[1];
00073     indices = VECTOR_ELT(blocksetup, 1);
00074     dummies = VECTOR_ELT(blocksetup, 2);
00075     pindices = VECTOR_ELT(blocksetup, 3);
00076     
00077     for (l = 1; l <= nlevels; l++) {
00078     
00079         /* number of elements in block `l' */
00080         index = VECTOR_ELT(indices, l - 1);
00081         dummy = VECTOR_ELT(dummies, l - 1);
00082         pindex = VECTOR_ELT(pindices, l - 1);
00083         nlev = LENGTH(index);
00084         iindex = INTEGER(index);
00085         ipindex = INTEGER(pindex);
00086 
00087         C_SampleNoReplace(INTEGER(dummy), nlev, nlev, ipindex);
00088 
00089         for (j = 0; j < nlev; j++) {
00090             ans[iindex[j]] = iindex[ipindex[j]];
00091         }
00092     }
00093 }
00094 
00095 SEXP R_blockperm (SEXP block) {
00096 
00097     SEXP blocksetup, ans;
00098     
00099     blocksetup = R_blocksetup(block);
00100     PROTECT(ans = allocVector(INTSXP, LENGTH(block)));
00101     GetRNGstate();
00102     C_blockperm(blocksetup, INTEGER(ans));
00103     PutRNGstate();
00104     UNPROTECT(1);
00105     return(ans);
00106 }
00107 
00108 SEXP R_MonteCarloIndependenceTest (SEXP x, SEXP y, SEXP block, SEXP B) {
00109 
00110     int n, p, q, pq, i, *index, *permindex, b, Bsim;
00111     SEXP ans, blocksetup, linstat;
00112     double *dx, *dy;
00113     
00114     n = nrow(x);
00115     p = ncol(x);
00116     q = ncol(y);
00117     pq = p*q;
00118     Bsim = INTEGER(B)[0];
00119     dx = REAL(x);
00120     dy = REAL(y);
00121     
00122     index = Calloc(n, int);
00123     permindex = Calloc(n, int);
00124 
00125     PROTECT(blocksetup = R_blocksetup(block));
00126 
00127     PROTECT(ans = allocVector(VECSXP, Bsim));
00128     
00129     for (i = 0; i < n; i++)
00130         index[i] = i;
00131         
00132     GetRNGstate();
00133         
00134     for (b = 0; b < Bsim; b++) {
00135         C_blockperm(blocksetup, permindex);
00136         SET_VECTOR_ELT(ans, b, linstat = allocVector(REALSXP, pq));
00137         C_PermutedLinearStatistic(dx, p, dy, q, n, n, index, permindex, REAL(linstat));
00138     }
00139 
00140     PutRNGstate();
00141 
00142     UNPROTECT(2);
00143     return(ans);
00144 }

Generated on Thu Jun 9 14:28:10 2005 for party by  doxygen 1.4.2