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
00036 nlev = 0;
00037 for (i = 0; i < n; i++) {
00038 if (iblock[i] == l) nlev++;
00039 }
00040
00041
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
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 }