/* fmin(f, xmin, xmax tol) */
SEXP do_fmin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue));
PROTECT(res = allocVector(REALSXP, 1));
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
REAL(res)[0] = Brent_fmin(xmin, xmax,
(double (*)(double, void*)) fcn1, &info, tol);
UNPROTECT(2);
return res;
}
/*
* callable function from R
*/
SEXP gmrfLik(
SEXP QR,
SEXP obsCovR,
SEXP xisqTausq,
SEXP YrepAddR
){
int Drep, dooptim, DxisqAgain; // length(xisqTausq)
double oneD=1.0, zeroD=0.0;
double optTol = pow(DBL_EPSILON, 0.25); // tolerence for fmin_brent
double optMin = log(0.01), optMax = log(100); // default interval for optimizer
int NxisqMax = 100; // number of xisqTausq's to retain when optimizing
double *YXVYX, *determinant, *determinantForReml;
double *m2logL, *m2logReL, *varHatMl, *varHatReml, *resultXisqTausq;
void *nothing;
SEXP resultR;
CHM_DN obsCov;
Ltype=0; // set to 1 for reml
Nrep =LENGTH(YrepAddR);
YrepAdd = REAL(YrepAddR);
Nobs = INTEGER(GET_DIM(obsCovR))[0];
Nxy = INTEGER(GET_DIM(obsCovR))[1];
Ncov = Nxy - Nrep;
Nxysq = Nxy*Nxy;
NxisqTausq = LENGTH(xisqTausq);
// if length zero, do optimization
dooptim=!NxisqTausq;
if(dooptim){
NxisqTausq = NxisqMax;
}
// Rprintf("d %d %d", dooptim, NxisqTausq);
resultR = PROTECT(allocVector(REALSXP, Nxysq*NxisqTausq + 8*Nrep*NxisqTausq));
YXVYX = REAL(resultR);
determinant = &REAL(resultR)[Nxysq*NxisqTausq];
determinantForReml = &REAL(resultR)[Nxysq*NxisqTausq + Nrep*NxisqTausq];
m2logL = &REAL(resultR)[Nxysq*NxisqTausq + 2*Nrep*NxisqTausq];
m2logReL = &REAL(resultR)[Nxysq*NxisqTausq + 3*Nrep*NxisqTausq];
varHatMl = &REAL(resultR)[Nxysq*NxisqTausq + 4*Nrep*NxisqTausq];
varHatReml = &REAL(resultR)[Nxysq*NxisqTausq + 5*Nrep*NxisqTausq];
resultXisqTausq = &REAL(resultR)[Nxysq*NxisqTausq + 6*Nrep*NxisqTausq];
YXYX = (double *) calloc(Nxysq,sizeof(double));
copyLx = (double *) calloc(Nxy*Nrep,sizeof(double));
Q = AS_CHM_SP(QR);
obsCov = AS_CHM_DN(obsCovR);
M_R_cholmod_start(&c);
// get some stuff ready
// allocate Lx
Lx = M_cholmod_copy_dense(obsCov,&c);
// likelihood without nugget
// YX Vinv YX
M_cholmod_sdmult(
Q,
0, &oneD, &zeroD, // transpose, scale, scale
obsCov,Lx,// in, out
&c);
// put t(obscov) Q obscov in result
F77_NAME(dgemm)(
// op(A), op(B),
"T", "N",
// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
&Nxy, &Nxy, &Nobs,
// alpha
&oneD,
// A, nrow(A)
obsCov->x, &Nobs,
// B, nrow(B)
Lx->x, &Nobs,
// beta
&zeroD,
// C, nrow(c)
YXVYX, &Nxy);
// Q = P' L D L' P
L = M_cholmod_analyze(Q, &c);
M_cholmod_factorize(Q,L, &c);
// determinant
determinant[0] = M_chm_factor_ldetL2(L);
resultXisqTausq[0]= R_PosInf;
ssqFromXprod(
YXVYX, // N by N
determinantForReml,
Nxy, Nrep,
copyLx);
for(Drep=0;Drep<Nrep;++Drep){
determinant[Drep] = determinant[0];
determinantForReml[Drep] = determinantForReml[0];
m2logL[Drep] = Nobs*log(YXVYX[Drep*Nxy+Drep]) - Nobs*log(Nobs) -
determinant[0] - YrepAdd[Drep];
m2logReL[Drep] = (Nobs-Ncov)*log(YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov)) +
determinantForReml[0] - determinant[0] - YrepAdd[Drep];
varHatMl[Drep] = YXVYX[Drep*Nxy+Drep]/Nobs;
varHatReml[Drep] = YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov);
}
// now with xisqTausq
obsCovRot = M_cholmod_solve(CHOLMOD_P, L,obsCov,&c);
// YXYX cross product of data
F77_NAME(dgemm)(
// op(A), op(B),
"T", "N",
// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
&Nxy, &Nxy, &Nobs,
// alpha
&oneD,
// A, nrow(A)
obsCovRot->x, &Nobs,
// B, nrow(B)
obsCovRot->x, &Nobs,
// beta
&zeroD,
// C, nrow(&c)
YXYX, &Nxy);
YXVYXglobal = YXVYX;
// Rprintf("done zero ", dooptim);
if(dooptim){
// put NA's where DxisqTausq hasnt been used
for(DxisqAgain=1;DxisqAgain < NxisqTausq; ++DxisqAgain){
determinant[DxisqAgain*Nrep] = NA_REAL;
determinantForReml[DxisqAgain*Nrep] = NA_REAL;
m2logL[DxisqAgain*Nrep] = NA_REAL;
m2logReL[DxisqAgain*Nrep] = NA_REAL;
varHatMl[DxisqAgain*Nrep] = NA_REAL;
varHatReml[DxisqAgain*Nrep] = NA_REAL;
}
DxisqTausq=1;
// do optimizer
Brent_fmin(
optMin, optMax,
logLoneLogNugget,
nothing, optTol);
// Rprintf("done opt ", dooptim);
NxisqTausq = DxisqTausq;
} else {
for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){
logLoneNugget(REAL(xisqTausq)[DxisqTausq], nothing);
}
}
// assign global values into their correct spot
for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){
for(Drep=0;Drep<Nrep;++Drep){
determinant[DxisqTausq*Nrep+Drep] =
determinant[DxisqTausq*Nrep];
determinantForReml[DxisqTausq*Nrep+Drep]=
determinantForReml[DxisqTausq*Nrep];
m2logL[DxisqTausq*Nrep+Drep] -=
determinant[0];
m2logReL[DxisqTausq*Nrep+Drep] -=
determinant[0];
varHatMl[DxisqTausq*Nrep + Drep] =
YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/Nobs;
varHatReml[DxisqTausq*Nrep + Drep] =
YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/(Nobs-Ncov);
resultXisqTausq[DxisqTausq*Nrep + Drep] =
resultXisqTausq[DxisqTausq*Nrep];
}
}
M_cholmod_free_factor(&L, &c);
M_cholmod_free_dense(&obsCovRot, &c);
M_cholmod_free_dense(&Lx, &c);
// don't free Q because it's from an R object
// M_cholmod_free_sparse(&Q, &c);
// don't free obsCov because it's from an R object
// M_cholmod_free_dense(&obsCov, &c);
free(copyLx);
free(YXYX);
M_cholmod_free_dense(&YwkL, &c);
M_cholmod_free_dense(&YwkD, &c);
M_cholmod_free_dense(&EwkL, &c);
M_cholmod_free_dense(&EwkD, &c);
M_cholmod_finish(&c);
UNPROTECT(1);
return resultR;
}
