The R Project SVN R

Rev

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

Rev 42726 Rev 49212
Line 376... Line 376...
376 
    s = CADR(R_fcall);
 376 
    s = CADR(R_fcall);
377 
    for (i = 0; i < n; i++) {
 377 
    for (i = 0; i < n; i++) {
378 
	if (!R_FINITE(x[i])) error(_("non-finite value supplied by 'nlm'"));
 378 
	if (!R_FINITE(x[i])) error(_("non-finite value supplied by 'nlm'"));
379 
	REAL(s)[i] = x[i];
 379 
	REAL(s)[i] = x[i];
380 
    }
 380 
    }
381 
    s = eval(state->R_fcall, state->R_env);
 381 
    s = PROTECT(eval(state->R_fcall, state->R_env));
382 
    switch(TYPEOF(s)) {
 382 
    switch(TYPEOF(s)) {
383 
    case INTSXP:
 383 
    case INTSXP:
384 
	if (length(s) != 1) goto badvalue;
 384 
	if (length(s) != 1) goto badvalue;
385 
	if (INTEGER(s)[0] == NA_INTEGER) {
 385 
	if (INTEGER(s)[0] == NA_INTEGER) {
386 
	    warning(_("NA replaced by maximum positive value"));
 386 
	    warning(_("NA replaced by maximum positive value"));
Line 398... Line 398...
398 
	break;
 398 
	break;
399 
    default:
 399 
    default:
400 
	goto badvalue;
 400 
	goto badvalue;
401 
    }
 401 
    }
402 
    if (state->have_gradient) {
 402 
    if (state->have_gradient) {
403 
	g = REAL(coerceVector(getAttrib(s, install("gradient")), REALSXP));
 403 
	g = REAL(PROTECT(coerceVector(getAttrib(s, install("gradient")), REALSXP)));
404 
	if (state->have_hessian) {
 404 
	if (state->have_hessian) {
405 
	    h = REAL(coerceVector(getAttrib(s, install("hessian")), REALSXP));
 405 
	    h = REAL(PROTECT(coerceVector(getAttrib(s, install("hessian")), REALSXP)));
406 
	}
 406 
	}
407 
    }
 407 
    }
408 
    FT_store(n, *f, x, g, h, state);
 408 
    FT_store(n, *f, x, g, h, state);
- 
 
 409 
    UNPROTECT(1 + state->have_gradient + state->have_hessian);
409 
    return;
 410 
    return;
410 
 
 411 
 
411 
 badvalue:
 412 
 badvalue:
412 
    error(_("invalid function value in 'nlm' optimizer"));
 413 
    error(_("invalid function value in 'nlm' optimizer"));
413 
}
 414 
}
414 
 
 415