Exemple #1
0
/* 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;
}
Exemple #2
0
/*
 * 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;
}