/* zeroin(f, xmin, xmax, tol, maxiter) */
SEXP do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
int iter;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
args = CDR(args);
/* maxiter */
iter = asInteger(CAR(args));
if (iter <= 0)
errorcall(call, _("'maxiter' must be positive"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
PROTECT(res = allocVector(REALSXP, 3));
REAL(res)[0] =
R_zeroin(xmin, xmax, (double (*)(double, void*)) fcn2,
(void *) &info, &tol, &iter);
REAL(res)[1] = (double)iter;
REAL(res)[2] = tol;
UNPROTECT(2);
return res;
}
/* zeroin2(f, ax, bx, f.ax, f.bx, tol, maxiter) */
SEXP zeroin2(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double f_ax, f_bx;
double xmin, xmax, tol;
int iter;
SEXP v, res;
struct callinfo info;
args = CDR(args);
PrintDefaults();
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v)) error(_("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin)) error(_("invalid '%s' value"), "xmin");
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax)) error(_("invalid '%s' value"), "xmax");
if (xmin >= xmax) error(_("'xmin' not less than 'xmax'"));
args = CDR(args);
/* f(ax) = f(xmin) */
f_ax = asReal(CAR(args));
if (ISNA(f_ax)) error(_("NA value for '%s' is not allowed"), "f.lower");
args = CDR(args);
/* f(bx) = f(xmax) */
f_bx = asReal(CAR(args));
if (ISNA(f_bx)) error(_("NA value for '%s' is not allowed"), "f.upper");
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0) error(_("invalid '%s' value"), "tol");
args = CDR(args);
/* maxiter */
iter = asInteger(CAR(args));
if (iter <= 0) error(_("'maxiter' must be positive"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
PROTECT(res = allocVector(REALSXP, 3));
REAL(res)[0] =
R_zeroin2(xmin, xmax, f_ax, f_bx, (double (*)(double, void*)) fcn2,
(void *) &info, &tol, &iter);
REAL(res)[1] = (double)iter;
REAL(res)[2] = tol;
UNPROTECT(2);
return res;
}
SEXP do_prmatrix(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int quote;
SEXP a, x, rowlab, collab, naprint;
char *rowname = NULL, *colname = NULL;
checkArity(op,args);
PrintDefaults(rho);
a = args;
x = CAR(a); a = CDR(a);
rowlab = CAR(a); a = CDR(a);
collab = CAR(a); a = CDR(a);
quote = asInteger(CAR(a)); a = CDR(a);
R_print.right = asInteger(CAR(a)); a = CDR(a);
naprint = CAR(a);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
errorcall(call, _("invalid 'na.print' specification"));
R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
R_print.na_width = R_print.na_width_noquote =
strlen(CHAR(R_print.na_string));
}
if (length(rowlab) == 0) rowlab = R_NilValue;
if (length(collab) == 0) collab = R_NilValue;
if (!isNull(rowlab) && !isString(rowlab))
errorcall(call, _("invalid row labels"));
if (!isNull(collab) && !isString(collab))
errorcall(call, _("invalid column labels"));
printMatrix(x, 0, getAttrib(x, R_DimSymbol), quote, R_print.right,
rowlab, collab, rowname, colname);
PrintDefaults(rho); /* reset, as na.print.etc may have been set */
return x;
}/* do_prmatrix */
/* fmin(f, xmin, xmax tol) */
SEXP do_fmin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue));
PROTECT(res = allocVector(REALSXP, 1));
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
REAL(res)[0] = Brent_fmin(xmin, xmax,
(double (*)(double, void*)) fcn1, &info, tol);
UNPROTECT(2);
return res;
}
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
right, useS4)) */
SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, naprint;
int tryS4;
Rboolean callShow = FALSE;
checkArity(op, args);
PrintDefaults(rho);
x = CAR(args); args = CDR(args);
if(!isNull(CAR(args))) {
R_print.digits = asInteger(CAR(args));
if (R_print.digits == NA_INTEGER ||
R_print.digits < R_MIN_DIGITS_OPT ||
R_print.digits > R_MAX_DIGITS_OPT)
errorcall(call, _("invalid 'digits' argument"));
}
args = CDR(args);
R_print.quote = asLogical(CAR(args));
if(R_print.quote == NA_LOGICAL)
errorcall(call, _("invalid 'quote' argument"));
args = CDR(args);
naprint = CAR(args);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
errorcall(call, _("invalid 'na.print' specification"));
R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
R_print.na_width = R_print.na_width_noquote =
strlen(CHAR(R_print.na_string));
}
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.gap = asInteger(CAR(args));
if (R_print.gap == NA_INTEGER || R_print.gap < 0)
errorcall(call, _("'gap' must be non-negative integer"));
}
args = CDR(args);
R_print.right = asLogical(CAR(args));
if(R_print.right == NA_LOGICAL)
errorcall(call, _("invalid 'right' argument"));
args = CDR(args);
tryS4 = asLogical(CAR(args));
if(tryS4 == NA_LOGICAL)
errorcall(call, _("invalid 'tryS4' internal argument"));
if(tryS4 && isObject(x) && isMethodsDispatchOn()) {
SEXP class = getAttrib(x, R_ClassSymbol);
if(length(class) == 1) {
/* internal version of isClass() */
char str[201];
snprintf(str, 200, ".__C__%s", CHAR(STRING_ELT(class, 0)));
if(findVar(install(str), rho) != R_UnboundValue)
callShow = TRUE;
}
}
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;
args = CDR(args);
PrintDefaults();
state = (function_info *) R_alloc(1, sizeof(function_info));
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
error(_("attempt to minimize non-function"));
PROTECT(state->R_fcall = lang2(v, R_NilValue));
args = CDR(args);
/* `p' : inital parameter value */
n = 0;
x = fixparam(CAR(args), &n);
args = CDR(args);
/* `hessian' : H. required? */
want_hessian = asLogical(CAR(args));
if (want_hessian == NA_LOGICAL) want_hessian = 0;
args = CDR(args);
/* `typsize' : typical size of parameter elements */
typsiz = fixparam(CAR(args), &n);
args = CDR(args);
/* `fscale' : expected function size */
fscale = asReal(CAR(args));
if (ISNA(fscale)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `msg' (bit pattern) */
omsg = msg = asInteger(CAR(args));
if (msg == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
ndigit = asInteger(CAR(args));
if (ndigit == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
gradtl = asReal(CAR(args));
if (ISNA(gradtl)) error(_("invalid NA value in parameter"));
args = CDR(args);
stepmx = asReal(CAR(args));
if (ISNA(stepmx)) error(_("invalid NA value in parameter"));
args = CDR(args);
steptol = asReal(CAR(args));
if (ISNA(steptol)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `iterlim' (def. 100) */
itnlim = asInteger(CAR(args));
if (itnlim == NA_INTEGER) error(_("invalid NA value in parameter"));
state->R_env = rho;
/* force one evaluation to check for the gradient and hessian */
iagflg = 0; /* No analytic gradient */
iahflg = 0; /* No analytic hessian */
state->have_gradient = 0;
state->have_hessian = 0;
R_gradientSymbol = install("gradient");
R_hessianSymbol = install("hessian");
/* This vector is shared with all subsequent calls */
v = allocVector(REALSXP, n);
for (i = 0; i < n; i++) REAL(v)[i] = x[i];
SETCADR(state->R_fcall, v);
SET_NAMED(v, 2); // in case the functions try to alter it
value = eval(state->R_fcall, state->R_env);
v = getAttrib(value, R_gradientSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == n && (isReal(v) || isInteger(v))) {
iagflg = 1;
state->have_gradient = 1;
v = getAttrib(value, R_hessianSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == (n * n) && (isReal(v) || isInteger(v))) {
iahflg = 1;
state->have_hessian = 1;
} else {
warning(_("hessian supplied is of the wrong length or mode, so ignored"));
}
}
} else {
warning(_("gradient supplied is of the wrong length or mode, so ignored"));
}
}
if (((msg/4) % 2) && !iahflg) { /* skip check of analytic Hessian */
msg -= 4;
}
if (((msg/2) % 2) && !iagflg) { /* skip check of analytic gradient */
msg -= 2;
}
FT_init(n, FT_SIZE, state);
/* Plug in the call to the optimizer here */
method = 1; /* Line Search */
iexp = iahflg ? 0 : 1; /* Function calls are expensive */
dlt = 1.0;
xpls = (double*)R_alloc(n, sizeof(double));
gpls = (double*)R_alloc(n, sizeof(double));
a = (double*)R_alloc(n*n, sizeof(double));
wrk = (double*)R_alloc(8*n, sizeof(double));
/*
* Dennis + Schnabel Minimizer
*
* SUBROUTINE OPTIF9(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
* + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
* + DLT,GRADTL,STEPMX,STEPTOL,
* + XPLS,FPLS,GPLS,ITRMCD,A,WRK)
*
*
* Note: I have figured out what msg does.
* It is actually a sum of bit flags as follows
* 1 = don't check/warn for 1-d problems
* 2 = don't check analytic gradients
* 4 = don't check analytic hessians
* 8 = don't print start and end info
* 16 = print at every iteration
* Using msg=9 is absolutely minimal
* I think we always check gradients and hessians
*/
optif9(n, n, x, (fcn_p) fcn, (fcn_p) Cd1fcn, (d2fcn_p) Cd2fcn,
state, typsiz, fscale, method, iexp, &msg, ndigit, itnlim,
iagflg, iahflg, dlt, gradtl, stepmx, steptol, xpls, &fpls,
gpls, &code, a, wrk, &itncnt);
if (msg < 0)
opterror(msg);
if (code != 0 && (omsg&8) == 0)
optcode(code);
if (want_hessian) {
PROTECT(value = allocVector(VECSXP, 6));
PROTECT(names = allocVector(STRSXP, 6));
fdhess(n, xpls, fpls, (fcn_p) fcn, state, a, n, &wrk[0], &wrk[n],
ndigit, typsiz);
for (i = 0; i < n; i++)
for (j = 0; j < i; j++)
a[i + j * n] = a[j + i * n];
}
else {
PROTECT(value = allocVector(VECSXP, 5));
PROTECT(names = allocVector(STRSXP, 5));
}
k = 0;
SET_STRING_ELT(names, k, mkChar("minimum"));
SET_VECTOR_ELT(value, k, ScalarReal(fpls));
k++;
SET_STRING_ELT(names, k, mkChar("estimate"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = xpls[i];
k++;
SET_STRING_ELT(names, k, mkChar("gradient"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = gpls[i];
k++;
if (want_hessian) {
SET_STRING_ELT(names, k, mkChar("hessian"));
SET_VECTOR_ELT(value, k, allocMatrix(REALSXP, n, n));
for (i = 0; i < n * n; i++)
REAL(VECTOR_ELT(value, k))[i] = a[i];
k++;
}
SET_STRING_ELT(names, k, mkChar("code"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = code;
k++;
/* added by Jim K Lindsey */
SET_STRING_ELT(names, k, mkChar("iterations"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = itncnt;
k++;
setAttrib(value, R_NamesSymbol, names);
UNPROTECT(3);
return value;
}
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
right, max, useS4)) */
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, naprint;
int tryS4;
Rboolean callShow = FALSE;
checkArity(op, args);
PrintDefaults();
x = CAR(args); args = CDR(args);
if(!isNull(CAR(args))) {
R_print.digits = asInteger(CAR(args));
if (R_print.digits == NA_INTEGER ||
R_print.digits < R_MIN_DIGITS_OPT ||
R_print.digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
}
args = CDR(args);
R_print.quote = asLogical(CAR(args));
if(R_print.quote == NA_LOGICAL)
error(_("invalid '%s' argument"), "quote");
args = CDR(args);
naprint = CAR(args);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
error(_("invalid 'na.print' specification"));
R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
R_print.na_width = R_print.na_width_noquote =
(int) strlen(CHAR(R_print.na_string));
}
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.gap = asInteger(CAR(args));
if (R_print.gap == NA_INTEGER || R_print.gap < 0)
error(_("'gap' must be non-negative integer"));
}
args = CDR(args);
R_print.right = (Rprt_adj) asLogical(CAR(args)); /* Should this be asInteger()? */
if(R_print.right == NA_LOGICAL)
error(_("invalid '%s' argument"), "right");
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.max = asInteger(CAR(args));
if(R_print.max == NA_INTEGER || R_print.max < 0)
error(_("invalid '%s' argument"), "max");
else if(R_print.max == INT_MAX) R_print.max--; // so we can add
}
args = CDR(args);
R_print.useSource = asLogical(CAR(args));
if(R_print.useSource == NA_LOGICAL)
error(_("invalid '%s' argument"), "useSource");
if(R_print.useSource) R_print.useSource = USESOURCE;
args = CDR(args);
tryS4 = asLogical(CAR(args));
if(tryS4 == NA_LOGICAL)
error(_("invalid 'tryS4' internal argument"));
if(tryS4 && IS_S4_OBJECT(x) && isMethodsDispatchOn())
callShow = TRUE;
if(callShow) {
/* we need to get show from the methods namespace if it is
not visible on the search path. */
SEXP call, showS;
showS = findVar(install("show"), rho);
if(showS == R_UnboundValue) {
SEXP methodsNS = R_FindNamespace(mkString("methods"));
if(methodsNS == R_UnboundValue)
error("missing methods namespace: this should not happen");
PROTECT(methodsNS);
showS = findVarInFrame3(methodsNS, install("show"), TRUE);
UNPROTECT(1);
if(showS == R_UnboundValue)
error("missing show() in methods namespace: this should not happen");
}
PROTECT(call = lang2(showS, x));
eval(call, rho);
UNPROTECT(1);
} else {
CustomPrintValue(x, rho);
}
PrintDefaults(); /* reset, as na.print etc may have been set */
return x;
}/* do_printdefault */
SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, sep, rnames, eol, na, dec, quote, xj;
int nr, nc, i, j, qmethod;
Rboolean wasopen, quote_rn = FALSE, *quote_col;
Rconnection con;
const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */;
char cdec;
SEXP *levels;
R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};
wt_info wi;
RCNTXT cntxt;
args = CDR(args);
x = CAR(args); args = CDR(args);
/* this is going to be a connection open or openable for writing */
if(!inherits(CAR(args), "connection"))
error(_("'file' is not a connection"));
con = getConnection(asInteger(CAR(args))); args = CDR(args);
if(!con->canwrite)
error(_("cannot write to this connection"));
wasopen = con->isopen;
if(!wasopen) {
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
}
nr = asInteger(CAR(args)); args = CDR(args);
nc = asInteger(CAR(args)); args = CDR(args);
rnames = CAR(args); args = CDR(args);
sep = CAR(args); args = CDR(args);
eol = CAR(args); args = CDR(args);
na = CAR(args); args = CDR(args);
dec = CAR(args); args = CDR(args);
quote = CAR(args); args = CDR(args);
qmethod = asLogical(CAR(args));
if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr");
if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc");
if(!isNull(rnames) && !isString(rnames))
error(_("invalid '%s' argument"), "rnames");
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
if(!isString(eol)) error(_("invalid '%s' argument"), "eol");
if(!isString(na)) error(_("invalid '%s' argument"), "na");
if(!isString(dec)) error(_("invalid '%s' argument"), "dec");
if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod");
csep = translateChar(STRING_ELT(sep, 0));
ceol = translateChar(STRING_ELT(eol, 0));
cna = translateChar(STRING_ELT(na, 0));
sdec = translateChar(STRING_ELT(dec, 0));
if(strlen(sdec) != 1)
error(_("'dec' must be a single character"));
cdec = sdec[0];
quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean));
for(j = 0; j < nc; j++) quote_col[j] = FALSE;
for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */
int this = INTEGER(quote)[i];
if(this == 0) quote_rn = TRUE;
if(this > 0) quote_col[this - 1] = TRUE;
}
R_AllocStringBuffer(0, &strBuf);
PrintDefaults();
wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */
wi.con = con;
wi.wasopen = wasopen;
wi.buf = &strBuf;
begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &wt_cleanup;
cntxt.cenddata = &wi;
if(isVectorList(x)) { /* A data frame */
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We do not assume factors have integer levels,
although they should. */
if(TYPEOF(xj) == INTSXP)
tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1,
quote_col[j], qmethod,
&strBuf, cdec);
else if(TYPEOF(xj) == REALSXP)
tmp = EncodeElement2(levels[j],
(int) (REAL(xj)[i] - 1),
quote_col[j], qmethod,
&strBuf, cdec);
else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElement2(xj, i, quote_col[j], qmethod,
&strBuf, cdec);
}
/* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
} else { /* A matrix */
if(!isVectorAtomic(x))
UNIMPLEMENTED_TYPE("write.table, matrix method", x);
/* quick integrity check */
if(LENGTH(x) != nr * nc)
error(_("corrupt matrix -- dims not not match length"));
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(x, i + j*nr)) tmp = cna;
else {
tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod,
&strBuf, cdec);
/* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
}
endcontext(&cntxt);
wt_cleanup(&wi);
return R_NilValue;
}
SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
{
cat_info ci;
RCNTXT cntxt;
SEXP objs, file, fill, sepr, labs, s;
int ifile;
Rconnection con;
int append;
int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines;
char buf[512];
const char *p = "";
checkArity(op, args);
/* Use standard printing defaults */
PrintDefaults();
objs = CAR(args);
args = CDR(args);
file = CAR(args);
ifile = asInteger(file);
con = getConnection(ifile);
if(!con->canwrite) /* if it is not open, we may not know yet */
error(_("cannot write to this connection"));
args = CDR(args);
sepr = CAR(args);
if (!isString(sepr))
error(_("invalid '%s' specification"), "sep");
nlsep = 0;
for (i = 0; i < LENGTH(sepr); i++)
if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */
args = CDR(args);
fill = CAR(args);
if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1))
error(_("invalid '%s' argument"), "fill");
if (isLogical(fill)) {
if (asLogical(fill) == 1)
pwidth = R_print.width;
else
pwidth = INT_MAX;
}
else pwidth = asInteger(fill);
if(pwidth <= 0) {
warning(_("non-positive 'fill' argument will be ignored"));
pwidth = INT_MAX;
}
args = CDR(args);
labs = CAR(args);
if (!isString(labs) && labs != R_NilValue)
error(_("invalid '%s' argument"), "labels");
lablen = length(labs);
args = CDR(args);
append = asLogical(CAR(args));
if (append == NA_LOGICAL)
error(_("invalid '%s' specification"), "append");
ci.wasopen = con->isopen;
ci.changedcon = switch_stdout(ifile, 0);
/* will open new connection if required, and check for writeable */
#ifdef Win32
/* do this after re-sinking output */
WinCheckUTF8();
#endif
ci.con = con;
/* set up a context which will close the connection if there is an error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &cat_cleanup;
cntxt.cenddata = &ci;
nobjs = length(objs);
width = 0;
ntot = 0;
nlines = 0;
for (iobj = 0; iobj < nobjs; iobj++) {
s = VECTOR_ELT(objs, iobj);
if (iobj != 0 && !isNull(s))
cat_printsep(sepr, ntot++);
n = length(s);
/* 0-length objects are ignored */
if (n > 0) {
if (labs != R_NilValue && (iobj == 0)
&& (asInteger(fill) > 0)) {
Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen)));
/* FIXME -- Rstrlen allows for double-width chars */
width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1;
nlines++;
}
if (isString(s))
p = trChar(STRING_ELT(s, 0));
else if (isSymbol(s)) /* length 1 */
p = CHAR(PRINTNAME(s));
else if (isVectorAtomic(s)) {
/* Not a string, as that is covered above.
Thus the maximum size is about 60.
The copy is needed as cat_newline might reuse the buffer.
Use strncpy is in case these assumptions change.
*/
p = EncodeElement0(s, 0, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
#ifdef fixed_cat
else if (isVectorList(s)) {
/* FIXME: call EncodeElement() for every element of s.
Real Problem: `s' can be large;
should do line breaking etc.. (buf is of limited size)
*/
}
#endif
else
errorcall(call,
_("argument %d (type '%s') cannot be handled by 'cat'"),
1+iobj, type2char(TYPEOF(s)));
/* FIXME : cat(...) should handle ANYTHING */
size_t w = strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
if ((iobj > 0) && (width + w + sepw > pwidth)) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
for (i = 0; i < n; i++, ntot++) {
Rprintf("%s", p);
width += (int)(w + sepw);
if (i < (n - 1)) {
cat_printsep(sepr, ntot);
if (isString(s))
p = trChar(STRING_ELT(s, i+1));
else {
p = EncodeElement0(s, i+1, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
w = (int) strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
/* This is inconsistent with the version above.
As from R 2.3.0, fill <= 0 is ignored. */
if ((width + w + sepw > pwidth) && pwidth) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
} else ntot--; /* we don't print sep after last, so don't advance */
}
}
}
if ((pwidth != INT_MAX) || nlsep)
Rprintf("\n");
/* end the context after anything that could raise an error but before
doing the cleanup so the cleanup doesn't get done twice */
endcontext(&cntxt);
cat_cleanup(&ci);
return R_NilValue;
}
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x;
int digits, nsmall, no = 1, w, d, e, wi, di, ei;
checkArity(op, args);
x = CAR(args);
R_xlen_t n = XLENGTH(x);
PrintDefaults();
digits = asInteger(CADR(args));
if (!isNull(CADR(args))) {
digits = asInteger(CADR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
nsmall = asInteger(CADDR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
w = 0;
d = 0;
e = 0;
switch (TYPEOF(x)) {
case RAWSXP:
formatRaw(RAW(x), n, &w);
break;
case LGLSXP:
formatLogical(LOGICAL(x), n, &w);
break;
case INTSXP:
formatInteger(INTEGER(x), n, &w);
break;
case REALSXP:
no = 3;
formatReal(REAL(x), n, &w, &d, &e, nsmall);
break;
case CPLXSXP:
no = 6;
wi = di = ei = 0;
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
break;
case STRSXP:
for (R_xlen_t i = 0; i < n; i++)
if (STRING_ELT(x, i) != NA_STRING) {
int il = Rstrlen(STRING_ELT(x, i), 0);
if (il > w) w = il;
}
break;
default:
error(_("atomic vector arguments only"));
}
x = allocVector(INTSXP, no);
INTEGER(x)[0] = w;
if(no > 1) {
INTEGER(x)[1] = d;
INTEGER(x)[2] = e;
}
if(no > 3) {
INTEGER(x)[3] = wi;
INTEGER(x)[4] = di;
INTEGER(x)[5] = ei;
}
return x;
}
/* Note that NA_STRING is not handled separately here. This is
deliberate -- see ?paste -- and implicitly coerces it to "NA"
*/
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, collapse, sep, x;
int sepw, u_sepw, ienc;
R_xlen_t i, j, k, maxlen, nx, pwidth;
const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
char *buf;
Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
use_sep = (PRIMVAL(op) == 0);
const void *vmax;
checkArity(op, args);
/* We use formatting and so we must initialize printing. */
PrintDefaults();
/* Check the arguments */
x = CAR(args);
if (!isVectorList(x))
error(_("invalid first argument"));
nx = xlength(x);
if(use_sep) { /* paste(..., sep, .) */
sep = CADR(args);
if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
error(_("invalid separator"));
sep = STRING_ELT(sep, 0);
csep = translateChar(sep);
u_sepw = sepw = (int) strlen(csep); // will be short
sepASCII = strIsASCII(csep);
sepKnown = ENC_KNOWN(sep) > 0;
sepUTF8 = IS_UTF8(sep);
sepBytes = IS_BYTES(sep);
collapse = CADDR(args);
} else { /* paste0(..., .) */
u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
collapse = CADR(args);
}
if (!isNull(collapse))
if(!isString(collapse) || LENGTH(collapse) <= 0 ||
STRING_ELT(collapse, 0) == NA_STRING)
error(_("invalid '%s' argument"), "collapse");
if(nx == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
/* Maximum argument length, coerce if needed */
maxlen = 0;
for (j = 0; j < nx; j++) {
if (!isString(VECTOR_ELT(x, j))) {
/* formerly in R code: moved to C for speed */
SEXP call, xj = VECTOR_ELT(x, j);
if(OBJECT(xj)) { /* method dispatch */
PROTECT(call = lang2(install("as.character"), xj));
SET_VECTOR_ELT(x, j, eval(call, env));
UNPROTECT(1);
} else if (isSymbol(xj))
SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
else
SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
if (!isString(VECTOR_ELT(x, j)))
error(_("non-string argument to internal 'paste'"));
}
if(xlength(VECTOR_ELT(x, j)) > maxlen)
maxlen = xlength(VECTOR_ELT(x, j));
}
if(maxlen == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
PROTECT(ans = allocVector(STRSXP, maxlen));
for (i = 0; i < maxlen; i++) {
/* Strategy for marking the encoding: if all inputs (including
* the separator) are ASCII, so is the output and we don't
* need to mark. Otherwise if all non-ASCII inputs are of
* declared encoding, we should mark.
* Need to be careful only to include separator if it is used.
*/
anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
if(nx > 1) {
allKnown = sepKnown || sepASCII;
anyKnown = sepKnown;
use_UTF8 = sepUTF8;
use_Bytes = sepBytes;
}
pwidth = 0;
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if(IS_UTF8(cs)) use_UTF8 = TRUE;
if(IS_BYTES(cs)) use_Bytes = TRUE;
}
}
if (use_Bytes) use_UTF8 = FALSE;
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
if(use_Bytes)
pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else if(use_UTF8)
pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else
pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
vmaxset(vmax);
}
}
if(use_sep) {
if (use_UTF8 && !u_csep) {
u_csep = translateCharUTF8(sep);
u_sepw = (int) strlen(u_csep); // will be short
}
pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
}
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if (use_UTF8) {
s = translateCharUTF8(cs);
strcpy(buf, s);
buf += strlen(s);
} else {
s = use_Bytes ? CHAR(cs) : translateChar(cs);
strcpy(buf, s);
buf += strlen(s);
allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
}
}
if (sepw != 0 && j != nx - 1) {
if (use_UTF8) {
strcpy(buf, u_csep);
buf += u_sepw;
} else {
strcpy(buf, csep);
buf += sepw;
}
}
vmax = vmaxget();
}
ienc = 0;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
}
/* Now collapse, if required. */
if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
sep = STRING_ELT(collapse, 0);
use_UTF8 = IS_UTF8(sep);
use_Bytes = IS_BYTES(sep);
for (i = 0; i < nx; i++) {
if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
}
if(use_Bytes) {
csep = CHAR(sep);
use_UTF8 = FALSE;
} else if(use_UTF8)
csep = translateCharUTF8(sep);
else
csep = translateChar(sep);
sepw = (int) strlen(csep);
anyKnown = ENC_KNOWN(sep) > 0;
allKnown = anyKnown || strIsASCII(csep);
pwidth = 0;
vmax = vmaxget();
for (i = 0; i < nx; i++)
if(use_UTF8) {
pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
vmaxset(vmax);
} else /* already translated */
pwidth += strlen(CHAR(STRING_ELT(ans, i)));
pwidth += (nx - 1) * sepw;
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (i = 0; i < nx; i++) {
if(i > 0) {
strcpy(buf, csep);
buf += sepw;
}
if(use_UTF8)
s = translateCharUTF8(STRING_ELT(ans, i));
else /* already translated */
s = CHAR(STRING_ELT(ans, i));
strcpy(buf, s);
while (*buf)
buf++;
allKnown = allKnown &&
(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
if(use_UTF8) vmaxset(vmax);
}
UNPROTECT(1);
ienc = CE_NATIVE;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
}
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return ans;
}
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
scientific) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP l, x, y, swd;
int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
int w, d, e;
int wi, di, ei, scikeep;
const char *strp;
R_xlen_t i, n;
checkArity(op, args);
PrintDefaults();
scikeep = R_print.scipen;
if (isEnvironment(x = CAR(args))) {
return mkString(EncodeEnvironment(x));
}
else if (!isVector(x))
error(_("first argument must be atomic"));
args = CDR(args);
trim = asLogical(CAR(args));
if (trim == NA_INTEGER)
error(_("invalid '%s' argument"), "trim");
args = CDR(args);
if (!isNull(CAR(args))) {
digits = asInteger(CAR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
args = CDR(args);
nsmall = asInteger(CAR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
args = CDR(args);
if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
if(wd == NA_INTEGER)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
adj = asInteger(CAR(args));
if(adj == NA_INTEGER || adj < 0 || adj > 3)
error(_("invalid '%s' argument"), "justify");
args = CDR(args);
na = asLogical(CAR(args));
if(na == NA_LOGICAL)
error(_("invalid '%s' argument"), "na.encode");
args = CDR(args);
if(LENGTH(CAR(args)) != 1)
error(_("invalid '%s' argument"), "scientific");
if(isLogical(CAR(args))) {
int tmp = LOGICAL(CAR(args))[0];
if(tmp == NA_LOGICAL) sci = NA_INTEGER;
else sci = tmp > 0 ?-100 : 100;
} else if (isNumeric(CAR(args))) {
sci = asInteger(CAR(args));
} else
error(_("invalid '%s' argument"), "scientific");
if(sci != NA_INTEGER) R_print.scipen = sci;
if ((n = XLENGTH(x)) <= 0) {
PROTECT(y = allocVector(STRSXP, 0));
} else {
switch (TYPEOF(x)) {
case LGLSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeLogical(LOGICAL(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case INTSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0;
else formatInteger(INTEGER(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeInteger(INTEGER(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case REALSXP:
formatReal(REAL(x), n, &w, &d, &e, nsmall);
if (trim) w = 0;
w = imax2(w, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case CPLXSXP:
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
if (trim) wi = w = 0;
w = imax2(w, wd); wi = imax2(wi, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case STRSXP:
{
/* this has to be different from formatString/EncodeString as
we don't actually want to encode here */
const char *s;
char *q;
int b, b0, cnt = 0, j;
SEXP s0, xx;
/* This is clumsy, but it saves rewriting and re-testing
this complex code */
PROTECT(xx = duplicate(x));
for (i = 0; i < n; i++) {
SEXP tmp = STRING_ELT(xx, i);
if(IS_BYTES(tmp)) {
const char *p = CHAR(tmp), *q;
char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
for (q = p; *q; q++) {
unsigned char k = (unsigned char) *q;
if (k >= 0x20 && k < 0x80) {
*qq++ = *q;
} else {
snprintf(buf, 5, "\\x%02x", k);
for(int j = 0; j < 4; j++) *qq++ = buf[j];
}
}
*qq = '\0';
s = pp;
} else s = translateChar(tmp);
if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
}
w = wd;
if (adj != Rprt_adj_none) {
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING)
w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
else if (na) w = imax2(w, R_print.na_width);
} else w = 0;
/* now calculate the buffer size needed, in bytes */
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING) {
il = Rstrlen(STRING_ELT(xx, i), 0);
cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
} else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
R_CheckStack2(cnt+1);
char buff[cnt+1];
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
if(!na && STRING_ELT(xx, i) == NA_STRING) {
SET_STRING_ELT(y, i, NA_STRING);
} else {
q = buff;
if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
else s0 = STRING_ELT(xx, i) ;
s = CHAR(s0);
il = Rstrlen(s0, 0);
b = w - il;
if(b > 0 && adj != Rprt_adj_left) {
b0 = (adj == Rprt_adj_centre) ? b/2 : b;
for(j = 0 ; j < b0 ; j++) *q++ = ' ';
b -= b0;
}
for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
if(b > 0 && adj != Rprt_adj_right)
for(j = 0 ; j < b ; j++) *q++ = ' ';
*q = '\0';
SET_STRING_ELT(y, i, mkChar(buff));
}
}
}
UNPROTECT(2); /* xx , y */
PROTECT(y);
break;
default:
error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
}
}
if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
setAttrib(y, R_DimSymbol, l);
if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(y, R_DimNamesSymbol, l);
} else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(y, R_NamesSymbol, l);
/* In case something else forgets to set PrintDefaults(), PR#14477 */
R_print.scipen = scikeep;
UNPROTECT(1); /* y */
return y;
}