/* Initialize R, that is start an embedded R.
Parameters are found in the global 'initargv'.
Return 0 on success, -1 on failure.
*/
int
EmbeddedR_init(void) {
if (RINTERF_ISREADY()) {
printf("R is already ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
if (! RINTERF_HASARGSSET()) {
/* Initialization arguments must be set and
R can only be initialized once */
printf("Initialization parameters must be set first.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
if (! initargv) {
printf("No initialisation argument. This should have been caught earlier.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
int status = Rf_initEmbeddedR(initargv->argc, initargv->argv);
if (status < 0) {
printf("R initialization failed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
/* R_Interactive = TRUE; */
/* #ifdef RIF_HAS_RSIGHAND */
/* R_SignalHandlers = 0; */
/* #endif */
/* #ifdef CSTACK_DEFNS */
/* /\* Taken from JRI: */
/* * disable stack checking, because threads will thow it off *\/ */
/* R_CStackStart = (uintptr_t) -1; */
/* R_CStackLimit = (uintptr_t) -1; */
/* /\* --- *\/ */
/* #endif */
//setup_Rmainloop();
/*FIXME: setting readline variables so R's oddly static declarations
become harmless*/
// #ifdef HAS_READLINE
// char *rl_completer, *rl_basic;
// rl_completer = strndup(rl_completer_word_break_characters, 200);
// rl_completer_word_break_characters = rl_completer;
// rl_basic = strndup(rl_basic_word_break_characters, 200);
// rl_basic_word_break_characters = rl_basic;
// #endif
/* */
errMessage_SEXP = findVar(Rf_install("geterrmessage"),
R_BaseNamespace);
RStatus |= (RINTERF_INITIALIZED);
RStatus ^= RINTERF_IDLE;
return 0;
}
REmbed::REmbed(const bool verbose, const bool interactive) : verbose(verbose), interactive(interactive)
{
loaded = false;
// need to load the library
RLibrary rlib;
if (!rlib.load()) {
// disable for future
appsettings->setValue(GC_EMBED_R, false);
rlib.errors.append("\nR has now been disabled in options.");
QMessageBox msg(QMessageBox::Information,
"Failed to load R library",
rlib.errors.join("\n"));
msg.exec();
return;
}
// we need to tell embedded R where to work
QString envR_HOME(getenv("R_HOME"));
QString configR_HOME = appsettings->value(NULL,GC_R_HOME,"").toString();
if (envR_HOME == "") {
if (configR_HOME == "") {
qDebug()<<"R HOME not set, R disabled";
return;
} else {
setenv("R_HOME", configR_HOME.toLatin1().constData(), true);
}
}
// fire up R
const char *R_argv[] = {name, "--gui=none", "--no-save",
"--no-readline", "--silent", "--vanilla", "--slave"};
int R_argc = sizeof(R_argv) / sizeof(R_argv[0]);
Rf_initEmbeddedR(R_argc, (char**)R_argv);
R_ReplDLLinit(); // this is to populate the repl console buffers
structRstart Rst;
R_DefParams(&Rst);
#ifdef WIN32
Rst.rhome = getenv("R_HOME");
Rst.home = getRUser();
Rst.CharacterMode = LinkDLL;
Rst.ReadConsole = &RTool::R_ReadConsoleWin;
Rst.WriteConsole = &RTool::R_WriteConsole;
Rst.WriteConsoleEx = &RTool::R_WriteConsoleEx;
Rst.CallBack = &RTool::R_ProcessEvents;
Rst.ShowMessage = &RTool::R_ShowMessage;
Rst.YesNoCancel = &RTool::R_YesNoCancel;
Rst.Busy = &RTool::R_Busy;
#endif
Rst.R_Interactive = (Rboolean) interactive; // sets interactive() to eval to false
R_SetParams(&Rst);
loaded = true;
}
void init_R(int argc, char **argv) {
int defaultArgc = 1;
char *defaultArgv[] = {(char*)"Rtest"};
if (argc == 0 || argv == NULL) {
argc = defaultArgc;
argv = defaultArgv;
}
Rf_initEmbeddedR(argc, argv);
}
/*
* Initialises the R interpreter.
*/
void init_R(int argc, char **argv){
char *defaultArgv[] = {"rsruby","--verbose"};
if (RSRUBY_R_HOME) {
setenv("R_HOME", RSRUBY_R_HOME, 0);
}
Rf_initEmbeddedR(sizeof(defaultArgv) / sizeof(defaultArgv[0]), defaultArgv);
//R_Interactive = FALSE; //Remove crash menu (and other interactive R features)
}
void CRInterface::run_r_init()
{
#ifdef R_HOME_ENV
setenv("R_HOME", R_HOME_ENV, 0);
#endif
char* name=strdup("R");
char* opts=strdup("-q");
char* argv[2]={name, opts};
Rf_initEmbeddedR(2, argv);
free(opts);
free(name);
}
void
RXSLT_init(xmlXPathParserContextPtr ctxt, int nargs)
{
const char *defaultArgs[] = {"Rxsltproc", "--silent"};
char **args;
int argc, i;
int mustFree;
if(R_alreadyInitialized)
return;
#ifdef XSLT_DEBUG
fprintf(stderr, "in RXSLT_init %d\n", nargs);fflush(stderr);
#endif
if(nargs == 0) {
argc = sizeof(defaultArgs)/sizeof(defaultArgs[0]);
args = (char **)defaultArgs;
} else {
args = (char **) malloc((nargs+1) * sizeof(char*));
args[0] = strdup("Rxsltproc");
argc = nargs+1;
for(i = 0; i < nargs; i++) {
xmlXPathObjectPtr obj = valuePop(ctxt);
if(obj->type) {
args[i+1] = strdup(xmlXPathCastToString(obj));
}
}
mustFree = TRUE;
}
Rf_initEmbeddedR(argc, args);
loadXSLPackage();
valuePush(ctxt, xmlXPathNewBoolean(1));
if(mustFree) {
for(i = 0; i < nargs+1; i++) {
free(args[i]);
}
free(args);
}
#if DEBUG_REGISTRATION
xsltRegisterExtFunction(getTransformCtxt(), "foo", R_URI, RXSLT_genericFunctionCall);
RXSLT_addFunction("foo", NULL_USER_OBJECT);
#endif
R_alreadyInitialized = 1;
return;
}
int main(int argc, char *argv[])
{
// Intialize the R environment.
int r_argc = 2;
char *r_argv[] = { "R", "--silent" };
Rf_initEmbeddedR(r_argc, r_argv);
int arg[] = { 1, 2, 3, 4, 5 };
// Invoke a function in R
source("func.R");
R_add1(5, arg);
// Release R environment
Rf_endEmbeddedR(0);
return(0);
}
int rffi_init(char* arg) //(int argc,char* argv[])
{
if(!rffi_initialized) {
char* argv[4];
argv[0]="REmbed";
argv[1]="--save";
argv[2]="--slave";
argv[3]="--quiet";
printf("arg=%s\n",arg);
R_CStackStart = (uintptr_t)-1;
Rf_initEmbeddedR(4,argv);
R_Interactive = FALSE;
printf("rffi init\n");
rffi_initialized=1;
return 1;
} else return 0;
}
/* {{{ proto void R::init([array argv])
*/
static PHP_METHOD(R, init)
{
zval *argv = NULL;
int argc = 3;
HashPosition pos;
char **argv_arr;
zval **element;
int i;
char *r_home;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "|a", &argv) == FAILURE) {
return;
}
r_home = getenv("R_HOME");
if (!r_home || r_home[0] == '\0') {
setenv("R_HOME", PHP_R_DIR, 0);
}
R_SetErrorHook(php_r_error_handler);
R_SetWarningHook(php_r_warning_handler);
if (argv) {
argc += zend_hash_num_elements(Z_ARRVAL_P(argv));
}
argv_arr = safe_emalloc(argc, sizeof(char *), 0);
argv_arr[0] = "REmbeddedPHP";
argv_arr[1] = "--gui=none";
argv_arr[2] = "--silent";
if (argv) {
i = 3;
for (zend_hash_internal_pointer_reset_ex(Z_ARRVAL_P(argv), &pos);
zend_hash_get_current_data_ex(Z_ARRVAL_P(argv), (void **) &element, &pos) == SUCCESS;
zend_hash_move_forward_ex(Z_ARRVAL_P(argv), &pos)
) {
convert_to_string_ex(element);
argv_arr[i] = Z_STRVAL_PP(element); /* no copy here, libR does strdup() itself */
i++;
}
}
Rf_initEmbeddedR(argc, argv_arr);
efree(argv_arr);
}
/** Initialises the R interpreter in the libR.so library.
*
* @param argv An OCaml array of strings, which gives the command
* line arguments used to invoke the R interpreter. Code
* segfaults if the array does not contain a first element,
* which is the name of the program, typically "R", or
* "OCaml-R". Other arguments typically are "--vanilla",
* "--slave"...
* @param sigs An OCaml integer. When set to 0, R signal handlers
* are not removed. When set, for example, to 1, R signal
* handlers are removed. It is very useful to remove signal
* handlers when embedding R. Requires R >= 2.3.1.
* @return 1 if R is correctly initialised.
*/
CAMLprim value ocamlr_initEmbeddedR (value ml_argv, value ml_sigs) {
int length = Wosize_val(ml_argv);
char* argv[length];
int i;
// We duplicate the OCaml array into a C array.
for (i=0; i<length; i++) argv[i]=String_val(Field(ml_argv, i));
/* Don't let R set up its own signal handlers when sigs = 1.
This requires R >= 2.3.1. */
if (Int_val(ml_sigs)) R_SignalHandlers = 0;
// This is the libR.so function.
i = Rf_initEmbeddedR(length, argv);
// Returns 1 if R is correctly initialised.
return Val_int(i);
}
int inla_R_init(void)
{
if (R_init == !INLA_OK) {
#pragma omp critical
{
if (R_init == !INLA_OK) {
char *Rargv[] = {"REmbeddedPostgres", "--gui=none", "--silent", "--no-init-file"};
int Rargc = sizeof(Rargv)/sizeof(Rargv[0]);
Rf_initEmbeddedR(Rargc, Rargv);
atexit(inla_R_exit); /* cleanup at exit */
R_init = INLA_OK;
if (R_debug)
fprintf(stderr, "R-interface: init\n");
}
}
}
return INLA_OK;
}
int rcall_init()
{
if (R_is_initialized == 1)
{
jl_error("R is running.");
return -1;
}
char *argv[] = {"RCall", "--slave"};
int argc = sizeof(argv)/sizeof(argv[0]);
int ret = Rf_initEmbeddedR(argc, argv);
if (ret < 0)
{
jl_error("R initialization failed.");
return -1;
}
rcall_register_routines();
R_is_ready = 1;
R_is_initialized = 1;
return ret;
}
/**
Initialize the plugin when it is loaded by Gnumeric.
*/
void
plugin_init_general(ErrorInfo **ret_error)
{
extern int Rf_initEmbeddedR(int argc, char *argv[]);
char *argv[] = {"Rgnumeric", "--silent"};
const char *profile;
char buf[1000];
*ret_error = NULL;
Rf_initEmbeddedR(sizeof(argv)/sizeof(argv[0]), argv);
/* Now, ensure the Gnumeric library is loaded. */
if(loadGnumericLibrary() == FALSE) {
*ret_error = error_info_new_printf("Failed to load RGnumeric library into R. Something's wrong");
return;
}
/* Read the different R gnumeric startup scripts
~/.gnumeric/plugins/R/Rprofile
~/.gnumeric/<version-number>/plugins/R/Rprofile
value of R_GNUMERIC_PROFILE
*/
sprintf(buf, "%s/.gnumeric/Rprofile", getenv("HOME"));
RGnumeric_loadProfile(buf);
sprintf(buf, "%s/.gnumeric/%s/plugins/R/Rprofile",
getenv("HOME"), GNUMERIC_VERSION_STRING);
RGnumeric_loadProfile(buf);
if((profile=getenv("R_GNUMERIC_PROFILE")) != NULL) {
RGnumeric_loadProfile(profile);
}
}
// TODO: use a vector<string> would make all this a bit more readable
void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp,
const bool verbose, const bool interactive) {
if (instance_m) {
throw std::runtime_error( "can only have one RInside instance" ) ;
} else {
instance_m = this ;
}
verbose_m = verbose; // Default is false
interactive_m = interactive;
// generated from Makevars{.win}
#include "RInsideEnvVars.h"
#ifdef WIN32
// we need a special case for Windows where users may deploy an RInside binary from CRAN
// which will have R_HOME set at compile time to CRAN's value -- so let's try to correct
// this here: a) allow user's setting of R_HOME and b) use R's get_R_HOME() function
if (getenv("R_HOME") == NULL) { // if on Windows and not set
char *rhome = get_R_HOME(); // query it, including registry
if (rhome != NULL) { // if something was found
setenv("R_HOME", get_R_HOME(), 1); // store what we got as R_HOME
} // this will now be used in next blocks
}
#endif
for (int i = 0; R_VARS[i] != NULL; i+= 2) {
if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
throw std::runtime_error(std::string("Could not set R environment variable ") +
std::string(R_VARS[i]) + std::string(" to ") +
std::string(R_VARS[i+1]));
}
}
}
#ifndef WIN32
R_SignalHandlers = 0; // Don't let R set up its own signal handlers
#endif
init_tempdir();
const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save",
"--no-readline", "--silent", "--vanilla", "--slave"};
int R_argc = sizeof(R_argv) / sizeof(R_argv[0]);
Rf_initEmbeddedR(R_argc, (char**)R_argv);
#ifndef WIN32
R_CStackLimit = -1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues'
#endif
R_ReplDLLinit(); // this is to populate the repl console buffers
structRstart Rst;
R_DefParams(&Rst);
Rst.R_Interactive = (Rboolean) interactive_m; // sets interactive() to eval to false
#ifdef WIN32
Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS
Rst.home = getRUser();
Rst.CharacterMode = LinkDLL;
Rst.ReadConsole = myReadConsole;
Rst.WriteConsole = myWriteConsole;
Rst.CallBack = myCallBack;
Rst.ShowMessage = myAskOk;
Rst.YesNoCancel = myAskYesNoCancel;
Rst.Busy = myBusy;
#endif
R_SetParams(&Rst);
if (true || loadRcpp) { // we always need Rcpp, so load it anyway
// Rf_install is used best by first assigning like this so that symbols get into the symbol table
// where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage
// collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up
SEXP suppressMessagesSymbol = Rf_install("suppressMessages");
SEXP requireSymbol = Rf_install("require");
Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv);
}
global_env_m = new Rcpp::Environment(); // member variable for access to R's global environment
autoloads(); // loads all default packages, using code autogenerate from Makevars{,.win}
if ((argc - optind) > 1){ // for argv vector in Global Env */
Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc );
assign(s_argv, "argv");
} else {
assign(R_NilValue, "argv") ;
}
init_rand(); // for tempfile() to work correctly */
}
void initR() {
char *argv[] = {"RdeR", "--quiet", "--vanilla"};
int argc = sizeof(argv) / sizeof(argv[0]);
Rf_initEmbeddedR(argc, argv);
}
int
main(int argc, char **argv)
{
int i;
xsltStylesheetPtr cur = NULL;
xmlDocPtr doc, style;
if (argc <= 1) {
usage(argv[0]);
return (1);
}
xmlInitMemory();
LIBXML_TEST_VERSION
defaultLoader = xmlGetExternalEntityLoader();
xmlLineNumbersDefault(1);
if (novalid == 0) /* TODO XML_DETECT_IDS | XML_COMPLETE_ATTRS */
xmlLoadExtDtdDefaultValue = 6;
else
xmlLoadExtDtdDefaultValue = 0;
for (i = 1; i < argc; i++) {
if (!strcmp(argv[i], "-"))
break;
if (argv[i][0] != '-')
continue;
#ifdef LIBXML_DEBUG_ENABLED
if ((!strcmp(argv[i], "-debug")) || (!strcmp(argv[i], "--debug"))) {
debug++;
} else
#endif
if ((!strcmp(argv[i], "-v")) ||
(!strcmp(argv[i], "-verbose")) ||
(!strcmp(argv[i], "--verbose"))) {
xsltSetGenericDebugFunc(stderr, NULL);
} else if ((!strcmp(argv[i], "-o")) ||
(!strcmp(argv[i], "-output")) ||
(!strcmp(argv[i], "--output"))) {
i++;
output = argv[i++];
} else if ((!strcmp(argv[i], "-V")) ||
(!strcmp(argv[i], "-version")) ||
(!strcmp(argv[i], "--version"))) {
printf("Using libxml %s, libxslt %s and libexslt %s\n",
xmlParserVersion, xsltEngineVersion, exsltLibraryVersion);
printf
("xsltproc was compiled against libxml %d, libxslt %d and libexslt %d\n",
LIBXML_VERSION, LIBXSLT_VERSION, LIBEXSLT_VERSION);
printf("libxslt %d was compiled against libxml %d\n",
xsltLibxsltVersion, xsltLibxmlVersion);
printf("libexslt %d was compiled against libxml %d\n",
exsltLibexsltVersion, exsltLibxmlVersion);
} else if ((!strcmp(argv[i], "-repeat"))
|| (!strcmp(argv[i], "--repeat"))) {
if (repeat == 0)
repeat = 20;
else
repeat = 100;
} else if ((!strcmp(argv[i], "-novalid")) ||
(!strcmp(argv[i], "--novalid"))) {
novalid++;
} else if ((!strcmp(argv[i], "-noout")) ||
(!strcmp(argv[i], "--noout"))) {
noout++;
#ifdef LIBXML_DOCB_ENABLED
} else if ((!strcmp(argv[i], "-docbook")) ||
(!strcmp(argv[i], "--docbook"))) {
docbook++;
#endif
#ifdef LIBXML_HTML_ENABLED
} else if ((!strcmp(argv[i], "-html")) ||
(!strcmp(argv[i], "--html"))) {
html++;
#endif
} else if ((!strcmp(argv[i], "-timing")) ||
(!strcmp(argv[i], "--timing"))) {
timing++;
} else if ((!strcmp(argv[i], "-profile")) ||
(!strcmp(argv[i], "--profile"))) {
profile++;
} else if ((!strcmp(argv[i], "-norman")) ||
(!strcmp(argv[i], "--norman"))) {
profile++;
} else if ((!strcmp(argv[i], "-warnnet")) ||
(!strcmp(argv[i], "--warnnet"))) {
xmlSetExternalEntityLoader(xsltNoNetExternalEntityLoader);
} else if ((!strcmp(argv[i], "-nonet")) ||
(!strcmp(argv[i], "--nonet"))) {
xmlSetExternalEntityLoader(xsltNoNetExternalEntityLoader);
nonet = 1;
#ifdef LIBXML_CATALOG_ENABLED
} else if ((!strcmp(argv[i], "-catalogs")) ||
(!strcmp(argv[i], "--catalogs"))) {
const char *catalogs;
catalogs = getenv("SGML_CATALOG_FILES");
if (catalogs == NULL) {
fprintf(stderr, "Variable $SGML_CATALOG_FILES not set\n");
} else {
xmlLoadCatalogs(catalogs);
}
#endif
#ifdef LIBXML_XINCLUDE_ENABLED
} else if ((!strcmp(argv[i], "-xinclude")) ||
(!strcmp(argv[i], "--xinclude"))) {
xinclude++;
xsltSetXIncludeDefault(1);
#endif
} else if ((!strcmp(argv[i], "-param")) ||
(!strcmp(argv[i], "--param"))) {
i++;
params[nbparams++] = argv[i++];
params[nbparams++] = argv[i];
if (nbparams >= 16) {
fprintf(stderr, "too many params\n");
return (1);
}
} else if ((!strcmp(argv[i], "-maxdepth")) ||
(!strcmp(argv[i], "--maxdepth"))) {
int value;
i++;
if (sscanf(argv[i], "%d", &value) == 1) {
if (value > 0)
xsltMaxDepth = value;
}
} else if (!strcmp(argv[i], "--r")) {
startRAutomatically = 1;
RstartupScript = strchr(argv[i],'=');
continue;
} else {
fprintf(stderr, "Unknown option %s\n", argv[i]);
usage(argv[0]);
return (1);
}
}
params[nbparams] = NULL;
/*
* Replace entities with their content.
*/
xmlSubstituteEntitiesDefault(1);
/*
* Register the EXSLT extensions
*/
exsltRegisterAll();
registerRModule(0);
if(startRAutomatically) {
extern int RXSLT_internalSource(const char *fileName);
int rargs = 1;
const char *rargv[] = { "Sxsltproc" };
Rf_initEmbeddedR(rargs, rargv);
loadXSLPackage();
if(RstartupScript && RstartupScript[0])
RXSLT_internalSource(RstartupScript);
}
for (i = 1; i < argc; i++) {
if ((!strcmp(argv[i], "-maxdepth")) ||
(!strcmp(argv[i], "--maxdepth"))) {
i++;
continue;
} else if ((!strcmp(argv[i], "-o")) ||
(!strcmp(argv[i], "-output")) ||
(!strcmp(argv[i], "--output"))) {
i++;
continue;
}
if ((!strcmp(argv[i], "-param")) || (!strcmp(argv[i], "--param"))) {
i += 2;
continue;
} else if(!strcmp(argv[i], "--r")) {
continue;
}
if ((argv[i][0] != '-') || (strcmp(argv[i], "-") == 0)) {
if (timing)
gettimeofday(&begin, NULL);
style = xmlParseFile((const char *) argv[i]);
if (timing) {
long msec;
gettimeofday(&end, NULL);
msec = end.tv_sec - begin.tv_sec;
msec *= 1000;
msec += (end.tv_usec - begin.tv_usec) / 1000;
fprintf(stderr, "Parsing stylesheet %s took %ld ms\n",
argv[i], msec);
}
if (style == NULL) {
fprintf(stderr, "cannot parse %s\n", argv[i]);
cur = NULL;
} else {
cur = xsltLoadStylesheetPI(style);
if (cur != NULL) {
/* it is an embedded stylesheet */
xsltProcess(style, cur, argv[i]);
xsltFreeStylesheet(cur);
exit(0);
}
cur = xsltParseStylesheetDoc(style);
if (cur != NULL) {
if (cur->indent == 1)
xmlIndentTreeOutput = 1;
else
xmlIndentTreeOutput = 0;
i++;
}
}
break;
}
}
/*
* disable CDATA from being built in the document tree
*/
xmlDefaultSAXHandlerInit();
xmlDefaultSAXHandler.cdataBlock = NULL;
if ((cur != NULL) && (cur->errors == 0)) {
for (; i < argc; i++) {
doc = NULL;
if (timing)
gettimeofday(&begin, NULL);
#ifdef LIBXML_HTML_ENABLED
if (html)
doc = htmlParseFile(argv[i], NULL);
else
#endif
#ifdef LIBXML_DOCB_ENABLED
if (docbook)
doc = docbParseFile(argv[i], NULL);
else
#endif
doc = xmlParseFile(argv[i]);
if (doc == NULL) {
fprintf(stderr, "unable to parse %s\n", argv[i]);
continue;
}
if (timing) {
long msec;
gettimeofday(&end, NULL);
msec = end.tv_sec - begin.tv_sec;
msec *= 1000;
msec += (end.tv_usec - begin.tv_usec) / 1000;
fprintf(stderr, "Parsing document %s took %ld ms\n",
argv[i], msec);
}
xsltProcess(doc, cur, argv[i]);
}
xsltFreeStylesheet(cur);
}
#ifdef CAN_UNREGISTER_MODULES
xsltUnregisterAllExtModules();
#endif
xmlCleanupParser();
xmlMemoryDump();
return (0);
}
// TODO: use a vector<string> would make all this a bit more readable
void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp) {
logTxt("RInside::ctor BEGIN", verbose);
if (instance_) {
throw std::runtime_error( "can only have one RInside instance" ) ;
} else {
instance_ = this ;
}
verbose_m = false; // Default is false
// generated as littler.h via from svn/littler/littler.R
#include <RInsideEnvVars.h>
for (int i = 0; R_VARS[i] != NULL; i+= 2) {
if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
//perror("ERROR: couldn't set/replace an R environment variable");
//exit(1);
throw std::runtime_error(std::string("Could not set R environment variable ") +
std::string(R_VARS[i]) + std::string(" to ") +
std::string(R_VARS[i+1]));
}
}
}
#ifndef WIN32
R_SignalHandlers = 0; // Don't let R set up its own signal handlers
#endif
#ifdef CSTACK_DEFNS
R_CStackLimit = (uintptr_t)-1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues'
#endif
init_tempdir();
const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save", "--no-readline", "--silent", "", ""};
const char *R_argv_opt[] = {"--vanilla", "--slave"};
int R_argc = (sizeof(R_argv) - sizeof(R_argv_opt) ) / sizeof(R_argv[0]);
Rf_initEmbeddedR(R_argc, (char**)R_argv);
R_ReplDLLinit(); // this is to populate the repl console buffers
structRstart Rst;
R_DefParams(&Rst);
Rst.R_Interactive = (Rboolean) FALSE; // sets interactive() to eval to false
#ifdef WIN32
Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS
Rst.home = getRUser();
Rst.CharacterMode = LinkDLL;
Rst.ReadConsole = myReadConsole;
Rst.WriteConsole = myWriteConsole;
Rst.CallBack = myCallBack;
Rst.ShowMessage = myAskOk;
Rst.YesNoCancel = myAskYesNoCancel;
Rst.Busy = myBusy;
#endif
R_SetParams(&Rst);
global_env = R_GlobalEnv ;
if (loadRcpp) { // if asked for, load Rcpp (before the autoloads)
// Rf_install is used best by first assigning like this so that symbols get into the symbol table
// where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage
// collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up
SEXP suppressMessagesSymbol = Rf_install("suppressMessages");
SEXP requireSymbol = Rf_install("require");
Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv);
}
autoloads(); // loads all default packages
if ((argc - optind) > 1){ // for argv vector in Global Env */
Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc );
assign(s_argv, "argv");
} else {
assign(R_NilValue, "argv") ;
}
init_rand(); // for tempfile() to work correctly */
logTxt("RInside::ctor END", verbose);
}
int main(int argc, char *argv[]){
// Housekeeping inputs
int warnings = 0; // Display warnings
int recover = 0; // Recover from previous simulation
int ir = 0;
int i = 0;
int j = 0;
int im = 0;
int nmoons_max = 100;
// Grid inputs
double timestep = 0.0; // Time step of the sim (yr)
double speedup = 0.0; // Speedup factor of the thermal evolution sim (if thermal-orbital sim taks too much time)
int NR = 0; // Number of grid zones
double total_time = 0.0; // Total time of sim
double output_every = 0.0; // Output frequency
int NT_output = 0; // Time step for writing output
// Planet inputs
double Mprim = 0.0; // Mass of the primary (host planet) (kg)
double Rprim = 0.0; // Radius of the primary (host planet) (km)
double Qprimi = 0.0; // Initial tidal Q of the primary (host planet)
double Qprimf = 0.0; // Final tidal Q of the primary
int Qmode = 0; // How Q changes over time between Qprimi and Qprimf. 0:linearly; 1:exponential decay; 2:exponential change
double k2prim = 0.0; // k2 tidal Love number of primary (Saturn: 0.39, Lainey et al. 2017?, 1.5 for homogeneous body)
double J2prim = 0.0; // 2nd zonal harmonic of gravity field (Saturn: 16290.71±0.27e-6, Jacobson et al., 2006)
double J4prim = 0.0; // 4th zonal harmonic of gravity field (-935.83±2.77e-6, Jacobson et al., 2006)
int nmoons = 0; // User-specified number of moons
double Mring = 0.0; // Mass of planet rings (kg). For Saturn, 4 to 7e19 kg (Robbins et al. 2010, http://dx.doi.org/10.1016/j.icarus.2009.09.012)
double aring_in = 0.0; // Inner orbital radius of rings (km). for Saturn B ring, 92000 km
double aring_out = 0.0; // Outer orbital radius of rings (km). for Saturn's A ring, 140000 km
// Tidal model inputs
int tidalmodel = 0; // 1: Elastic model; 2: Maxwell model; 3: Burgers model; 4: Andrade model
double tidetimes = 0.0; // Multiply tidal dissipation by this factor, realistically up to 10 (McCarthy & Cooper 2016)
// Geophysical inputs
double rhoHydrRock = 0.0; // Density of hydrated rock endmember (kg m-3)
double rhoDryRock = 0.0; // Density of dry rock endmember (kg m-3)
int chondr = 0; // Nature of the chondritic material incorporated (3/30/2015: default=CI or 1=CO), matters
// for radiogenic heating, see Thermal-state()
// Icy world inputs
double r_p[nmoons_max]; // Planetary radius
double rho_p[nmoons_max]; // Planetary density (g cm-3)
double Tsurf[nmoons_max]; // Surface temperature
double Tinit[nmoons_max]; // Initial temperature
double tzero[nmoons_max]; // Time of formation (Myr)
double nh3[nmoons_max]; // Ammonia w.r.t. water
double salt[nmoons_max]; // Salt w.r.t. water (3/30/2015: binary quantity)
double Xhydr_init[nmoons_max]; // Initial degree of hydration of the rock (0=fully dry, 1=fully hydrated)
int hy[nmoons_max]; // Allow for rock hydration/dehydration?
double Xfines[nmoons_max]; // Mass or volume fraction of rock in fine grains that don't settle into a core (0=none, 1=all)
double Xpores[nmoons_max]; // Mass of volume fraction of core occupied by ice and/or liquid (i.e., core porosity filled with ice and/or liquid)
double porosity[nmoons_max]; // Bulk porosity
int startdiff[nmoons_max]; // Start differentiated?
int orbevol[nmoons_max]; // Orbital evolution?
double aorb[nmoons_max]; // Moon orbital semi-major axis (km)
double eorb[nmoons_max]; // Moon orbital eccentricity
for (im=0;im<nmoons_max;im++) {
tzero[im] = 0.0;
r_p[im] = 0.0;
rho_p[im] = 0.0;
Tsurf[im] = 0.0;
Tinit[im] = 0.0;
nh3[im] = 0.0;
salt[im] = 0.0;
Xhydr_init[im] = 0.0;
Xfines[im] = 0.0;
Xpores[im] = 0.0;
hy[im] = 0.0;
porosity[im] = 0.0;
startdiff[im] = 0.0;
orbevol[im] = 0.0;
aorb[im] = 0.0;
eorb[im] = 0.0;
}
// Call specific subroutines
int run_thermal = 0; // Run thermal code
int run_aTP = 0; // Generate a table of flaw size that maximize stress (Vance et al. 2007)
int run_alpha_beta = 0; // Calculate thermal expansivity and compressibility tables
int run_crack_species = 0; // Calculate equilibrium constants of species that dissolve or precipitate
int run_geochem = 0; // Run the PHREEQC code for the specified ranges of parameters
int run_compression = 0; // Re-calculate last internal structure of Thermal() output by taking into account the effects of compression
int run_cryolava = 0; // Calculate gas-driven exsolution
// Crack subroutine inputs
int *crack_input = (int*) malloc(5*sizeof(int));
int *crack_species = (int*) malloc(4*sizeof(int));
// Geochemistry subroutine inputs
double Tmax = 0.0;
double Tmin = 0.0;
double Tstep = 0.0;
double Pmax = 0.0;
double Pmin = 0.0;
double Pstep = 0.0;
double pemax = 0.0;
double pemin = 0.0;
double pestep = 0.0;
double WRmax = 0.0; // Max water:rock ratio by mass
double WRmin = 0.0; // Min water:rock ratio by mass
double WRstep = 0.0; // Step (multiplicative) in water:rock ratio
// Cryolava subroutine inputs
int t_cryolava = 0; // Time at which to calculate gas exsolution
double CHNOSZ_T_MIN = 0.0; // Minimum temperature for the subcrt() routine of CHNOSZ to work
// Default: 235 K (Cryolava), 245 K (Crack, P>200 bar)
int n_inputs = 200;
double *input = (double*) malloc(n_inputs*sizeof(double));
if (input == NULL) printf("IcyDwarf: Not enough memory to create input[%d]\n", n_inputs);
for (i=0;i<n_inputs;i++) input[i] = 0.0;
//-------------------------------------------------------------------
// Startup
//-------------------------------------------------------------------
printf("\n");
printf("-------------------------------------------------------------------\n");
printf("IcyDwarf v18.6\n");
if (v_release == 1) printf("Release mode\n");
else if (cmdline == 1) printf("Command line mode\n");
printf("-------------------------------------------------------------------\n");
// Initialize the R environment. We do it here, in the main loop, because this can be done only once.
// Otherwise, the program crashes at the second initialization.
setenv("R_HOME","/Library/Frameworks/R.framework/Resources",1); // Specify R home directory
Rf_initEmbeddedR(argc, argv); // Launch R
CHNOSZ_init(1); // Launch CHNOSZ
// Get current directory. Works for Mac only! To switch between platforms, see:
// http://stackoverflow.com/questions/1023306/finding-current-executables-path-without-proc-self-exe
char path[1024];
unsigned int size = sizeof(path);
path[0] = '\0';
if (_NSGetExecutablePath(path, &size) == 0)
printf("\n");
else
printf("IcyDwarf: Couldn't retrieve executable directory. Buffer too small; need size %u\n", size);
//-------------------------------------------------------------------
// Read input
//-------------------------------------------------------------------
input = icy_dwarf_input (input, path);
i = 0;
//-----------------------------
warnings = (int) input[i]; i++;
recover = (int) input[i]; i++;
//-----------------------------
NR = input[i]; i++;
timestep = input[i]; i++; // yr
speedup = input[i]; i++;
total_time = input[i]; i++; // Myr
output_every = input[i]; i++; // Myr
//-----------------------------
Mprim = input[i]; i++; // kg
Rprim = input[i]; i++; // km
Qprimi = input[i]; i++; Qprimf = input[i]; i++; Qmode = (int) input[i]; i++;
k2prim = input[i]; i++; J2prim = input[i]; i++; J4prim = input[i]; i++;
nmoons = (int) input[i]; i++;
Mring = input[i]; i++; // kg
aring_in = input[i]; i++; // cm
aring_out = input[i]; i++; // cm
//-----------------------------
for (im=0;im<nmoons;im++) r_p[im] = input[i+im]; // km
i=i+nmoons;
for (im=0;im<nmoons;im++) rho_p[im] = input[i+im]; // g cm-3
i=i+nmoons;
for (im=0;im<nmoons;im++) Tsurf[im] = input[i+im]; // K
i=i+nmoons;
for (im=0;im<nmoons;im++) Tinit[im] = input[i+im]; // K
i=i+nmoons;
for (im=0;im<nmoons;im++) tzero[im] = input[i+im]; // Myr
i=i+nmoons;
for (im=0;im<nmoons;im++) nh3[im] = input[i+im]; // Fraction w.r.t. H2O
i=i+nmoons;
for (im=0;im<nmoons;im++) salt[im] = input[i+im]; // 0 or 1
i=i+nmoons;
for (im=0;im<nmoons;im++) Xhydr_init[im] = input[i+im];
i=i+nmoons;
for (im=0;im<nmoons;im++) hy[im] = input[i+im];
i=i+nmoons;
for (im=0;im<nmoons;im++) porosity[im] = input[i+im]; // vol fraction
i=i+nmoons;
for (im=0;im<nmoons;im++) Xfines[im] = input[i+im]; // mass fraction = vol fraction
i=i+nmoons;
for (im=0;im<nmoons;im++) Xpores[im] = input[i+im]; // vol fraction
i=i+nmoons;
for (im=0;im<nmoons;im++) startdiff[im] = (int) input[i+im];
i=i+nmoons;
for (im=0;im<nmoons;im++) aorb[im] = input[i+im]; // km
i=i+nmoons;
for (im=0;im<nmoons;im++) eorb[im] = input[i+im];
i=i+nmoons;
for (im=0;im<nmoons;im++) orbevol[im] = (int) input[i+im];
i=i+nmoons;
//-----------------------------
rhoDryRock = input[i]; i++; // g cm-3
rhoHydrRock = input[i]; i++; // g cm-3
chondr = (int) input[i]; i++;
tidalmodel = (int) input[i]; i++;
tidetimes = input[i]; i++;
//-----------------------------
run_thermal = (int) input[i]; i++;
run_aTP = (int) input[i]; i++;
run_alpha_beta = (int) input[i]; i++;
run_crack_species = (int) input[i]; i++;
run_geochem = (int) input[i]; i++;
Tmin = input[i]; i++; Tmax = input[i]; i++; Tstep = input[i]; i++;
Pmin = input[i]; i++; Pmax = input[i]; i++; Pstep = input[i]; i++;
pemin = input[i]; i++; pemax = input[i]; i++; pestep = input[i]; i++;
WRmin = input[i]; i++; WRmax = input[i]; i++; WRstep = input[i]; i++;
run_compression = (int) input[i]; i++;
run_cryolava = (int) input[i]; i++;
t_cryolava = (int) input[i]/output_every; i++; // Myr
CHNOSZ_T_MIN = input[i]; i++; // K
//-----------------------------
for (j=0;j<4;j++) {
crack_input[j] = (int) input[i]; i++;
}
for (j=0;j<4;j++) {
crack_species[j] = (int) input[i]; i++;
}
if (nmoons > nmoons_max) {
printf("Too many moons for the code to handle. Increase nmoon_max in the source code\n");
exit(0);
}
//-------------------------------------------------------------------
// Print input
//-------------------------------------------------------------------
printf("1 for Yes, 0 for No\n");
printf("--------------------------------------------------------------------------------------------------------\n");
printf("| Housekeeping |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||\n");
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Warnings? | %d\n", warnings);
printf("| Recover? | %d\n", recover);
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Grid |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||\n");
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Number of grid zones | %d\n", NR);
printf("| Thermal-orbital simulation time step (yr) | %g\n", timestep);
printf("| Thermal simulation speedup factor | %g\n", speedup);
printf("| Total time of thermal simulation (Myr) | %g\n", total_time);
printf("| Output every (Myr) | %g\n", output_every);
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Host planet parameters |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||\n");
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Mass (kg) (0 if world is not a moon) | %g\n", Mprim);
printf("| Radius (km) | %g\n", Rprim);
printf("| Tidal Q (initial,today,{0:lin 1:exp 2:1-exp}) | %g %g %d\n", Qprimi, Qprimf, Qmode);
printf("| Love number k2; zonal gravity harmonics J2, J4| %g %g %g\n", k2prim, J2prim, J4prim);
printf("| Number of moons | %d\n", nmoons);
printf("| Ring mass (kg) (0 if no rings) | %g\n", Mring);
printf("| Ring inner edge (km) | %g\n", aring_in);
printf("| Ring outer edge (km) | %g\n", aring_out);
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Icy world parameters |||||||||||||||||||||||||| World 1 | World 2 | World 3 | World 4 | World 5 |\n");
printf("|-----------------------------------------------|----------|----------|----------|----------|----------|\n");
printf("| Radius assuming zero porosity (km) |");
for (im=0;im<nmoons;im++) printf(" %g \t", r_p[im]);
printf("\n| Density assuming zero porosity (g cm-3) |");
for (im=0;im<nmoons;im++) printf(" %g \t", rho_p[im]);
printf("\n| Surface temperature (K) |");
for (im=0;im<nmoons;im++) printf(" %g \t", Tsurf[im]);
printf("\n| Initial temperature (K) |");
for (im=0;im<nmoons;im++) printf(" %g \t", Tinit[im]);
printf("\n| Time of formation (Myr) |");
for (im=0;im<nmoons;im++) printf(" %g \t", tzero[im]);
printf("\n| Ammonia w.r.t. water |");
for (im=0;im<nmoons;im++) printf(" %g \t", nh3[im]);
printf("\n| Briny liquid? y=1, n=0 |");
for (im=0;im<nmoons;im++) printf(" %g \t", salt[im]);
printf("\n| Initial degree of hydration |");
for (im=0;im<nmoons;im++) printf(" %g \t", Xhydr_init[im]);
printf("\n| Hydrate/dehydrate? |");
for (im=0;im<nmoons;im++) printf(" %d \t", hy[im]);
printf("\n| Initial porosity volume fraction |");
for (im=0;im<nmoons;im++) printf(" %g \t", porosity[im]);
printf("\n| Fraction of rock in fines |");
for (im=0;im<nmoons;im++) printf(" %g \t", Xfines[im]);
printf("\n| Core ice/liquid water volume fraction |");
for (im=0;im<nmoons;im++) printf(" %g \t", Xpores[im]);
printf("\n| Start differentiated? |");
for (im=0;im<nmoons;im++) printf(" %d \t", startdiff[im]);
printf("\n| Initial orbital semi-major axis (km) |");
for (im=0;im<nmoons;im++) printf(" %g ", aorb[im]);
printf("\n| Initial orbital eccentricity |");
for (im=0;im<nmoons;im++) printf(" %g \t", eorb[im]);
printf("\n| Allow orbit to change? |");
for (im=0;im<nmoons;im++) printf(" %d \t", orbevol[im]);
printf("\n|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Dry rock density (g cm-3) | %g\n", rhoDryRock);
printf("| Hydrated rock density (g cm-3) | %g\n", rhoHydrRock);
printf("| Chondrite type? CI=0 CO=1 | %d\n", chondr);
printf("| Tidal rheology? Maxwell=2 Burgers=3 Andrade=4 | %d\n", tidalmodel);
printf("| Tidal heating x... | %g\n", tidetimes);
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Subroutines ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||\n");
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Run thermal code? | %d\n", run_thermal);
printf("| Generate core crack aTP table? | %d\n", run_aTP);
printf("| Generate water alpha beta table? | %d\n", run_alpha_beta);
printf("| Generate crack species log K with CHNOSZ? | %d\n", run_crack_species);
printf("| Run geochemistry code? (min max step) | %d\n", run_geochem);
printf("| Temperature | %g %g %g\n", Tmin, Tmax, Tstep);
printf("| Pressure | %g %g %g\n", Pmin, Pmax, Pstep);
printf("| pe = FMQ + ... | %g %g %g\n", pemin, pemax, pestep);
printf("| Water:rock mass ratio | %g %g %g\n", WRmin, WRmax, WRstep);
printf("| Run compression code? | %d\n", run_compression);
printf("| Run cryovolcanism code? | %d\n", run_cryolava);
printf("| After how many output steps? | %d\n", t_cryolava);
printf("| Minimum temperature to run CHNOSZ (K) | %g\n", CHNOSZ_T_MIN);
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Core crack options |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||\n");
printf("|-----------------------------------------------|------------------------------------------------------|\n");
printf("| Include thermal expansion/contrac mismatch? | %d\n", crack_input[0]);
printf("| Include pore water expansion? | %d\n", crack_input[1]);
printf("| Include hydration/dehydration vol changes? | %d\n", crack_input[2]);
printf("| Include dissolution/precipitation...? | %d\n", crack_input[3]);
printf("| ... of silica? | %d\n", crack_species[0]);
printf("| ... of serpentine? | %d\n", crack_species[1]);
printf("| ... of carbonate (magnesite)? | %d\n", crack_species[2]);
printf("|------------------------------------------------------------------------------------------------------|\n\n");
// Conversions to cgs
total_time = total_time*Myr2sec;
output_every = output_every*Myr2sec;
Mprim = Mprim/gram;
Rprim = Rprim*km2cm;
Mring = Mring/gram;
aring_in = aring_in*km2cm;
aring_out = aring_out*km2cm;
for (im=0;im<nmoons;im++) {
r_p[im] = r_p[im]*km2cm;
tzero[im] = tzero[im]*Myr2sec;
aorb[im] = aorb[im]*km2cm;
}
// Conversions to SI
rhoDryRock = rhoDryRock*gram/cm/cm/cm;
rhoHydrRock = rhoHydrRock*gram/cm/cm/cm;
NT_output = floor(total_time/output_every)+1;
//-------------------------------------------------------------------
// Cracking depth calculations
//-------------------------------------------------------------------
if (run_aTP == 1) {
printf("Calculating expansion mismatch optimal flaw size matrix...\n");
aTP(path, warnings);
printf("\n");
}
if (run_alpha_beta == 1) {
printf("Calculating alpha(T,P) and beta(T,P) tables for water using CHNOSZ...\n");
Crack_water_CHNOSZ(argc, argv, path, warnings);
printf("\n");
}
if (run_crack_species == 1) {
printf("Calculating log K for crack species using CHNOSZ...\n");
Crack_species_CHNOSZ(argc, argv, path, warnings);
printf("\n");
}
//-------------------------------------------------------------------
// Run thermal code
//-------------------------------------------------------------------
double **Xhydr = (double**) malloc(nmoons*sizeof(double*)); // Degree of hydration, 0=dry, 1=hydrated
if (Xhydr == NULL) printf("IcyDwarf: Not enough memory to create Xhydr[nmoons]\n");
for (im=0;im<nmoons;im++) {
Xhydr[im] = (double*) malloc(NR*sizeof(double));
if (Xhydr[im] == NULL) printf("Thermal: Not enough memory to create Xhydr[nmoons][NR]\n");
}
for (im=0;im<nmoons;im++) {
for (ir=0;ir<NR;ir++) Xhydr[im][ir] = Xhydr_init[im];
}
if (run_thermal == 1) {
printf("Running thermal evolution code...\n");
PlanetSystem(argc, argv, path, warnings, recover, NR, timestep, speedup, tzero, total_time, output_every, nmoons, Mprim, Rprim, Qprimi, Qprimf,
Qmode, k2prim, J2prim, J4prim, Mring, aring_out, aring_in, r_p, rho_p, rhoHydrRock, rhoDryRock, nh3, salt, Xhydr, porosity, Xpores,
Xfines, Tinit, Tsurf, startdiff, aorb, eorb, tidalmodel, tidetimes, orbevol, hy, chondr, crack_input, crack_species);
printf("\n");
}
//-------------------------------------------------------------------
// Water-rock reactions
//-------------------------------------------------------------------
if (run_geochem == 1) {
printf("Running PHREEQC across the specified range of parameters...\n");
ParamExploration(path, Tmin, Tmax, Tstep,
Pmin, Pmax, Pstep,
pemin, pemax, pestep,
WRmin, WRmax, WRstep);
printf("\n");
}
//-------------------------------------------------------------------
// Compression
//-------------------------------------------------------------------
if (run_compression == 1) {
printf("Running Compression routine...\n");
// Read thermal output
thermalout **thoutput = (thermalout**) malloc(NR*sizeof(thermalout*)); // Thermal model output
if (thoutput == NULL) printf("IcyDwarf: Not enough memory to create the thoutput structure\n");
for (ir=0;ir<NR;ir++) {
thoutput[ir] = (thermalout*) malloc(NT_output*sizeof(thermalout));
if (thoutput[ir] == NULL) printf("IcyDwarf: Not enough memory to create the thoutput structure\n");
}
thoutput = read_thermal_output (thoutput, NR, NT_output, path);
compression(NR, NT_output, thoutput, NT_output-1, 205, 302, 403, 0, path, rhoHydrRock, rhoDryRock, Xhydr[0]);
for (ir=0;ir<NR;ir++) free (thoutput[ir]);
free (thoutput);
printf("\n");
}
//-------------------------------------------------------------------
// Cryolava calculations
//-------------------------------------------------------------------
if (run_cryolava == 1) {
printf("Calculating gas-driven exsolution at t=%d...\n", t_cryolava);
// Read thermal output
thermalout **thoutput = (thermalout**) malloc(NR*sizeof(thermalout*)); // Thermal model output
if (thoutput == NULL) printf("IcyDwarf: Not enough memory to create the thoutput structure\n");
for (ir=0;ir<NR;ir++) {
thoutput[ir] = (thermalout*) malloc(NT_output*sizeof(thermalout));
if (thoutput[ir] == NULL) printf("IcyDwarf: Not enough memory to create the thoutput structure\n");
}
thoutput = read_thermal_output (thoutput, NR, NT_output, path);
for (ir=0;ir<NR;ir++) Xhydr[0][ir] = thoutput[ir][NT_output].xhydr;
if (t_cryolava > NT_output) {
printf("Icy Dwarf: t_cryolava > total time of sim\n");
return -1;
}
Cryolava(argc, argv, path, NR, NT_output, (float) r_p[0], thoutput, t_cryolava, CHNOSZ_T_MIN, warnings, rhoHydrRock, rhoDryRock, Xhydr[0]);
for (ir=0;ir<NR;ir++) free (thoutput[ir]);
free (thoutput);
printf("\n");
}
//-------------------------------------------------------------------
// Exit
//-------------------------------------------------------------------
for (im=0;im<nmoons;im++) free(Xhydr[im]);
free (input);
free (crack_input);
free (crack_species);
free (Xhydr);
Rf_endEmbeddedR(0); // Close R and CHNOSZ
printf("Exiting IcyDwarf...\n");
return 0;
}
int main(int argc, char **argv){
/* R embedded arguments, and optional arguments to be picked via cmdline switches */
char *R_argv[] = {(char*)programName, "--gui=none", "--no-restore", "--no-save", "--no-readline", "--silent", "", ""};
char *R_argv_opt[] = {"--vanilla", "--slave"};
int R_argc = (sizeof(R_argv) - sizeof(R_argv_opt) ) / sizeof(R_argv[0]);
int i, nargv, c, optpos=0, vanilla=0, quick=0, interactive=0, datastdin=0;
char *evalstr = NULL;
char *libstr = NULL;
char *libpathstr = NULL;
SEXP s_argv;
structRstart Rst;
char *datastdincmd = "X <- read.csv(file(\"stdin\"), stringsAsFactors=FALSE);";
static struct option optargs[] = {
{"help", no_argument, NULL, 'h'},
{"usage", no_argument, 0, 0},
{"version", no_argument, NULL, 'V'},
{"vanilla", no_argument, NULL, 'v'},
{"eval", required_argument, NULL, 'e'},
{"packages", required_argument, NULL, 'l'},
{"verbose", no_argument, NULL, 'p'},
{"rtemp", no_argument, NULL, 't'},
{"quick", no_argument, NULL, 'q'},
{"interactive", no_argument, NULL, 'i'},
{"datastdin", no_argument, NULL, 'd'},
{"libpath", required_argument, NULL, 'L'},
{0, 0, 0, 0}
};
while ((c = getopt_long(argc, argv, "+hVve:npl:L:tqid", optargs, &optpos)) != -1) {
switch (c) {
case 0: /* numeric 0 is code for a long option */
/* printf ("Got option %s %d", optargs[optpos].name, optpos);*/
switch (optpos) { /* so switch on the position in the optargs struct */
/* cases 0, 2, and 3 can't happen as they are covered by the '-h', */
/* '-V', and '-v' equivalences */
case 1:
showUsageAndExit();
break; /* never reached */
case 5:
verbose = 1;
break;
default:
printf("Uncovered option position '%d'. Try `%s --help' for help\n",
optpos, programName);
exit(-1);
}
break;
case 'h': /* -h is the sole short option, cf getopt_long() call */
showHelpAndExit();
break; /* never reached */
case 'e':
evalstr = optarg;
break;
case 'l':
libstr = optarg;
break;
case 'v':
vanilla=1;
break;
case 'p':
verbose=1;
break;
case 'V':
showVersionAndExit();
break; /* never reached */
case 't':
perSessionTempDir=TRUE;
break;
case 'q':
quick=1;
break;
case 'i':
interactive=1;
break;
case 'd':
datastdin=1;
break;
case 'L':
libpathstr = optarg;
break;
default:
printf("Unknown option '%c'. Try `%s --help' for help\n",(char)c, programName);
exit(-1);
}
}
if (vanilla) {
R_argv[R_argc++] = R_argv_opt[0];
}
if (!verbose) {
R_argv[R_argc++] = R_argv_opt[1];
}
#ifdef DEBUG
printf("R_argc %d sizeof(R_argv) \n", R_argc, sizeof(R_argv));
for (i=0; i<7; i++) {
printf("R_argv[%d] = %s\n", i, R_argv[i]);
}
printf("optind %d, argc %d\n", optind, argc);
for (i=0; i<argc; i++) {
printf("argv[%d] = %s\n", i, argv[i]);
}
#endif
/* Now, argv[optind] could be a file we want to source -- if we're
* in the 'shebang' case -- or it could be an expression from stdin.
* So call stat(1) on it, and if its a file we will treat it as such.
*/
struct stat sbuf;
if (optind < argc && evalstr==NULL) {
if ((strcmp(argv[optind],"-") != 0) && (stat(argv[optind],&sbuf) != 0)) {
perror(argv[optind]);
exit(1);
}
}
/* Setenv R_* env vars: insert or replace into environment. */
for (i = 0; R_VARS[i] != NULL; i+= 2){
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
perror("ERROR: couldn't set/replace an R environment variable");
exit(1);
}
}
/* We don't require() default packages upon startup; rather, we
* set up delayedAssign's instead. see autoloads().
*/
if (setenv("R_DEFAULT_PACKAGES","NULL",1) != 0) {
perror("ERROR: couldn't set/replace R_DEFAULT_PACKAGES");
exit(1);
}
R_SignalHandlers = 0; /* Don't let R set up its own signal handlers */
#ifdef CSTACK_DEFNS
R_CStackLimit = (uintptr_t)-1; /* Don't do any stack checking, see R Exts, '8.1.5 Threading issues' */
#endif
littler_InitTempDir(); /* Set up temporary directoy */
Rf_initEmbeddedR(R_argc, R_argv); /* Initialize the embedded R interpreter */
R_ReplDLLinit(); /* this is to populate the repl console buffers */
if (!interactive) { /* new in littler 0.1.3 */
R_DefParams(&Rst);
Rst.R_Interactive = 0; /* sets interactive() to eval to false */
R_SetParams(&Rst);
}
ptr_R_CleanUp = littler_CleanUp; /* R Exts, '8.1.2 Setting R callbacks */
if (quick != 1) { /* Unless user chose not to load libraries */
autoloads(); /* Force all default package to be dynamically required */
}
/* Place any argv arguments into argv vector in Global Environment */
/* if we have an evalstr supplied from -e|--eval, correct for it */
if ((argc - optind - (evalstr==NULL)) >= 1) {
int offset = (evalstr==NULL) + (strcmp(argv[optind],"-") == 0);
/* Build string vector */
nargv = argc - optind - offset;
PROTECT(s_argv = allocVector(STRSXP,nargv));
for (i = 0; i <nargv; i++){
STRING_PTR(s_argv)[i] = mkChar(argv[i+offset+optind]);
#ifdef DEBUG
printf("Passing %s to R\n", argv[i+offset+optind]);
#endif
}
UNPROTECT(1);
setVar(install("argv"),s_argv,R_GlobalEnv);
} else {
setVar(install("argv"),R_NilValue,R_GlobalEnv);
}
init_rand(); /* for tempfile() to work correctly */
if (!vanilla) {
FILE *fp;
char rprofilesite[128];
snprintf(rprofilesite, 110, "%s/etc/Rprofile.site", getenv("R_HOME"));
if (fp = fopen(rprofilesite, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", rprofilesite);
#endif
source(rprofilesite);
}
char dotrprofile[128];
snprintf(dotrprofile, 110, "%s/.Rprofile", getenv("HOME"));
if (fp = fopen(dotrprofile, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", dotrprofile);
#endif
source(dotrprofile);
}
char *etclittler = "/etc/littler.r"; /* load /etc/litter.r if it exists */
if (fp = fopen(etclittler, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", etclittler);
#endif
source(etclittler);
}
char dotlittler[128]; /* load ~/.litter.r if it exists */
snprintf(dotlittler, 110, "%s/.littler.r", getenv("HOME"));
if (fp = fopen(dotlittler, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", dotlittler);
#endif
source(dotlittler);
}
}
if (libpathstr != NULL) { /* if requested by user, set libPaths */
char buf[128];
membuf_t pb = init_membuf(512);
snprintf(buf, 127 - 12 - strlen(libpathstr), ".libPaths(\"%s\");", libpathstr);
parse_eval(&pb, buf, 1);
destroy_membuf(pb);
}
if (libstr != NULL) { /* if requested by user, load libraries */
char *ptr, *token, *strptr;
char buf[128];
ptr = token = libstr;
membuf_t pb = init_membuf(512);
while (token != NULL) {
token = strtok_r(ptr, ",", &strptr);
ptr = NULL; /* after initial call strtok expects NULL */
if (token != NULL) {
snprintf(buf, 127 - 27 - strlen(token), "suppressMessages(library(%s));", token);
parse_eval(&pb, buf, 1);
}
}
destroy_membuf(pb);
}
if (datastdin) { /* if req. by user, read 'dat' from stdin */
membuf_t pb = init_membuf(512);
parse_eval(&pb, datastdincmd, 1);
destroy_membuf(pb);
}
/* Now determine which R code to evaluate */
int exit_val = 0;
if (evalstr != NULL) {
/* we have a command line expression to evaluate */
membuf_t pb = init_membuf(1024);
exit_val = parse_eval(&pb, evalstr, 1);
destroy_membuf(pb);
} else if (optind < argc && (strcmp(argv[optind],"-") != 0)) {
/* call R function source(filename) */
exit_val = source(argv[optind]);
} else {
/* Or read from stdin */
membuf_t lb = init_membuf(1024);
membuf_t pb = init_membuf(1024);
int lineno = 1;
while(readline_stdin(&lb)){
exit_val = parse_eval(&pb,(char*)lb->buf,lineno++);
if (exit_val) break;
}
destroy_membuf(lb);
destroy_membuf(pb);
}
littler_CleanUp(SA_NOSAVE, exit_val, 0);
return(0); /* not reached, but making -Wall happy */
}
