コード例 #1
0
ファイル: reTrms.cpp プロジェクト: rforge/lme4
    Rcpp::List reTrms::condVar(double scale) {
	if (scale < 0 || !R_finite(scale))
	    throw runtime_error("scale must be non-negative and finite");
	int nf = d_flist.size();
	IntegerVector nc = ncols(), nl = nlevs(), nct = nctot(), off = offsets();
	
    	List ans(nf);
	CharacterVector nms = d_flist.names();
	ans.names() = clone(nms);
	
	for (int i = 0; i < nf; i++) {
	    int ncti = nct[i], nli = nl[i];
	    IntegerVector trms = terms(i);
	    int *cset = new int[ncti], nct2 = ncti * ncti;
	    
	    NumericVector ansi(Dimension(ncti, ncti, nli));
	    ans[i] = ansi;
	    double *ai = ansi.begin();
	    
	    for (int j = 0; j < nli; j++) {
		int kk = 0;
		for (int jj = 0; jj < trms.size(); jj++) {
		    int tjj = trms[jj];
		    for (int k = 0; k < nc[tjj]; k++)
			cset[kk++] = off[tjj] + j * nc[tjj] + k;
		}
		CHM_SP cols =
		    M_cholmod_submatrix(&d_Lambda, (int*)NULL, -1, cset, ncti,
					1/*values*/, 1/*sorted*/, &c);
		CHM_SP sol = d_L.spsolve(CHOLMOD_A, cols);
		CHM_SP tcols = M_cholmod_transpose(cols, 1/*values*/, &c);
		M_cholmod_free_sparse(&cols, &c);
		CHM_SP var = M_cholmod_ssmult(tcols, sol, 0/*stype*/,
					      1/*values*/, 1/*sorted*/, &c);
		M_cholmod_free_sparse(&sol, &c);
		M_cholmod_free_sparse(&tcols, &c);
		CHM_DN dvar = M_cholmod_sparse_to_dense(var, &c);
		M_cholmod_free_sparse(&var, &c);
		Memcpy(ai + j * nct2, (double*)dvar->x, nct2);
		M_cholmod_free_dense(&dvar, &c);
	    }
	    delete[] cset;
	    transform(ansi.begin(), ansi.end(), ansi.begin(),
		      bind2nd(multiplies<double>(), scale * scale));
	}
	return ans;
    }
コード例 #2
0
ファイル: matrix.c プロジェクト: rforge/blme
void solveSparseCholeskySystem(int operationType, const_CHM_FR leftHandSide,
                               const double *rightHandSide, int numColsRightHandSide,
                               double *target)
{
  int commonDim = leftHandSide->n;
  
  CHM_DN chol_rightHandSide = N_AS_CHM_DN((double *) rightHandSide, commonDim, numColsRightHandSide);
  CHM_DN solution;
  R_CheckStack();
  
  solution = M_cholmod_solve(operationType,
                             leftHandSide,
                             chol_rightHandSide,
                             &cholmodCommon);
  if (!solution) error("cholmod_solve (%d) failed", operationType);
  
  // copy result into the dense, non-cholmod matrix
  Memcpy(target, (const double *) (solution->x),
         commonDim * numColsRightHandSide);
  M_cholmod_free_dense(&solution, &cholmodCommon);
}
コード例 #3
0
ファイル: mcmcsamp.cpp プロジェクト: danielmarcelino/lme4
/**
 * Update the fixed effects and the orthogonal random effects in an MCMC sample
 * from an mer object.
 *
 * @param x an mer object
 * @param sigma current standard deviation of the per-observation
 *        noise terms.
 * @param fvals pointer to memory in which to store the updated beta
 * @param rvals pointer to memory in which to store the updated b (may
 *              be (double*)NULL)
 */
static void MCMC_beta_u(SEXP x, double sigma, double *fvals, double *rvals)
{
    int *dims = DIMS_SLOT(x);
    int i1 = 1, p = dims[p_POS], q = dims[q_POS];
    double *V = V_SLOT(x), *fixef = FIXEF_SLOT(x), *muEta = MUETA_SLOT(x),
            *u = U_SLOT(x), mone[] = {-1,0}, one[] = {1,0};
    CHM_FR L = L_SLOT(x);
    double *del1 = Calloc(q, double), *del2 = Alloca(p, double);
    CHM_DN sol, rhs = N_AS_CHM_DN(del1, q, 1);
    R_CheckStack();

    if (V || muEta) {
        error(_("Update not yet written"));
    } else {			/* Linear mixed model */
        update_L(x);
        update_RX(x);
        lmm_update_fixef_u(x);
        /* Update beta */
        for (int j = 0; j < p; j++) del2[j] = sigma * norm_rand();
        F77_CALL(dtrsv)("U", "N", "N", &p, RX_SLOT(x), &p, del2, &i1);
        for (int j = 0; j < p; j++) fixef[j] += del2[j];
        /* Update u */
        for (int j = 0; j < q; j++) del1[j] = sigma * norm_rand();
        F77_CALL(dgemv)("N", &q, &p, mone, RZX_SLOT(x), &q,
                        del2, &i1, one, del1, &i1);
        sol = M_cholmod_solve(CHOLMOD_Lt, L, rhs, &c);
        for (int j = 0; j < q; j++) u[j] += ((double*)(sol->x))[j];
        M_cholmod_free_dense(&sol, &c);
        update_mu(x);	     /* and parts of the deviance slot */
    }
    Memcpy(fvals, fixef, p);
    if (rvals) {
        update_ranef(x);
        Memcpy(rvals, RANEF_SLOT(x), q);
    }
    Free(del1);
}
コード例 #4
0
ファイル: gmrfLik.c プロジェクト: rforge/diseasemapping
/*
 * 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;
}
コード例 #5
0
ファイル: solve_subset.c プロジェクト: TheoMichelot/adcomp
/* Perform recursions for k'th supernode */
void tmb_recursion_super(CHM_SP Lsparse, int k, CHM_FR L, cholmod_common *c){
  int* super=L->super;
  int* Ls=L->s;
  int* Lpi=L->pi;
  int ncol=super[k+1]-super[k]; /* ncol of supernode */
  int nrow=Lpi[k+1]-Lpi[k]; /* Number of rows in supernode */
  /* q contains row-indices of *entire* supernode */
  /* p contains row-indices excluding those of diagonal */
  /* s contains row-indices of diagonal - setdiff(q,p) */
  int* q=Ls+Lpi[k];    /* Pointer to L->s [L->pi [k]] */
  int nq=nrow;         /* length of q */
  // int* p=q+ncol;       /* Exclude triangle in diagonal */
  int np=nq-ncol;      /* length of p */
  int* s=q;
  int ns=ncol;         /* length of s */
  /* do not sort because p is sorted */
  int info; /* For lapack */
  int i,j;
  double ONE=1.0, ZERO=0.0, MONE=-1.0;
  CHM_DN x = densesubmatrix(Lsparse,q,nq,q,nq,c);
  double *xx=x->x;
  double *Lss=xx, *Lps=xx+ns, *Ssp=xx+(nq*ns), *Spp=xx+(nq*ns+ns);
  /* Workspace to hold output from dsymm */
  double *wrk=malloc(nq*ns*sizeof(double));
  double *wrkps=wrk+ns;
  if(np>0){
    F77_CALL(dtrsm)("Right","Lower","No transpose","Not unit",
		    &np,&ns,&MONE,Lss,&nq,Lps,&nq);
    for(i=ns;i<nq;i++){for(j=0;j<ns;j++)Lss[j+nq*i] = Lss[i+nq*j];} /* Copy Transpose*/
    memcpy(wrk,Lss,nq*ns*sizeof(double));    
    F77_CALL(dsymm)("Left","Lower",&np,&ns,&ONE,Spp,&nq,Lps,&nq,&ZERO,wrkps,&nq);
    memcpy(Lss,wrk,nq*ns*sizeof(double));
    F77_CALL(dpotri)("L",&ns,Lss,&nq,&info);
    F77_CALL(dgemm)("N","N",&ns,&ns,&np,&ONE,Ssp,&nq,Lps,&nq,&ONE,Lss,&nq);
  } else {
    F77_CALL(dpotri)("L",&ns,Lss,&nq,&info);
  }
  /* ----------- Fill results into L(q,s) -------*/
  double *Lx=Lsparse->x;
  int *Lp=Lsparse->p;
  int m=Lp[s[0]];
  for(j=0;j<ns;j++){
    for(i=j;i<nq;i++){
      Lx[m]=Lss[i+j*nq];
      m++;
    }
  }

  /* Count flops */
  /* if(control.countflops){ */
  /*   double Ns=ns; */
  /*   double Np=np; */
  /*   if(np>0){ */
  /*     flopcount[0]+=(Ns*(Ns+1))*0.5*Np; /\* dtrsm *\/ */
  /*     flopcount[1]+=Np*Np*Ns; /\* dsymm *\/ */
  /*     flopcount[2]+=2.0*(Ns*Ns*Ns)/3.0; /\* dpotri *\/ */
  /*     flopcount[3]+=Ns*Np*Ns; /\* dgemm *\/ */
  /*   } else { */
  /*     flopcount[2]+=2.0*(Ns*Ns*Ns)/3.0; /\* dpotri *\/ */
  /*   } */
  /* } */

  /* Clean up */
  M_cholmod_free_dense(&x,c);
  free(wrk);
}