StreitbergRoehmel.c

Go to the documentation of this file.
00001 
00011 #include <R.h>
00012 #include <Rmath.h>
00013 #include <Rdefines.h>
00014 
00015 /*
00016         length(scores) <= 1.000.000 observations only.
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       compute the joint permutation distribution of the 
00050       sum of the first m_a elements of score_a and score_b
00051       (usualy score_a = rep(1, length(score_a)) and 
00052               score_b = Data scores, Wilcoxon, Ansari ...).
00053       In this case the exact conditional distribution 
00054       in the simple independent two-sample problem is computed.
00055     */ 
00056 
00057     int n, im_a, im_b;          /* number of observations */
00058 
00059     SEXP H, x;                  /* matrix of permutations and vector 
00060                                    of probabilities */ 
00061   
00062     int i, j, k, sum_a = 0, sum_b = 0, s_a = 0, s_b = 0, isb;
00063     double msum = 0.0;          /* little helpers */
00064   
00065     int *iscore_a, *iscore_b;   /* pointers to R structures */
00066     double *dH, *dx;
00067 
00068     /* some basic checks, should be improved */  
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];  /* cosmetics only */
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     /* compute the total sum of the scores and check if they are >= 0 */
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       optimization according to Streitberg & Roehmel
00106     */
00107         
00108     sum_a = imin2(sum_a, im_a);
00109     sum_b = imin2(sum_b, im_b);
00110 
00111     /*
00112         initialize H
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         start the Shift-Algorithm with H[0,0] = 1
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             compute H up to row im_aand column im_b
00135             Note: 
00136             sum_a = min(sum_a, m)
00137             sum_b = min(sum_b, c)
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         return the whole matrix H 
00150         Note: use matrix(H, nrow=m_a+1, byrow=TRUE) in R
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             get the values for sample size im_a (in row m) and sum it up
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             compute probabilities and return the density x to R
00172             the support is min(score_b):sum(score_b)
00173             [dpq] stuff is done in R
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       compute the permutation distribution of the sum of the 
00208       absolute values of the positive elements of `scores'
00209     */ 
00210 
00211     int n;      /* number of observations */ 
00212     SEXP H;     /* vector giving the density of statistics 0:sum(scores) */
00213   
00214     int i, k, sum_a = 0, s_a = 0; /* little helpers */
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       Initialize H
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       start the shift-algorithm with H[0] = 1.0
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         get the number of permutations
00250     */
00251 
00252     for (i = 0; i <= sum_a; i++)
00253         msum += dH[i];
00254         
00255     /*
00256         compute probabilities and return the density H to R
00257         [dpq] stuff is done in R
00258     */ 
00259         
00260     for (i = 0; i <= sum_a; i++)
00261         dH[i] = dH[i]/msum;     /* 0 is a possible realization */
00262 
00263     UNPROTECT(1);       
00264     return(H);
00265 }

Generated on Tue Apr 24 16:56:50 2007 for coin by  doxygen 1.4.6