00001
00011 #include <R.h>
00012 #include <Rmath.h>
00013 #include <Rdefines.h>
00014
00015
00016
00017
00018
00019 #define PERM_MAX_N 1000000
00020
00021
00046 SEXP R_cpermdist2(SEXP score_a, SEXP score_b, SEXP m_a, SEXP m_b,
00047 SEXP retProb) {
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057 int n, im_a, im_b;
00058
00059 SEXP H, x;
00060
00061
00062 int i, j, k, sum_a = 0, sum_b = 0, s_a = 0, s_b = 0, isb;
00063 double msum = 0.0;
00064
00065 int *iscore_a, *iscore_b;
00066 double *dH, *dx;
00067
00068
00069
00070 if (!isVector(score_a))
00071 error("score_a is not a vector");
00072
00073 n = LENGTH(score_a);
00074
00075 if (!isVector(score_b))
00076 error("score_b is not a vector");
00077
00078 if (LENGTH(score_b) != n)
00079 error("length of score_a and score_b differ");
00080
00081 iscore_a = INTEGER(score_a);
00082 iscore_b = INTEGER(score_b);
00083
00084 if (TYPEOF(retProb) != LGLSXP)
00085 error("retProb is not a logical");
00086
00087 im_a = INTEGER(m_a)[0];
00088 im_b = INTEGER(m_b)[0];
00089
00090 if (n > PERM_MAX_N)
00091 error("n > %d in R_cpermdistr2", PERM_MAX_N);
00092
00093
00094
00095 for (i = 0; i < n; i++) {
00096 if (iscore_a[i] < 0)
00097 error("score_a for observation number %d is negative", i);
00098 if (iscore_b[i] < 0)
00099 error("score_b for observation number %d is negative", i);
00100 sum_a += iscore_a[i];
00101 sum_b += iscore_b[i];
00102 }
00103
00104
00105
00106
00107
00108 sum_a = imin2(sum_a, im_a);
00109 sum_b = imin2(sum_b, im_b);
00110
00111
00112
00113
00114
00115 PROTECT(H = allocVector(REALSXP, (sum_a + 1) * (sum_b + 1)));
00116 dH = REAL(H);
00117
00118 for (i = 0; i <= sum_a; i++) {
00119 isb = i * (sum_b + 1);
00120 for (j = 0; j <= sum_b; j++) dH[isb + j] = 0.0;
00121 }
00122
00123
00124
00125
00126
00127 dH[0] = 1.0;
00128
00129 for (k = 0; k < n; k++) {
00130 s_a += iscore_a[k];
00131 s_b += iscore_b[k];
00132
00133
00134
00135
00136
00137
00138
00139
00140 for (i = imin2(im_a, s_a); i >= iscore_a[k]; i--) {
00141 isb = i * (sum_b + 1);
00142 for (j = imin2(im_b,s_b); j >= iscore_b[k]; j--)
00143 dH[isb + j] +=
00144 dH[(i - iscore_a[k]) * (sum_b + 1) + (j - iscore_b[k])];
00145 }
00146 }
00147
00148
00149
00150
00151
00152
00153 if (!LOGICAL(retProb)[0]) {
00154 UNPROTECT(1);
00155 return(H);
00156 } else {
00157 PROTECT(x = allocVector(REALSXP, sum_b));
00158 dx = REAL(x);
00159
00160
00161
00162
00163
00164 isb = im_a * (sum_b + 1);
00165 for (j = 0; j < sum_b; j++) {
00166 dx[j] = dH[isb + j + 1];
00167 msum += dx[j];
00168 }
00169
00170
00171
00172
00173
00174
00175
00176 for (j = 0; j < sum_b; j++)
00177 dx[j] = dx[j]/msum;
00178
00179 UNPROTECT(2);
00180 return(x);
00181 }
00182 }
00183
00204 SEXP R_cpermdist1(SEXP scores) {
00205
00206
00207
00208
00209
00210
00211 int n;
00212 SEXP H;
00213
00214 int i, k, sum_a = 0, s_a = 0;
00215 int *iscores;
00216 double msum = 0.0;
00217 double *dH;
00218
00219 n = LENGTH(scores);
00220 iscores = INTEGER(scores);
00221
00222 if (n > PERM_MAX_N)
00223 error("n > %d in R_cpermdist1", PERM_MAX_N);
00224
00225 for (i = 0; i < n; i++) sum_a += iscores[i];
00226
00227
00228
00229
00230
00231 PROTECT(H = allocVector(REALSXP, sum_a + 1));
00232 dH = REAL(H);
00233 for (i = 0; i <= sum_a; i++) dH[i] = 0.0;
00234
00235
00236
00237
00238
00239 dH[0] = 1.0;
00240
00241 for (k = 0; k < n; k++) {
00242 s_a = s_a + iscores[k];
00243 for (i = s_a; i >= iscores[k]; i--)
00244 dH[i] = dH[i] + dH[i - iscores[k]];
00245 }
00246
00247
00248
00249
00250
00251
00252 for (i = 0; i <= sum_a; i++)
00253 msum += dH[i];
00254
00255
00256
00257
00258
00259
00260 for (i = 0; i <= sum_a; i++)
00261 dH[i] = dH[i]/msum;
00262
00263 UNPROTECT(1);
00264 return(H);
00265 }