void C_VarianceLinearStatistic
(
const int P,
const int Q,
const double *VarInf,
const double *ExpX,
const double *VarX,
const int sumweights,
double *P_tmp, /* work array */
const int add,
double *PQ_ans
) {
if (P * Q == 1) {
C_CovarianceLinearStatistic(P, Q, VarInf, ExpX, VarX,
sumweights, P_tmp, (add >= 1),
PQ_ans);
} else {
double f1 = (double) sumweights / (sumweights - 1);
double f2 = 1.0 / (sumweights - 1);
for (int p = 0; p < P; p++)
P_tmp[p] = f1 * VarX[p] - f2 * ExpX[p] * ExpX[p];
C_kronecker(VarInf, 1, Q, P_tmp, 1, P, 1 - (add >= 1),
PQ_ans);
}
}
SEXP R_kronecker(SEXP A, SEXP B) {
int m, n, r, s;
SEXP ans;
if (!isReal(A) || !isReal(B))
error("R_kronecker: A and / or B are not of type REALSXP");
m = nrow(A);
n = ncol(A);
r = nrow(B);
s = ncol(B);
PROTECT(ans = allocVector(REALSXP, m * n * r * s));
C_kronecker(REAL(A), m, n, REAL(B), r, s, REAL(ans));
UNPROTECT(1);
return(ans);
}
void C_ExpectCovarLinearStatistic(const double* x, const int p, const int q,
const double* weights, const int n,
const SEXP expcovinf, SEXP ans) {
int i, j, k, pq;
double sweights = 0.0, f1, f2, tmp;
double *swx, *CT1, *CT2, *Covy_x_swx,
*dExp_y, *dCov_y, *dExp_T, *dCov_T;
pq = p * q;
/* the expectation and covariance of the influence function */
dExp_y = REAL(GET_SLOT(expcovinf, coin_expectationSym));
dCov_y = REAL(GET_SLOT(expcovinf, coin_covarianceSym));
sweights = REAL(GET_SLOT(expcovinf, coin_sumweightsSym))[0];
if (sweights <= 1.0)
error("C_ExpectCovarLinearStatistic: sum of weights is less than one");
/* prepare for storing the results */
dExp_T = REAL(GET_SLOT(ans, coin_expectationSym));
dCov_T = REAL(GET_SLOT(ans, coin_covarianceSym));
/* allocate storage: all helpers, initially zero */
swx = Calloc(p, double); /* p x 1 */
CT1 = Calloc(p * p, double); /* p x p */
for (i = 0; i < n; i++) {
/* observations with zero case weights do not contribute */
if (weights[i] == 0.0) continue;
for (k = 0; k < p; k++) {
tmp = weights[i] * x[k * n + i];
swx[k] += tmp;
/* covariance part */
for (j = 0; j < p; j++) {
CT1[j * p + k] += tmp * x[j * n + i];
}
}
}
/*
* dExp_T: expectation of the linear statistic T
*/
for (k = 0; k < p; k++) {
for (j = 0; j < q; j++)
dExp_T[j * p + k] = swx[k] * dExp_y[j];
}
/*
* dCov_T: covariance of the linear statistic T
*/
f1 = sweights/(sweights - 1);
f2 = (1/(sweights - 1));
if (pq == 1) {
dCov_T[0] = f1 * dCov_y[0] * CT1[0];
dCov_T[0] -= f2 * dCov_y[0] * swx[0] * swx[0];
} else {
/* two more helpers needed */
CT2 = Calloc(pq * pq, double); /* pq x pq */
Covy_x_swx = Calloc(pq * q, double); /* pq x q */
C_kronecker(dCov_y, q, q, CT1, p, p, dCov_T);
C_kronecker(dCov_y, q, q, swx, p, 1, Covy_x_swx);
C_kronecker(Covy_x_swx, pq, q, swx, 1, p, CT2);
for (k = 0; k < (pq * pq); k++)
dCov_T[k] = f1 * dCov_T[k] - f2 * CT2[k];
/* clean up */
Free(CT2); Free(Covy_x_swx);
}
/* clean up */
Free(swx); Free(CT1);
}
