00001
00009 #include "party.h"
00010
00011
00018 double C_quadformConditionalPvalue(const double tstat, const double df) {
00019 return(pchisq(tstat, df, 0, 0));
00020 }
00021
00022
00029 SEXP R_quadformConditionalPvalue(SEXP tstat, SEXP df) {
00030
00031 SEXP ans;
00032
00033 PROTECT(ans = allocVector(REALSXP, 1));
00034 REAL(ans)[0] = C_quadformConditionalPvalue(REAL(tstat)[0], REAL(df)[0]);
00035 UNPROTECT(1);
00036 return(ans);
00037 }
00038
00039
00052 double C_maxabsConditionalPvalue(const double tstat, const double *Sigma,
00053 const int pq, int *maxpts, double *releps, double *abseps, double *tol) {
00054
00055 int *n, *nu, *inform, i, j, *infin, sub;
00056 double *lower, *upper, *delta, *corr, *sd, *myerror,
00057 *prob, ans;
00058
00059
00060 if (pq == 1)
00061 return(2*pnorm(fabs(tstat)*-1.0, 0.0, 1.0, 1, 0));
00062
00063 n = Calloc(1, int);
00064 nu = Calloc(1, int);
00065 myerror = Calloc(1, double);
00066 prob = Calloc(1, double);
00067 nu[0] = 0;
00068 inform = Calloc(1, int);
00069 n[0] = pq;
00070
00071 if (n[0] == 2)
00072 corr = Calloc(1, double);
00073 else
00074 corr = Calloc(n[0] + ((n[0] - 2) * (n[0] - 1))/2, double);
00075
00076 sd = Calloc(n[0], double);
00077 lower = Calloc(n[0], double);
00078 upper = Calloc(n[0], double);
00079 infin = Calloc(n[0], int);
00080 delta = Calloc(n[0], double);
00081
00082
00083
00084
00085
00086 for (i = 0; i < n[0]; i++) {
00087
00088 if (Sigma[i*n[0] + i] < tol[0])
00089 sd[i] = 0.0;
00090 else
00091 sd[i] = sqrt(Sigma[i*n[0] + i]);
00092
00093
00094 lower[i] = fabs(tstat) * -1.0;
00095 upper[i] = fabs(tstat);
00096 infin[i] = 2;
00097 delta[i] = 0.0;
00098 for (j = 0; j < i; j++) {
00099 sub = (int) (j+1) + (double) ((i-1)*(i)) / 2 - 1;
00100 if (sd[i] == 0.0 || sd[j] == 0.0)
00101 corr[sub] = 0.0;
00102 else
00103 corr[sub] = Sigma[i*n[0] + j] / (sd[i] * sd[j]);
00104 }
00105 }
00106
00107
00108 F77_CALL(mvtdst)(n, nu, lower, upper, infin, corr, delta,
00109 maxpts, abseps, releps, tol, myerror, prob, inform);
00110
00111
00112 switch (inform[0]) {
00113 case 0: break;
00114 case 1: warning("cmvnorm: completion with ERROR > EPS"); break;
00115 case 2: warning("cmvnorm: N > 1000 or N < 1");
00116 prob[0] = 0.0;
00117 break;
00118 case 3: warning("cmvnorm: correlation matrix not positive semi-definite");
00119 prob[0] = 0.0;
00120 break;
00121 default: warning("cmvnorm: unknown problem in MVTDST");
00122 prob[0] = 0.0;
00123 }
00124 ans = prob[0];
00125 Free(corr); Free(sd); Free(lower); Free(upper);
00126 Free(infin); Free(delta); Free(myerror); Free(prob);
00127 Free(n); Free(nu); Free(inform);
00128 return(1 - ans);
00129 }
00130
00131
00142 SEXP R_maxabsConditionalPvalue(SEXP tstat, SEXP Sigma, SEXP maxpts,
00143 SEXP releps, SEXP abseps, SEXP tol) {
00144
00145 SEXP ans;
00146 int pq;
00147
00148 pq = nrow(Sigma);
00149
00150 PROTECT(ans = allocVector(REALSXP, 1));
00151 REAL(ans)[0] = C_maxabsConditionalPvalue(REAL(tstat)[0], REAL(Sigma), pq,
00152 INTEGER(maxpts), REAL(releps), REAL(abseps), REAL(tol));
00153 UNPROTECT(1);
00154 return(ans);
00155 }
00156
00157
00169 void C_MonteCarlo(double *criterion, SEXP learnsample, SEXP weights,
00170 SEXP fitmem, SEXP varctrl, SEXP gtctrl, double *ans_pvalues) {
00171
00172 int ninputs, nobs, j, i, k;
00173 SEXP responses, inputs, y, x, xmem, expcovinf;
00174 double sweights, *stats, tmp = 0.0, smax, *dweights;
00175 int m, *counts, b, B, *dummy, *permindex, *index, *permute;
00176
00177 ninputs = get_ninputs(learnsample);
00178 nobs = get_nobs(learnsample);
00179 responses = GET_SLOT(learnsample, PL2_responsesSym);
00180 inputs = GET_SLOT(learnsample, PL2_inputsSym);
00181 dweights = REAL(weights);
00182
00183
00184 B = get_nresample(gtctrl);
00185
00186 y = get_transformation(responses, 1);
00187
00188 expcovinf = GET_SLOT(fitmem, PL2_expcovinfSym);
00189
00190 sweights = REAL(GET_SLOT(expcovinf, PL2_sumweightsSym))[0];
00191 m = (int) sweights;
00192
00193 stats = Calloc(ninputs, double);
00194 counts = Calloc(ninputs, int);
00195
00196 dummy = Calloc(m, int);
00197 permute = Calloc(m, int);
00198 index = Calloc(m, int);
00199 permindex = Calloc(m, int);
00200
00201
00202
00203 j = 0;
00204 for (i = 0; i < nobs; i++) {
00205 for (k = 0; k < dweights[i]; k++) {
00206 index[j] = i;
00207 j++;
00208 }
00209 }
00210
00211 for (b = 0; b < B; b++) {
00212
00213
00214 C_SampleNoReplace(dummy, m, m, permute);
00215 for (k = 0; k < m; k++) permindex[k] = index[permute[k]];
00216
00217
00218 for (j = 1; j <= ninputs; j++) {
00219 x = get_transformation(inputs, j);
00220
00221
00222 xmem = get_varmemory(fitmem, j);
00223 if (!has_missings(inputs, j)) {
00224 C_PermutedLinearStatistic(REAL(x), ncol(x), REAL(y), ncol(y),
00225 nobs, m, index, permindex,
00226 REAL(GET_SLOT(xmem, PL2_linearstatisticSym)));
00227 } else {
00228 error("cannot resample with missing values");
00229 }
00230
00231
00232 C_TeststatCriterion(xmem, varctrl, &tmp, &stats[j - 1]);
00233 }
00234
00235
00236 smax = C_max(stats, ninputs);
00237
00238
00239 for (j = 0; j < ninputs; j++) {
00240 if (smax > criterion[j]) counts[j]++;
00241 }
00242 }
00243
00244
00245 for (j = 0; j < ninputs; j++)
00246 ans_pvalues[j] = (double) counts[j] / B;
00247
00248
00249
00250
00251
00252 for (j = 1; j <= ninputs; j++) {
00253 x = get_transformation(inputs, j);
00254
00255 xmem = get_varmemory(fitmem, j);
00256 C_LinearStatistic(REAL(x), ncol(x), REAL(y), ncol(y),
00257 dweights, nobs,
00258 REAL(GET_SLOT(xmem, PL2_linearstatisticSym)));
00259 }
00260
00261
00262 Free(stats); Free(counts); Free(dummy); Free(permute);
00263 Free(index); Free(permindex);
00264 }
00265
00266
00277 SEXP R_MonteCarlo(SEXP criterion, SEXP learnsample, SEXP weights,
00278 SEXP fitmem, SEXP varctrl, SEXP gtctrl) {
00279
00280 SEXP ans;
00281
00282 GetRNGstate();
00283
00284 PROTECT(ans = allocVector(REALSXP, get_ninputs(learnsample)));
00285 C_MonteCarlo(REAL(criterion), learnsample, weights, fitmem, varctrl,
00286 gtctrl, REAL(ans));
00287
00288 PutRNGstate();
00289
00290 UNPROTECT(1);
00291 return(ans);
00292 }