char* Quartz_TranslateFontFamily(char* family, int face, char *devfamily) {
SEXP graphicsNS, quartzenv, fontdb, fontnames;
int i, nfonts;
char* result = devfamily;
PROTECT_INDEX xpi;
PROTECT(graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices"))));
PROTECT_WITH_INDEX(quartzenv = findVar(install(".Quartzenv"),
graphicsNS), &xpi);
if(TYPEOF(quartzenv) == PROMSXP)
REPROTECT(quartzenv = eval(quartzenv, graphicsNS), xpi);
PROTECT(fontdb = findVar(install(".Quartz.Fonts"), quartzenv));
PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
nfonts = LENGTH(fontdb);
if (strlen(family) > 0) {
int found = 0;
for (i=0; i<nfonts && !found; i++) {
char* fontFamily = CHAR(STRING_ELT(fontnames, i));
if (strcmp(family, fontFamily) == 0) {
found = 1;
result = SaveFontSpec(VECTOR_ELT(fontdb, i), face-1);
}
}
if (!found)
warning(_("Font family not found in Quartz font database"));
}
UNPROTECT(4);
return result;
}
SEXP GetPkgEnv(const char *pkgName)
{
SEXP pkgNS, pkgEnv;
PROTECT(pkgNS = R_FindNamespace(ScalarString(mkChar(pkgName))));
PROTECT(pkgEnv = Rf_findVar(install(".pkg.env"), pkgNS));
if(TYPEOF(pkgEnv) == PROMSXP) {
PROTECT(pkgEnv);
pkgEnv = eval(pkgEnv, pkgNS);
UNPROTECT(1);
}
UNPROTECT(2);
return pkgEnv;
}
SEXP InstanceObjectTable::methodClosure(const char *name) const {
static SEXP qtbaseNS = R_FindNamespace(mkString("qtbase"));
static SEXP qinvokeSym = install("qinvoke");
SEXP f, pf, body;
PROTECT(f = allocSExp(CLOSXP));
SET_CLOENV(f, qtbaseNS);
pf = allocList(1);
SET_FORMALS(f, pf);
SET_TAG(pf, R_DotsSymbol);
SETCAR(pf, R_MissingArg);
PROTECT(body =
lang4(qinvokeSym, _instance->sexp(), mkString(name), R_DotsSymbol));
SET_BODY(f, body);
UNPROTECT(2);
return f;
}
SEXP GetVarFromPkgEnv(const char *varName, const char *pkgName)
{
/* See grDevices/src/devPS getFontDB() */
SEXP pkgNS, pkgEnv, var;
PROTECT(pkgNS = R_FindNamespace(ScalarString(mkChar(pkgName))));
PROTECT(pkgEnv = Rf_findVar(install(".pkg.env"), pkgNS));
if(TYPEOF(pkgEnv) == PROMSXP) {
PROTECT(pkgEnv);
pkgEnv = eval(pkgEnv, pkgNS);
UNPROTECT(1);
}
PROTECT(var = Rf_findVar(install(varName), pkgEnv));
UNPROTECT(3);
return var;
}
static void curlCommon(CURL *hnd, int redirect, int verify)
{
const char *capath = getenv("CURL_CA_BUNDLE");
if (verify) {
if (capath && capath[0])
curl_easy_setopt(hnd, CURLOPT_CAINFO, capath);
#ifdef Win32
else
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYPEER, 0L);
#endif
} else {
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYHOST, 0L);
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYPEER, 0L);
}
// for consistency, but all that does is look up an option.
SEXP sMakeUserAgent = install("makeUserAgent");
SEXP agentFun = PROTECT(lang2(sMakeUserAgent, ScalarLogical(0)));
SEXP utilsNS = PROTECT(R_FindNamespace(mkString("utils")));
SEXP sua = eval(agentFun, utilsNS);
UNPROTECT(1); /* utilsNS */
PROTECT(sua);
if(TYPEOF(sua) != NILSXP)
curl_easy_setopt(hnd, CURLOPT_USERAGENT, CHAR(STRING_ELT(sua, 0)));
UNPROTECT(2);
int timeout0 = asInteger(GetOption1(install("timeout")));
long timeout = timeout0 = NA_INTEGER ? 0 : 1000L * timeout0;
curl_easy_setopt(hnd, CURLOPT_CONNECTTIMEOUT_MS, timeout);
curl_easy_setopt(hnd, CURLOPT_TIMEOUT_MS, timeout);
if (redirect) {
curl_easy_setopt(hnd, CURLOPT_FOLLOWLOCATION, 1L);
curl_easy_setopt(hnd, CURLOPT_MAXREDIRS, 20L);
}
int verbosity = asInteger(GetOption1(install("internet.info")));
if (verbosity < 2) curl_easy_setopt(hnd, CURLOPT_VERBOSE, 1L);
// enable the cookie engine, keep cookies in memory
curl_easy_setopt(hnd, CURLOPT_COOKIEFILE, "");
}
/*
Because we call this function via Rf_eval(), we end up
with an extra call on the stack when we enter recover.
*/
SEXP
stop(const char *className, const char *msg, ...)
{
char buf[10000];
SEXP error, e, ns_env, ns_name;
va_list ap;
va_start(ap, msg);
/* Rvsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap); */
vsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap);
va_end(ap);
PROTECT(error = mkString(buf));
/*
const char * classNames[] = {"simpleError", "error", "condition"};
PROTECT(tmp = allocVector(STRSXP, sizeof(classNames)/sizeof(classNames[0])));
for(i = 0; i < sizeof(classNames)/sizeof(classNames[0]); i++)
SET_STRING_ELT(tmp, i+1, mkChar(classNames[i]));
SET_STRING_ELT(tmp, 0, mkChar(className));
SET_CLASS(error, tmp);
*/
PROTECT(e = allocVector(LANGSXP, 2));
PROTECT(ns_name = mkString("XML"));
ns_env = R_FindNamespace(ns_name);
SETCAR(e, findVarInFrame(ns_env, Rf_install("xmlStop")));
SETCAR(CDR(e), error);
Rf_eval(e, R_GlobalEnv);
UNPROTECT(3);
/*
errorcall(error, "%s", msg);
UNPROTECT(1);
*/
return(error);
}
R_init_splusTimeSeries(DllInfo *dll)
{
R_registerRoutines(dll, cMethods, NULL, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
/* These are callable from other packages' C code: */
#define RREGDEF(name) R_RegisterCCallable("splusTimeSeries", #name, (DL_FUNC) name)
splusTimeSeries_NS = R_FindNamespace(mkString("splusTimeSeries"));
if(splusTimeSeries_NS == R_UnboundValue)
error("missing 'splusTimeSeries' namespace: should never happen");
#ifdef DEBUG_splusTimeSeries
if(isEnvironment(splusTimeSeries_NS))
Rprintf("splusTimeSeries_NS: %s\n",
CHAR(asChar(eval(lang2(install("format"),splusTimeSeries_NS),
R_GlobalEnv))));
else
#else
if(!isEnvironment(splusTimeSeries_NS))
#endif
error("splusTimeSeries namespace not determined correctly");
}
static void initialize_rlcompletion(void)
{
if(rcompgen_active >= 0) return;
/* Find if package utils is around */
if(rcompgen_active < 0) {
char *p = getenv("R_COMPLETION");
if(p && streql(p, "FALSE")) {
rcompgen_active = 0;
return;
}
/* First check if namespace is loaded */
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else { /* Then try to load it */
SEXP cmdSexp, cmdexpr;
ParseStatus status;
int i;
char *p = "try(loadNamespace('rcompgen'), silent=TRUE)";
PROTECT(cmdSexp = mkString(p));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if(status == PARSE_OK) {
for(i = 0; i < length(cmdexpr); i++)
eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
}
UNPROTECT(2);
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else {
rcompgen_active = 0;
return;
}
}
}
rcompgen_rho = R_FindNamespace(mkString("utils"));
RComp_assignBufferSym = install(".assignLinebuffer");
RComp_assignStartSym = install(".assignStart");
RComp_assignEndSym = install(".assignEnd");
RComp_assignTokenSym = install(".assignToken");
RComp_completeTokenSym = install(".completeToken");
RComp_getFileCompSym = install(".getFileComp");
RComp_retrieveCompsSym = install(".retrieveCompletions");
/* Tell the completer that we want a crack first. */
rl_attempted_completion_function = R_custom_completion;
/* Disable sorting of possible completions; only readline >= 6 */
#if RL_READLINE_VERSION >= 0x0600
/* if (rl_readline_version >= 0x0600) */
rl_sort_completion_matches = 0;
#endif
/* token boundaries. Includes *,+ etc, but not $,@ because those
are easier to handle at the R level if the whole thing is
available. However, this breaks filename completion if partial
filenames contain things like $, % etc. Might be possible to
associate a M-/ override like bash does. One compromise is that
we exclude / from the breakers because that is frequently found
in filenames even though it is also an operator. This can be
handled in R code (although it shouldn't be necessary if users
surround operators with spaces, as they should). */
/* FIXME: quotes currently lead to filename completion without any
further ado. This is not necessarily the best we can do, since
quotes after a [, $, [[, etc should be treated differently. I'm
not testing this now, but this should be doable by removing quote
characters from the strings below and handle it with other things
in 'specialCompletions()' in R. The problem with that approach
is that file name completion will probably have to be done
manually in R, which is not trivial. One way to go might be to
forego file name completion altogether when TAB completing, and
associate M-/ or something to filename completion (a startup
message might say so, to remind users)
All that might not be worth the pain though (vector names would
be practically impossible, to begin with) */
return;
}
R_init_Matrix(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
/* These are callable from other packages' C code: */
#define RREGDEF(name) R_RegisterCCallable("Matrix", #name, (DL_FUNC) name)
RREGDEF(Csparse_diagU2N);
RREGDEF(as_cholmod_dense);
RREGDEF(as_cholmod_factor);
RREGDEF(as_cholmod_sparse);
RREGDEF(chm_factor_to_SEXP);
RREGDEF(chm_factor_ldetL2);
RREGDEF(chm_factor_update);
RREGDEF(chm_sparse_to_SEXP);
RREGDEF(chm_triplet_to_SEXP);
RREGDEF(cholmod_l_aat);
RREGDEF(cholmod_l_add);
RREGDEF(cholmod_l_allocate_dense);
RREGDEF(cholmod_l_allocate_sparse);
RREGDEF(cholmod_l_allocate_triplet);
RREGDEF(cholmod_l_analyze);
RREGDEF(cholmod_l_analyze_p);
RREGDEF(cholmod_l_band_inplace);
RREGDEF(cholmod_l_change_factor);
RREGDEF(cholmod_l_copy);
RREGDEF(cholmod_l_copy_dense);
RREGDEF(cholmod_l_copy_factor);
RREGDEF(cholmod_l_copy_sparse);
RREGDEF(cholmod_l_defaults);
RREGDEF(cholmod_l_dense_to_sparse);
RREGDEF(cholmod_l_factor_to_sparse);
RREGDEF(cholmod_l_factorize);
RREGDEF(cholmod_l_factorize_p);
RREGDEF(cholmod_l_finish);
RREGDEF(cholmod_l_free_dense);
RREGDEF(cholmod_l_free_factor);
RREGDEF(cholmod_l_free_sparse);
RREGDEF(cholmod_l_free_triplet);
RREGDEF(cholmod_l_nnz);
RREGDEF(cholmod_l_scale);
RREGDEF(cholmod_l_sdmult);
RREGDEF(cholmod_l_solve);
RREGDEF(cholmod_l_sort);
RREGDEF(cholmod_l_sparse_to_dense);
RREGDEF(cholmod_l_sparse_to_triplet);
RREGDEF(cholmod_l_speye);
RREGDEF(cholmod_l_spsolve);
RREGDEF(cholmod_l_ssmult);
RREGDEF(cholmod_l_start);
RREGDEF(cholmod_l_submatrix);
RREGDEF(cholmod_l_transpose);
RREGDEF(cholmod_l_triplet_to_sparse);
RREGDEF(cholmod_l_vertcat);
RREGDEF(dpoMatrix_chol);
RREGDEF(numeric_as_chm_dense);
R_cholmod_l_start(&c);
Matrix_DimNamesSym = install("Dimnames");
Matrix_DimSym = install("Dim");
Matrix_diagSym = install("diag");
Matrix_factorSym = install("factors");
Matrix_iSym = install("i");
Matrix_jSym = install("j");
Matrix_lengthSym = install("length");
Matrix_pSym = install("p");
Matrix_permSym = install("perm");
Matrix_uploSym = install("uplo");
Matrix_xSym = install("x");
Matrix_NS = R_FindNamespace(mkString("Matrix"));
if(Matrix_NS == R_UnboundValue)
error(_("missing 'Matrix' namespace: should never happen"));
#ifdef DEBUG_Matrix
if(isEnvironment(Matrix_NS))
Rprintf("Matrix_NS: %s\n",
CHAR(asChar(eval(lang2(install("format"),Matrix_NS),
R_GlobalEnv))));
else
#else
if(!isEnvironment(Matrix_NS))
#endif
error(_("Matrix namespace not determined correctly"));
}
/* .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 */
