/* 'name' should be 1-element STRSXP or SYMSXP */
SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
{
PROTECT(vec);
PROTECT(name);
if (isString(name))
name = install(translateChar(STRING_ELT(name, 0)));
if (val == R_NilValue) {
UNPROTECT(2);
return removeAttrib(vec, name);
}
/* We allow attempting to remove names from NULL */
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if (NAMED(val)) val = duplicate(val);
SET_NAMED(val, NAMED(val) | NAMED(vec));
UNPROTECT(2);
if (name == R_NamesSymbol)
return namesgets(vec, val);
else if (name == R_DimSymbol)
return dimgets(vec, val);
else if (name == R_DimNamesSymbol)
return dimnamesgets(vec, val);
else if (name == R_ClassSymbol)
return classgets(vec, val);
else if (name == R_TspSymbol)
return tspgets(vec, val);
else if (name == R_CommentSymbol)
return commentgets(vec, val);
else if (name == R_RowNamesSymbol)
return row_names_gets(vec, val);
else
return installAttrib(vec, name, val);
}
SEXP numeric_deriv(SEXP args)
{
SEXP theta, expr, rho, ans, ans1, gradient, par, dimnames;
double tt, xx, delta, eps = sqrt(DOUBLE_EPS);
int start, i, j;
expr = CADR(args);
if(!isString(theta = CADDR(args)))
error("theta should be of type character");
if(!isEnvironment(rho = CADDDR(args)))
error("rho should be an environment");
PROTECT(ans = coerceVector(eval(expr, rho), REALSXP));
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), LENGTH(theta)));
for(i = 0, start = 0; i < LENGTH(theta); i++, start += LENGTH(ans)) {
PROTECT(par = findVar(install(CHAR(STRING_ELT(theta, i))), rho));
tt = REAL(par)[0];
xx = fabs(tt);
delta = (xx < 1) ? eps : xx*eps;
REAL(par)[0] += delta;
PROTECT(ans1 = coerceVector(eval(expr, rho), REALSXP));
for(j = 0; j < LENGTH(ans); j++)
REAL(gradient)[j + start] =
(REAL(ans1)[j] - REAL(ans)[j])/delta;
REAL(par)[0] = tt;
UNPROTECT(2); /* par, ans1 */
}
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 1, theta);
dimnamesgets(gradient, dimnames);
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(3); /* ans gradient dimnames */
return ans;
}
SEXP attribute_hidden do_earg_matrix(SEXP call, SEXP op, SEXP arg_vals, SEXP arg_snr, SEXP arg_snc, SEXP arg_byrow,
SEXP arg_dimnames, SEXP arg_miss_nr, SEXP arg_miss_nc, SEXP rho)
{
SEXP vals, ans, snr, snc, dimnames;
int nr = 1, nc = 1, byrow, miss_nr, miss_nc;
R_xlen_t lendat;
vals = arg_vals;
switch(TYPEOF(vals)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
case EXPRSXP:
case VECSXP:
break;
default:
error(_("'data' must be of a vector type, was '%s'"),
type2char(TYPEOF(vals)));
}
lendat = XLENGTH(vals);
snr = arg_snr;
snc = arg_snc;
byrow = asLogical(arg_byrow);
if (byrow == NA_INTEGER)
error(_("invalid '%s' argument"), "byrow");
dimnames = arg_dimnames;
miss_nr = asLogical(arg_miss_nr);
miss_nc = asLogical(arg_miss_nc);
if (!miss_nr) {
if (!isNumeric(snr)) error(_("non-numeric matrix extent"));
nr = asInteger(snr);
if (nr == NA_INTEGER)
error(_("invalid 'nrow' value (too large or NA)"));
if (nr < 0)
error(_("invalid 'nrow' value (< 0)"));
}
if (!miss_nc) {
if (!isNumeric(snc)) error(_("non-numeric matrix extent"));
nc = asInteger(snc);
if (nc == NA_INTEGER)
error(_("invalid 'ncol' value (too large or NA)"));
if (nc < 0)
error(_("invalid 'ncol' value (< 0)"));
}
if (miss_nr && miss_nc) {
if (lendat > INT_MAX) error("data is too long");
nr = (int) lendat;
} else if (miss_nr) {
if (lendat > (double) nc * INT_MAX) error("data is too long");
// avoid division by zero
if (nc == 0) {
if (lendat) error(_("nc = 0 for non-null data"));
else nr = 0;
} else
nr = (int) ceil((double) lendat / (double) nc);
} else if (miss_nc) {
if (lendat > (double) nr * INT_MAX) error("data is too long");
// avoid division by zero
if (nr == 0) {
if (lendat) error(_("nr = 0 for non-null data"));
else nc = 0;
} else
nc = (int) ceil((double) lendat / (double) nr);
}
if(lendat > 0) {
R_xlen_t nrc = (R_xlen_t) nr * nc;
if (lendat > 1 && nrc % lendat != 0) {
if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
((lendat < nr) && (nr / lendat) * lendat != nr))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d]"), lendat, nr);
else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
((lendat < nc) && (nc / lendat) * lendat != nc))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d]"), lendat, nc);
}
else if ((lendat > 1) && (nrc == 0)){
warning(_("data length exceeds size of matrix"));
}
}
#ifndef LONG_VECTOR_SUPPORT
if ((double)nr * (double)nc > INT_MAX)
error(_("too many elements specified"));
#endif
PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
if(lendat) {
if (isVector(vals))
copyMatrix(ans, vals, byrow);
else
copyListMatrix(ans, vals, byrow);
} else if (isVector(vals)) { /* fill with NAs */
R_xlen_t N = (R_xlen_t) nr * nc, i;
switch(TYPEOF(vals)) {
case STRSXP:
for (i = 0; i < N; i++)
SET_STRING_ELT(ans, i, NA_STRING);
break;
case LGLSXP:
for (i = 0; i < N; i++)
LOGICAL(ans)[i] = NA_LOGICAL;
break;
case INTSXP:
for (i = 0; i < N; i++)
INTEGER(ans)[i] = NA_INTEGER;
break;
case REALSXP:
for (i = 0; i < N; i++)
REAL(ans)[i] = NA_REAL;
break;
case CPLXSXP:
{
Rcomplex na_cmplx;
na_cmplx.r = NA_REAL;
na_cmplx.i = 0;
for (i = 0; i < N; i++)
COMPLEX(ans)[i] = na_cmplx;
}
break;
case RAWSXP:
memset(RAW(ans), 0, N);
break;
default:
/* don't fill with anything */
;
}
}
if(!isNull(dimnames)&& length(dimnames) > 0)
ans = dimnamesgets(ans, dimnames);
UNPROTECT(1);
return ans;
}
