void
VR_nnHessian(Sint *ntr, Sdata *train, Sdata *weights,
double *inwts, Sdata *Hess)
{
int i, j;
NTrain = *ntr;
TrainIn = train;
TrainOut = train + Ninputs * NTrain;
Weights = weights;
for (i = 0; i < Nweights; i++)
wts[i] = inwts[i];
H = Lmatrix(Nweights);
h = vect(Nunits);
h1 = vect(Nunits);
w = matrix(Nunits, Nunits);
for (i = 0; i < Nweights; i++)
for (j = 0; j <= i; j++)
H[i][j] = 0.0;
for (j = FirstOutput; j < Nunits; j++)
for (i = FirstHidden; i < FirstOutput; i++)
w[i][j] = 0.0;
for (j = FirstOutput; j < Nunits; j++)
for (i = Nconn[j]; i < Nconn[j + 1]; i++)
w[Conn[i]][j] = wts[i];
for (i = 0; i < NTrain; i++) {
for (j = 0; j < Noutputs; j++)
toutputs[j] = TrainOut[i + NTrain * j];
pHessian(TrainIn + i, toutputs, Weights[i], NTrain);
}
for (i = 0; i < Nweights; i++)
H[i][i] += 2 * Decay[i];
for (i = 0; i < Nweights; i++)
for (j = 0; j < Nweights; j++)
*Hess++ = H[max9(i, j)][min9(i, j)];
free_Lmatrix(H, Nweights);
free_vect(h);
free_vect(h1);
free_matrix(w, Nunits, Nunits);
}
void
vmmin(int n0, double *b, double *Fmin, optimfn fminfn, optimgr fmingr,
int maxit, int trace, int *mask,
double abstol, double reltol, int nREPORT, void *ex,
int *fncount, int *grcount, int *fail)
{
Rboolean accpoint, enough;
double *g, *t, *X, *c, **B;
int count, funcount, gradcount;
double f, gradproj;
int i, j, ilast, iter = 0;
double s, steplength;
double D1, D2;
int n, *l;
if (maxit <= 0) {
*fail = 0;
*Fmin = fminfn(n0, b, ex);
*fncount = *grcount = 0;
return;
}
if (nREPORT <= 0)
error(_("REPORT must be > 0 (method = \"BFGS\")"));
l = (int *) R_alloc(n0, sizeof(int));
n = 0;
for (i = 0; i < n0; i++) if (mask[i]) l[n++] = i;
g = vect(n0);
t = vect(n);
X = vect(n);
c = vect(n);
B = Lmatrix(n);
f = fminfn(n0, b, ex);
if (!R_FINITE(f))
error(_("initial value in 'vmmin' is not finite"));
if (trace) Rprintf("initial value %f \n", f);
*Fmin = f;
funcount = gradcount = 1;
fmingr(n0, b, g, ex);
iter++;
ilast = gradcount;
do {
if (ilast == gradcount) {
for (i = 0; i < n; i++) {
for (j = 0; j < i; j++) B[i][j] = 0.0;
B[i][i] = 1.0;
}
}
for (i = 0; i < n; i++) {
X[i] = b[l[i]];
c[i] = g[l[i]];
}
gradproj = 0.0;
for (i = 0; i < n; i++) {
s = 0.0;
for (j = 0; j <= i; j++) s -= B[i][j] * g[l[j]];
for (j = i + 1; j < n; j++) s -= B[j][i] * g[l[j]];
t[i] = s;
gradproj += s * g[l[i]];
}
if (gradproj < 0.0) { /* search direction is downhill */
steplength = 1.0;
accpoint = FALSE;
do {
count = 0;
for (i = 0; i < n; i++) {
b[l[i]] = X[i] + steplength * t[i];
if (reltest + X[i] == reltest + b[l[i]]) /* no change */
count++;
}
if (count < n) {
f = fminfn(n0, b, ex);
funcount++;
accpoint = R_FINITE(f) &&
(f <= *Fmin + gradproj * steplength * acctol);
if (!accpoint) {
steplength *= stepredn;
}
}
} while (!(count == n || accpoint));
enough = (f > abstol) &&
fabs(f - *Fmin) > reltol * (fabs(*Fmin) + reltol);
/* stop if value if small or if relative change is low */
if (!enough) {
count = n;
*Fmin = f;
}
if (count < n) {/* making progress */
*Fmin = f;
fmingr(n0, b, g, ex);
gradcount++;
iter++;
D1 = 0.0;
for (i = 0; i < n; i++) {
t[i] = steplength * t[i];
c[i] = g[l[i]] - c[i];
D1 += t[i] * c[i];
}
if (D1 > 0) {
D2 = 0.0;
for (i = 0; i < n; i++) {
s = 0.0;
for (j = 0; j <= i; j++)
s += B[i][j] * c[j];
for (j = i + 1; j < n; j++)
s += B[j][i] * c[j];
X[i] = s;
D2 += s * c[i];
}
D2 = 1.0 + D2 / D1;
for (i = 0; i < n; i++) {
for (j = 0; j <= i; j++)
B[i][j] += (D2 * t[i] * t[j]
- X[i] * t[j] - t[i] * X[j]) / D1;
}
} else { /* D1 < 0 */
ilast = gradcount;
}
} else { /* no progress */
if (ilast < gradcount) {
count = 0;
ilast = gradcount;
}
}
} else { /* uphill search */
count = 0;
if (ilast == gradcount) count = n;
else ilast = gradcount;
/* Resets unless has just been reset */
}
if (trace && (iter % nREPORT == 0))
Rprintf("iter%4d value %f\n", iter, f);
if (iter >= maxit) break;
if (gradcount - ilast > 2 * n)
ilast = gradcount; /* periodic restart */
} while (count != n || ilast != gradcount);
if (trace) {
Rprintf("final value %f \n", *Fmin);
if (iter < maxit) Rprintf("converged\n");
else Rprintf("stopped after %i iterations\n", iter);
}
*fail = (iter < maxit) ? 0 : 1;
*fncount = funcount;
*grcount = gradcount;
}
