static int dogleg_preloop(const void * vtrust_state, void * vstate) { int status; const gsl_multifit_nlinear_trust_state *trust_state = (const gsl_multifit_nlinear_trust_state *) vtrust_state; dogleg_state_t *state = (dogleg_state_t *) vstate; const gsl_multifit_nlinear_parameters *params = trust_state->params; double u; double alpha; /* ||g||^2 / ||Jg||^2 */ /* initialize linear least squares solver */ status = (params->solver->init)(trust_state, trust_state->solver_state); if (status) return status; /* prepare the linear solver to compute Gauss-Newton step */ status = (params->solver->presolve)(0.0, trust_state, trust_state->solver_state); if (status) return status; /* solve: J dx_gn = -f for Gauss-Newton step */ status = (params->solver->solve)(trust_state->f, state->dx_gn, trust_state, trust_state->solver_state); if (status) return status; /* now calculate the steepest descent step */ /* compute workp = D^{-1} g and its norm */ gsl_vector_memcpy(state->workp, trust_state->g); gsl_vector_div(state->workp, trust_state->diag); state->norm_Dinvg = gsl_blas_dnrm2(state->workp); /* compute workp = D^{-2} g */ gsl_vector_div(state->workp, trust_state->diag); /* compute: workn = J D^{-2} g */ gsl_blas_dgemv(CblasNoTrans, 1.0, trust_state->J, state->workp, 0.0, state->workn); state->norm_JDinv2g = gsl_blas_dnrm2(state->workn); u = state->norm_Dinvg / state->norm_JDinv2g; alpha = u * u; /* dx_sd = -alpha D^{-2} g */ gsl_vector_memcpy(state->dx_sd, state->workp); gsl_vector_scale(state->dx_sd, -alpha); state->norm_Dgn = scaled_enorm(trust_state->diag, state->dx_gn); state->norm_Dsd = scaled_enorm(trust_state->diag, state->dx_sd); return GSL_SUCCESS; }
int gsl_multifit_linear_genform1 (const gsl_vector * L, const gsl_vector * cs, gsl_vector * c, gsl_multifit_linear_workspace * work) { if (L->size > work->pmax) { GSL_ERROR("L vector does not match workspace", GSL_EBADLEN); } else if (L->size != cs->size) { GSL_ERROR("cs vector does not match L", GSL_EBADLEN); } else if (L->size != c->size) { GSL_ERROR("c vector does not match L", GSL_EBADLEN); } else { /* compute true solution vector c = L^{-1} c~ */ gsl_vector_memcpy(c, cs); gsl_vector_div(c, L); return GSL_SUCCESS; } }
int gsl_linalg_pcholesky_svx(const gsl_matrix * LDLT, const gsl_permutation * p, gsl_vector * x) { if (LDLT->size1 != LDLT->size2) { GSL_ERROR ("LDLT matrix must be square", GSL_ENOTSQR); } else if (LDLT->size1 != p->size) { GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); } else if (LDLT->size2 != x->size) { GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); } else { gsl_vector_const_view D = gsl_matrix_const_diagonal(LDLT); /* x := P b */ gsl_permute_vector(p, x); /* solve: L w = P b */ gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasUnit, LDLT, x); /* solve: D y = w */ gsl_vector_div(x, &D.vector); /* solve: L^T z = y */ gsl_blas_dtrsv(CblasLower, CblasTrans, CblasUnit, LDLT, x); /* compute: x = P^T z */ gsl_permute_vector_inverse(p, x); return GSL_SUCCESS; } }
static int multifit_wlinear_svd (const gsl_matrix * X, const gsl_vector * w, const gsl_vector * y, double tol, int balance, size_t * rank, gsl_vector * c, gsl_matrix * cov, double *chisq, gsl_multifit_linear_workspace * work) { if (X->size1 != y->size) { GSL_ERROR ("number of observations in y does not match rows of matrix X", GSL_EBADLEN); } else if (X->size2 != c->size) { GSL_ERROR ("number of parameters c does not match columns of matrix X", GSL_EBADLEN); } else if (w->size != y->size) { GSL_ERROR ("number of weights does not match number of observations", GSL_EBADLEN); } else if (cov->size1 != cov->size2) { GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR); } else if (c->size != cov->size1) { GSL_ERROR ("number of parameters does not match size of covariance matrix", GSL_EBADLEN); } else if (X->size1 != work->n || X->size2 != work->p) { GSL_ERROR ("size of workspace does not match size of observation matrix", GSL_EBADLEN); } else { const size_t n = X->size1; const size_t p = X->size2; size_t i, j, p_eff; gsl_matrix *A = work->A; gsl_matrix *Q = work->Q; gsl_matrix *QSI = work->QSI; gsl_vector *S = work->S; gsl_vector *t = work->t; gsl_vector *xt = work->xt; gsl_vector *D = work->D; /* Scale X, A = sqrt(w) X */ gsl_matrix_memcpy (A, X); for (i = 0; i < n; i++) { double wi = gsl_vector_get (w, i); if (wi < 0) wi = 0; { gsl_vector_view row = gsl_matrix_row (A, i); gsl_vector_scale (&row.vector, sqrt (wi)); } } /* Balance the columns of the matrix A if requested */ if (balance) { gsl_linalg_balance_columns (A, D); } else { gsl_vector_set_all (D, 1.0); } /* Decompose A into U S Q^T */ gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt); /* Solve sqrt(w) y = A c for c, by first computing t = sqrt(w) y */ for (i = 0; i < n; i++) { double wi = gsl_vector_get (w, i); double yi = gsl_vector_get (y, i); if (wi < 0) wi = 0; gsl_vector_set (t, i, sqrt (wi) * yi); } gsl_blas_dgemv (CblasTrans, 1.0, A, t, 0.0, xt); /* Scale the matrix Q, Q' = Q S^-1 */ gsl_matrix_memcpy (QSI, Q); { double alpha0 = gsl_vector_get (S, 0); p_eff = 0; for (j = 0; j < p; j++) { gsl_vector_view column = gsl_matrix_column (QSI, j); double alpha = gsl_vector_get (S, j); if (alpha <= tol * alpha0) { alpha = 0.0; } else { alpha = 1.0 / alpha; p_eff++; } gsl_vector_scale (&column.vector, alpha); } *rank = p_eff; } gsl_vector_set_zero (c); /* Solution */ gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c); /* Unscale the balancing factors */ gsl_vector_div (c, D); /* Compute chisq, from residual r = y - X c */ { double r2 = 0; for (i = 0; i < n; i++) { double yi = gsl_vector_get (y, i); double wi = gsl_vector_get (w, i); gsl_vector_const_view row = gsl_matrix_const_row (X, i); double y_est, ri; gsl_blas_ddot (&row.vector, c, &y_est); ri = yi - y_est; r2 += wi * ri * ri; } *chisq = r2; /* Form covariance matrix cov = (X^T W X)^-1 = (Q S^-1) (Q S^-1)^T */ for (i = 0; i < p; i++) { gsl_vector_view row_i = gsl_matrix_row (QSI, i); double d_i = gsl_vector_get (D, i); for (j = i; j < p; j++) { gsl_vector_view row_j = gsl_matrix_row (QSI, j); double d_j = gsl_vector_get (D, j); double s; gsl_blas_ddot (&row_i.vector, &row_j.vector, &s); gsl_matrix_set (cov, i, j, s / (d_i * d_j)); gsl_matrix_set (cov, j, i, s / (d_i * d_j)); } } } return GSL_SUCCESS; } }
int gsl_multifit_linear_svd (const gsl_matrix * X, const gsl_vector * y, double tol, size_t * rank, gsl_vector * c, gsl_matrix * cov, double *chisq, gsl_multifit_linear_workspace * work) { if (X->size1 != y->size) { GSL_ERROR ("number of observations in y does not match rows of matrix X", GSL_EBADLEN); } else if (X->size2 != c->size) { GSL_ERROR ("number of parameters c does not match columns of matrix X", GSL_EBADLEN); } else if (cov->size1 != cov->size2) { GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR); } else if (c->size != cov->size1) { GSL_ERROR ("number of parameters does not match size of covariance matrix", GSL_EBADLEN); } else if (X->size1 != work->n || X->size2 != work->p) { GSL_ERROR ("size of workspace does not match size of observation matrix", GSL_EBADLEN); } else if (tol <= 0) { GSL_ERROR ("tolerance must be positive", GSL_EINVAL); } else { const size_t n = X->size1; const size_t p = X->size2; size_t i, j, p_eff; gsl_matrix *A = work->A; gsl_matrix *Q = work->Q; gsl_matrix *QSI = work->QSI; gsl_vector *S = work->S; gsl_vector *xt = work->xt; gsl_vector *D = work->D; /* Copy X to workspace, A <= X */ gsl_matrix_memcpy (A, X); /* Balance the columns of the matrix A */ gsl_linalg_balance_columns (A, D); /* Decompose A into U S Q^T */ gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt); /* Solve y = A c for c */ gsl_blas_dgemv (CblasTrans, 1.0, A, y, 0.0, xt); /* Scale the matrix Q, Q' = Q S^-1 */ gsl_matrix_memcpy (QSI, Q); { double alpha0 = gsl_vector_get (S, 0); p_eff = 0; for (j = 0; j < p; j++) { gsl_vector_view column = gsl_matrix_column (QSI, j); double alpha = gsl_vector_get (S, j); if (alpha <= tol * alpha0) { alpha = 0.0; } else { alpha = 1.0 / alpha; p_eff++; } gsl_vector_scale (&column.vector, alpha); } *rank = p_eff; } gsl_vector_set_zero (c); gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c); /* Unscale the balancing factors */ gsl_vector_div (c, D); /* Compute chisq, from residual r = y - X c */ { double s2 = 0, r2 = 0; for (i = 0; i < n; i++) { double yi = gsl_vector_get (y, i); gsl_vector_const_view row = gsl_matrix_const_row (X, i); double y_est, ri; gsl_blas_ddot (&row.vector, c, &y_est); ri = yi - y_est; r2 += ri * ri; } s2 = r2 / (n - p_eff); /* p_eff == rank */ *chisq = r2; /* Form variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */ for (i = 0; i < p; i++) { gsl_vector_view row_i = gsl_matrix_row (QSI, i); double d_i = gsl_vector_get (D, i); for (j = i; j < p; j++) { gsl_vector_view row_j = gsl_matrix_row (QSI, j); double d_j = gsl_vector_get (D, j); double s; gsl_blas_ddot (&row_i.vector, &row_j.vector, &s); gsl_matrix_set (cov, i, j, s * s2 / (d_i * d_j)); gsl_matrix_set (cov, j, i, s * s2 / (d_i * d_j)); } } } return GSL_SUCCESS; } }
int lseShurComplement(gsl_matrix * A, gsl_matrix * C, gsl_vector * b, gsl_vector * d, gsl_vector * x, gsl_vector * lambda, double * sigma) { int i; double xi; gsl_vector *c0, *S, *tau; gsl_matrix *CT, *U; gsl_permutation *perm; gsl_vector_view row, cp; gsl_matrix_view R; if (A->size2 != C->size2) return -1; if (A->size2 != x->size) return -1; if (A->size1 < A->size2) return -1; if (b != NULL && A->size1 != b->size) return -1; if (C->size1 != d->size) return -1; if (C->size1 != lambda->size) return -1; c0 = gsl_vector_alloc(x->size); gsl_matrix_get_row(c0, C, 0); /* Cholesky factorization of A^T A = R^T R via QRPT decomposition */ perm = gsl_permutation_alloc(x->size); tau = gsl_vector_alloc(x->size); gsl_linalg_QRPT_decomp(A, tau, perm, &i, x); /* cp = R^{-T} P A^T b = Q^T b */ if (b != NULL) { gsl_linalg_QR_QTvec(A, tau, b); cp = gsl_vector_subvector(b, 0, x->size); } gsl_vector_free(tau); /* C P -> C */ R = gsl_matrix_submatrix(A, 0, 0, A->size2, A->size2); for (i = 0; i < C->size1; ++i) { row = gsl_matrix_row(C, i); gsl_permute_vector(perm, &row.vector); } /* Compute C inv(R) -> C */ gsl_blas_dtrsm(CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, 1.0, &R.matrix, C); /* The Schur complement D = C C^T, Compute SVD of D = U S^2 U^T by SVD of C^T = V S U^T */ CT = gsl_matrix_alloc(C->size2, C->size1); gsl_matrix_transpose_memcpy(CT, C); U = gsl_matrix_alloc(CT->size2, CT->size2); S = gsl_vector_alloc(CT->size2); gsl_linalg_SV_decomp(CT, U, S, lambda); /* Right hand side of the Shur complement system d - C (A^T A)^-1 A^T b = d - C cp -> d (with C P R^-1 -> C and R^-T P^T A^T b -> cp) */ if (b != NULL) { gsl_blas_dgemv(CblasNoTrans, -1.0, C, &cp.vector, 1.0, d); } /* Calculate S U^T lambda, where -lambda is the Lagrange multiplier */ gsl_blas_dgemv(CblasTrans, 1.0, U, d, 0.0, lambda); gsl_vector_div(lambda, S); /* Calculate sigma = || A x ||_2 = || x ||_2 (before inv(R) x -> x) */ *sigma = gsl_blas_dnrm2(lambda); /* Compute inv(R)^T C^T lambda = C^T lambda (with C inv(R) ->C) */ gsl_blas_dgemv(CblasNoTrans, 1.0, CT, lambda, 0.0, x); /* x = inv(A^T A) C^T lambda = inv(R) [inv(R)^T C^T lambda] */ if (R.matrix.data[R.matrix.size1 * R.matrix.size2 - 1] != 0.0) { gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, x); } else { /* Special case when A is singular */ gsl_vector_set_basis(x, x->size - 1); *sigma = 0.0; } /* Permute back, 1-step iterative refinement on first constraint */ gsl_permute_vector_inverse(perm, x); gsl_blas_ddot(x, c0, &xi); gsl_vector_scale(x, d->data[0] / xi); /* get the real lambda from S U^T lambda previously stored in lambda */ gsl_vector_div(lambda, S); gsl_vector_memcpy(S, lambda); gsl_blas_dgemv(CblasNoTrans, 1.0, U, S, 0.0, lambda); gsl_vector_free(c0); gsl_vector_free(S); gsl_matrix_free(U); gsl_matrix_free(CT); gsl_permutation_free(perm); return 0; }
/** **************************************************************************************************************/ double g_outer_R (int Rn, double *betaincTauDBL, void *params) /*typedef double optimfn(int n, double *par, void *ex);*/ { int i,j; double term1=0.0,singlegrp=0.0; const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/ const gsl_vector *priormean = designdata->priormean; const gsl_vector *priorsd = designdata->priorsd; const gsl_vector *priorgamshape = designdata->priorgamshape; const gsl_vector *priorgamscale = designdata->priorgamscale; gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */ gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/ gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/ gsl_vector *betaincTau=((struct fnparams *) params)->betaincTau;/** to copy betaincTauDBL into **/ double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */ int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */ int verbose=((struct fnparams *) params)->verbose;/** */ int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/ int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/ double term2=0.0,term3=0.0,term4=0.0,gval=0.0; /*Rprintf("%d %d\n",n_betas,betaincTau->size);*/ double tau; for(i=0;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betaincTauDBL[i]);} /** copy R double array into gsl vect **/ /*Rprintf("got = %f %f %f\n",gsl_vector_get(betaincTau,0),gsl_vector_get(betaincTau,1),gsl_vector_get(betaincTau,2));*/ tau=gsl_vector_get(betaincTau,n_betas);/** extract the tau-precision from *beta - last entry */ /*Rprintf("g_outer_ tau=%f\n",tau);*/ if(tau<0.0){Rprintf("tau negative in g_outer!\n");error("");} /** beta are the parameters values at which the function is to be evaluated **/ /** gvalue is the return value - a single double */ /** STOP - NEED TO copy betaincTau into shorter beta since last entry is tau = precision */ for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/ } /** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */ /** first we want to evaluate each of the integrals for each data group **/ for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/ /*j=0;*/ /* Rprintf("processing group %d\n",j+1); Rprintf("tau in loop=%f\n",gsl_vector_get(betaincTau,n_betas));*/ singlegrp=g_inner(betaincTau,designdata,j, epsabs_inner,maxiters_inner,verbose); if(gsl_isnan(singlegrp)){error("nan in g_inner\n");} term1+= singlegrp; } /** NOTE: uncomment next line as useful for debugging as this should be the same as logLik value from lme4 */ /* Rprintf("total loglike=%e\n",term1);*/ /*Rprintf("term1 in g_outer=%f\n",term1);*/ /** part 2 the priors for the means **/ term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));} /** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/ gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */ gsl_vector_memcpy(vectmp2,priormean); gsl_vector_scale(vectmp2,-1.0); gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/ gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/ gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */ gsl_vector_memcpy(vectmp1,priorsd); gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */ gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/ gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */ gsl_vector_set_all(vectmp1,1.0); /** ones vector */ gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */ /** part 3 the prior for the precision tau **/ term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau) -(tau/gsl_vector_get(priorgamscale,0)); gval=(-1.0/n)*(term1+term2+term3+term4); /** NO PRIOR */ /* Rprintf("WARNING - NO PRIOR\n");*/ #ifdef NOPRIOR gval=(-1.0/n)*(term1); #endif if(gsl_isnan(gval)){error("g_outer_R\n");} /*Rprintf("g_outer_final=%f term1=%f term2=%f term3=%f term4=%f total=%f %d\n",gval,term1,term2,term3,term4,term1+term2+term3+term4,n); */ return(gval);/** negative since its a minimiser */ }
void KFKSDS_steady (int *dim, double *sy, double *sZ, double *sT, double *sH, double *sR, double *sV, double *sQ, double *sa0, double *sP0, double *tol, int *maxiter, double *ksconvfactor, double *mll, double *epshat, double *vareps, double *etahat, double *vareta, double *sumepsmisc, double *sumetamisc) { int i, ip1, n = dim[0], m = dim[2], ir = dim[3], convref, nmconvref, nm1 = n-1; int irsod = ir * sizeof(double); //double v[n], f[n], invf[n], vof[n]; std::vector<double> v(n), f(n), invf(n), vof(n); sumepsmisc[0] = 0.0; gsl_vector * sum_eta_misc = gsl_vector_calloc(ir); gsl_vector * etahat_sq = gsl_vector_alloc(ir); gsl_vector_view Z = gsl_vector_view_array(sZ, m); gsl_vector * Z_cp = gsl_vector_alloc(m); gsl_matrix * K = gsl_matrix_alloc(n, m); gsl_vector_view K_irow; gsl_matrix_view Q = gsl_matrix_view_array(sQ, m, m); gsl_matrix_view V = gsl_matrix_view_array(sV, ir, ir); gsl_matrix_view R = gsl_matrix_view_array(sR, m, ir); gsl_matrix * r = gsl_matrix_alloc(n + 1, m); gsl_vector_view r_row_t; gsl_vector_view r_row_tp1 = gsl_matrix_row(r, n); gsl_vector_set_zero(&r_row_tp1.vector); std::vector<gsl_matrix*> L(n); std::vector<gsl_matrix*> N(n+1); N.at(n) = gsl_matrix_calloc(m, m); gsl_vector_view Ndiag; gsl_vector_view Qdiag = gsl_matrix_diagonal(&Q.matrix); gsl_vector * Qdiag_msq = gsl_vector_alloc(m); gsl_vector_memcpy(Qdiag_msq, &Qdiag.vector); gsl_vector_mul(Qdiag_msq, &Qdiag.vector); gsl_vector_scale(Qdiag_msq, -1.0); gsl_vector * sum_vareta = gsl_vector_calloc(m); KF_steady(dim, sy, sZ, sT, sH, sR, sV, sQ, sa0, sP0, mll, &v, &f, &invf, &vof, K, &L, tol, maxiter); convref = dim[5]; if (convref == -1) { convref = n; } else convref = ceil(convref * ksconvfactor[0]); nmconvref = n - convref; gsl_vector_view vaux; gsl_matrix * Mmm = gsl_matrix_alloc(m, m); gsl_matrix * ZtZ = gsl_matrix_alloc(m, m); gsl_matrix_view maux1, maux2; maux1 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), m, 1); gsl_vector_memcpy(Z_cp, &Z.vector); maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix, &maux2.matrix, 0.0, ZtZ); gsl_vector * var_eps = gsl_vector_alloc(n); double msHsq = -1.0 * pow(*sH, 2); vaux = gsl_vector_view_array(&f[0], n); gsl_vector_set_all(var_eps, msHsq); gsl_vector_div(var_eps, &vaux.vector); gsl_vector_add_constant(var_eps, *sH); gsl_matrix * eta_hat = gsl_matrix_alloc(n, ir); gsl_matrix * Mrm = gsl_matrix_alloc(ir, m); gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, &V.matrix, &R.matrix, 0.0, Mrm); for (i = n-1; i > -1; i--) { ip1 = i + 1; if (i != n-1) //the case i=n-1 was initialized above r_row_tp1 = gsl_matrix_row(r, ip1); r_row_t = gsl_matrix_row(r, i); gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &r_row_tp1.vector, 0.0, &r_row_t.vector); gsl_vector_memcpy(Z_cp, &Z.vector); gsl_vector_scale(Z_cp, vof[i]); gsl_vector_add(&r_row_t.vector, Z_cp); N.at(i) = gsl_matrix_alloc(m, m); if (i < convref || i > nmconvref) { gsl_matrix_memcpy(N.at(i), ZtZ); gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N.at(ip1), 0.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), invf[i], N.at(i)); } else { gsl_matrix_memcpy(N.at(i), N.at(ip1)); } if (dim[6] == 0 || dim[6] == 1) { if (i < convref || i == nm1) { K_irow = gsl_matrix_row(K, i); } gsl_blas_ddot(&K_irow.vector, &r_row_tp1.vector, &epshat[i]); epshat[i] -= vof[i]; epshat[i] *= -*sH; if (i < convref || i > nmconvref) { maux1 = gsl_matrix_view_array(gsl_vector_ptr(&K_irow.vector, 0), 1, m); maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix, N.at(ip1), 0.0, &maux2.matrix); vaux = gsl_vector_view_array(gsl_vector_ptr(var_eps, i), 1); gsl_blas_dgemv(CblasNoTrans, msHsq, &maux2.matrix, &K_irow.vector, 1.0, &vaux.vector); vareps[i] = gsl_vector_get(&vaux.vector, 0); } else { vareps[i] = vareps[ip1]; } sumepsmisc[0] += epshat[i] * epshat[i] + vareps[i]; } if (dim[6] == 0 || dim[6] == 2) { vaux = gsl_matrix_row(eta_hat, i); gsl_blas_dgemv(CblasNoTrans, 1.0, Mrm, &r_row_tp1.vector, 0.0, &vaux.vector); memcpy(&etahat[i*ir], (&vaux.vector)->data, irsod); if (i != n-1) { gsl_vector_memcpy(etahat_sq, &vaux.vector); gsl_vector_mul(etahat_sq, etahat_sq); gsl_vector_add(sum_eta_misc, etahat_sq); } if (i != n-1) { if (i < convref || i > nmconvref) { Ndiag = gsl_matrix_diagonal(N.at(ip1)); gsl_vector_memcpy(Z_cp, &Ndiag.vector); gsl_vector_mul(Z_cp, Qdiag_msq); gsl_vector_add(Z_cp, &Qdiag.vector); gsl_vector_set_zero(sum_vareta); gsl_vector_add(sum_vareta, Z_cp); } gsl_blas_dgemv(CblasTrans, 1.0, &R.matrix, sum_vareta, 1.0, sum_eta_misc); } } gsl_matrix_free(L.at(i)); gsl_matrix_free(N.at(ip1)); } gsl_matrix_free(N.at(0)); if (dim[6] == 0 || dim[6] == 2) { memcpy(&sumetamisc[0], sum_eta_misc->data, irsod); } gsl_vector_free(Z_cp); gsl_vector_free(var_eps); gsl_vector_free(Qdiag_msq); gsl_vector_free(sum_vareta); gsl_vector_free(sum_eta_misc); gsl_vector_free(etahat_sq); gsl_matrix_free(eta_hat); gsl_matrix_free(Mrm); gsl_matrix_free(r); gsl_matrix_free(K); gsl_matrix_free(ZtZ); gsl_matrix_free(Mmm); }
int Holling2(double t, const double y[], double ydot[], void *params){ double alpha = 0.3; // respiration double lambda = 0.65; // ecologic efficiency double hand = 0.35; // handling time double beta = 0.5; // intraspecific competition double aij = 6.0; // attack rate //double migratingPop = 0.01; int i, j,l = 0; // Hilfsvariablen double rowsum = 0; //double colsum = 0; // int test = 0; // // if(test<5) // { // printf("Richtiges Holling"); // } // test++; //-- Struktur zerlegen------------------------------------------------------------------------------------------------------------------------------- struct foodweb *nicheweb = (struct foodweb *)params; // pointer cast from (void*) to (struct foodweb*) //printf("t in Holling 2=%f\n", t); gsl_vector *network = (nicheweb->network); // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S int S = nicheweb->S; int Y = nicheweb->Y; int Rnum = nicheweb->Rnum; //double d = nicheweb->d; int Z = nicheweb->Z; //double dij = pow(10, d); double Bmigr = gsl_vector_get(network, (Rnum+S)*(S+Rnum)+1+Y*Y+1+(Rnum+S)+S); //printf("Bmigr ist %f\n", Bmigr); double nu,mu, tau; int SpeciesNumber; tau = gsl_vector_get(nicheweb->migrPara,0); mu = gsl_vector_get(nicheweb->migrPara,1); // if((int)nu!=0) // { // printf("nu ist nicht null sondern %f\n",nu); // } nu = gsl_vector_get(nicheweb->migrPara,2); SpeciesNumber = gsl_vector_get(nicheweb->migrPara,3); double tlast = gsl_vector_get(nicheweb->migrPara,4); // if(SpeciesNumber!= 0) // { // //printf("SpeciesNumber %i\n", SpeciesNumber); // } //printf("t oben %f\n",t); //int len = (Rnum+S)*(Rnum+S)+2+Y*Y+(Rnum+S)+S; gsl_vector_view A_view = gsl_vector_subvector(network, 0, (Rnum+S)*(Rnum+S)); // Fressmatrix A als Vektor gsl_matrix_view EA_mat = gsl_matrix_view_vector(&A_view.vector, (Rnum+S), (Rnum+S)); // A als Matrix_view gsl_matrix *EAmat = &EA_mat.matrix; // A als Matrix gsl_vector_view D_view = gsl_vector_subvector(network, (Rnum+S)*(Rnum+S)+1, Y*Y); // Migrationsmatrix D als Vektor gsl_matrix_view ED_mat = gsl_matrix_view_vector(&D_view.vector, Y, Y); // D als Matrixview gsl_matrix *EDmat = &ED_mat.matrix; // D als Matrix gsl_vector_view M_vec = gsl_vector_subvector(network, ((Rnum+S)*(Rnum+S))+1+(Y*Y)+1, (Rnum+S)); // Massenvektor gsl_vector *Mvec = &M_vec.vector; //-- verändere zu dem gewünschten Zeitpunkt Migrationsmatrix if( (t > tau) && (tlast < tau)) { //printf("mu ist %f\n", gsl_vector_get(nicheweb->migrPara,1)); //printf("nu ist %f\n", nu); gsl_vector_set(nicheweb->migrPara,4,t); //printf("Setze Link für gewünschte Migration\n"); // printf("t oben %f\n",t); // printf("tlast oben %f\n",tlast); gsl_matrix_set(EDmat, nu, mu, 1.); //int m; // for(l = 0; l< Y;l++) // { // for(m=0;m<Y;m++) // { // printf("%f\t",gsl_matrix_get(EDmat,l,m)); // } // printf("\n"); // } } else { gsl_matrix_set_zero(EDmat); } // printf("\ncheckpoint Holling2 I\n"); // printf("\nS = %i\n", S); // printf("\nS + Rnum = %i\n", S+Rnum); // // printf("\nSize A_view = %i\n", (int)A_view.vector.size); // printf("\nSize D_view = %i\n", (int)D_view.vector.size); // printf("\nSize M_vec = %i\n", (int)M_vec.vector.size); // for(i=0; i<(Rnum+S)*Y; i++){ // printf("\ny = %f\n", y[i]); // } // for(i=0; i<(Rnum+S)*Y; i++){ // printf("\nydot = %f\n", ydot[i]); // } //--zusätzliche Variablen anlegen------------------------------------------------------------------------------------------------------------- double ytemp[(Rnum+S)*Y]; for(i=0; i<(Rnum+S)*Y; i++) ytemp[i] = y[i]; // temp array mit Kopie der Startwerte for(i=0; i<(Rnum+S)*Y; i++) ydot[i] = 0; // Ergebnis, in das evolve_apply schreibt gsl_vector_view yfddot_vec = gsl_vector_view_array(ydot, (Rnum+S)*Y); //Notiz: vector_view_array etc. arbeiten auf den original Daten der ihnen zugeordneten Arrays/Vektoren! gsl_vector *yfddotvec = &yfddot_vec.vector; // zum einfacheren Rechnen ydot über vector_view_array ansprechen gsl_vector_view yfd_vec = gsl_vector_view_array(ytemp, (Rnum+S)*Y); gsl_vector *yfdvec = &yfd_vec.vector; // Startwerte der Populationen //-- neue Objekte zum Rechnen anlegen-------------------------------------------------------------------------------------------------------- gsl_matrix *AFgsl = gsl_matrix_calloc(Rnum+S, Rnum+S); // matrix of foraging efforts // gsl_matrix *ADgsl = gsl_matrix_calloc(Y,Y); // matrix of migration efforts gsl_matrix *Emat = gsl_matrix_calloc(Rnum+S, Rnum+S); // gsl objects for calculations of populations gsl_vector *tvec = gsl_vector_calloc(Rnum+S); gsl_vector *rvec = gsl_vector_calloc(Rnum+S); gsl_vector *svec = gsl_vector_calloc(Rnum+S); // gsl_matrix *Dmat = gsl_matrix_calloc(Y,Y); // gsl objects for calculations of migration // gsl_vector *d1vec = gsl_vector_calloc(Y); gsl_vector *d2vec = gsl_vector_calloc(Y); gsl_vector *d3vec = gsl_vector_calloc(Y); // printf("\ncheckpoint Holling2 III\n"); //-- Einzelne Patches lösen------------------------------------------------------------------------------------------------------------ for(l=0; l<Y; l++) // start of patch solving { gsl_matrix_set_zero(AFgsl); // Objekte zum Rechnen vor jedem Patch nullen gsl_matrix_set_zero(Emat); gsl_vector_set_zero(tvec); gsl_vector_set_zero(rvec); gsl_vector_set_zero(svec); gsl_vector_view ydot_vec = gsl_vector_subvector(yfddotvec, (Rnum+S)*l, (Rnum+S)); // enthält ydot von Patch l gsl_vector *ydotvec = &ydot_vec.vector; gsl_vector_view y_vec = gsl_vector_subvector(yfdvec, (Rnum+S)*l, (Rnum+S)); // enthält Startwerte der Population in l gsl_vector *yvec = &y_vec.vector; gsl_matrix_memcpy(AFgsl, EAmat); for(i=0; i<Rnum+S; i++) { gsl_vector_view rowA = gsl_matrix_row(AFgsl,i); rowsum = gsl_blas_dasum(&rowA.vector); if(rowsum !=0 ) { for(j=0; j<Rnum+S; j++) gsl_matrix_set(AFgsl, i, j, (gsl_matrix_get(AFgsl,i,j)/rowsum)); // normiere Beute Afgsl = A(Beutelinks auf 1 normiert) = f(i,j) } } gsl_matrix_memcpy(Emat, EAmat); // Emat = A gsl_matrix_scale(Emat, aij); // Emat(i,j) = a(i,j) gsl_matrix_mul_elements(Emat, AFgsl); // Emat(i,j) = a(i,j)*f(i,j) gsl_vector_memcpy(svec, yvec); // s(i) = y(i) gsl_vector_scale(svec, hand); // s(i) = y(i)*h gsl_blas_dgemv(CblasNoTrans, 1, Emat, svec, 0, rvec); // r(i) = Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_add_constant(rvec, 1); // r(i) = 1+Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_memcpy(tvec, Mvec); // t(i) = masse(i)^(-0.25) gsl_vector_div(tvec, rvec); // t(i) = masse(i)^(-0.25)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_vector_mul(tvec, yvec); // t(i) = masse(i)^(-0.25)*y(i)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_blas_dgemv(CblasTrans, 1, Emat, tvec, 0, rvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j) gsl_vector_mul(rvec, yvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j)*y(i) [rvec: Praedation] gsl_blas_dgemv(CblasNoTrans, lambda, Emat, yvec, 0, ydotvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j) gsl_vector_mul(ydotvec, tvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j)*t(i) gsl_vector_memcpy(svec, Mvec); gsl_vector_scale(svec, alpha); // s(i) = alpha*masse^(-0.25) [svec=Respiration bzw. Mortalitaet] gsl_vector_memcpy(tvec, Mvec); gsl_vector_scale(tvec, beta); // t(i) = beta*masse^(-0.25) gsl_vector_mul(tvec, yvec); // t(i) = beta*y(i) gsl_vector_add(svec, tvec); // s(i) = alpha*masse^(-0.25)+beta*y(i) gsl_vector_mul(svec, yvec); // s(i) = alpha*masse^(-0.25)*y(i)+beta*y(i)*y(i) gsl_vector_add(svec, rvec); // [svec: Respiration, competition und Praedation] gsl_vector_sub(ydotvec, svec); // ydot(i) = Fressen-Respiration-Competition-Praedation for(i=0; i<Rnum; i++) gsl_vector_set(ydotvec, i, 0.0); // konstante Ressourcen }// Ende Einzelpatch, Ergebnis steht in ydotvec // printf("\ncheckpoint Holling2 IV\n"); //-- Migration lösen--------------------------------------------------------------------------------------------------------- gsl_vector *ydottest = gsl_vector_calloc(Y); double ydotmigr = gsl_vector_get(nicheweb->migrPara, 5); // int count=0,m; // for(l = 0; l< Y;l++) // { // for(m=0;m<Y;m++) // { // count += gsl_matrix_get(EDmat,l,m); // } // } // if(count!=0) // { // //printf("count %i\n",count); // //printf("t unten %f\n",t); // //printf("tau %f\n",tau); // for(l = 0; l< Y;l++) // { // for(m=0;m<Y;m++) // { // printf("%f\t",gsl_matrix_get(EDmat,l,m)); // } // printf("\n"); // } // } double max = gsl_matrix_max(EDmat); for(l = Rnum; l< Rnum+S; l++) // start of migration solving { if(l == SpeciesNumber+Rnum && max !=0 ) { //printf("max ist %f\n",max); //printf("l ist %i\n",l); // gsl_matrix_set_zero(ADgsl); // reset gsl objects for every patch // gsl_matrix_set_zero(Dmat); // gsl_vector_set_zero(d1vec); gsl_vector_set_zero(d2vec); gsl_vector_set_zero(d3vec); gsl_vector_set_zero(ydottest); // Untervektor von yfddot (enthält ydot[]) mit offset l (Rnum...Rnum+S) und Abstand zwischen den Elementen (stride) von Rnum+S. // Dies ergibt gerade die Größe einer Spezies in jedem Patch in einem Vektor gsl_vector_view dydot_vec = gsl_vector_subvector_with_stride(yfddotvec, l, (Rnum+S), Y); // ydot[] gsl_vector *dydotvec = &dydot_vec.vector; /* gsl_vector_view dy_vec = gsl_vector_subvector_with_stride(yfdvec, l, (Rnum+S), Y); // Startgrößen der Spezies pro Patch gsl_vector *dyvec = &dy_vec.vector; */ // gsl_matrix_memcpy(ADgsl, EDmat); // ADgsl = D // // if(nicheweb->M == 1) // umschalten w: patchwise (Abwanderung aus jedem Patch gleich), sonst linkwise (Abwanderung pro link gleich) // { // for(i=0; i<Y; i++) // { // gsl_vector_view colD = gsl_matrix_column(ADgsl, i); // Spalte i aus Migrationsmatrix // colsum = gsl_blas_dasum(&colD.vector); // if(colsum!=0) // { // for(j=0;j<Y;j++) // gsl_matrix_set(ADgsl,j,i,(gsl_matrix_get(ADgsl,j,i)/colsum)); // ADgsl: D mit normierten Links // } // } // } // // gsl_matrix_memcpy(Dmat, EDmat); // Dmat = D // gsl_matrix_scale(Dmat, dij); // Dmat(i,j) = d(i,j) (Migrationsstärke) // gsl_matrix_mul_elements(Dmat, ADgsl); // Dmat(i,j) = d(i,j)*xi(i,j) (skalierte und normierte Migrationsmatrix) // // gsl_vector_set_all(d1vec, 1/gsl_vector_get(Mvec, l)); // d1(i)= m(l)^0.25 // gsl_vector_mul(d1vec, dyvec); // d1(i)= m(l)^0.25*y(i) // gsl_blas_dgemv(CblasNoTrans, 1, Dmat, d1vec, 0, d2vec); // d2(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j) // // gsl_vector_set_all(d1vec, 1); // d1(i)= 1 // gsl_blas_dgemv(CblasTrans, 1, Dmat, d1vec, 0, d3vec); // d3(i)= Sum_j d(i,j)*xi(i,j) // gsl_vector_scale(d3vec, 1/gsl_vector_get(Mvec,l)); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25 // gsl_vector_mul(d3vec, dyvec); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i) // gsl_vector_set(d2vec,nu,Bmigr); gsl_vector_set(d3vec,mu,Bmigr); gsl_vector_add(ydottest,d2vec); gsl_vector_sub(ydottest,d3vec); //printf("d2vec ist %f\n",gsl_vector_get(d2vec,0)); //printf("d3vec ist %f\n",gsl_vector_get(d3vec,0)); //if(gsl_vector_get(ydottest,mu)!=0) //{ ydotmigr += gsl_vector_get(ydottest,nu); // printf("ydotmigr ist %f\n",ydotmigr); gsl_vector_set(nicheweb->migrPara,5,ydotmigr); // if(ydotmigr !=0) // { // printf("ydottest aufaddiert ist %f\n",ydotmigr); // printf("ydottest aufaddiert ist %f\n",gsl_vector_get(nicheweb->migrPara,5)); // } gsl_vector_add(dydotvec, d2vec); // gsl_vector_sub(dydotvec, d3vec); // Ergebnis in dydotvec (also ydot[]) = Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j) - Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i) } }// Patch i gewinnt das was aus allen j Patches zuwandert und verliert was von i auswandert //printf("ydot ist %f\n",gsl_vector_get(ydottest,0)); //printf("\ncheckpoint Holling2 V\n"); /* for(i=0; i<(Rnum+S)*Y; i++){ printf("\ny = %f\tydot=%f\n", y[i], ydot[i]); } */ //--check for fixed point attractor----------------------------------------------------------------------------------- if(t>7800){ gsl_vector_set(nicheweb->fixpunkte, 0, 0); gsl_vector_set(nicheweb->fixpunkte, 1, 0); gsl_vector_set(nicheweb->fixpunkte, 2, 0); int fix0 = (int)gsl_vector_get(nicheweb->fixpunkte, 0); int fix1 = (int)gsl_vector_get(nicheweb->fixpunkte, 1); int fix2 = (int)gsl_vector_get(nicheweb->fixpunkte, 2); //printf("t unten = %f\n", t); for(i=0; i<(Rnum+S)*Y; i++) { if(y[i] <= 0) { fix0++; fix1++; fix2++; } else { if((ydot[i]/y[i]<0.0001) || (ydot[i]<0.0001)) fix0++; if(ydot[i]/y[i]<0.0001) fix1++; if(ydot[i]<0.0001) fix2++; } } if(fix0==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 3, 1); if(fix1==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 4, 1); if(fix2==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 5, 1); } //--Speicher leeren----------------------------------------------------------------------------------------------------- gsl_matrix_free(Emat); // gsl_matrix_free(Dmat); gsl_matrix_free(AFgsl); // gsl_matrix_free(ADgsl); gsl_vector_free(tvec); gsl_vector_free(rvec); gsl_vector_free(svec); // gsl_vector_free(d1vec); gsl_vector_free(d2vec); gsl_vector_free(d3vec); gsl_vector_free(ydottest); // printf("\nCheckpoint Holling2 VI\n"); return GSL_SUCCESS; }
/** ************************************************************************************* ***************************************************************************************** *****************************************************************************************/ double g_pois_outer_marg_R (int Rn, double *betashortDBL, void *params) /** double g_outer_marg_R(int Rn, double *betaincTauDBL, void *params);*/ { /** betashort is full beta vector (inc precision) bu then minus one term **/ int i,j; double term1=0.0,singlegrp=0.0; const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/ const gsl_vector *priormean = designdata->priormean; const gsl_vector *priorsd = designdata->priorsd; const gsl_vector *priorgamshape = designdata->priorgamshape; const gsl_vector *priorgamscale = designdata->priorgamscale; gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */ gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/ gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/ double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */ int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */ int verbose=((struct fnparams *) params)->verbose;/** */ int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/ int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/ /** this is extra stuff to deal with the fixed beta **/ gsl_vector *betaincTau = ((struct fnparams *) params)->betafull;/** will hold "full beta vector" inc precision **/ double betafixed = ((struct fnparams *) params)->betafixed;/** the fixed beta value passed through**/ int betaindex = ((struct fnparams *) params)->betaindex; double term2=0.0,term3=0.0,term4=0.0,gval=0.0; double tau; if(betaindex==0){gsl_vector_set(betaincTau,0,betafixed); for(i=1;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betashortDBL[i-1]);}} if(betaindex==(betaincTau->size-1)){gsl_vector_set(betaincTau,betaincTau->size-1,betafixed); for(i=0;i<betaincTau->size-1;i++){gsl_vector_set(betaincTau,i,betashortDBL[i]);}} if(betaindex>0 && betaindex<(betaincTau->size-1)){ for(i=0;i<betaindex;i++){gsl_vector_set(betaincTau,i,betashortDBL[i]);} gsl_vector_set(betaincTau,betaindex,betafixed); for(i=betaindex+1;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betashortDBL[i-1]);} } /*Rprintf("passed:\n"); for(i=0;i<betaincTau->size;i++){Rprintf("%10.10f ",gsl_vector_get(betaincTau,i));}Rprintf("\n"); */ tau=gsl_vector_get(betaincTau,n_betas);/** extract the tau-precision from *beta - last entry */ /*if(tau<0){Rprintf("negative tau in g_outer\n");return(DBL_MAX);}*/ if(tau<0.0){Rprintf("tau negative in g_outer!\n");error("");} /** beta are the parameters values at which the function is to be evaluated **/ /** gvalue is the return value - a single double */ /** STOP - NEED TO copy betaincTau into shorter beta since last entry is tau = precision */ for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/ } /** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */ /** first we want to evaluate each of the integrals for each data group **/ for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/ /*j=0;*/ /*Rprintf("processing group %d\n",j+1);*/ singlegrp=g_pois_inner(betaincTau,designdata,j,epsabs_inner,maxiters_inner,verbose); if(gsl_isnan(singlegrp)){error("nan in g_inner\n");} term1+= singlegrp; } /*Rprintf("term1 in g_outer=%f\n",term1);*/ /** part 2 the priors for the means **/ term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));} /** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/ gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */ gsl_vector_memcpy(vectmp2,priormean); gsl_vector_scale(vectmp2,-1.0); gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/ gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/ gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */ gsl_vector_memcpy(vectmp1,priorsd); gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */ gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/ gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */ gsl_vector_set_all(vectmp1,1.0); /** ones vector */ gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */ /** part 3 the prior for the precision tau **/ term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau) -(tau/gsl_vector_get(priorgamscale,0)); gval=(-1.0/n)*(term1+term2+term3+term4); if(gsl_isnan(gval)){error("g_pois_outer_R\n");} /*Rprintf("gvalue=%10.10f\n",gval);*/ return(gval);/** negative since its a minimiser */ }
double* intraguildPred(struct foodweb nicheweb, const double y[], double* intraPred) { int i,j,l; int S = nicheweb.S; int Y = nicheweb.Y; int Rnum = nicheweb.Rnum; gsl_vector *network = nicheweb.network; // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S double lambda = nicheweb.lambda; double aij = nicheweb.aij; double hand = nicheweb.hand; /* Massen rausholen */ gsl_vector_view A_view = gsl_vector_subvector(network, 0, (Rnum+S)*(Rnum+S)); // Fressmatrix A als Vektor gsl_matrix_view EA_mat = gsl_matrix_view_vector(&A_view.vector, (Rnum+S), (Rnum+S)); // A als Matrix_view gsl_matrix *EAmat = &EA_mat.matrix; // A als Matrix gsl_vector_view M_vec = gsl_vector_subvector(network, ((Rnum+S)*(Rnum+S))+1+(Y*Y)+1, (Rnum+S)); // Massenvektor gsl_vector *Mvec = &M_vec.vector; // massvector: M(i)=m^(-0.25) double ytemp[(Rnum+S)*Y]; // tempvector for populations and efforts for(i=0;i<(Rnum+S)*Y;i++) ytemp[i]=y[i]; /* Alles view_array */ /* Auslesen von ytemp = y[]; sind Population */ gsl_vector_view yfd_vec=gsl_vector_view_array(ytemp,(Rnum+S)*Y); gsl_vector *yfdvec=&yfd_vec.vector; // populations and efforts for later use /* Initialisierungen */ gsl_matrix *AFgsl=gsl_matrix_calloc(Rnum+S, Rnum+S); // matrix of foraging efforts gsl_matrix *Emat=gsl_matrix_calloc(Rnum+S, Rnum+S); // gsl objects for calculations of populations gsl_vector *tvec=gsl_vector_calloc(Rnum+S); gsl_vector *rvec=gsl_vector_calloc(Rnum+S); gsl_vector *svec=gsl_vector_calloc(Rnum+S); gsl_vector *intraPredTemp=gsl_vector_calloc(Rnum+S); for(l=0;l<Y;l++) // start of patch solving { /* Initialisierungen */ gsl_matrix_set_zero(AFgsl); // reset gsl objects for every patch gsl_matrix_set_zero(Emat); gsl_vector_set_zero(tvec); gsl_vector_set_zero(rvec); gsl_vector_set_zero(svec); /* Je Vektoren von (Res+S) Elementen */ /* yfdvec enthält die Population */ gsl_vector_view y_vec=gsl_vector_subvector(yfdvec,(Rnum+S)*l,(Rnum+S)); gsl_vector *yvecint=&y_vec.vector; /* Kopie von EAmat erstellen */ gsl_matrix_memcpy(AFgsl,EAmat); for(i=0;i<Rnum+S;i++) { /* Nehme i-te Zeile aus A */ gsl_vector_view tempp=gsl_matrix_row(AFgsl,i); /* Summiere Absolutwerte der Zeile */ double temp1; temp1=gsl_blas_dasum(&tempp.vector); if(temp1!=0) { /* Teile die Einträge, die nicht- Null sind durch Anzahl an nicht-Nullen in dieser Zeile*/ /* und setzte diesen Wert dann an den entsprechenden Platz */ /* Man erhält also eine prozentuale Verbindung */ for(j=0;j<Rnum+S;j++) gsl_matrix_set(AFgsl,i,j,(gsl_matrix_get(AFgsl,i,j)/temp1)); } } /* aij ist Attackrate; AFgsl ist jetzt normiert- also fij */ gsl_matrix_memcpy(Emat,EAmat); gsl_matrix_scale(Emat,aij); // Emat(i,j) = a(i,j) gsl_matrix_mul_elements(Emat,AFgsl); // Emat(i,j) = a(i,j)*f(i,j) /* hand = handling time */ /* Berechnung wie aus Paper */ gsl_vector_set(yvecint,0,0); printf("y: %f\n",gsl_vector_get(yvecint,0)); gsl_vector_memcpy(svec,yvecint); // s(i)=y(i) gsl_vector_scale(svec, hand); // s(i)=y(i)*h gsl_blas_dgemv(CblasNoTrans,1,Emat,svec,0,rvec); // r(i)=Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_add_constant(rvec,1); // r(i)=1+Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_memcpy(tvec,Mvec); // t(i)=masse(i)^(-0.25) gsl_vector_div(tvec,rvec); // t(i)=masse(i)^(-0.25)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_vector_mul(tvec,yvecint); // t(i)=masse(i)^(-0.25)*y(i)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_blas_dgemv(CblasNoTrans,lambda,Emat,yvecint,0,intraPredTemp); // ydot(i)=Sum_j lambda*a(i,j)*f(i,j)*y(j) gsl_vector_mul(intraPredTemp,tvec); intraPred[l] = gsl_blas_dasum(intraPredTemp); } /* Speicher befreien */ gsl_matrix_free(Emat); gsl_matrix_free(AFgsl); gsl_vector_free(tvec); gsl_vector_free(rvec); gsl_vector_free(svec); gsl_vector_free(intraPredTemp); return 0; }
static int cgst_step(const void * vtrust_state, const double delta, gsl_vector * dx, void * vstate) { int status; const gsl_multilarge_nlinear_trust_state *trust_state = (const gsl_multilarge_nlinear_trust_state *) vtrust_state; cgst_state_t *state = (cgst_state_t *) vstate; const gsl_vector * x = trust_state->x; const gsl_vector * f = trust_state->f; const gsl_vector * swts = trust_state->sqrt_wts; const gsl_vector * diag = trust_state->diag; const gsl_multilarge_nlinear_parameters * params = trust_state->params; gsl_multilarge_nlinear_fdf * fdf = trust_state->fdf; double alpha, beta, u; double norm_Jd; /* || J D^{-1} d_i || */ double norm_r; /* || r_i || */ double norm_rp1; /* || r_{i+1} || */ size_t i; /* Step 1 of [1], section 2; scale gradient as * * g~ = D^{-1} g * * for better numerical stability */ for (i = 0; i < state->p; ++i) { double gi = gsl_vector_get(trust_state->g, i); double di = gsl_vector_get(trust_state->diag, i); gsl_vector_set(state->z, i, 0.0); gsl_vector_set(state->r, i, -gi / di); gsl_vector_set(state->d, i, -gi / di); gsl_vector_set(state->workp, i, gi / di); } /* compute || g~ || */ state->norm_g = gsl_blas_dnrm2(state->workp); for (i = 0; i < state->cgmaxit; ++i) { /* workp := D^{-1} d_i */ gsl_vector_memcpy(state->workp, state->d); gsl_vector_div(state->workp, trust_state->diag); /* workn := J D^{-1} d_i */ status = gsl_multilarge_nlinear_eval_df(CblasNoTrans, x, f, state->workp, swts, params->h_df, params->fdtype, fdf, state->workn, NULL); if (status) return status; /* compute || J D^{-1} d_i || */ norm_Jd = gsl_blas_dnrm2(state->workn); /* Step 2 of [1], section 2 */ if (norm_Jd == 0.0) { double tau = cgst_calc_tau(state->z, state->d, delta); /* dx = z_i + tau*d_i */ scaled_addition(1.0, state->z, tau, state->d, dx); gsl_vector_div(dx, diag); return GSL_SUCCESS; } /* Step 3 of [1], section 2 */ norm_r = gsl_blas_dnrm2(state->r); u = norm_r / norm_Jd; alpha = u * u; /* workp <= z_{i+1} = z_i + alpha_i*d_i */ scaled_addition(1.0, state->z, alpha, state->d, state->workp); u = gsl_blas_dnrm2(state->workp); if (u >= delta) { double tau = cgst_calc_tau(state->z, state->d, delta); /* dx = z_i + tau*d_i */ scaled_addition(1.0, state->z, tau, state->d, dx); gsl_vector_div(dx, diag); return GSL_SUCCESS; } /* store z_{i+1} */ gsl_vector_memcpy(state->z, state->workp); /* Step 4 of [1], section 2 */ /* compute: workp := alpha B d_i = alpha D^{-1} J^T J D^{-1} d_i, * where J D^{-1} d_i is already stored in workn */ status = gsl_multilarge_nlinear_eval_df(CblasTrans, x, f, state->workn, swts, params->h_df, params->fdtype, fdf, state->workp, NULL); if (status) return status; gsl_vector_div(state->workp, trust_state->diag); gsl_vector_scale(state->workp, alpha); /* r_{i+1} = r_i - alpha*B*d_i */ gsl_vector_sub(state->r, state->workp); norm_rp1 = gsl_blas_dnrm2(state->r); u = norm_rp1 / state->norm_g; if (u < state->cgtol) { gsl_vector_memcpy(dx, state->z); gsl_vector_div(dx, diag); return GSL_SUCCESS; } /* Step 5 of [1], section 2 */ /* compute u = ||r_{i+1}|| / || r_i|| */ u = norm_rp1 / norm_r; beta = u * u; /* compute: d_{i+1} = rt_{i+1} + beta*d_i */ scaled_addition(1.0, state->r, beta, state->d, state->d); } /* failed to converge, return current estimate */ gsl_vector_memcpy(dx, state->z); gsl_vector_div(dx, diag); return GSL_EMAXITER; }
/** * needs: * params file * BURN_IN_ITERATIONS * first line in calibration_result * BETA_ALIGNMENT * BETA_0 * SKIP_CALIBRATE_ALLCHAINS ** * does: * calibrate remaining chains (beta < 1) * writes all betas, stepwidths and start values in file calibration_result ** * provides: * stepwidths of first chain (calibration_result) * new params file (params_suggest) * new start values (calibration_result) **/ void calibrate_rest() { int n_beta = N_BETA; const double desired_acceptance_rate = TARGET_ACCEPTANCE_RATE; const double max_ar_deviation = MAX_AR_DEVIATION; double beta_0 = BETA_0; const unsigned long burn_in_iterations = BURN_IN_ITERATIONS; const unsigned long iter_limit = ITER_LIMIT; const double mul = MUL; unsigned int n_par; int i; gsl_vector * stepwidth_factors; mcmc ** chains = setup_chains(); read_calibration_file(chains, 1); printf("Calibrating chains\n"); fflush(stdout); n_par = get_n_par(chains[0]); stepwidth_factors = gsl_vector_alloc(n_par); gsl_vector_set_all(stepwidth_factors, 1); i = 1; if (n_beta > 1) { if (beta_0 < 0) set_beta(chains[i], get_chain_beta(i, n_beta, calc_beta_0( chains[0], stepwidth_factors))); else set_beta(chains[i], get_chain_beta(i, n_beta, beta_0)); gsl_vector_free(get_steps(chains[i])); chains[i]->params_step = dup_vector(get_steps(chains[0])); gsl_vector_scale(get_steps(chains[i]), pow(get_beta(chains[i]), -0.5)); set_params(chains[i], dup_vector(get_params_best(chains[0]))); calc_model(chains[i], NULL); mcmc_check(chains[i]); printf("Calibrating second chain to infer stepwidth factor\n"); printf("\tChain %2d - ", i); printf("beta = %f\tsteps: ", get_beta(chains[i])); dump_vectorln(get_steps(chains[i])); fflush(stdout); markov_chain_calibrate(chains[i], burn_in_iterations, desired_acceptance_rate, max_ar_deviation, iter_limit, mul, DEFAULT_ADJUST_STEP); gsl_vector_scale(stepwidth_factors, pow(get_beta(chains[i]), -0.5)); gsl_vector_mul(stepwidth_factors, get_steps(chains[0])); gsl_vector_div(stepwidth_factors, get_steps(chains[i])); mem_free(chains[i]->additional_data); } printf("stepwidth factors: "); dump_vectorln(stepwidth_factors); if (beta_0 < 0) { beta_0 = calc_beta_0(chains[0], stepwidth_factors); printf("automatic beta_0: %f\n", beta_0); } fflush(stdout); #pragma omp parallel for for (i = 1; i < n_beta; i++) { printf("\tChain %2d - ", i); fflush(stdout); chains[i]->additional_data = mem_malloc(sizeof(parallel_tempering_mcmc)); set_beta(chains[i], get_chain_beta(i, n_beta, beta_0)); gsl_vector_free(get_steps(chains[i])); chains[i]->params_step = dup_vector(get_steps(chains[0])); gsl_vector_scale(get_steps(chains[i]), pow(get_beta(chains[i]), -0.5)); gsl_vector_mul(get_steps(chains[i]), stepwidth_factors); set_params(chains[i], dup_vector(get_params_best(chains[0]))); calc_model(chains[i], NULL); mcmc_check(chains[i]); printf("beta = %f\tsteps: ", get_beta(chains[i])); dump_vectorln(get_steps(chains[i])); fflush(stdout); #ifndef SKIP_CALIBRATE_ALLCHAINS markov_chain_calibrate(chains[i], burn_in_iterations, desired_acceptance_rate, max_ar_deviation, iter_limit, mul, DEFAULT_ADJUST_STEP); #else burn_in(chains[i], burn_in_iterations); #endif } gsl_vector_free(stepwidth_factors); fflush(stdout); printf("all chains calibrated.\n"); for (i = 0; i < n_beta; i++) { printf("\tChain %2d - beta = %f \tsteps: ", i, get_beta(chains[i])); dump_vectorln(get_steps(chains[i])); } write_calibration_summary(chains, n_beta); write_calibrations_file(chains, n_beta); }
/** **************************************************************************************************************/ double g_outer_gaus_single (double x, void *params) { int i,j; double term1=0.0; const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/ gsl_vector *betaincTau = ((struct fnparams *) params)->betaincTau;/** include precision */ int fixed_beta =((struct fnparams *) params)->fixed_index;/** which parameter is to be treated as fixed */ const gsl_vector *priormean = designdata->priormean; const gsl_vector *priorsd = designdata->priorsd; const gsl_vector *priorgamshape = designdata->priorgamshape; const gsl_vector *priorgamscale = designdata->priorgamscale; gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */ gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/ gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/ double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */ int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */ int verbose=((struct fnparams *) params)->verbose;/** */ int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/ int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/ double term2=0.0,term3=0.0,term4=0.0,gval=0.0, term5=0.0; /*Rprintf("%d %d\n",n_betas,betaincTau->size);*/ double tau_rv,tau_resid, copyBeta=0.0; /** need to replace variable fixed_beta with x **/ copyBeta=gsl_vector_get(betaincTau,fixed_beta);/** store value so can reset later */ gsl_vector_set(betaincTau,fixed_beta,x); tau_rv=gsl_vector_get(betaincTau,betaincTau->size-2);/** extract the tau-precision from *beta - last entry */ /*Rprintf("g_outer_rv tau=%f\n",tau_rv);*/ tau_resid=gsl_vector_get(betaincTau,betaincTau->size-1);/** extract the tau-precision from *beta - last entry */ /*Rprintf("g_outer_resid tau=%f\n",tau_resid);*/ if(tau_rv<=0.0){/*Rprintf("tau_rv negative=%e in g_outer_gaus_single!\n",tau_rv);*/ /** aborting so re-copy value of beta changed back to what it was since passed by memory **/ /** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */ gsl_vector_set(betaincTau,fixed_beta,copyBeta); return(GSL_NAN); /*error("");*/} if(tau_resid<=0.0){/*Rprintf("tau_resid negative=%e in g_outer_gaus_single!\n",tau_resid);*/ /** aborting so re-copy value of beta changed back to what it was since passed by memory **/ /** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */ gsl_vector_set(betaincTau,fixed_beta,copyBeta); return(GSL_NAN); /*error("");*/} /** beta are the parameters values at which the function is to be evaluated **/ /** gvalue is the return value - a single double */ /** STOP - NEED TO copy betaincTau into shorter beta since last two entries are group precision then residual precision */ for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/ } /** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */ /** first we want to evaluate each of the integrals for each data group **/ for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/ /*j=0;*/ /*Rprintf("processing group %d\n",j+1);*/ term1+= g_inner_gaus(betaincTau,designdata,j, epsabs_inner,maxiters_inner,verbose); } /*Rprintf("term1 in g_outer=%f\n",term1);*/ /** part 2 the priors for the means **/ term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));} /** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/ gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */ gsl_vector_memcpy(vectmp2,priormean); gsl_vector_scale(vectmp2,-1.0); gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/ gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/ gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */ gsl_vector_memcpy(vectmp1,priorsd); gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */ gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/ gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */ gsl_vector_set_all(vectmp1,1.0); /** ones vector */ gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */ /** part 3 the prior for the group precision tau_rv **/ term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau_rv) -(tau_rv/gsl_vector_get(priorgamscale,0)); /** part 4 the prior for the residual precision tau_resid **/ term5= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau_resid) -(tau_resid/gsl_vector_get(priorgamscale,0)); gval=(-1.0/n)*(term1+term2+term3+term4+term5); /** NO PRIOR */ /* Rprintf("WARNING - NO PRIOR\n");*/ #ifdef NOPRIOR gval=(-1.0/n)*(term1); #endif /** finally re-copy value of beta changed back to what it was since passed by memory **/ gsl_vector_set(betaincTau,fixed_beta,copyBeta); if(gsl_isnan(gval)){error("g_outer_gaus_single\n");} /*Rprintf("g_outer_final=%f term1=%f term2=%f term3=%f term4=%f term5=%f total=%f %d\n",gval,term1,term2,term3,term4,term5,term1+term2+term3+term4,n);*/ return(gval);/** negative since its a minimiser */ }