00001
00009 #include "CI_common.h"
00010
00022 void C_kronecker (const double *A, const int m, const int n,
00023 const double *B, const int r, const int s,
00024 double *ans) {
00025
00026 int i, j, k, l, mr, js, ir;
00027 double y;
00028
00029 mr = m * r;
00030 for (i = 0; i < m; i++) {
00031 ir = i * r;
00032 for (j = 0; j < n; j++) {
00033 js = j * s;
00034 y = A[j*m + i];
00035 for (k = 0; k < r; k++) {
00036 for (l = 0; l < s; l++) {
00037 ans[(js + l) * mr + ir + k] = y * B[l * r + k];
00038 }
00039 }
00040 }
00041 }
00042 }
00043
00044
00054 void C_ExpectCovarInfluence(const double* y, const int q,
00055 const double* weights, const int n,
00056 SEXP ans) {
00057
00058 int i, j, k, jq;
00059
00060
00061 double *dExp_y, *dCov_y, *dsweights, tmp;
00062
00063
00064 dExp_y = REAL(GET_SLOT(ans, CI_expectationSym));
00065 for (j = 0; j < q; j++) dExp_y[j] = 0.0;
00066
00067 dCov_y = REAL(GET_SLOT(ans, CI_covarianceSym));
00068 for (j = 0; j < q*q; j++) dCov_y[j] = 0.0;
00069
00070 dsweights = REAL(GET_SLOT(ans, CI_sumweightsSym));
00071
00072
00073
00074 dsweights[0] = 0;
00075 for (i = 0; i < n; i++) dsweights[0] += weights[i];
00076 if (dsweights[0] <= 1)
00077 error("C_ExpectCovarInfluence: sum of weights is less than one");
00078
00079
00080
00081
00082
00083 for (i = 0; i < n; i++) {
00084
00085
00086
00087 if (weights[i] == 0.0) continue;
00088
00089 for (j = 0; j < q; j++)
00090 dExp_y[j] += weights[i] * y[j * n + i];
00091 }
00092
00093 for (j = 0; j < q; j++)
00094 dExp_y[j] = dExp_y[j] / dsweights[0];
00095
00096
00097
00098
00099
00100
00101 for (i = 0; i < n; i++) {
00102
00103 if (weights[i] == 0.0) continue;
00104
00105 for (j = 0; j < q; j++) {
00106 tmp = weights[i] * (y[j * n + i] - dExp_y[j]);
00107 jq = j * q;
00108 for (k = 0; k < q; k++)
00109 dCov_y[jq + k] += tmp * (y[k * n + i] - dExp_y[k]);
00110 }
00111 }
00112
00113 for (j = 0; j < q*q; j++)
00114 dCov_y[j] = dCov_y[j] / dsweights[0];
00115 }
00116
00117
00124 SEXP R_ExpectCovarInfluence(SEXP y, SEXP weights) {
00125
00126 SEXP ans;
00127 int q, n;
00128
00129 if (!isReal(y) || !isReal(weights))
00130 error("R_ExpectCovarInfluence: arguments are not of type REALSXP");
00131
00132 n = nrow(y);
00133 q = ncol(y);
00134
00135 if (LENGTH(weights) != n)
00136 error("R_ExpectCovarInfluence: vector of case weights does not have %d elements", n);
00137
00138
00139 PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovarInfluence")));
00140 SET_SLOT(ans, CI_expectationSym,
00141 PROTECT(allocVector(REALSXP, q)));
00142 SET_SLOT(ans, CI_covarianceSym,
00143 PROTECT(allocMatrix(REALSXP, q, q)));
00144 SET_SLOT(ans, CI_sumweightsSym,
00145 PROTECT(allocVector(REALSXP, 1)));
00146
00147 C_ExpectCovarInfluence(REAL(y), q, REAL(weights), n, ans);
00148
00149 UNPROTECT(4);
00150 return(ans);
00151 }
00152
00153
00166 void C_ExpectCovarLinearStatistic(const double* x, const int p,
00167 const double* y, const int q,
00168 const double* weights, const int n,
00169 const SEXP expcovinf, SEXP ans) {
00170
00171 int i, j, k, pq, ip;
00172 double sweights = 0.0, f1, f2, tmp;
00173 double *swx, *CT1, *CT2, *Covy_x_swx,
00174 *dExp_y, *dCov_y, *dExp_T, *dCov_T;
00175
00176 pq = p * q;
00177
00178
00179 dExp_y = REAL(GET_SLOT(expcovinf, CI_expectationSym));
00180 dCov_y = REAL(GET_SLOT(expcovinf, CI_covarianceSym));
00181 sweights = REAL(GET_SLOT(expcovinf, CI_sumweightsSym))[0];
00182
00183 if (sweights <= 1.0)
00184 error("C_ExpectCovarLinearStatistic: sum of weights is less than one");
00185
00186
00187 dExp_T = REAL(GET_SLOT(ans, CI_expectationSym));
00188 dCov_T = REAL(GET_SLOT(ans, CI_covarianceSym));
00189
00190
00191 swx = Calloc(p, double);
00192 CT1 = Calloc(p * p, double);
00193
00194 for (i = 0; i < n; i++) {
00195
00196
00197 if (weights[i] == 0.0) continue;
00198
00199 ip = i*p;
00200 for (k = 0; k < p; k++) {
00201 tmp = weights[i] * x[k * n + i];
00202 swx[k] += tmp;
00203
00204
00205 for (j = 0; j < p; j++) {
00206 CT1[j * p + k] += tmp * x[j * n + i];
00207 }
00208 }
00209 }
00210
00211
00212
00213
00214
00215 for (k = 0; k < p; k++) {
00216 for (j = 0; j < q; j++)
00217 dExp_T[j * p + k] = swx[k] * dExp_y[j];
00218 }
00219
00220
00221
00222
00223
00224 f1 = sweights/(sweights - 1);
00225 f2 = (1/(sweights - 1));
00226
00227 if (pq == 1) {
00228 dCov_T[0] = f1 * dCov_y[0] * CT1[0];
00229 dCov_T[0] -= f2 * dCov_y[0] * swx[0] * swx[0];
00230 } else {
00231
00232 CT2 = Calloc(pq * pq, double);
00233 Covy_x_swx = Calloc(pq * q, double);
00234
00235 C_kronecker(dCov_y, q, q, CT1, p, p, dCov_T);
00236 C_kronecker(dCov_y, q, q, swx, p, 1, Covy_x_swx);
00237 C_kronecker(Covy_x_swx, pq, q, swx, 1, p, CT2);
00238
00239 for (k = 0; k < (pq * pq); k++)
00240 dCov_T[k] = f1 * dCov_T[k] - f2 * CT2[k];
00241
00242
00243 Free(CT2); Free(Covy_x_swx);
00244 }
00245
00246
00247 Free(swx); Free(CT1);
00248 }
00249
00250
00259 SEXP R_ExpectCovarLinearStatistic(SEXP x, SEXP y, SEXP weights,
00260 SEXP expcovinf) {
00261
00262 SEXP ans;
00263 int n, p, q, pq;
00264
00265
00266
00267 n = nrow(x);
00268 p = ncol(x);
00269 q = ncol(y);
00270 pq = p * q;
00271
00272 if (nrow(y) != n)
00273 error("y does not have %d rows", n);
00274 if (LENGTH(weights) != n)
00275 error("vector of case weights does not have %d elements", n);
00276
00277 PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovar")));
00278 SET_SLOT(ans, CI_expectationSym,
00279 PROTECT(allocVector(REALSXP, pq)));
00280 SET_SLOT(ans, CI_covarianceSym,
00281 PROTECT(allocMatrix(REALSXP, pq, pq)));
00282
00283 C_ExpectCovarLinearStatistic(REAL(x), p, REAL(y), q,
00284 REAL(weights), n, expcovinf, ans);
00285
00286 UNPROTECT(3);
00287 return(ans);
00288 }
00289
00301 void C_LinearStatistic (const double *x, const int p,
00302 const double *y, const int q,
00303 const double *weights, const int n,
00304 double *ans) {
00305
00306 int i, j, k, kp, kn, ip;
00307 double tmp;
00308
00309 for (k = 0; k < q; k++) {
00310
00311 kn = k * n;
00312 kp = k * p;
00313 for (j = 0; j < p; j++) ans[kp + j] = 0.0;
00314
00315 for (i = 0; i < n; i++) {
00316
00317
00318 if (weights[i] == 0.0) continue;
00319
00320 tmp = y[kn + i] * weights[i];
00321
00322 ip = i * p;
00323 for (j = 0; j < p; j++)
00324 ans[kp + j] += x[j*n + i] * tmp;
00325 }
00326 }
00327 }
00328
00329
00337 SEXP R_LinearStatistic(SEXP x, SEXP y, SEXP weights) {
00338
00339
00340 SEXP ans;
00341
00342
00343 int n, p, q;
00344
00345
00346
00347
00348
00349
00350 if (!isReal(x) || !isReal(y) || !isReal(weights))
00351 error("LinStat: arguments are not of type REALSXP");
00352
00353 n = nrow(y);
00354 if (nrow(x) != n || LENGTH(weights) != n)
00355 error("LinStat: dimensions don't match");
00356
00357 q = ncol(y);
00358 p = ncol(x);
00359
00360 PROTECT(ans = allocVector(REALSXP, p*q));
00361
00362 C_LinearStatistic(REAL(x), p, REAL(y), q, REAL(weights), n,
00363 REAL(ans));
00364
00365 UNPROTECT(1);
00366 return(ans);
00367 }
00368
00369
00383 void C_PermutedLinearStatistic(const double *x, const int p,
00384 const double *y, const int q,
00385 const int n, const int nperm,
00386 const int *indx, const int *perm,
00387 double *ans) {
00388
00389 int i, j, k, kp, kn, knpi;
00390
00391 for (k = 0; k < q; k++) {
00392
00393 kn = k * n;
00394 kp = k * p;
00395 for (j = 0; j < p; j++) ans[kp + j] = 0.0;
00396
00397 for (i = 0; i < nperm; i++) {
00398
00399 knpi = kn + perm[i];
00400
00401 for (j = 0; j < p; j++)
00402 ans[kp + j] += x[j*n + indx[i]] * y[knpi];
00403 }
00404 }
00405 }
00406
00407
00416 SEXP R_PermutedLinearStatistic(SEXP x, SEXP y, SEXP indx, SEXP perm) {
00417
00418 SEXP ans;
00419 int n, nperm, p, q, i, *iperm, *iindx;
00420
00421
00422
00423
00424
00425 if (!isReal(x) || !isReal(y))
00426 error("R_PermutedLinearStatistic: arguments are not of type REALSXP");
00427
00428 if (!isInteger(perm))
00429 error("R_PermutedLinearStatistic: perm is not of type INTSXP");
00430 if (!isInteger(indx))
00431 error("R_PermutedLinearStatistic: indx is not of type INTSXP");
00432
00433 n = nrow(y);
00434 nperm = LENGTH(perm);
00435 iperm = INTEGER(perm);
00436 if (LENGTH(indx) != nperm)
00437 error("R_PermutedLinearStatistic: dimensions don't match");
00438 iindx = INTEGER(indx);
00439
00440 if (nrow(x) != n)
00441 error("R_PermutedLinearStatistic: dimensions don't match");
00442
00443 for (i = 0; i < nperm; i++) {
00444 if (iperm[i] < 0 || iperm[i] > (n - 1) )
00445 error("R_PermutedLinearStatistic: perm is not between 1 and nobs");
00446 if (iindx[i] < 0 || iindx[i] > (n - 1) )
00447 error("R_PermutedLinearStatistic: indx is not between 1 and nobs");
00448 }
00449
00450 q = ncol(y);
00451 p = ncol(x);
00452
00453 PROTECT(ans = allocVector(REALSXP, p*q));
00454
00455 C_PermutedLinearStatistic(REAL(x), p, REAL(y), q, n, nperm,
00456 iindx, iperm, REAL(ans));
00457
00458 UNPROTECT(1);
00459 return(ans);
00460 }
00461
00462
00472 void C_scmatleft(const double *x, const int p,
00473 const int q, double *ans) {
00474
00475
00476
00477
00478
00479
00480
00481
00482
00483
00484
00485
00486
00487 int k, j, pq;
00488
00489 pq = p * q;
00490 for (j = 0; j < q; j++) {
00491 for (k = 0; k < p; k++) {
00492 ans[pq * j + q*k + j] = x[k];
00493 }
00494 }
00495 }
00496
00497
00504 SEXP R_scmatleft(SEXP x, SEXP pq) {
00505
00506 SEXP ans;
00507 double *dans, *dx;
00508 int p, q, i;
00509
00510 if (!isReal(x)) error("R_scmatleft: x not of type REALSXP");
00511 if (!isInteger(pq)) error("R_scmatleft: pq not of type INTSXP");
00512
00513 dx = REAL(x);
00514 p = LENGTH(x);
00515 q = INTEGER(pq)[0] / p;
00516
00517 PROTECT(ans = allocMatrix(REALSXP, q, p*q));
00518 dans = REAL(ans);
00519 for (i = 0; i < q*p*q; i++) dans[i] = 0.0;
00520
00521 C_scmatleft(dx, p, q, dans);
00522
00523 UNPROTECT(1);
00524 return(ans);
00525 }
00526
00527
00537 void C_scmatright(const double *x, const int p,
00538 const int q, double *ans) {
00539
00540
00541
00542
00543
00544
00545
00546
00547
00548
00549
00550
00551
00552
00553 int i, k, pp;
00554
00555 pp = p * p;
00556 for (k = 0; k < q; k++) {
00557 for (i = 0; i < p; i++) {
00558 ans[pp * k + i * p + i] = x[k];
00559 }
00560 }
00561 }
00562
00569 SEXP R_scmatright(SEXP x, SEXP pq) {
00570
00571 SEXP ans;
00572 double *dans, *dx;
00573 int p, q, i;
00574
00575 if (!isReal(x)) error("R_scmatright: x not of type REALSXP");
00576 if (!isInteger(pq)) error("R_scmatright: pq not of type INTSXP");
00577
00578 dx = REAL(x);
00579 q = LENGTH(x);
00580 p = INTEGER(pq)[0] / q;
00581
00582 PROTECT(ans = allocMatrix(REALSXP, p, p*q));
00583 dans = REAL(ans);
00584
00585 for (i = 0; i < p*p*q; i++) dans[i] = 0.0;
00586
00587 C_scmatright(dx, p, q, dans);
00588
00589 UNPROTECT(1);
00590 return(ans);
00591 }