00001
00002 #include <R.h>
00003 #include <Rmath.h>
00004 #include <Rinternals.h>
00005 #include "party.h"
00006
00007 SEXP kronecker (SEXP A, SEXP B) {
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019 SEXP ans;
00020
00021 int i, m, j, n, k, r, l, s, mr, ns, x = 0;
00022 double y, z;
00023
00024 if (!isReal(A) || !isReal(B))
00025 error("A and B are not of type REAL");
00026
00027 if (isMatrix(A)) {
00028 m = INTEGER(getAttrib(A, R_DimSymbol))[0];
00029 n = INTEGER(getAttrib(A, R_DimSymbol))[1];
00030 } else {
00031 m = LENGTH(A);
00032 n = 1;
00033 }
00034
00035 if (isMatrix(B)) {
00036 r = INTEGER(getAttrib(B, R_DimSymbol))[0];
00037 s = INTEGER(getAttrib(B, R_DimSymbol))[1];
00038 } else {
00039 r = LENGTH(B);
00040 s = 1;
00041 }
00042
00043 mr = m*r;
00044 ns = n*s;
00045
00046 PROTECT(ans = allocMatrix(REALSXP, mr, ns));
00047
00048 for (i = 0; i < m; i++) {
00049 for (j = 0; j < n; j++) {
00050
00051 y = REAL(A)[aindx(i, j, m)];
00052
00053 for (k = 0; k < r; k++) {
00054 for (l = 0; l < s; l++) {
00055
00056 x = aindx(i*r + k, j*s + l, mr);
00057 z = REAL(B)[aindx(k, l, r)];
00058 REAL(ans)[x] = y * z;
00059
00060 }
00061 }
00062 }
00063 }
00064 UNPROTECT(1);
00065 return(ans);
00066 }
00067
00068 void setAllZero(SEXP A) {
00069
00070 int n, m, i, j;
00071 SEXP tmp;
00072
00073 n = LENGTH(A);
00074 for (i = 0; i < n; i++) {
00075 tmp = VECTOR_ELT(A, i);
00076 m = LENGTH(tmp);
00077 for (j = 0; j < m; j++) REAL(tmp)[j] = 0.0;
00078 }
00079 }
00080
00081 SEXP ec(SEXP Weights, SEXP Scores, SEXP cweights) {
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094 SEXP W;
00095
00096
00097
00098 SEXP S;
00099
00100
00101
00102 SEXP cw;
00103
00104
00105
00106 SEXP ans, expL, covL;
00107
00108
00109
00110 int nobs, i;
00111 int p, k;
00112 int q, j;
00113 int pq;
00114
00115
00116
00117 double scw;
00118
00119
00120
00121 double f1, f2;
00122 SEXP ES, VS, VT1, VT2;
00123 SEXP wi, wiT, swi, swiT, wi_k_VS, VTp, wi_k_wiT;
00124 SEXP helpers;
00125
00126
00127
00128 PROTECT(W = coerceVector(Weights, REALSXP));
00129 PROTECT(S = coerceVector(Scores, REALSXP));
00130 PROTECT(cw = coerceVector(cweights, REALSXP));
00131
00132
00133
00134 nobs = INTEGER(getAttrib(W, R_DimSymbol))[1];
00135 p = INTEGER(getAttrib(W, R_DimSymbol))[0];
00136 q = INTEGER(getAttrib(S, R_DimSymbol))[1];
00137 pq = p * q;
00138
00139 if (INTEGER(getAttrib(S, R_DimSymbol))[0] != nobs)
00140 error("score matrix does not have %d rows", nobs);
00141 if (LENGTH(cw) != nobs)
00142 error("vector of case weights does not have %d elements", nobs);
00143
00144
00145
00146 scw = 0;
00147 for (i = 0; i < nobs; i++) scw = scw + REAL(cw)[i];
00148
00149
00150
00151 PROTECT(ans = allocVector(VECSXP, 2));
00152 SET_VECTOR_ELT(ans, 0, expL = allocVector(REALSXP, pq));
00153 SET_VECTOR_ELT(ans, 1, covL = allocMatrix(REALSXP, pq, pq));
00154
00155
00156
00157 PROTECT(helpers = allocVector(VECSXP, 7));
00158 SET_VECTOR_ELT(helpers, 0, ES = allocMatrix(REALSXP, 1, q));
00159 SET_VECTOR_ELT(helpers, 1, VS = allocMatrix(REALSXP, q, q));
00160 SET_VECTOR_ELT(helpers, 2, wi = allocMatrix(REALSXP, p, 1));
00161 SET_VECTOR_ELT(helpers, 3, wiT = allocMatrix(REALSXP, 1, p));
00162 SET_VECTOR_ELT(helpers, 4, swi = allocMatrix(REALSXP, p, 1));
00163 SET_VECTOR_ELT(helpers, 5, swiT = allocMatrix(REALSXP, 1, p));
00164 SET_VECTOR_ELT(helpers, 6, VTp = allocMatrix(REALSXP, p, p));
00165
00166
00167
00168 setAllZero(helpers);
00169
00170
00171
00172
00173
00174
00175
00176 for (i = 0; i < nobs; i++) {
00177
00178
00179
00180 if (REAL(cw)[i] == 0.0) continue;
00181
00182 for (j = 0; j < q; j++) {
00183 REAL(ES)[j] = REAL(ES)[j]
00184 + REAL(cw)[i] * REAL(S)[aindx(i, j, nobs)];
00185 }
00186 for (k = 0; k < p; k++) {
00187 REAL(swi)[k] = REAL(swi)[k]
00188 + REAL(cw)[i] * REAL(W)[aindx(k, i, p)];
00189 }
00190 }
00191
00192 for (j = 0; j < q; j++) {
00193 REAL(ES)[j] = REAL(ES)[j] / scw;
00194 }
00195
00196
00197
00198
00199
00200
00201 for (k = 0; k < p; k++) {
00202 REAL(swiT)[k] = REAL(swi)[k];
00203 for (j = 0; j < q; j++) {
00204 REAL(expL)[aindx(k,j,p)] = REAL(swi)[k] * REAL(ES)[j];
00205 }
00206 }
00207
00208
00209
00210
00211
00212 for (i = 0; i < nobs; i++) {
00213
00214 if (REAL(cw)[i] == 0.0) continue;
00215
00216 for (j = 0; j < q; j++) {
00217 for (k = 0; k < q; k++) {
00218 REAL(VS)[aindx(k, j, q)] = REAL(VS)[aindx(k, j, q)] +
00219 REAL(cw)[i] * (REAL(S)[aindx(i, k, nobs)] - REAL(ES)[k]) *
00220 (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]);
00221 }
00222 }
00223 }
00224
00225 for (j = 0; j < q*q; j++) {
00226 REAL(VS)[j] = REAL(VS)[j] / scw;
00227 }
00228
00229
00230
00231
00232
00233 for (i = 0; i < nobs; i++) {
00234
00235 if (REAL(cw)[i] == 0.0) continue;
00236
00237 for (k = 0; k < p; k++) {
00238 REAL(wi)[k] = REAL(W)[aindx(k, i, p)];
00239 REAL(wiT)[k] = REAL(W)[aindx(k, i, p)];
00240 }
00241
00242 wi_k_wiT = kronecker(wi, wiT);
00243
00244 for (k = 0; k < p*p; k++) {
00245 REAL(VTp)[k] = REAL(VTp)[k] + REAL(cw)[i] * REAL(wi_k_wiT)[k];
00246 }
00247 }
00248
00249 VT1 = kronecker(VS, VTp);
00250
00251 wi_k_VS = kronecker(VS, swi);
00252 VT2 = kronecker(wi_k_VS, swiT);
00253
00254 f1 = scw/(scw - 1);
00255 f2 = (1/(scw - 1));
00256
00257 for (k = 0; k < (pq * pq); k++) {
00258 REAL(covL)[k] = f1 * REAL(VT1)[k] - f2 * REAL(VT2)[k];
00259 }
00260
00261 UNPROTECT(5);
00262 return(ans);
00263 }
00264
00265
00266 SEXP evS(SEXP Scores, SEXP cweights) {
00267
00268
00269
00270
00271
00272
00273 SEXP S;
00274
00275
00276
00277 SEXP cw;
00278
00279
00280
00281 SEXP ans, ES, VS, scw;
00282
00283
00284
00285 int nobs, i;
00286 int k;
00287 int q, j;
00288
00289
00290
00291 PROTECT(S = coerceVector(Scores, REALSXP));
00292 PROTECT(cw = coerceVector(cweights, REALSXP));
00293
00294
00295
00296 nobs = INTEGER(getAttrib(S, R_DimSymbol))[0];
00297 q = INTEGER(getAttrib(S, R_DimSymbol))[1];
00298
00299 if (LENGTH(cw) != nobs)
00300 error("vector of case weights does not have %d elements", nobs);
00301
00302
00303
00304 PROTECT(ans = allocVector(VECSXP, 3));
00305 SET_VECTOR_ELT(ans, 0, ES = allocVector(REALSXP, q));
00306 SET_VECTOR_ELT(ans, 1, VS = allocVector(REALSXP, q));
00307 SET_VECTOR_ELT(ans, 2, scw = allocVector(REALSXP, 1));
00308
00309 setAllZero(ans);
00310
00311 for (i = 0; i < nobs; i++) {
00312
00313 if (REAL(cw)[i] == 0.0) continue;
00314
00315 REAL(scw)[0] = REAL(scw)[0] + REAL(cw)[i];
00316
00317 for (k = 0; k < q; k++) {
00318 REAL(ES)[k] = REAL(ES)[k]
00319 + REAL(cw)[i] * REAL(S)[aindx(i, k, nobs)];
00320 }
00321
00322 }
00323
00324 for (k = 0; k < q; k++) {
00325 REAL(ES)[k] = REAL(ES)[k] / REAL(scw)[0];
00326 }
00327
00328 for (i = 0; i < nobs; i++) {
00329
00330 if (REAL(cw)[i] == 0.0) continue;
00331
00332 for (j = 0; j < q; j++) {
00333 REAL(VS)[j] = REAL(VS)[j] +
00334 REAL(cw)[i] * (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]) *
00335 (REAL(S)[aindx(i, j, nobs)] - REAL(ES)[j]);
00336 }
00337 }
00338
00339 for (k = 0; k < q; k++) {
00340 REAL(VS)[k] = REAL(VS)[k] / REAL(scw)[0];
00341 }
00342
00343 UNPROTECT(3);
00344 return(ans);
00345 }
00346
00347
00348 SEXP evL(SEXP Weights, SEXP Scores, SEXP cweights, SEXP evSans) {
00349
00350
00351
00352
00353
00354
00355
00356
00357
00358
00359
00360
00361 SEXP W;
00362
00363
00364
00365 SEXP S;
00366
00367
00368
00369 SEXP cw;
00370
00371
00372
00373
00374 SEXP ans, expL, varL;
00375
00376
00377
00378 int nobs, i;
00379 int p, k;
00380 int q, j;
00381 int pq;
00382
00383 double scw;
00384
00385
00386
00387 double f1, f2;
00388 SEXP helpers, ES, VS, wi, wii;
00389
00390
00391
00392 PROTECT(W = coerceVector(Weights, REALSXP));
00393 PROTECT(S = coerceVector(Scores, REALSXP));
00394 PROTECT(cw = coerceVector(cweights, REALSXP));
00395
00396
00397
00398 nobs = INTEGER(getAttrib(W, R_DimSymbol))[1];
00399 p = INTEGER(getAttrib(W, R_DimSymbol))[0];
00400 q = INTEGER(getAttrib(S, R_DimSymbol))[1];
00401 pq = p * q;
00402
00403 if (INTEGER(getAttrib(S, R_DimSymbol))[0] != nobs)
00404 error("score matrix does not have %d rows", nobs);
00405 if (LENGTH(cw) != nobs)
00406 error("vector of case weights does not have %d elements", nobs);
00407
00408
00409
00410 scw = REAL(VECTOR_ELT(evSans, 2))[0];
00411 ES = VECTOR_ELT(evSans, 0);
00412 VS = VECTOR_ELT(evSans, 1);
00413
00414
00415
00416 PROTECT(ans = allocVector(VECSXP, 2));
00417 SET_VECTOR_ELT(ans, 0, expL = allocVector(REALSXP, pq));
00418 SET_VECTOR_ELT(ans, 1, varL = allocVector(REALSXP, pq));
00419
00420 PROTECT(helpers = allocVector(VECSXP, 2));
00421 SET_VECTOR_ELT(helpers, 0, wi = allocVector(REALSXP, p));
00422 SET_VECTOR_ELT(helpers, 1, wii = allocVector(REALSXP, p));
00423
00424 setAllZero(helpers);
00425
00426 for (i = 0; i < nobs; i++) {
00427
00428 if (REAL(cw)[i] == 0.0) continue;
00429
00430 for (k = 0; k < p; k++) {
00431 REAL(wi)[k] = REAL(wi)[k]
00432 + REAL(cw)[i] * REAL(W)[aindx(k, i, p)];
00433 }
00434
00435 for (k = 0; k < p; k++) {
00436 REAL(wii)[k] = REAL(wii)[k]
00437 + REAL(cw)[i] * REAL(W)[aindx(k, i, p)]
00438 * REAL(W)[aindx(k, i, p)];
00439 }
00440 }
00441
00442 f1 = scw/(scw - 1);
00443 f2 = (1/(scw - 1));
00444 for (k = 0; k < p; k++) {
00445 for (j = 0; j < q; j++) {
00446 REAL(expL)[j*p + k] = REAL(ES)[j] * REAL(wi)[k];
00447 REAL(varL)[j*p + k] = f1*REAL(VS)[j] * REAL(wii)[k]
00448 - f2*REAL(VS)[j] * REAL(wi)[k]*REAL(wi)[k];
00449 }
00450 }
00451 UNPROTECT(5);
00452 return(ans);
00453 }
00454
00455 SEXP ev(SEXP Weights, SEXP Scores, SEXP cweights) {
00456
00457
00458
00459
00460
00461
00462
00463
00464
00465
00466
00467 SEXP evSans, ans;
00468
00469 evSans = evS(Scores, cweights);
00470 ans = evL(Weights, Scores, cweights, evSans);
00471 return(ans);
00472
00473 }