Int_t RooIpatia2::getAnalyticalIntegral(RooArgSet& allVars, RooArgSet& analVars, const char* /*rangeName*/) const
{
// LIST HERE OVER WHICH VARIABLES ANALYTICAL INTEGRATION IS SUPPORTED,
// ASSIGN A NUMERIC CODE FOR EACH SUPPORTED (SET OF) PARAMETERS
// THE EXAMPLE BELOW ASSIGNS CODE 1 TO INTEGRATION OVER VARIABLE X
// YOU CAN ALSO IMPLEMENT MORE THAN ONE ANALYTICAL INTEGRAL BY REPEATING THE matchArgs
// EXPRESSION MULTIPLE TIMES
if (matchArgs(allVars,analVars,x) && fb==0. && zeta ==0 && l< 0) return 1 ;
return 0 ;
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object, previous, ans, argList;
char buffer[21];
static SEXP do_retracemem_formals = NULL;
if (do_retracemem_formals == NULL)
do_retracemem_formals = allocFormalsList2(install("x"),
R_PreviousSymbol);
PROTECT(argList = matchArgs(do_retracemem_formals, args, call));
if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
object = CAR(argList);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
previous = CADR(argList);
if(!isNull(previous) && !isString(previous))
errorcall(call, _("invalid '%s' argument"), "previous");
if (RTRACE(object)) {
snprintf(buffer, 21, "<%p>", (void *) object);
ans = mkString(buffer);
} else {
R_Visible = 0;
ans = R_NilValue;
}
if (previous != R_NilValue){
SET_RTRACE(object, 1);
if (R_current_trace_state()) {
/* FIXME: previous will have <0x....> whereas other values are
without the < > */
Rprintf("tracemem[%s -> %p]: ",
translateChar(STRING_ELT(previous, 0)), (void *) object);
memtrace_stack_dump();
}
}
UNPROTECT(1);
return ans;
#else
R_Visible = 0; /* for consistency with other case */
return R_NilValue;
#endif
}
Int_t RooExpOfPoly::getAnalyticalIntegral(RooArgSet& allVars, RooArgSet& analVars, const char* rangeName) const
{
if(matchArgs(allVars, analVars, m)) return 1;
if(matchArgs(allVars, analVars, pT)) return 2;
return 0;
}
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
int nargs = length(args), lf;
Rboolean One = nargs == 1;
R_xlen_t i, lout = NA_INTEGER;
static SEXP do_seq_formals = NULL;
if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
return(ans);
/* This is a primitive and we manage argument matching ourselves.
We pretend this is
seq(from, to, by, length.out, along.with, ...)
*/
if (do_seq_formals == NULL) {
do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
R_PreserveObject(do_seq_formals);
tmp = do_seq_formals;
SET_TAG(tmp, install("from")); tmp = CDR(tmp);
SET_TAG(tmp, install("to")); tmp = CDR(tmp);
SET_TAG(tmp, install("by")); tmp = CDR(tmp);
SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_DotsSymbol);
}
PROTECT(args = matchArgs(do_seq_formals, args, call));
from = CAR(args); args = CDR(args);
to = CAR(args); args = CDR(args);
by = CAR(args); args = CDR(args);
len = CAR(args); args = CDR(args);
along = CAR(args);
if(One && from != R_MissingArg) {
lf = length(from);
if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
double rfrom = asReal(from);
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
ans = seq_colon(1.0, rfrom, call);
}
else if (lf)
ans = seq_colon(1.0, (double)lf, call);
else
ans = allocVector(INTSXP, 0);
goto done;
}
if(along != R_MissingArg) {
lout = XLENGTH(along);
if(One) {
ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
goto done;
}
} else if(len != R_MissingArg && len != R_NilValue) {
double rout = asReal(len);
if(ISNAN(rout) || rout <= -0.5)
errorcall(call, _("'length.out' must be a non-negative number"));
if(length(len) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
lout = (R_xlen_t) ceil(rout);
}
if(lout == NA_INTEGER) {
double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
if(from == R_MissingArg) rfrom = 1.0;
else if(length(from) != 1) error("'from' must be of length 1");
if(to == R_MissingArg) rto = 1.0;
else if(length(to) != 1) error("'to' must be of length 1");
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
if (!R_FINITE(rto))
errorcall(call, "'to' cannot be NA, NaN or infinite");
if(by == R_MissingArg)
ans = seq_colon(rfrom, rto, call);
else {
if(length(by) != 1) error("'by' must be of length 1");
double del = rto - rfrom, n, dd;
R_xlen_t nn;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(del == 0.0 && rto == 0.0) {
ans = to;
goto done;
}
/* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
n = del/rby;
if(!R_FINITE(n)) {
if(del == 0.0 && rby == 0.0) {
ans = from;
goto done;
} else
errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
}
dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
if(dd < 100 * DBL_EPSILON) {
ans = from;
goto done;
}
#ifdef LONG_VECTOR_SUPPORT
if(n > 100 * (double) INT_MAX)
#else
if(n > (double) INT_MAX)
#endif
errorcall(call, _("'by' argument is much too small"));
if(n < - FEPS)
errorcall(call, _("wrong sign in 'by' argument"));
if(TYPEOF(from) == INTSXP &&
TYPEOF(to) == INTSXP &&
TYPEOF(by) == INTSXP) {
int *ia, ifrom = asInteger(from), iby = asInteger(by);
/* With the current limits on integers and FEPS
reduced below 1/INT_MAX this is the same as the
next, so this is future-proofing against longer integers.
*/
/* seq.default gives integer result from
from + (0:n)*by
*/
nn = (R_xlen_t) n;
ans = allocVector(INTSXP, nn+1);
ia = INTEGER(ans);
for(i = 0; i <= nn; i++)
ia[i] = (int)(ifrom + i * iby);
} else {
nn = (int)(n + FEPS);
ans = allocVector(REALSXP, nn+1);
ra = REAL(ans);
for(i = 0; i <= nn; i++)
ra[i] = rfrom + (double)i * rby;
/* Added in 2.9.0 */
if (nn > 0)
if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
ra[nn] = rto;
}
}
} else if (lout == 0) {
ans = allocVector(INTSXP, 0);
} else if (One) {
ans = seq_colon(1.0, (double)lout, call);
} else if (by == R_MissingArg) {
double rfrom = asReal(from), rto = asReal(to), rby;
if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
ans = allocVector(REALSXP, lout);
if(lout > 0) REAL(ans)[0] = rfrom;
if(lout > 1) REAL(ans)[lout - 1] = rto;
if(lout > 2) {
rby = (rto - rfrom)/(double)(lout - 1);
for(i = 1; i < lout-1; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (to == R_MissingArg) {
double rfrom = asReal(from), rby = asReal(by), rto;
if(from == R_MissingArg) rfrom = 1.0;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
rto = rfrom + (double)(lout-1)*rby;
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (from == R_MissingArg) {
double rto = asReal(to), rby = asReal(by),
rfrom = rto - (double)(lout-1)*rby;
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
}
}
} else
errorcall(call, _("too many arguments"));
done:
UNPROTECT(1);
return ans;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
* ------- but also called from ./eval.c */
SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *saveToplevelContext;
RCNTXT *saveGlobalContext;
RCNTXT thiscontext, returncontext, *cptr;
int savestack, browselevel;
SEXP ap, topExp, argList;
/* argument matching */
PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("text"));
SET_TAG(CDR(ap), install("condition"));
SET_TAG(CDDR(ap), install("expr"));
SET_TAG(CDDDR(ap), install("skipCalls"));
argList = matchArgs(ap, args, call);
UNPROTECT(1);
PROTECT(argList);
/* substitute defaults */
if(CAR(argList) == R_MissingArg)
SETCAR(argList, mkString(""));
if(CADR(argList) == R_MissingArg)
SETCAR(CDR(argList), R_NilValue);
if(CADDR(argList) == R_MissingArg)
SETCAR(CDDR(argList), ScalarLogical(1));
if(CADDDR(argList) == R_MissingArg)
SETCAR(CDDDR(argList), ScalarInteger(0));
/* return if 'expr' is not TRUE */
if( !asLogical(CADDR(argList)) ) {
UNPROTECT(1);
return R_NilValue;
}
/* Save the evaluator state information */
/* so that it can be restored on exit. */
browselevel = countContexts(CTXT_BROWSER, 1);
savestack = R_PPStackTop;
PROTECT(topExp = R_CurrentExpr);
saveToplevelContext = R_ToplevelContext;
saveGlobalContext = R_GlobalContext;
if (!RDEBUG(rho)) {
int skipCalls = asInteger(CADDDR(argList));
cptr = R_GlobalContext;
while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--)
&& cptr->callflag )
cptr = cptr->nextcontext;
Rprintf("Called from: ");
int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv));
if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp;
if( cptr != R_ToplevelContext ) {
PrintValueRec(cptr->call, rho);
SET_RDEBUG(cptr->cloenv, 1);
} else
Rprintf("top level \n");
R_BrowseLines = 0;
}
R_ReturnedValue = R_NilValue;
/* Here we establish two contexts. The first */
/* of these provides a target for return */
/* statements which a user might type at the */
/* browser prompt. The (optional) second one */
/* acts as a target for error returns. */
begincontext(&returncontext, CTXT_BROWSER, call, rho,
R_BaseEnv, argList, R_NilValue);
if (!SETJMP(returncontext.cjmpbuf)) {
begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
R_BaseEnv, R_NilValue, R_NilValue);
if (SETJMP(thiscontext.cjmpbuf)) {
SET_RESTART_BIT_ON(thiscontext.callflag);
R_ReturnedValue = R_NilValue;
R_Visible = FALSE;
}
R_GlobalContext = &thiscontext;
R_InsertRestartHandlers(&thiscontext, TRUE);
R_ReplConsole(rho, savestack, browselevel+1);
endcontext(&thiscontext);
}
endcontext(&returncontext);
/* Reset the interpreter state. */
R_CurrentExpr = topExp;
UNPROTECT(1);
R_PPStackTop = savestack;
UNPROTECT(1);
R_CurrentExpr = topExp;
R_ToplevelContext = saveToplevelContext;
R_GlobalContext = saveGlobalContext;
return R_ReturnedValue;
}
