Main Page | Directories | File List | File Members | Related Pages

Convenience.c

Go to the documentation of this file.
00001 
00009 #include "party.h"
00010 
00011 
00026 void C_LinStatExpCov(const double *x, const int p,
00027                      const double *y, const int q,
00028                      const double *weights, const int n,
00029                      const int cexpcovinf, SEXP expcovinf, SEXP ans) {
00030 
00031     C_LinearStatistic(x, p, y, q, weights, n, 
00032                       REAL(GET_SLOT(ans, PL2_linearstatisticSym)));
00033     if (cexpcovinf)
00034         C_ExpectCovarInfluence(y, q, weights, n, expcovinf);
00035     C_ExpectCovarLinearStatistic(x, p, y, q, weights, n, 
00036                                  expcovinf, ans);
00037 }
00038 
00039 
00046 void C_LinStatExpCovMPinv(SEXP linexpcov, double tol) {
00047     C_MPinv(GET_SLOT(linexpcov, PL2_covarianceSym), tol, 
00048             GET_SLOT(linexpcov, PL2_svdmemSym), linexpcov);
00049 }
00050 
00051 
00059 void C_MLinearStatistic(SEXP linexpcov, SEXP ScoreMatrix, SEXP ans) {
00060     
00061     int nr, nc, pq;
00062     double *dummy;
00063     
00064     nr = nrow(ScoreMatrix);
00065     nc = ncol(ScoreMatrix);
00066     pq = get_dimension(linexpcov);
00067     dummy = Calloc(nr * pq, double);
00068     
00069     C_matprod(REAL(ScoreMatrix), nrow(ScoreMatrix), ncol(ScoreMatrix), 
00070               REAL(GET_SLOT(linexpcov, PL2_linearstatisticSym)), pq, 1, 
00071               REAL(GET_SLOT(ans, PL2_linearstatisticSym)));
00072     C_matprod(REAL(ScoreMatrix), nr, nc, 
00073               REAL(GET_SLOT(linexpcov, PL2_expectationSym)), pq, 1, 
00074               REAL(GET_SLOT(ans, PL2_expectationSym)));
00075     C_matprod(REAL(ScoreMatrix), nr, nc, 
00076               REAL(GET_SLOT(linexpcov, PL2_covarianceSym)), pq, pq, 
00077               dummy);
00078     C_matprodT(dummy, nr, pq, REAL(ScoreMatrix), nr, nc, 
00079                REAL(GET_SLOT(ans, PL2_covarianceSym)));
00080     Free(dummy);
00081 }
00082 
00083 
00091 double C_TestStatistic(const SEXP linexpcov, const int type, const double tol) {
00092 
00093     int pq;
00094     double ans = 0.0;
00095     
00096     pq = get_dimension(linexpcov);
00097 
00098     switch(type) {
00099         /* maxabs-type test statistic */
00100         case 1:
00101             ans = C_maxabsTestStatistic(
00102                 REAL(GET_SLOT(linexpcov, PL2_linearstatisticSym)),
00103                 REAL(GET_SLOT(linexpcov, PL2_expectationSym)),
00104                 REAL(GET_SLOT(linexpcov, PL2_covarianceSym)),
00105                 pq, tol);
00106             break;
00107         /* quadform-type test statistic */
00108         case 2:
00109             ans = C_quadformTestStatistic(
00110                 REAL(GET_SLOT(linexpcov, PL2_linearstatisticSym)), 
00111                 REAL(GET_SLOT(linexpcov, PL2_expectationSym)),
00112                 REAL(GET_SLOT(linexpcov, PL2_MPinvSym)), pq);
00113             break;
00114         default: error("C_TestStatistic: undefined value for type argument");
00115     }
00116     return(ans);
00117 }
00118 
00119 
00131 double C_ConditionalPvalue(const double tstat, SEXP linexpcov,
00132                            const int type, double tol,
00133                            int *maxpts, double *releps, double *abseps) {
00134                            
00135     int pq;
00136     double ans = 0.0;
00137     
00138     pq = get_dimension(linexpcov);
00139 
00140     switch(type) {
00141         /* maxabs-type test statistic */
00142         case MAXABS:
00143             ans = C_maxabsConditionalPvalue(tstat,
00144                 REAL(GET_SLOT(linexpcov, PL2_covarianceSym)),
00145                 pq, maxpts, releps, abseps, &tol);
00146             break;
00147         /* quadform-type test statistic */
00148         case QUADFORM:
00149             ans = C_quadformConditionalPvalue(tstat, 
00150                 REAL(GET_SLOT(linexpcov, PL2_rankSym))[0]);
00151             break;
00152         default: error("C_ConditionalPvalue: undefined value for type argument");
00153     }
00154     return(ans);
00155 }
00156 
00157 
00163 SEXP R_get_response(SEXP learnsample) {
00164     return(VECTOR_ELT(GET_SLOT(GET_SLOT(learnsample, PL2_responsesSym), 
00165                                PL2_variablesSym), 0));
00166 }
00167 
00168 
00175 void R_set_response(SEXP learnsample, SEXP y) {
00176 
00177     double *v, *t, *j, *dy;
00178     int i, n;
00179     
00180     n = LENGTH(y);
00181     dy = REAL(y);
00182     
00183     if (LENGTH(R_get_response(learnsample)) != n)
00184         error("lengths of arguments don't match");
00185     
00186     v = REAL(VECTOR_ELT(GET_SLOT(GET_SLOT(learnsample, PL2_responsesSym), 
00187                                  PL2_variablesSym), 0));
00188     t = REAL(VECTOR_ELT(GET_SLOT(GET_SLOT(learnsample, PL2_responsesSym), 
00189                                  PL2_transformationsSym), 0));
00190     j = REAL(GET_SLOT(GET_SLOT(learnsample, PL2_responsesSym), 
00191                       PL2_jointtransfSym));
00192     
00193     for (i = 0; i < n; i++) {
00194         v[i] = dy[i];
00195         t[i] = dy[i];
00196         j[i] = dy[i];
00197     }
00198 }

Generated on Tue Sep 6 01:02:54 2005 for party by  doxygen 1.4.2