int gsl_linalg_cholesky_svx2 (const gsl_matrix * LLT, const gsl_vector * S, gsl_vector * x) { if (LLT->size1 != LLT->size2) { GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR); } else if (LLT->size2 != S->size) { GSL_ERROR ("matrix size must match S", GSL_EBADLEN); } else if (LLT->size2 != x->size) { GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); } else { /* b~ = diag(S) b */ gsl_vector_mul(x, S); /* Solve for c using forward-substitution, L c = b~ */ gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasNonUnit, LLT, x); /* Perform back-substitution, L^T x~ = c */ gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LLT, x); /* compute original solution vector x = S x~ */ gsl_vector_mul(x, S); return GSL_SUCCESS; } }
/// Multiply by a vector (per element) GSLVector &GSLVector::operator*=(const GSLVector &v) { if (size() != v.size()) { throw std::runtime_error("GSLVectors have different sizes."); } gsl_vector_mul(gsl(), v.gsl()); return *this; }
static int fdfridge_f(const gsl_vector * x, void * params, gsl_vector * f) { int status; gsl_multifit_fdfridge *w = (gsl_multifit_fdfridge *) params; const size_t n = w->n; const size_t p = w->p; gsl_vector_view f_user = gsl_vector_subvector(f, 0, n); gsl_vector_view f_tik = gsl_vector_subvector(f, n, p); /* call user callback function to get residual vector f */ status = gsl_multifit_eval_wf(w->fdf, x, NULL, &f_user.vector); if (status) return status; if (w->L_diag) { /* store diag(L_diag) x in Tikhonov portion of f~ */ gsl_vector_memcpy(&f_tik.vector, x); gsl_vector_mul(&f_tik.vector, w->L_diag); } else if (w->L) { /* store Lx in Tikhonov portion of f~ */ gsl_blas_dgemv(CblasNoTrans, 1.0, w->L, x, 0.0, &f_tik.vector); } else { /* store \lambda x in Tikhonov portion of f~ */ gsl_vector_memcpy(&f_tik.vector, x); gsl_vector_scale(&f_tik.vector, w->lambda); } return GSL_SUCCESS; } /* fdfridge_f() */
static void moveGN( const gsl_matrix *Vt, const gsl_vector *sig2, const gsl_vector *ufuncsig, double lambda2, gsl_vector * dx, int k, gsl_vector * scaling ) { gsl_vector_set_zero(dx); double threshold = gsl_vector_get(sig2, 0) * Vt->size2 * DBL_EPSILON * 100; size_t i; for (i = 0; (i<sig2->size) &&(gsl_vector_get(sig2, i) >= threshold); i++) { gsl_vector VtRow = gsl_matrix_const_row(Vt, i).vector; gsl_blas_daxpy(gsl_vector_get(ufuncsig, i) / (gsl_vector_get(sig2, i) * gsl_vector_get(sig2, i) + lambda2), &VtRow, dx); } /* if (i >= k) { PRINTF("Pseudoinverse threshold exceeded.\n"); PRINTF("Threshold: %g, i: %d, last: %g, next: %g\n", threshold, i, gsl_vector_get(sig2, i-1), gsl_vector_get(sig2, i)); }*/ if (scaling != NULL) { gsl_vector_mul(dx, scaling); } }
gsl_vector* determineStandardDeviation(int length, gsl_vector* meanOfData, gsl_vector* meanSquOfData, int L, gsl_vector* standardDeviation) { gsl_vector* meanOfDataSqu = gsl_vector_calloc(length); //printf("meanSquOfData ist oben %f\n", gsl_vector_get(meanSquOfData,3)); gsl_vector_memcpy(meanOfDataSqu, meanOfData); //printf("meanOfData ist %f\n", gsl_vector_get(meanOfDataSqu,3)); gsl_vector_mul(meanOfDataSqu, meanOfData); // printf("meanOfDataSqu ist oben %f\n", gsl_vector_get(meanOfDataSqu,3)); // printf("L ist %i\n",L); for(int i = 0 ; i < length; i++) { gsl_vector_set(meanSquOfData,i,gsl_vector_get(meanSquOfData,i)/L); gsl_vector_set(meanOfDataSqu,i,gsl_vector_get(meanOfDataSqu,i)/(L*L)); // if(i==3) // { // printf("meanOfDataSqu ist %f\n", gsl_vector_get(meanOfDataSqu,i)); // printf("meanSquOfData ist %f\n", gsl_vector_get(meanSquOfData,i)); // } gsl_vector_set(standardDeviation, i, sqrt(gsl_vector_get(meanSquOfData,i) - gsl_vector_get(meanOfDataSqu,i))); } gsl_vector_free(meanOfDataSqu); return standardDeviation; }
int gsl_multilarge_nlinear_eval_fvv(const double h, const gsl_vector *x, const gsl_vector *v, const gsl_vector *f, const gsl_vector *swts, gsl_multilarge_nlinear_fdf *fdf, gsl_vector *yvv, gsl_vector *work) { int status; if (fdf->fvv != NULL) { /* call user-supplied function */ status = ((*((fdf)->fvv)) (x, v, fdf->params, yvv)); ++(fdf->nevalfvv); } else { #if 0 /* use finite difference approximation */ /* status = gsl_multilarge_nlinear_fdfvv(h, x, v, f, J, swts, fdf, yvv, work); */ #endif } /* yvv <- sqrt(W) yvv */ if (swts) gsl_vector_mul(yvv, swts); return status; }
double normal_null_maximum(gsl_vector *means,gsl_vector *s) { assert(means->size == s->size); // Baskara coefs. double a,b,c; gsl_vector *s2=gsl_vector_alloc(means->size); gsl_blas_dcopy(s,s2); gsl_vector_mul(s2,s2); gsl_vector *B=gsl_vector_alloc(means->size); gsl_blas_dcopy(means,B); gsl_blas_dscal(-2.0,B); //printf("B=%lg %lg\n",ELTd(B,0),ELTd(B,1)); gsl_vector *C=gsl_vector_alloc(means->size); gsl_blas_dcopy(means,C); gsl_vector_mul(C,C); gsl_vector *prods=gsl_vector_alloc(means->size); mutual_prod(s2,prods); a=gsl_blas_dasum(prods); gsl_blas_ddot(B,prods,&b); gsl_blas_ddot(C,prods,&c); printf("null max: a=%lf b=%lf c=%lf\n",a,b,c); double delta=b*b-4*a*c; double x0=-b/(2.0*a); printf("null max: delta=%lg\n",delta); if (fabs(delta) < 1e-5) { return x0; } else { if (delta > 0) { double x1=(-b-sqrt(delta))/(2.0*a); double x2=(-b-sqrt(delta))/(2.0*a); printf("null max: x1=%lg x2=%lg\n",x1,x2); return x1; } else { printf("WARNING: Null max not found!\n"); return x0; } } }
static double robust_robsigma(const gsl_vector *r, const double s, const double tune, gsl_multifit_robust_workspace *w) { double sigma; size_t i; const size_t n = w->n; const size_t p = w->p; const double st = s * tune; double a, b, lambda; /* compute u = r / sqrt(1 - h) / st */ gsl_vector_memcpy(w->workn, r); gsl_vector_mul(w->workn, w->resfac); gsl_vector_scale(w->workn, 1.0 / st); /* compute w(u) and psi'(u) */ w->type->wfun(w->workn, w->psi); w->type->psi_deriv(w->workn, w->dpsi); /* compute psi(u) = u*w(u) */ gsl_vector_mul(w->psi, w->workn); /* Street et al, Eq (3) */ a = gsl_stats_mean(w->dpsi->data, w->dpsi->stride, n); /* Street et al, Eq (5) */ b = 0.0; for (i = 0; i < n; ++i) { double psi_i = gsl_vector_get(w->psi, i); double resfac = gsl_vector_get(w->resfac, i); double fac = 1.0 / (resfac*resfac); /* 1 - h */ b += fac * psi_i * psi_i; } b /= (double) (n - p); /* Street et al, Eq (5) */ lambda = 1.0 + ((double)p)/((double)n) * (1.0 - a) / a; sigma = lambda * sqrt(b) * st / a; return sigma; } /* robust_robsigma() */
int gsl_linalg_pcholesky_svx2(const gsl_matrix * LDLT, const gsl_permutation * p, const gsl_vector * S, 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->size1 != S->size) { GSL_ERROR ("matrix size must match S", GSL_EBADLEN); } else if (LDLT->size2 != x->size) { GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); } else { int status; /* x := S b */ gsl_vector_mul(x, S); /* solve: A~ x~ = b~, with A~ = S A S, b~ = S b */ status = gsl_linalg_pcholesky_svx(LDLT, p, x); if (status) return status; /* compute: x = S x~ */ gsl_vector_mul(x, S); return GSL_SUCCESS; } }
gsl_vector* determineMeanSqu(gsl_vector* object, int length, gsl_vector* meanSqu) { gsl_vector* meanSqutemp = gsl_vector_calloc(length); gsl_vector_memcpy(meanSqutemp, object); gsl_vector_mul(meanSqutemp, object); gsl_vector_add(meanSqu, meanSqutemp); gsl_vector_free(meanSqutemp); return 0; }
static double dogleg_beta(const double t, const double delta, const gsl_vector * diag, dogleg_state_t * state) { double beta; double a, b, c; /* compute: workp = t*dx_gn - dx_sd */ scaled_addition(t, state->dx_gn, -1.0, state->dx_sd, state->workp); /* a = || D (t*dx_gn - dx_sd) ||^2 */ a = scaled_enorm(diag, state->workp); a *= a; /* workp = D^T D (t*dx_gn - dx_sd) */ gsl_vector_mul(state->workp, diag); gsl_vector_mul(state->workp, diag); /* b = 2 dx_sd^T D^T D (t*dx_gn - dx-sd) */ gsl_blas_ddot(state->dx_sd, state->workp, &b); b *= 2.0; /* c = || D dx_sd ||^2 - delta^2 = (||D dx_sd|| + delta) (||D dx_sd|| - delta) */ c = (state->norm_Dsd + delta) * (state->norm_Dsd - delta); if (b > 0.0) { beta = (-2.0 * c) / (b + sqrt(b*b - 4.0*a*c)); } else { beta = (-b + sqrt(b*b - 4.0*a*c)) / (2.0 * a); } return beta; }
int crearg (gsl_vector* mtiempo, gsl_matrix* answer, int size) { gsl_vector* cte = gsl_vector_calloc( size ); gsl_vector* tt = gsl_vector_calloc( size ); gsl_vector_set_all (cte , 1.0); gsl_vector_add (tt,mtiempo); gsl_vector_mul (tt, mtiempo); gsl_vector_scale (tt, 0.5); gsl_matrix_set_col (answer, 0, cte); gsl_matrix_set_col (answer, 1, mtiempo); gsl_matrix_set_col (answer, 2, tt); return 0; }
int gsl_multilarge_nlinear_eval_f(gsl_multilarge_nlinear_fdf *fdf, const gsl_vector *x, const gsl_vector *swts, gsl_vector *y) { int s = ((*((fdf)->f)) (x, fdf->params, y)); ++(fdf->nevalf); /* y <- sqrt(W) y */ if (swts) gsl_vector_mul(y, swts); return s; }
void update_last_delta(par_c* q, par* p) { int n = p->num_layers; if (p->transformation_type == 1){ // cross entropy loss and softmax transformation p->cost_prime(q->transf_x[n-1],q->y,q->delta[n-2]); } else{ // squared error loss and sigmoid transformation gsl_vector* cp; gsl_vector* sp; cp = gsl_vector_alloc(p->layer_sizes[n-1]); // derivative of squared error loss p->cost_prime(q->transf_x[n-1],q->y, cp); // derivative of sigmoid p->trans_final_prime(q->z[n-1], &sp); // delta gsl_vector_mul(cp,sp); gsl_vector_memcpy(q->delta[n - 2], cp); gsl_vector_free(cp); gsl_vector_free(sp); } }
void backpropagation (par_c* q, par* p) { /* for observation (x,y) updates the cumulative gradient of biases and weights. Calculates deltas along the way. */ // Output layer first update_last_delta(q,p); // For previous layers gsl_vector* sp; for (int l = p->num_layers - 2; l > 0; l--){ p->trans_prime(q->z[l], &sp); // delta(l-1) = (W(l)'.delta(l)) * sigmoid'(z(l)) gsl_blas_dgemv(CblasTrans,1,p->weights[l],q->delta[l],0,q->delta[l-1]); gsl_vector_mul(q->delta[l-1],sp); gsl_vector_free(sp); } update_gradients(q,p); }
int lls_complex_fold(const gsl_matrix_complex *A, const gsl_vector_complex *b, lls_complex_workspace *w) { const size_t n = A->size1; if (A->size2 != w->p) { fprintf(stderr, "lls_complex_fold: A has wrong size2\n"); return GSL_EBADLEN; } else if (n != b->size) { fprintf(stderr, "lls_complex_fold: b has wrong size\n"); return GSL_EBADLEN; } else { int s = 0; double bnorm; #if 0 size_t i; gsl_vector_view wv = gsl_vector_subvector(w->w_robust, 0, n); if (w->niter > 0) { gsl_vector_complex_view rc = gsl_vector_complex_subvector(w->r_complex, 0, n); gsl_vector_view rv = gsl_vector_subvector(w->r, 0, n); /* calculate residuals with previously computed coefficients: r = b - A c */ gsl_vector_complex_memcpy(&rc.vector, b); gsl_blas_zgemv(CblasNoTrans, GSL_COMPLEX_NEGONE, A, w->c, GSL_COMPLEX_ONE, &rc.vector); /* compute Re(r) */ for (i = 0; i < n; ++i) { gsl_complex ri = gsl_vector_complex_get(&rc.vector, i); gsl_vector_set(&rv.vector, i, GSL_REAL(ri)); } /* calculate weights with robust weighting function */ gsl_multifit_robust_weights(&rv.vector, &wv.vector, w->robust_workspace_p); } else gsl_vector_set_all(&wv.vector, 1.0); /* compute final weights as product of input and robust weights */ gsl_vector_mul(wts, &wv.vector); #endif /* AHA += A^H A, using only the upper half of the matrix */ s = gsl_blas_zherk(CblasUpper, CblasConjTrans, 1.0, A, 1.0, w->AHA); if (s) return s; /* AHb += A^H b */ s = gsl_blas_zgemv(CblasConjTrans, GSL_COMPLEX_ONE, A, b, GSL_COMPLEX_ONE, w->AHb); if (s) return s; /* bHb += b^H b */ bnorm = gsl_blas_dznrm2(b); w->bHb += bnorm * bnorm; fprintf(stderr, "norm(AHb) = %.12e, bHb = %.12e\n", gsl_blas_dznrm2(w->AHb), w->bHb); if (!gsl_finite(w->bHb)) { fprintf(stderr, "bHb is NAN\n"); exit(1); } return s; } } /* lls_complex_fold() */
void KFKSDS_deriv_C (int *dim, double *sy, double *sZ, double *sT, double *sH, double *sR, double *sV, double *sQ, double *sa0, double *sP0, double *dvof, double *epshat, double *vareps, double *etahat, double *vareta, double *r, double *N, double *dr, double *dN, double *dahat, double *dvareps) { //int s, p = dim[1], mp1 = m + 1; int i, ip1, j, k, n = dim[0], m = dim[2], ir = dim[3], rp1 = ir + 1, nrp1 = n * rp1, rp1m = rp1 * m, iaux, irp1m, irsod = ir * sizeof(double), msod = m * sizeof(double), nsod = n * sizeof(double), rp1msod = rp1 * msod; //double invf[n], vof[n], msHsq, dfinvfsq[nrp1]; double msHsq; std::vector<double> invf(n); std::vector<double> vof(n); std::vector<double> dfinvfsq(nrp1); gsl_matrix_view Q = gsl_matrix_view_array(sQ, m, m); gsl_vector_view Z = gsl_vector_view_array(sZ, m); gsl_vector * Z_cp = gsl_vector_alloc(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_matrix * a_pred = gsl_matrix_alloc(n, m); std::vector<gsl_matrix*> P_pred(n); gsl_matrix * K = gsl_matrix_alloc(n, m); gsl_vector_view K_irow; std::vector<gsl_matrix*> L(n); 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); std::vector<gsl_matrix*> da_pred(rp1); std::vector< std::vector<gsl_matrix*> > dP_pred(n, std::vector<gsl_matrix*>(rp1)); std::vector<gsl_matrix*> dK(n); // filtering KF_deriv_aux_C(dim, sy, sZ, sT, sH, sR, sV, sQ, sa0, sP0, &invf, &vof, dvof, &dfinvfsq, a_pred, &P_pred, K, &L, &da_pred, &dP_pred, &dK); // state vector smoothing and disturbances smoothing gsl_matrix_view V = gsl_matrix_view_array(sV, ir, ir); gsl_matrix_view R = gsl_matrix_view_array(sR, m, ir); gsl_vector_view vaux; gsl_vector *vaux2 = gsl_vector_alloc(m); gsl_matrix *Mmm = gsl_matrix_alloc(m, m); gsl_matrix *Mmm2 = gsl_matrix_alloc(m, m); gsl_matrix *Mrm = gsl_matrix_alloc(ir, m); gsl_vector_memcpy(Z_cp, &Z.vector); gsl_matrix *r0 = gsl_matrix_alloc(n + 1, m); gsl_vector_view r_row_t; gsl_vector_view r_row_tp1 = gsl_matrix_row(r0, n); gsl_vector_set_zero(&r_row_tp1.vector); std::vector<gsl_matrix*> N0(n + 1); N0.at(n) = gsl_matrix_calloc(m, m); gsl_vector_view Ndiag; gsl_vector *var_eps = gsl_vector_alloc(n); msHsq = -1.0 * pow(*sH, 2); //vaux = gsl_vector_view_array(invf, n); vaux = gsl_vector_view_array(&invf[0], n); gsl_vector_set_all(var_eps, msHsq); gsl_vector_mul(var_eps, &vaux.vector); gsl_vector_add_constant(var_eps, *sH); gsl_vector *vr = gsl_vector_alloc(ir); gsl_matrix *dL = gsl_matrix_alloc(m, m); std::vector<gsl_matrix*> dr0(n + 1); dr0.at(n) = gsl_matrix_calloc(rp1, m); gsl_vector_view dr_row_t, dr_row_tp1; std::vector< std::vector<gsl_matrix*> > dN0(n + 1, std::vector<gsl_matrix*>(rp1)); for (j = 0; j < rp1; j++) { (dN0.at(n)).at(j) = gsl_matrix_calloc(m, m); } for (i = n-1; i > -1; i--) { ip1 = i + 1; iaux = (i-1) * rp1m; irp1m = i * rp1m; if (i != n-1) //the case i=n-1 was initialized above r_row_tp1 = gsl_matrix_row(r0, ip1); r_row_t = gsl_matrix_row(r0, 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.at(i)); gsl_vector_add(&r_row_t.vector, Z_cp); gsl_vector_memcpy(vaux2, &r_row_tp1.vector); memcpy(&r[i * m], vaux2->data, msod); N0.at(i) = gsl_matrix_alloc(m, m); gsl_matrix_memcpy(N0.at(i), ZtZ); gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N0.at(ip1), 0.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), invf.at(i), N0.at(i)); vaux = gsl_matrix_diagonal(N0.at(ip1)); gsl_vector_memcpy(vaux2, &vaux.vector); memcpy(&N[i * m], vaux2->data, msod); K_irow = gsl_matrix_row(K, i); gsl_blas_ddot(&K_irow.vector, &r_row_tp1.vector, &epshat[i]); epshat[i] -= vof.at(i); epshat[i] *= -*sH; 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, N0.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); gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, &V.matrix, &R.matrix, 0.0, Mrm); gsl_blas_dgemv(CblasNoTrans, 1.0, Mrm, &r_row_tp1.vector, 0.0, vr); memcpy(&etahat[i*ir], vr->data, irsod); Ndiag = gsl_matrix_diagonal(N0.at(ip1)); gsl_vector_memcpy(Z_cp, &Ndiag.vector); gsl_vector_mul(Z_cp, Qdiag_msq); gsl_vector_add(Z_cp, &Qdiag.vector); gsl_blas_dgemv(CblasTrans, 1.0, &R.matrix, Z_cp, 0.0, vr); memcpy(&vareta[i*ir], vr->data, irsod); // derivatives dr0.at(i) = gsl_matrix_alloc(rp1, m); for (j = 0; j < rp1; j++) { k = i + j * n; gsl_vector_memcpy(Z_cp, &Z.vector); gsl_vector_scale(Z_cp, dvof[k]); vaux = gsl_matrix_row(dK.at(i), j); maux1 = gsl_matrix_view_array(gsl_vector_ptr(&vaux.vector, 0), m, 1); maux2 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), 1, m); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, &maux1.matrix, &maux2.matrix, 0.0, dL); dr_row_t = gsl_matrix_row(dr0.at(i), j); dr_row_tp1 = gsl_matrix_row(dr0.at(ip1), j); gsl_blas_dgemv(CblasTrans, 1.0, dL, &r_row_tp1.vector, 0.0, &dr_row_t.vector); gsl_vector_add(&dr_row_t.vector, Z_cp); gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &dr_row_tp1.vector, 1.0, &dr_row_t.vector); (dN0.at(i)).at(j) = gsl_matrix_alloc(m, m); gsl_matrix_memcpy((dN0.at(i)).at(j), ZtZ); gsl_matrix_scale((dN0.at(i)).at(j), -1.0 * dfinvfsq.at(k)); gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, dL, N0.at(ip1), 0.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), 1.0, (dN0.at(i)).at(j)); gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), (dN0.at(ip1)).at(j), 0.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), 1.0, (dN0.at(i)).at(j)); gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N0.at(ip1), 0.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, dL, 1.0, (dN0.at(i)).at(j)); if (i != 0) { vaux = gsl_matrix_diagonal((dN0.at(i)).at(j)); gsl_vector_memcpy(vaux2, &vaux.vector); memcpy(&dN[iaux + j * m], vaux2->data, msod); } vaux = gsl_matrix_row(da_pred.at(j), i); gsl_blas_dgemv(CblasNoTrans, 1.0, (dP_pred.at(i)).at(j) , &r_row_t.vector, 1.0, &vaux.vector); gsl_blas_dgemv(CblasNoTrans, 1.0, P_pred.at(i), &dr_row_t.vector, 1.0, &vaux.vector); gsl_vector_memcpy(vaux2, &vaux.vector); memcpy(&dahat[irp1m + j * m], vaux2->data, msod); gsl_matrix_memcpy(Mmm, (dP_pred.at(i)).at(j)); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, (dP_pred.at(i)).at(j), N0.at(i), 0.0, Mmm2); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2, P_pred.at(i), 1.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, P_pred.at(i), (dN0.at(i)).at(j), 0.0, Mmm2); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2, P_pred.at(i), 1.0, Mmm); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, P_pred.at(i), N0.at(i), 0.0, Mmm2); gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2, (dP_pred.at(i)).at(j), 1.0, Mmm); gsl_matrix_mul_elements(Mmm, ZtZ); std::vector<double> vmm(Mmm->data, Mmm->data + m*m); dvareps[i*rp1 + j] = std::accumulate(vmm.begin(), vmm.end(), 0.0); gsl_matrix_free((dN0.at(ip1)).at(j)); gsl_matrix_free((dP_pred.at(i)).at(j)); } if (i != 0) { memcpy(&dr[iaux], (dr0.at(i))->data, rp1msod); } gsl_matrix_free(dr0.at(ip1)); gsl_matrix_free(dK.at(i)); gsl_matrix_free(P_pred.at(i)); gsl_matrix_free(L.at(i)); gsl_matrix_free(N0.at(ip1)); } gsl_matrix_free(N0.at(0)); gsl_matrix_free(dr0.at(0)); for (j = 0; j < rp1; j++) { gsl_matrix_free((dN0.at(0)).at(j)); gsl_matrix_free(da_pred.at(j)); } memcpy(&vareps[0], var_eps->data, nsod); gsl_matrix_free(Mmm); gsl_matrix_free(Mmm2); gsl_matrix_free(Mrm); gsl_matrix_free(r0); gsl_matrix_free(K); gsl_matrix_free(dL); gsl_matrix_free(a_pred); gsl_vector_free(Z_cp); gsl_matrix_free(ZtZ); gsl_vector_free(var_eps); gsl_vector_free(vr); gsl_vector_free(Qdiag_msq); gsl_vector_free(vaux2); }}
int OptimizationOptions::lmpinvOptimize( NLSFunction *F, gsl_vector* x_vec, IterationLogger *itLog ) { int status, status_dx, status_grad, k; double g_norm, x_norm; if (this->maxiter < 0 || this->maxiter > 5000) { throw new Exception("opt.maxiter should be in [0;5000].\n"); } int scaled = 1; //this->submethod; /* LM */ gsl_matrix *jac = gsl_matrix_alloc(F->getNsq(), F->getNvar()); gsl_vector *func = gsl_vector_alloc(F->getNsq()); gsl_vector *g = gsl_vector_alloc(F->getNvar()); gsl_vector *x_cur = gsl_vector_alloc(F->getNvar()); gsl_vector *x_new = gsl_vector_alloc(F->getNvar()); gsl_vector *dx = gsl_vector_alloc(F->getNvar()); gsl_vector *scaling = scaled ? gsl_vector_alloc(F->getNvar()) : NULL; gsl_matrix *tempv = gsl_matrix_alloc(jac->size2, jac->size2); gsl_vector *tempufuncsig = gsl_vector_alloc(jac->size2); gsl_vector *templm = gsl_vector_alloc(jac->size2); gsl_vector *sig = gsl_vector_alloc(mymin(jac->size1, jac->size2)); double lambda2 = 0, f_new; int start_lm = 1; /* Determine optimal work */ size_t status_svd = 0, minus1 = -1; double tmp; dgesvd_("A", "O", &jac->size2, &jac->size1, jac->data, &jac->tda, sig->data, tempv->data, &tempv->size2, NULL, &jac->size1, &tmp, &minus1, &status_svd); gsl_vector *work_vec = gsl_vector_alloc(tmp); /* optimization loop */ Log::lprintf(Log::LOG_LEVEL_FINAL, "SLRA optimization:\n"); status = GSL_SUCCESS; status_dx = GSL_CONTINUE; status_grad = GSL_CONTINUE; this->iter = 0; gsl_vector_memcpy(x_cur, x_vec); F->computeFuncAndJac(x_cur, func, jac); gsl_multifit_gradient(jac, func, g); gsl_vector_scale(g, 2); gsl_blas_ddot(func, func, &this->fmin); if (itLog != NULL) { itLog->reportIteration(0, x_cur, this->fmin, g); } { gsl_vector *g2 = gsl_vector_alloc(g->size); F->computeFuncAndGrad(x_vec, NULL, g2); gsl_vector_sub(g2, g); if (gsl_vector_max(g2) > 1e-10 || gsl_vector_min(g2) < -1e-10) { Log::lprintf(Log::LOG_LEVEL_NOTIFY, "Gradient error, max = %14.10f, min = %14.10f ...", gsl_vector_max(g2), gsl_vector_min(g2)); print_vec(g2); } gsl_vector_free(g2); } while (status_dx == GSL_CONTINUE && status_grad == GSL_CONTINUE && status == GSL_SUCCESS && this->iter < this->maxiter) { /* Check convergence criteria (except dx) */ if (this->maxx > 0) { if (gsl_vector_max(x_cur) > this->maxx || gsl_vector_min(x_cur) < -this->maxx ){ break; } } this->iter++; if (scaling != NULL) { normalizeJacobian(jac, scaling); } /* Compute the SVD */ dgesvd_("A", "O", &jac->size2, &jac->size1, jac->data, &jac->tda, sig->data, tempv->data, &tempv->size2, NULL, &jac->size1, work_vec->data, &work_vec->size, &status_svd); gsl_blas_dgemv(CblasTrans, -1.0, jac, func, 0.0, tempufuncsig); gsl_vector_mul(tempufuncsig, sig); while (1) { moveGN(tempv, sig, tempufuncsig, lambda2, dx, F->getNEssVar(), scaling); gsl_vector_memcpy(x_new, x_cur); gsl_vector_add(x_new, dx); F->computeFuncAndGrad(x_new, &f_new, NULL); if (f_new <= this->fmin + 1e-16) { lambda2 = 0.4 * lambda2; break; } if (lambda2 > 1e100) { status = GSL_ENOPROG; break; } /* Else: update lambda */ if (start_lm) { lambda2 = gsl_vector_get(sig, 0) * gsl_vector_get(sig, 0); start_lm = 0; } else { lambda2 = 10 * lambda2; Log::lprintf(Log::LOG_LEVEL_ITER, "lambda: %f\n", lambda2); } } /* check the dx convergence criteria */ if (this->epsabs != 0 || this->epsrel != 0) { status_dx = gsl_multifit_test_delta(dx, x_cur, this->epsabs, this->epsrel); } gsl_vector_memcpy(x_cur, x_new); F->computeFuncAndJac(x_cur, func, jac); gsl_multifit_gradient(jac, func, g); gsl_vector_scale(g, 2); gsl_blas_ddot(func, func, &this->fmin); if (itLog != NULL) { itLog->reportIteration(this->iter, x_cur, this->fmin, g); } status_grad = gsl_multifit_test_gradient(g, this->epsgrad); } if (this->iter >= this->maxiter) { status = EITER; } gsl_blas_ddot(func, func, &this->fmin); /* print exit information */ if (Log::getMaxLevel() >= Log::LOG_LEVEL_FINAL) { /* unless "off" */ switch (status) { case EITER: Log::lprintf("SLRA optimization terminated by reaching " "the maximum number of iterations.\n" "The result could be far from optimal.\n"); break; case GSL_ETOLF: Log::lprintf("Lack of convergence: " "progress in function value < machine EPS.\n"); break; case GSL_ETOLX: Log::lprintf("Lack of convergence: " "change in parameters < machine EPS.\n"); break; case GSL_ETOLG: Log::lprintf("Lack of convergence: " "change in gradient < machine EPS.\n"); break; case GSL_ENOPROG: Log::lprintf("Possible lack of convergence: no progress.\n"); break; } if (status_grad != GSL_CONTINUE && status_dx != GSL_CONTINUE) { Log::lprintf("Optimization terminated by reaching the convergence " "tolerance for both X and the gradient.\n"); } else { if (status_grad != GSL_CONTINUE) { Log::lprintf("Optimization terminated by reaching the convergence " "tolerance for the gradient.\n"); } else { Log::lprintf("Optimization terminated by reaching the convergence " "tolerance for X.\n"); } } } gsl_vector_memcpy(x_vec, x_cur); gsl_vector_free(work_vec); gsl_matrix_free(jac); gsl_vector_free(func); gsl_vector_free(g); gsl_vector_free(x_cur); gsl_vector_free(x_new); if (scaling != NULL) { gsl_vector_free(scaling); } gsl_vector_free(dx); gsl_matrix_free(tempv); gsl_vector_free(tempufuncsig); gsl_vector_free(templm); gsl_vector_free(sig); return GSL_SUCCESS; /* <- correct with status */ }
int gsl_multifit_robust(const gsl_matrix * X, const gsl_vector * y, gsl_vector * c, gsl_matrix * cov, gsl_multifit_robust_workspace *w) { /* check matrix and vector sizes */ 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 != w->n || X->size2 != w->p) { GSL_ERROR ("size of workspace does not match size of observation matrix", GSL_EBADLEN); } else { int s; double chisq; const double tol = GSL_SQRT_DBL_EPSILON; int converged = 0; size_t numit = 0; const size_t n = y->size; double sigy = gsl_stats_sd(y->data, y->stride, n); double sig_lower; size_t i; /* * if the initial fit is very good, then finding outliers by comparing * them to the residual standard deviation is difficult. Therefore we * set a lower bound on the standard deviation estimate that is a small * fraction of the standard deviation of the data values */ sig_lower = 1.0e-6 * sigy; if (sig_lower == 0.0) sig_lower = 1.0; /* compute initial estimates using ordinary least squares */ s = gsl_multifit_linear(X, y, c, cov, &chisq, w->multifit_p); if (s) return s; /* save Q S^{-1} of original matrix */ gsl_matrix_memcpy(w->QSI, w->multifit_p->QSI); gsl_vector_memcpy(w->D, w->multifit_p->D); /* compute statistical leverage of each data point */ s = gsl_linalg_SV_leverage(w->multifit_p->A, w->resfac); if (s) return s; /* correct residuals with factor 1 / sqrt(1 - h) */ for (i = 0; i < n; ++i) { double h = gsl_vector_get(w->resfac, i); if (h > 0.9999) h = 0.9999; gsl_vector_set(w->resfac, i, 1.0 / sqrt(1.0 - h)); } /* compute residuals from OLS fit r = y - X c */ s = gsl_multifit_linear_residuals(X, y, c, w->r); if (s) return s; /* compute estimate of sigma from ordinary least squares */ w->stats.sigma_ols = gsl_blas_dnrm2(w->r) / sqrt((double) w->stats.dof); while (!converged && ++numit <= w->maxiter) { double sig; /* adjust residuals by statistical leverage (see DuMouchel and O'Brien) */ s = gsl_vector_mul(w->r, w->resfac); if (s) return s; /* compute estimate of standard deviation using MAD */ sig = robust_madsigma(w->r, w); /* scale residuals by standard deviation and tuning parameter */ gsl_vector_scale(w->r, 1.0 / (GSL_MAX(sig, sig_lower) * w->tune)); /* compute weights using these residuals */ s = w->type->wfun(w->r, w->weights); if (s) return s; gsl_vector_memcpy(w->c_prev, c); /* solve weighted least squares with new weights */ s = gsl_multifit_wlinear(X, w->weights, y, c, cov, &chisq, w->multifit_p); if (s) return s; /* compute new residuals r = y - X c */ s = gsl_multifit_linear_residuals(X, y, c, w->r); if (s) return s; converged = robust_test_convergence(w->c_prev, c, tol); } /* compute final MAD sigma */ w->stats.sigma_mad = robust_madsigma(w->r, w); /* compute robust estimate of sigma */ w->stats.sigma_rob = robust_robsigma(w->r, w->stats.sigma_mad, w->tune, w); /* compute final estimate of sigma */ w->stats.sigma = robust_sigma(w->stats.sigma_ols, w->stats.sigma_rob, w); /* store number of iterations */ w->stats.numit = numit; { double dof = (double) w->stats.dof; double rnorm = w->stats.sigma * sqrt(dof); /* see DuMouchel, sec 4.2 */ double ss_err = rnorm * rnorm; double ss_tot = gsl_stats_tss(y->data, y->stride, n); /* compute R^2 */ w->stats.Rsq = 1.0 - ss_err / ss_tot; /* compute adjusted R^2 */ w->stats.adj_Rsq = 1.0 - (1.0 - w->stats.Rsq) * (n - 1.0) / dof; /* compute rmse */ w->stats.rmse = sqrt(ss_err / dof); /* store SSE */ w->stats.sse = ss_err; } /* calculate covariance matrix = sigma^2 (X^T X)^{-1} */ s = robust_covariance(w->stats.sigma, cov, w); if (s) return s; /* raise an error if not converged */ if (numit > w->maxiter) { GSL_ERROR("maximum iterations exceeded", GSL_EMAXITER); } return s; } } /* gsl_multifit_robust() */
double* metabolicLoss(struct foodweb nicheweb, const double y[], double* metLoss) { int S = nicheweb.S; int Y = nicheweb.Y; int Rnum = nicheweb.Rnum; double alpha = nicheweb.alpha; gsl_vector *network = nicheweb.network; // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S int i,l; /* Massen rausholen */ 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; 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_vector *svec=gsl_vector_calloc(Rnum+S); for(l=0;l<Y;l++) // start of patch solving { /* Initialisierungen */ gsl_vector_set_zero(svec); /* yfdvec enthält die Population */ gsl_vector_view y_vec=gsl_vector_subvector(yfdvec,(Rnum+S)*l,(Rnum+S)); gsl_vector *yvecmet=&y_vec.vector; gsl_vector_memcpy(svec,Mvec); //printf("svec vorher: %f\n",gsl_vector_get(svec,3)); gsl_vector_scale(svec,alpha); // s(i)=alpha*masse^(-0.25) [svec=Respiration bzw. Mortalitaet] //printf("svec nachher: %f\n",gsl_vector_get(svec,3)); gsl_vector_set(yvecmet,0,0); // es wird nur der Fluss zur Ressource benötigt gsl_vector_mul(svec,yvecmet); // s(i) = alpha*masse^(-0.25)*y(i) metLoss[l] = gsl_blas_dasum(svec); //printf("metloss %f\n",metLoss[0]); } /* Speicher befreien */ gsl_vector_free(svec); return 0; }
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; }
/** **************************************************************************************************************/ 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); }
/* solve system with given lambda and L = diag(L) and test against * normal equations solution */ static void test_reg3(const double lambda, const gsl_vector * L, const gsl_matrix * X, const gsl_vector * y, const gsl_vector * wts, const double tol, gsl_multifit_linear_workspace * w, const char * desc) { const size_t n = X->size1; const size_t p = X->size2; double rnorm0, snorm0; double rnorm1, snorm1; gsl_vector *c0 = gsl_vector_alloc(p); gsl_vector *c1 = gsl_vector_alloc(p); gsl_matrix *XTX = gsl_matrix_alloc(p, p); /* X^T W X + lambda^2 L^T L */ gsl_vector *XTy = gsl_vector_alloc(p); /* X^T W y */ gsl_matrix *Xs = gsl_matrix_alloc(n, p); /* standard form X~ */ gsl_vector *ys = gsl_vector_alloc(n); /* standard form y~ */ gsl_vector *Lc = gsl_vector_alloc(p); gsl_vector *r = gsl_vector_alloc(n); gsl_permutation *perm = gsl_permutation_alloc(p); int signum; size_t j; /* compute Xs = sqrt(W) X, ys = sqrt(W) y */ gsl_multifit_linear_wstdform1(NULL, X, wts, y, Xs, ys, w); /* construct XTy = X^T W y */ gsl_blas_dgemv(CblasTrans, 1.0, Xs, ys, 0.0, XTy); /* construct XTX = X^T W X + lambda^2 L^T L */ gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, Xs, Xs, 0.0, XTX); for (j = 0; j < p; ++j) { double lj = gsl_vector_get(L, j); *gsl_matrix_ptr(XTX, j, j) += pow(lambda * lj, 2.0); } /* solve XTX c = XTy with LU decomp */ gsl_linalg_LU_decomp(XTX, perm, &signum); gsl_linalg_LU_solve(XTX, perm, XTy, c0); /* solve with reg routine */ gsl_multifit_linear_wstdform1(L, X, wts, y, Xs, ys, w); gsl_multifit_linear_svd(Xs, w); gsl_multifit_linear_solve(lambda, Xs, ys, c1, &rnorm0, &snorm0, w); gsl_multifit_linear_genform1(L, c1, c1, w); /* test snorm = ||L c1|| */ gsl_vector_memcpy(Lc, c1); gsl_vector_mul(Lc, L); snorm1 = gsl_blas_dnrm2(Lc); gsl_test_rel(snorm0, snorm1, tol, "test_reg3: %s, snorm lambda=%g n=%zu p=%zu", desc, lambda, n, p); /* test rnorm = ||y - X c1||, compute again Xs = sqrt(W) X and ys = sqrt(W) y */ gsl_multifit_linear_wstdform1(NULL, X, wts, y, Xs, ys, w); gsl_vector_memcpy(r, ys); gsl_blas_dgemv(CblasNoTrans, -1.0, Xs, c1, 1.0, r); rnorm1 = gsl_blas_dnrm2(r); gsl_test_rel(rnorm0, rnorm1, tol, "test_reg3: %s, rnorm lambda=%g n=%zu p=%zu", desc, lambda, n, p); /* test c0 = c1 */ for (j = 0; j < p; ++j) { double c0j = gsl_vector_get(c0, j); double c1j = gsl_vector_get(c1, j); gsl_test_rel(c1j, c0j, tol, "test_reg3: %s, c0/c1 j=%zu lambda=%g n=%zu p=%zu", desc, j, lambda, n, p); } gsl_matrix_free(Xs); gsl_matrix_free(XTX); gsl_vector_free(XTy); gsl_vector_free(c0); gsl_vector_free(c1); gsl_vector_free(Lc); gsl_vector_free(ys); gsl_vector_free(r); gsl_permutation_free(perm); }
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; }
/** * 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_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 */ }
void kjg_fpca ( size_t K, size_t L, size_t I, double* eval, double* evec) { struct timespec x, y, d; clock_gettime(CLOCK_REALTIME, &x); fprintf(stderr, "Started fastPCA: "); print_time(&x); fprintf(stderr, "\n"); if (K >= L) exit(1); if (I == 0) exit(1); size_t m = get_ncols(); size_t n = get_nrows(); // PART A - compute Q such that X ~ Q * (Q^T) * X gsl_matrix* G1 = gsl_matrix_alloc(n, L); gsl_matrix* G2 = gsl_matrix_alloc(n, L); gsl_matrix* Q = gsl_matrix_alloc(m, (I + 1) * L); gsl_matrix* Gswap; gsl_rng *r = kjg_gsl_rng_init(); kjg_gsl_ran_ugaussian_matrix(r, G1); gsl_rng_free(r); size_t i; for (i = 0; i < I; i++) { gsl_matrix_view Qi = gsl_matrix_submatrix(Q, 0, i * L, m, L); // do the multiplication kjg_fpca_XTXA(G1, &Qi.matrix, G2); // orthonormalize (Gram-Schmidt equivalent) kjg_gsl_matrix_QR(G2); Gswap = G2; G2 = G1; G1 = Gswap; } gsl_matrix_view Qi = gsl_matrix_submatrix(Q, 0, I * L, m, L); kjg_fpca_XA(G1, &Qi.matrix); { gsl_matrix* V = gsl_matrix_alloc(Q->size2, Q->size2); gsl_vector* S = gsl_vector_alloc(Q->size2); kjg_gsl_SVD(Q, V, S); gsl_matrix_free(V); gsl_vector_free(S); } // kjg_gsl_matrix_QR(Q); // QR decomposition is less accurate than SVD gsl_matrix_free(G1); gsl_matrix_free(G2); // PART B - compute B matrix, take SVD and return gsl_matrix* B = gsl_matrix_alloc(n, (I + 1) * L); kjg_fpca_XTB(Q, B); gsl_matrix* Utilda = gsl_matrix_alloc((I + 1) * L, (I + 1) * L); gsl_vector* Stilda = gsl_vector_alloc((I + 1) * L); kjg_gsl_SVD(B, Utilda, Stilda); gsl_matrix_view Vk = gsl_matrix_submatrix(B, 0, 0, n, K); gsl_matrix_view evec_view = gsl_matrix_view_array(evec, n, K); gsl_matrix_memcpy(&evec_view.matrix, &Vk.matrix); gsl_vector_view Sk = gsl_vector_subvector(Stilda, 0, K); gsl_vector_view eval_view = gsl_vector_view_array(eval, K); gsl_vector_mul(&Sk.vector, &Sk.vector); gsl_vector_scale(&Sk.vector, 1.0 / m); gsl_vector_memcpy(&eval_view.vector, &Sk.vector); gsl_matrix_free(Q); gsl_matrix_free(B); gsl_matrix_free(Utilda); gsl_vector_free(Stilda); clock_gettime(CLOCK_REALTIME, &y); fprintf(stderr, "Finished fastPCA: "); print_time(&y); fprintf(stderr, "\n"); diff_time(&y, &x, &d); fprintf(stderr, "Elapsed fastPCA: "); print_time(&d); fprintf(stderr, "\n"); }
int main(int argc, char **argv){ int row = atoi(argv[2]); int col = atoi(argv[3]); printf("%d %d\n", row, col); gsl_matrix* data = gsl_matrix_alloc(row, col); //gsl_matrix* data = gsl_matrix_alloc(col, row); FILE* f = fopen(argv[1], "r"); gsl_matrix_fscanf(f, data); //gsl_matrix_fread(f, data); //gsl_matrix_transpose_memcpy(data, data_raw); fclose(f); //printf("%f %f", gsl_matrix_get(data,0,0), gsl_matrix_get(data,0,1)); //f = fopen("test.dat", "w"); //gsl_matrix_fprintf(f, data, "%f"); //fclose(f); // data centering, subtract the mean in each dimension (col.-wise) int i, j; double mean, sum, std; gsl_vector_view col_vector; for (i = 0; i < col; ++i){ col_vector = gsl_matrix_column(data, i); mean = gsl_stats_mean((&col_vector.vector)->data, 1, (&col_vector.vector)->size); gsl_vector_add_constant(&col_vector.vector, -mean); gsl_matrix_set_col(data, i, &col_vector.vector); } char filename[50]; //sprintf(filename, "%s.zscore", argv[1]); //print2file(filename, data); gsl_matrix* u; if (col > row) { u = gsl_matrix_alloc(data->size2, data->size1); gsl_matrix_transpose_memcpy(u, data); } else { u = gsl_matrix_alloc(data->size1, data->size2); gsl_matrix_memcpy(u, data); } // svd gsl_matrix* X = gsl_matrix_alloc(col, col); gsl_matrix* V = gsl_matrix_alloc(u->size2, u->size2); gsl_vector* S = gsl_vector_alloc(u->size2); gsl_vector* work = gsl_vector_alloc(u->size2); gsl_linalg_SV_decomp(u, V, S, work); //gsl_linalg_SV_decomp_jacobi(u, V, S); // mode coefficient //print2file("u.dat", u); /* // characteristic mode gsl_matrix* diag = diag_alloc(S); gsl_matrix* mode = gsl_matrix_alloc(diag->size1, V->size1); gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, diag, V, 0.0, mode); gsl_matrix_transpose(mode); print2file("mode.dat", mode); gsl_matrix_transpose(mode); */ // reconstruction gsl_matrix *recons = gsl_matrix_alloc(u->size2, data->size1); if (col > row) { gsl_matrix_view data_sub = gsl_matrix_submatrix(data, 0, 0, u->size2, u->size2); gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, V, &data_sub.matrix, 0.0, recons); } else gsl_blas_dgemm(CblasTrans, CblasTrans, 1.0, V, data, 0.0, recons); //gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, u, mode, 0.0, // recons); gsl_matrix *recons_trans = gsl_matrix_alloc(recons->size2, recons->size1); gsl_matrix_transpose_memcpy(recons_trans, recons); // take the first two eigenvectors gsl_matrix_view final = gsl_matrix_submatrix(recons_trans, 0, 0, recons_trans->size1, 2); print2file(argv[4], &final.matrix); // eigenvalue gsl_vector_mul(S, S); f = fopen("eigenvalue.dat", "w"); //gsl_vector_fprintf(f, S, "%f"); fclose(f); gsl_matrix_free(data); gsl_matrix_free(X); gsl_matrix_free(V); //gsl_matrix_free(diag); //gsl_matrix_free(mode); gsl_matrix_free(recons); gsl_matrix_free(recons_trans); gsl_matrix_free(u); gsl_vector_free(S); gsl_vector_free(work); //gsl_vector_free(zero); //gsl_vector_free(corrcoef); //gsl_vector_free(corrcoef_mean); return 0; }
/** **************************************************************************************************************/ 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 */ }