/* .Internal(identical(..)) */
SEXP attribute_hidden do_identical(SEXP call, SEXP op, SEXP args, SEXP env)
{
int num_eq = 1, single_NA = 1, attr_as_set = 1, ignore_bytecode = 1, nargs = length(args), flags;
/* avoid problems with earlier (and future) versions captured in S4 methods */
/* checkArity(op, args); */
if (nargs < 5)
error("%d arguments passed to .Internal(%s) which requires %d",
length(args), PRIMNAME(op), PRIMARITY(op));
if (nargs >= 5) {
num_eq = asLogical(CADDR(args));
single_NA = asLogical(CADDDR(args));
attr_as_set = asLogical(CAD4R(args));
}
if (nargs >= 6)
ignore_bytecode = asLogical(CAD4R(CDR(args)));
if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");
if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");
if(attr_as_set == NA_LOGICAL) error(_("invalid '%s' value"), "attrib.as.set");
if(ignore_bytecode == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.bytecode");
flags = (num_eq ? 0 : 1) + (single_NA ? 0 : 2) + (attr_as_set ? 0 : 4) + (ignore_bytecode ? 0 : 8);
return ScalarLogical(R_compute_identical(CAR(args), CADR(args), flags));
}
bool IsAllowed(
const int iPred, // in: candidate predictor
const int iParent, // in: candidate parent term
const int Dirs[], // in:
const int nPreds, // in:
const int nMaxTerms) // in:
{
if(AllowedFuncGlobal == NULL)
return TRUE;
SEXP s = AllowedFuncGlobal; // 1st element is the function
s = CDR(s); // 2nd element is "degree"
INTEGER(CADR(s))[0] = iPred+1; // 3rd element is "pred"
int* p = INTEGER(CADDR(s)); // 4th element is "parents"
int i, nDegree = 1;
for(i = 0; i < nPreds; i++) {
p[i] = Dirs_(iParent, i);
if(p[i])
nDegree++;
}
INTEGER(CAR(s))[0] = nDegree;
// optional 5th element already initialized to predictor names
if(nArgsGlobal >= 5) // optional 6th element is "first"
*(LOGICAL(CAD4R(s))) = FirstGlobal;
FirstGlobal = false;
return EvalAllowedFunc();
}
SEXP actuar_do_panjer(SEXP args)
{
SEXP p0, p1, fs0, sfx, a, b, conv, tol, maxit, echo, sfs;
double *fs, *fx, cumul;
int upper, m, k, n, x = 1;
double norm; /* normalizing constant */
double term; /* constant in the (a, b, 1) case */
/* The length of vector fs is not known in advance. We opt for a
* simple scheme: allocate memory for a vector of size 'size',
* double the size when the vector is full. */
int size = INITSIZE;
fs = (double *) S_alloc(size, sizeof(double));
/* All values received from R are then protected. */
PROTECT(p0 = coerceVector(CADR(args), REALSXP));
PROTECT(p1 = coerceVector(CADDR(args), REALSXP));
PROTECT(fs0 = coerceVector(CADDDR(args), REALSXP));
PROTECT(sfx = coerceVector(CAD4R(args), REALSXP));
PROTECT(a = coerceVector(CAD5R(args), REALSXP));
PROTECT(b = coerceVector(CAD6R(args), REALSXP));
PROTECT(conv = coerceVector(CAD7R(args), INTSXP));
PROTECT(tol = coerceVector(CAD8R(args), REALSXP));
PROTECT(maxit = coerceVector(CAD9R(args), INTSXP));
PROTECT(echo = coerceVector(CAD10R(args), LGLSXP));
/* Initialization of some variables */
fx = REAL(sfx); /* severity distribution */
upper = length(sfx) - 1; /* severity distribution support upper bound */
fs[0] = REAL(fs0)[0]; /* value of Pr[S = 0] (computed in R) */
cumul = REAL(fs0)[0]; /* cumulative probability computed */
norm = 1 - REAL(a)[0] * fx[0]; /* normalizing constant */
n = INTEGER(conv)[0]; /* number of convolutions to do */
/* If printing of recursions was asked for, start by printing a
* header and the probability at 0. */
if (LOGICAL(echo)[0])
Rprintf("x\tPr[S = x]\tCumulative probability\n%d\t%.8g\t%.8g\n",
0, fs[0], fs[0]);
/* (a, b, 0) case (if p0 is NULL) */
if (isNull(CADR(args)))
do
{
/* Stop after 'maxit' recursions and issue warning. */
if (x > INTEGER(maxit)[0])
{
warning(_("maximum number of recursions reached before the probability distribution was complete"));
break;
}
/* If fs is too small, double its size */
if (x >= size)
{
fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
size = size << 1;
}
m = x;
if (x > upper) m = upper; /* upper bound of the sum */
/* Compute probability up to the scaling constant */
for (k = 1; k <= m; k++)
fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
fs[x] = fs[x]/norm; /* normalization */
cumul += fs[x]; /* cumulative sum */
if (LOGICAL(echo)[0])
Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);
x++;
} while (cumul < REAL(tol)[0]);
/* (a, b, 1) case (if p0 is non-NULL) */
else
{
/* In the (a, b, 1) case, the recursion formula has an
* additional term involving f_X(x). The mathematical notation
* assumes that f_X(x) = 0 for x > m (the maximal value of the
* distribution). We need to treat this specifically in
* programming, though. */
double fxm;
/* Constant term in the (a, b, 1) case. */
term = (REAL(p1)[0] - (REAL(a)[0] + REAL(b)[0]) * REAL(p0)[0]);
do
{
/* Stop after 'maxit' recursions and issue warning. */
if (x > INTEGER(maxit)[0])
{
warning(_("maximum number of recursions reached before the probability distribution was complete"));
break;
}
if (x >= size)
{
fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
size = size << 1;
}
m = x;
if (x > upper)
{
m = upper; /* upper bound of the sum */
fxm = 0.0; /* i.e. no additional term */
}
else
fxm = fx[m]; /* i.e. additional term */
for (k = 1; k <= m; k++)
fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
fs[x] = (fs[x] + fxm * term) / norm;
cumul += fs[x];
if (LOGICAL(echo)[0])
Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);
x++;
} while (cumul < REAL(tol)[0]);
}
/* If needed, convolve the distribution obtained above with itself
* using a very simple direct technique. Since we want to
* continue storing the distribution in array 'fs', we need to
* copy the vector in an auxiliary array at each convolution. */
if (n)
{
int i, j, ox;
double *ofs; /* auxiliary array */
/* Resize 'fs' to its final size after 'n' convolutions. Each
* convolution increases the length from 'x' to '2 * x - 1'. */
fs = (double *) S_realloc((char *) fs, (1 << n) * (x - 1) + 1, size, sizeof(double));
/* Allocate enough memory in the auxiliary array for the 'n'
* convolutions. This is just slightly over half the final
* size of 'fs'. */
ofs = (double *) S_alloc((1 << (n - 1)) * (x - 1) + 1, sizeof(double));
for (k = 0; k < n; k++)
{
memcpy(ofs, fs, x * sizeof(double)); /* keep previous array */
ox = x; /* previous array length */
x = (x << 1) - 1; /* new array length */
for(i = 0; i < x; i++)
fs[i] = 0.0;
for(i = 0; i < ox; i++)
for(j = 0; j < ox; j++)
fs[i + j] += ofs[i] * ofs[j];
}
}
/* Copy the values of fs to a SEXP which will be returned to R. */
PROTECT(sfs = allocVector(REALSXP, x));
memcpy(REAL(sfs), fs, x * sizeof(double));
UNPROTECT(11);
return(sfs);
}
