The R Project SVN – R – Diff – /trunk/src/appl/optim.c



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1999-2025  The R Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.

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)
{
    bool accpoint, enough;
    double *g, *t, *X, *c, **B;
    int   count, funcount, gradcount;
    double f, gradproj;
    int   i, j, ilast, iter = 0;
    double s, steplength;

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

	   double alpha, double bet, double gamm, int trace,
	   int *fncount, int maxit)
{
    char action[50];
    int C;
    bool calcvert;
    double convtol, f;
    int funcount=0, H, i, j, L=0;
    int n1=0;
    double oldsize;
    double **P;

	return;
    }
    if (trace)
	Rprintf("  Nelder-Mead direct search function minimizer\n");
    P = matrix(n, n+1);
    *fail = false;
    f = fminfn(n, Bvec, ex);
    if (!R_FINITE(f)) {
	error(_("function cannot be evaluated at initial parameters"));
	*fail = true;
    } else {
	if (trace) Rprintf("function value for initial parameters = %f\n", f);
	funcount = 1;
	convtol = intol * (fabs(f) + intol);
	if (trace) Rprintf("  Scaled convergence tolerance is %g\n", convtol);

		trystep *= 10;
	    }
	    size += trystep;
	}
	oldsize = size;
	calcvert = true;
	do {
	    if (calcvert) {
		for (j = 0; j < n1; j++) {
		    if (j + 1 != L) {
			for (i = 0; i < n; i++)

			if (!R_FINITE(f)) f = big;
			funcount++;
			P[n1 - 1][j] = f;
		    }
		}
		calcvert = false;
	    }
 
	    VL = P[n1 - 1][L - 1];
	    VH = VL;
	    H = L;

			P[i][H - 1] = Bvec[i];
		    P[n1 - 1][H - 1] = f;
		} else {
		    if (VR >= VH) {
			strcpy(action, "SHRINK         ");
			calcvert = true;
			size = 0.0;
			for (j = 0; j < n1; j++) {
			    if (j + 1 != L) {
				for (i = 0; i < n; i++) {
				    P[i][j] = bet * (P[i][j] - P[i][L - 1])

void cgmin(int n, double *Bvec, double *X, double *Fmin,
	   optimfn fminfn, optimgr fmingr, int *fail,
	   double abstol, double intol, void *ex, int type, int trace,
	   int *fncount, int *grcount, int maxit)
{
    bool accpoint;
    double *c, *g, *t;
    int count, cycle, cyclimit;
    double f;
    double G1, G2, G3, gradproj;
    int funcount=0, gradcount=0, i;

    double tol;
 
    if (maxit <= 0) {
	*Fmin = fminfn(n, Bvec, ex);
	*fncount = *grcount = 0;
	*fail = false;
	return;
    }
    if (trace) {
	Rprintf("  Conjugate gradients function minimizer\n");
	switch (type) {

			t[i] = t[i] * G3 - g[i];
			gradproj += t[i] * g[i];
		    }
		    steplength = oldstep;
 
		    accpoint = false;
		    do {
			count = 0;
			for (i = 0; i < n; i++) {
			    Bvec[i] = X[i] + steplength * t[i];
			    if (reltest + X[i] == reltest + Bvec[i])

Rev 87292	Rev 87925
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1999-2014 The R Core Team`	3	`* Copyright (C) 1999-2025 The R Core Team`
4	`*`	4	`*`
5	`* This program is free software; you can redistribute it and/or modify`	5	`* This program is free software; you can redistribute it and/or modify`
6	`* it under the terms of the GNU General Public License as published by`	6	`* it under the terms of the GNU General Public License as published by`
7	`* the Free Software Foundation; either version 2 of the License, or`	7	`* the Free Software Foundation; either version 2 of the License, or`
8	`* (at your option) any later version.`	8	`* (at your option) any later version.`
Line 114...	Line 114...
114	`vmmin(int n0, double b, double Fmin, optimfn fminfn, optimgr fmingr,`	114	`vmmin(int n0, double b, double Fmin, optimfn fminfn, optimgr fmingr,`
115	`int maxit, int trace, int *mask,`	115	`int maxit, int trace, int *mask,`
116	`double abstol, double reltol, int nREPORT, void *ex,`	116	`double abstol, double reltol, int nREPORT, void *ex,`
117	`int fncount, int grcount, int *fail)`	117	`int fncount, int grcount, int *fail)`
118	`{`	118	`{`
119	`Rboolean accpoint, enough;`	119	`bool accpoint, enough;`
120	`double g, t, X, c, **B;`	120	`double g, t, X, c, **B;`
121	`int count, funcount, gradcount;`	121	`int count, funcount, gradcount;`
122	`double f, gradproj;`	122	`double f, gradproj;`
123	`int i, j, ilast, iter = 0;`	123	`int i, j, ilast, iter = 0;`
124	`double s, steplength;`	124	`double s, steplength;`
Line 172...	Line 172...
172	`gradproj += s * g[l[i]];`	172	`gradproj += s * g[l[i]];`
173	`}`	173	`}`
174		174
175	`if (gradproj < 0.0) { /* search direction is downhill */`	175	`if (gradproj < 0.0) { /* search direction is downhill */`
176	`steplength = 1.0;`	176	`steplength = 1.0;`
177	`accpoint = FALSE;`	177	`accpoint = false;`
178	`do {`	178	`do {`
179	`count = 0;`	179	`count = 0;`
180	`for (i = 0; i < n; i++) {`	180	`for (i = 0; i < n; i++) {`
181	`b[l[i]] = X[i] + steplength * t[i];`	181	`b[l[i]] = X[i] + steplength * t[i];`
182	`if (reltest + X[i] == reltest + b[l[i]]) /* no change */`	182	`if (reltest + X[i] == reltest + b[l[i]]) /* no change */`
Line 270...	Line 270...
270	`double alpha, double bet, double gamm, int trace,`	270	`double alpha, double bet, double gamm, int trace,`
271	`int *fncount, int maxit)`	271	`int *fncount, int maxit)`
272	`{`	272	`{`
273	`char action[50];`	273	`char action[50];`
274	`int C;`	274	`int C;`
275	`Rboolean calcvert;`	275	`bool calcvert;`
276	`double convtol, f;`	276	`double convtol, f;`
277	`int funcount=0, H, i, j, L=0;`	277	`int funcount=0, H, i, j, L=0;`
278	`int n1=0;`	278	`int n1=0;`
279	`double oldsize;`	279	`double oldsize;`
280	`double **P;`	280	`double **P;`
Line 289...	Line 289...
289	`return;`	289	`return;`
290	`}`	290	`}`
291	`if (trace)`	291	`if (trace)`
292	`Rprintf(" Nelder-Mead direct search function minimizer\n");`	292	`Rprintf(" Nelder-Mead direct search function minimizer\n");`
293	`P = matrix(n, n+1);`	293	`P = matrix(n, n+1);`
294	`*fail = FALSE;`	294	`*fail = false;`
295	`f = fminfn(n, Bvec, ex);`	295	`f = fminfn(n, Bvec, ex);`
296	`if (!R_FINITE(f)) {`	296	`if (!R_FINITE(f)) {`
297	`error(_("function cannot be evaluated at initial parameters"));`	297	`error(_("function cannot be evaluated at initial parameters"));`
298	`*fail = TRUE;`	298	`*fail = true;`
299	`} else {`	299	`} else {`
300	`if (trace) Rprintf("function value for initial parameters = %f\n", f);`	300	`if (trace) Rprintf("function value for initial parameters = %f\n", f);`
301	`funcount = 1;`	301	`funcount = 1;`
302	`convtol = intol * (fabs(f) + intol);`	302	`convtol = intol * (fabs(f) + intol);`
303	`if (trace) Rprintf(" Scaled convergence tolerance is %g\n", convtol);`	303	`if (trace) Rprintf(" Scaled convergence tolerance is %g\n", convtol);`
Line 328...	Line 328...
328	`trystep *= 10;`	328	`trystep *= 10;`
329	`}`	329	`}`
330	`size += trystep;`	330	`size += trystep;`
331	`}`	331	`}`
332	`oldsize = size;`	332	`oldsize = size;`
333	`calcvert = TRUE;`	333	`calcvert = true;`
334	`do {`	334	`do {`
335	`if (calcvert) {`	335	`if (calcvert) {`
336	`for (j = 0; j < n1; j++) {`	336	`for (j = 0; j < n1; j++) {`
337	`if (j + 1 != L) {`	337	`if (j + 1 != L) {`
338	`for (i = 0; i < n; i++)`	338	`for (i = 0; i < n; i++)`
Line 341...	Line 341...
341	`if (!R_FINITE(f)) f = big;`	341	`if (!R_FINITE(f)) f = big;`
342	`funcount++;`	342	`funcount++;`
343	`P[n1 - 1][j] = f;`	343	`P[n1 - 1][j] = f;`
344	`}`	344	`}`
345	`}`	345	`}`
346	`calcvert = FALSE;`	346	`calcvert = false;`
347	`}`	347	`}`
348		348
349	`VL = P[n1 - 1][L - 1];`	349	`VL = P[n1 - 1][L - 1];`
350	`VH = VL;`	350	`VH = VL;`
351	`H = L;`	351	`H = L;`
Line 425...	Line 425...
425	`P[i][H - 1] = Bvec[i];`	425	`P[i][H - 1] = Bvec[i];`
426	`P[n1 - 1][H - 1] = f;`	426	`P[n1 - 1][H - 1] = f;`
427	`} else {`	427	`} else {`
428	`if (VR >= VH) {`	428	`if (VR >= VH) {`
429	`strcpy(action, "SHRINK ");`	429	`strcpy(action, "SHRINK ");`
430	`calcvert = TRUE;`	430	`calcvert = true;`
431	`size = 0.0;`	431	`size = 0.0;`
432	`for (j = 0; j < n1; j++) {`	432	`for (j = 0; j < n1; j++) {`
433	`if (j + 1 != L) {`	433	`if (j + 1 != L) {`
434	`for (i = 0; i < n; i++) {`	434	`for (i = 0; i < n; i++) {`
435	`P[i][j] = bet * (P[i][j] - P[i][L - 1])`	435	`P[i][j] = bet * (P[i][j] - P[i][L - 1])`
Line 470...	Line 470...
470	`void cgmin(int n, double Bvec, double X, double *Fmin,`	470	`void cgmin(int n, double Bvec, double X, double *Fmin,`
471	`optimfn fminfn, optimgr fmingr, int *fail,`	471	`optimfn fminfn, optimgr fmingr, int *fail,`
472	`double abstol, double intol, void *ex, int type, int trace,`	472	`double abstol, double intol, void *ex, int type, int trace,`
473	`int fncount, int grcount, int maxit)`	473	`int fncount, int grcount, int maxit)`
474	`{`	474	`{`
475	`Rboolean accpoint;`	475	`bool accpoint;`
476	`double c, g, *t;`	476	`double c, g, *t;`
477	`int count, cycle, cyclimit;`	477	`int count, cycle, cyclimit;`
478	`double f;`	478	`double f;`
479	`double G1, G2, G3, gradproj;`	479	`double G1, G2, G3, gradproj;`
480	`int funcount=0, gradcount=0, i;`	480	`int funcount=0, gradcount=0, i;`
Line 482...	Line 482...
482	`double tol;`	482	`double tol;`
483		483
484	`if (maxit <= 0) {`	484	`if (maxit <= 0) {`
485	`*Fmin = fminfn(n, Bvec, ex);`	485	`*Fmin = fminfn(n, Bvec, ex);`
486	`fncount = grcount = 0;`	486	`fncount = grcount = 0;`
487	`*fail = FALSE;`	487	`*fail = false;`
488	`return;`	488	`return;`
489	`}`	489	`}`
490	`if (trace) {`	490	`if (trace) {`
491	`Rprintf(" Conjugate gradients function minimizer\n");`	491	`Rprintf(" Conjugate gradients function minimizer\n");`
492	`switch (type) {`	492	`switch (type) {`
Line 576...	Line 576...
576	`t[i] = t[i] * G3 - g[i];`	576	`t[i] = t[i] * G3 - g[i];`
577	`gradproj += t[i] * g[i];`	577	`gradproj += t[i] * g[i];`
578	`}`	578	`}`
579	`steplength = oldstep;`	579	`steplength = oldstep;`
580		580
581	`accpoint = FALSE;`	581	`accpoint = false;`
582	`do {`	582	`do {`
583	`count = 0;`	583	`count = 0;`
584	`for (i = 0; i < n; i++) {`	584	`for (i = 0; i < n; i++) {`
585	`Bvec[i] = X[i] + steplength * t[i];`	585	`Bvec[i] = X[i] + steplength * t[i];`
586	`if (reltest + X[i] == reltest + Bvec[i])`	586	`if (reltest + X[i] == reltest + Bvec[i])`

The R Project SVN R

(root)/trunk/src/appl/optim.c @ 63243 – Rev 87292 → 87925