The R Project SVN R

Rev

Rev 42307 | Rev 42726 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 42307 Rev 42701
Line 157... Line 157...
157 
}
 157 
}
158 
 
 158 
 
159 
/* zeroin(f, xmin, xmax, tol, maxiter) */
 159 
/* zeroin(f, xmin, xmax, tol, maxiter) */
160 
SEXP attribute_hidden do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho)
 160 
SEXP attribute_hidden do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho)
161 
{
 161 
{
- 
 
 162 
#define DO_ZEROIN_part_1				\
162 
    double xmin, xmax, tol;
 163 
    double xmin, xmax, tol;				\
163 
    int iter;
 164 
    int iter;						\
164 
    SEXP v, res;
 165 
    SEXP v, res;					\
165 
    struct callinfo info;
 166 
    struct callinfo info;				\
166 
 
 167 
							\
167 
    checkArity(op, args);
 168 
    checkArity(op, args);				\
168 
    PrintDefaults(rho);
 169 
    PrintDefaults(rho);					\
169 
 
 170 
							\
170 
    /* the function to be minimized */
 171 
    /* the function to be minimized */			\
171 
 
 - 
 
172 
    v = CAR(args);
 172 
    v = CAR(args);					\
173 
    if (!isFunction(v))
 173 
    if (!isFunction(v))					\
174 
	error(_("attempt to minimize non-function"));
 174 
	error(_("attempt to minimize non-function"));	\
- 
 
 175 
    args = CDR(args);					\
- 
 
 176 
							\
- 
 
 177 
    /* xmin */						\
- 
 
 178 
    xmin = asReal(CAR(args));				\
- 
 
 179 
    if (!R_FINITE(xmin))				\
- 
 
 180 
	error(_("invalid '%s' value"), "xmin");		\
- 
 
 181 
    args = CDR(args);					\
- 
 
 182 
							\
- 
 
 183 
    /* xmax */						\
- 
 
 184 
    xmax = asReal(CAR(args));				\
- 
 
 185 
    if (!R_FINITE(xmax))				\
- 
 
 186 
	error(_("invalid '%s' value"), "xmax");		\
- 
 
 187 
    if (xmin >= xmax)					\
- 
 
 188 
	error(_("'xmin' not less than 'xmax'"));	\
175 
    args = CDR(args);
 189 
    args = CDR(args)
- 
 
 190 
 
- 
 
 191 
#define DO_ZEROIN_part_2						\
- 
 
 192 
    /* tol */								\
- 
 
 193 
    tol = asReal(CAR(args));						\
- 
 
 194 
    if (!R_FINITE(tol) || tol <= 0.0)					\
- 
 
 195 
	error(_("invalid '%s' value"), "tol");				\
- 
 
 196 
    args = CDR(args);							\
- 
 
 197 
									\
- 
 
 198 
    /* maxiter */							\
- 
 
 199 
    iter = asInteger(CAR(args));					\
- 
 
 200 
    if (iter <= 0)							\
- 
 
 201 
	error(_("'maxiter' must be positive"));				\
- 
 
 202 
									\
- 
 
 203 
    info.R_env = rho;							\
- 
 
 204 
    PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */	\
- 
 
 205 
    SETCADR(info.R_fcall, allocVector(REALSXP, 1));			\
- 
 
 206 
    PROTECT(res = allocVector(REALSXP, 3))
176 
 
 207 
 
- 
 
 208 
    DO_ZEROIN_part_1;
177 
    /* xmin */
 209 
    DO_ZEROIN_part_2;
178 
 
 210 
 
179 
    xmin = asReal(CAR(args));
 211 
    REAL(res)[0] =
- 
 
 212 
	R_zeroin(xmin, xmax,   (double (*)(double, void*)) fcn2,
180 
    if (!R_FINITE(xmin))
 213 
		 (void *) &info, &tol, &iter);
181 
	error(_("invalid '%s' value"), "xmin");
 214 
    REAL(res)[1] = (double)iter;
- 
 
 215 
    REAL(res)[2] = tol;
182 
    args = CDR(args);
 216 
    UNPROTECT(2);
- 
 
 217 
    return res;
- 
 
 218 
}
183 
 
 219 
 
- 
 
 220 
/* zeroin2(f, ax, bx, f.ax, f.bx, tol, maxiter) */
- 
 
 221 
SEXP attribute_hidden do_zeroin2(SEXP call, SEXP op, SEXP args, SEXP rho)
- 
 
 222 
{
184 
    /* xmax */
 223 
    double f_ax, f_bx;
- 
 
 224 
    DO_ZEROIN_part_1;
185 
 
 225 
 
- 
 
 226 
    /* f(ax) = f(xmin) */
186 
    xmax = asReal(CAR(args));
 227 
    f_ax = asReal(CAR(args));
187 
    if (!R_FINITE(xmax))
 228 
    if (!R_FINITE(f_ax))
188 
	error(_("invalid '%s' value"), "xmax");
 229 
	error(_("invalid '%s' value"), "f_ax");
189 
    if (xmin >= xmax)
 - 
 
190 
	error(_("'xmin' not less than 'xmax'"));
 - 
 
191 
    args = CDR(args);
 230 
    args = CDR(args);
192 
 
 231 
 
193 
    /* tol */
 232 
    /* f(bx) = f(xmax) */
194 
 
 - 
 
195 
    tol = asReal(CAR(args));
 233 
    f_bx = asReal(CAR(args));
196 
    if (!R_FINITE(tol) || tol <= 0.0)
 234 
    if (!R_FINITE(f_bx))
197 
	error(_("invalid '%s' value"), "tol");
 235 
	error(_("invalid '%s' value"), "f_bx");
198 
    args = CDR(args);
 236 
    args = CDR(args);
199 
 
 237 
 
200 
    /* maxiter */
 238 
    DO_ZEROIN_part_2;
201 
    iter = asInteger(CAR(args));
 - 
 
202 
    if (iter <= 0)
 - 
 
203 
	error(_("'maxiter' must be positive"));
 - 
 
204 
 
 239 
 
205 
    info.R_env = rho;
 - 
 
206 
    PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
 - 
 
207 
    SETCADR(info.R_fcall, allocVector(REALSXP, 1));
 - 
 
208 
    PROTECT(res = allocVector(REALSXP, 3));
 - 
 
209 
    REAL(res)[0] =
 240 
    REAL(res)[0] =
210 
	R_zeroin(xmin, xmax,   (double (*)(double, void*)) fcn2,
 241 
	R_zeroin2(xmin, xmax, f_ax, f_bx, (double (*)(double, void*)) fcn2,
211 
		 (void *) &info, &tol, &iter);
 242 
		 (void *) &info, &tol, &iter);
212 
    REAL(res)[1] = (double)iter;
 243 
    REAL(res)[1] = (double)iter;
213 
    REAL(res)[2] = tol;
 244 
    REAL(res)[2] = tol;
214 
    UNPROTECT(2);
 245 
    UNPROTECT(2);
215 
    return res;
 246 
    return res;
216 
}
 247 
}
- 
 
 248 
#undef DO_ZEROIN_part_1
- 
 
 249 
#undef DO_ZEROIN_part_2
217
250
218 
 
 251 
 
219 
 
 252 
 
220 
/* General Nonlinear Optimization */
 253 
/* General Nonlinear Optimization */
221 
 
 254