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
00066 nlev = 0;
00067 for (i = 0; i < n; i++) {
00068 if (iblock[i] == l) nlev++;
00069 }
00070
00071
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
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
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 }