The R Project SVN R

Rev

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

Rev 28034 Rev 28135
Line 43... Line 43...
43 
static SEXP CoshSymbol;
 43 
static SEXP CoshSymbol;
44 
static SEXP TanhSymbol;
 44 
static SEXP TanhSymbol;
45 
static SEXP SqrtSymbol;
 45 
static SEXP SqrtSymbol;
46 
static SEXP PnormSymbol;
 46 
static SEXP PnormSymbol;
47 
static SEXP DnormSymbol;
 47 
static SEXP DnormSymbol;
- 
 
 48 
static SEXP AsinSymbol;
- 
 
 49 
static SEXP AcosSymbol;
- 
 
 50 
static SEXP AtanSymbol;
48 
 
 51 
 
49 
static Rboolean Initialized = FALSE;
 52 
static Rboolean Initialized = FALSE;
50 
 
 53 
 
51 
 
 54 
 
52 
static void InitDerivSymbols()
 55 
static void InitDerivSymbols()
Line 68... Line 71...
68 
    CoshSymbol = install("cosh");
 71 
    CoshSymbol = install("cosh");
69 
    TanhSymbol = install("tanh");
 72 
    TanhSymbol = install("tanh");
70 
    SqrtSymbol = install("sqrt");
 73 
    SqrtSymbol = install("sqrt");
71 
    PnormSymbol = install("pnorm");
 74 
    PnormSymbol = install("pnorm");
72 
    DnormSymbol = install("dnorm");
 75 
    DnormSymbol = install("dnorm");
- 
 
 76 
    AsinSymbol = install("asin");
- 
 
 77 
    AcosSymbol = install("acos");
- 
 
 78 
    AtanSymbol = install("atan");
- 
 
 79 
 
73 
    Initialized = TRUE;
 80 
    Initialized = TRUE;
74 
}
 81 
}
75 
 
 82 
 
76 
static SEXP Constant(double x)
 83 
static SEXP Constant(double x)
77 
{
 84 
{
Line 245... Line 252...
245 
	ans = lang2(SinhSymbol, arg1);
 252 
	ans = lang2(SinhSymbol, arg1);
246 
    }
 253 
    }
247 
    else if (fun == TanhSymbol) {
 254 
    else if (fun == TanhSymbol) {
248 
	ans = lang2(TanhSymbol, arg1);
 255 
	ans = lang2(TanhSymbol, arg1);
249 
    }
 256 
    }
- 
 
 257 
    else if (fun == SqrtSymbol) {
- 
 
 258 
	ans = lang2(SqrtSymbol, arg1);
- 
 
 259 
    }
250 
    else if (fun == PnormSymbol) {
 260 
    else if (fun == PnormSymbol) {
251 
	ans = lang2(PnormSymbol, arg1);
 261 
	ans = lang2(PnormSymbol, arg1);
252 
    }
 262 
    }
253 
    else if (fun == DnormSymbol) {
 263 
    else if (fun == DnormSymbol) {
254 
	ans = lang2(DnormSymbol, arg1);
 264 
	ans = lang2(DnormSymbol, arg1);
255 
    }
 265 
    }
- 
 
 266 
    else if (fun == AsinSymbol) {
- 
 
 267 
	ans = lang2(AsinSymbol, arg1);
- 
 
 268 
    }
- 
 
 269 
    else if (fun == AcosSymbol) {
- 
 
 270 
	ans = lang2(AcosSymbol, arg1);
- 
 
 271 
    }
- 
 
 272 
    else if (fun == AtanSymbol) {
- 
 
 273 
	ans = lang2(AtanSymbol, arg1);
- 
 
 274 
    }
256 
    else ans = Constant(NA_REAL);
 275 
    else ans = Constant(NA_REAL);
257 
    /* FIXME */
 276 
    /* FIXME */
258 
#ifdef NOTYET
 277 
#ifdef NOTYET
259 
    if (length(ans) == 2 && isAtomic(CADR(ans)) && CAR(ans) != MinusSymbol)
 278 
    if (length(ans) == 2 && isAtomic(CADR(ans)) && CAR(ans) != MinusSymbol)
260 
	c = eval(c, rho);
 279 
	c = eval(c, rho);
Line 447... Line 466...
447 
	}
 466 
	}
448 
	else if (CAR(expr) == DnormSymbol) {
 467 
	else if (CAR(expr) == DnormSymbol) {
449 
	    ans = simplify(TimesSymbol,
 468 
	    ans = simplify(TimesSymbol,
450 
			   PP(simplify(MinusSymbol, CADR(expr), R_MissingArg)),
 469 
			   PP(simplify(MinusSymbol, CADR(expr), R_MissingArg)),
451 
			   PP(simplify(TimesSymbol,
 470 
			   PP(simplify(TimesSymbol,
452 
			   PP(simplify(DnormSymbol, CADR(expr), R_MissingArg)),
 471 
				       PP(simplify(DnormSymbol, CADR(expr), R_MissingArg)),
- 
 
 472 
				       PP(D(CADR(expr), var))))),
- 
 
 473 
		UNPROTECT(4);
- 
 
 474 
	}
- 
 
 475 
	else if (CAR(expr) == AsinSymbol) {
- 
 
 476 
	    ans = simplify(DivideSymbol,
453 
			   PP(D(CADR(expr), var))))),
 477 
			   PP(D(CADR(expr), var)),
- 
 
 478 
			   PP(simplify(SqrtSymbol,
- 
 
 479 
				       PP(simplify(MinusSymbol,Constant(1.),
- 
 
 480 
						   PP(simplify(PowerSymbol,
- 
 
 481 
							       CADR(expr),Constant(2.))))),
- 
 
 482 
				       R_MissingArg))),
454 
		UNPROTECT(4);
 483 
		UNPROTECT(4);
455 
	}
 484 
	}
- 
 
 485 
	else if (CAR(expr) == AcosSymbol) {
- 
 
 486 
	    ans = simplify(MinusSymbol,
- 
 
 487 
			   PP(simplify(DivideSymbol,
- 
 
 488 
				       PP(D(CADR(expr), var)),
- 
 
 489 
				       PP(simplify(SqrtSymbol,
- 
 
 490 
						   PP(simplify(MinusSymbol,Constant(1.),
- 
 
 491 
							       PP(simplify(PowerSymbol,
- 
 
 492 
									   CADR(expr),Constant(2.))))),
- 
 
 493 
						   R_MissingArg)))),R_MissingArg),
- 
 
 494 
		UNPROTECT(5);
- 
 
 495 
	}
- 
 
 496 
	else if (CAR(expr) == AtanSymbol) {
- 
 
 497 
	    ans = simplify(DivideSymbol,
- 
 
 498 
			   PP(D(CADR(expr), var)),
- 
 
 499 
			   PP(simplify(PlusSymbol,Constant(1.),
- 
 
 500 
				       PP(simplify(PowerSymbol,
- 
 
 501 
						   CADR(expr),Constant(2.)))))),
- 
 
 502 
		UNPROTECT(3);
- 
 
 503 
	}
- 
 
 504 
 
456 
	else {
 505 
	else {
457 
	    SEXP u = deparse1(CAR(expr), 0);
 506 
	    SEXP u = deparse1(CAR(expr), 0);
458 
	    error("Function `%s' is not in the derivatives table",
 507 
	    error("Function `%s' is not in the derivatives table",
459 
		  CHAR(STRING_ELT(u, 0)));
 508 
		  CHAR(STRING_ELT(u, 0)));
460 
	}
 509 
	}
461
510 
 
462 
	break;
 511 
	break;
463 
    default:
 512 
    default:
464 
	ans = Constant(NA_REAL);
 513 
	ans = Constant(NA_REAL);
465 
    }
 514 
    }
466 
    return ans;
 515 
    return ans;
Line 757... Line 806...
757 
    PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
 806 
    PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
758 
    SETCAR(dim, install("c"));
 807 
    SETCAR(dim, install("c"));
759 
    SETCADR(dim, lang2(install("length"), install(".value")));
 808 
    SETCADR(dim, lang2(install("length"), install(".value")));
760 
    SETCADDR(dim, allocVector(REALSXP, 1));
 809 
    SETCADDR(dim, allocVector(REALSXP, 1));
761 
    REAL(CADDR(dim))[0] = length(names);
 810 
    REAL(CADDR(dim))[0] = length(names);
762 
    SETCADDDR(dim, allocVector(REALSXP, 1));
811 
    SETCADDDR(dim, allocVector(REALSXP, 1));
763 
    REAL(CADDDR(dim))[0] = length(names);
 812 
    REAL(CADDDR(dim))[0] = length(names);
764 
    PROTECT(data = allocVector(REALSXP, 1));
 813 
    PROTECT(data = allocVector(REALSXP, 1));
765 
    REAL(data)[0] = 0;
 814 
    REAL(data)[0] = 0;
766 
    PROTECT(p = lang4(install("array"), data, dim, dimnames));
 815 
    PROTECT(p = lang4(install("array"), data, dim, dimnames));
767 
    p = lang3(install("<-"), install(".hessian"), p);
 816 
    p = lang3(install("<-"), install(".hessian"), p);
Line 861... Line 910...
861 
    checkArity(op, args);
 910 
    checkArity(op, args);
862 
    vmax = vmaxget();
 911 
    vmax = vmaxget();
863 
    InitDerivSymbols();
 912 
    InitDerivSymbols();
864 
    PROTECT(exprlist = LCONS(install("{"), R_NilValue));
 913 
    PROTECT(exprlist = LCONS(install("{"), R_NilValue));
865 
    /* expr: */
 914 
    /* expr: */
866 
    if (isExpression(CAR(args)))
915 
    if (isExpression(CAR(args)))
867 
	PROTECT(expr = VECTOR_ELT(CAR(args), 0));
 916 
	PROTECT(expr = VECTOR_ELT(CAR(args), 0));
868 
    else PROTECT(expr = CAR(args));
 917 
    else PROTECT(expr = CAR(args));
869 
    args = CDR(args);
 918 
    args = CDR(args);
870 
    /* namevec: */
 919 
    /* namevec: */
871 
    names = CAR(args);
 920 
    names = CAR(args);
Line 885... Line 934...
885 
    hessian = asLogical(CAR(args));
 934 
    hessian = asLogical(CAR(args));
886 
    /* NOTE: FindSubexprs is destructive, hence the duplication */
 935 
    /* NOTE: FindSubexprs is destructive, hence the duplication */
887 
    PROTECT(ans = duplicate(expr));
 936 
    PROTECT(ans = duplicate(expr));
888 
    f_index = FindSubexprs(ans, exprlist, tag);
 937 
    f_index = FindSubexprs(ans, exprlist, tag);
889 
    d_index = (int*)R_alloc(nderiv, sizeof(int));
 938 
    d_index = (int*)R_alloc(nderiv, sizeof(int));
890 
    if (hessian)
939 
    if (hessian)
891 
	d2_index = (int*)R_alloc((nderiv * (1 + nderiv))/2, sizeof(int));
 940 
	d2_index = (int*)R_alloc((nderiv * (1 + nderiv))/2, sizeof(int));
892 
    else d2_index = d_index;/*-Wall*/
 941 
    else d2_index = d_index;/*-Wall*/
893 
    UNPROTECT(1);
 942 
    UNPROTECT(1);
894 
    for(i=0, k=0; i<nderiv ; i++) {
 943 
    for(i=0, k=0; i<nderiv ; i++) {
895 
	PROTECT(ans = duplicate(expr));
 944 
	PROTECT(ans = duplicate(expr));
Line 1015... Line 1064...
1015 
 
 1064 
 
1016 
    if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
 1065 
    if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
1017 
	funarg = names;
 1066 
	funarg = names;
1018 
    }
 1067 
    }
1019 
 
 1068 
 
1020 
    if (TYPEOF(funarg) == CLOSXP)
1069 
    if (TYPEOF(funarg) == CLOSXP)
1021 
    {
 1070 
    {
1022 
	s = allocSExp(CLOSXP);
 1071 
	s = allocSExp(CLOSXP);
1023 
	SET_FORMALS(s, FORMALS(funarg));
 1072 
	SET_FORMALS(s, FORMALS(funarg));
1024 
	SET_CLOENV(s, CLOENV(funarg));
 1073 
	SET_CLOENV(s, CLOENV(funarg));
1025 
	funarg = s;
 1074 
	funarg = s;