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 */
}
