int
getRLength(SEXP obj)
{
return(Rf_length(obj));
}
SEXP
R_readFromJSON(SEXP r_input, SEXP depth, SEXP allowComments, SEXP func, SEXP data, SEXP maxChar)
{
JSON_config conf;
struct JSON_parser_struct *parser;
SEXP ans = R_NilValue;
int do_unprotect = 1;
RJSONParserInfo info = {NULL, NULL, CE_NATIVE};
init_JSON_config(&conf);
conf.depth = INTEGER(depth)[0];
conf.allow_comments = LOGICAL(allowComments)[0];
/* Handle the callback function and data here. First the C routines and data context.*/
if(Rf_length(data)) {
SEXP tmp = VECTOR_ELT(data, 1);
void *ptr;
switch(TYPEOF(tmp)) {
case NILSXP:
ptr = NULL;
break;
case INTSXP:
case LGLSXP:
ptr = INTEGER(tmp);
break;
case REALSXP:
ptr = REAL(tmp);
break;
case VECSXP:
ptr = VECTOR_PTR(tmp);
break;
default:
ptr = NULL;
}
conf.callback = (JSON_parser_callback) R_ExternalPtrAddr(VECTOR_ELT(data, 0));
conf.callback_ctx = ptr;
do_unprotect = 0;
} else if(func != R_NilValue && TYPEOF(func) == CLOSXP) {
/* we have a function*/
SEXP e;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, func);
SETCAR(CDR(e), allocVector(INTSXP, 1));
SET_NAMES(CAR(CDR(e)), info.names = NEW_CHARACTER(1));
SETCAR(CDR(CDR(e)), R_NilValue);
info.func = e;
ans = R_NilValue;
conf.callback = R_json_basicCallback;
conf.callback_ctx = &info;
} else if(func == R_NilValue)
PROTECT(ans = NEW_LIST(1));
else { /* You what? */
PROBLEM "unhandled type of R object as handler function %d", TYPEOF(func)
ERROR;
}
parser = new_JSON_parser(&conf);
if(inherits(r_input, "connection")) {
R_json_parse_connection(r_input, maxChar, parser);
} else {
R_json_parse_character(r_input, maxChar, parser);
}
if(do_unprotect)
UNPROTECT(1);
return(ans);
}
void CallProxy::traverse_call( SEXP obj ){
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("global") ){
SEXP symb = CADR(obj) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find(CHAR(PRINTNAME(symb))) ;
call = res ;
return ;
}
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("column") ){
call = get_column(CADR(obj), env, subsets) ;
return ;
}
if( ! Rf_isNull(obj) ){
SEXP head = CAR(obj) ;
switch( TYPEOF( head ) ){
case LANGSXP:
if( CAR(head) == Rf_install("global") ){
SEXP symb = CADR(head) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find( CHAR(PRINTNAME(symb)) ) ;
SETCAR(obj, res) ;
SET_TYPEOF(obj, LISTSXP) ;
break ;
}
if( CAR(head) == Rf_install("column")){
Symbol column = get_column( CADR(head), env, subsets) ;
SETCAR(obj, column ) ;
head = CAR(obj) ;
proxies.push_back( CallElementProxy( head, obj ) );
break ;
}
if( CAR(head) == Rf_install("~")) break ;
if( CAR(head) == Rf_install("order_by") ) break ;
if( CAR(head) == Rf_install("function") ) break ;
if( CAR(head) == Rf_install("local") ) return ;
if( CAR(head) == Rf_install("<-") ){
stop( "assignments are forbidden" ) ;
}
if( Rf_length(head) == 3 ){
SEXP symb = CAR(head) ;
if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){
// Rprintf( "CADR(obj) = " ) ;
// Rf_PrintValue( CADR(obj) ) ;
// for things like : foo( bar = bling )$bla
// so that `foo( bar = bling )` gets processed
if( TYPEOF(CADR(head)) == LANGSXP ){
traverse_call( CDR(head) ) ;
}
// deal with foo$bar( bla = boom )
if( TYPEOF(CADDR(head)) == LANGSXP ){
traverse_call( CDDR(head) ) ;
}
break ;
} else {
traverse_call( CDR(head) ) ;
}
} else {
traverse_call( CDR(head) ) ;
}
break ;
case LISTSXP:
traverse_call( head ) ;
traverse_call( CDR(head) ) ;
break ;
case SYMSXP:
if( TYPEOF(obj) != LANGSXP ){
if( ! subsets.count(head) ){
if( head == R_MissingArg ) break ;
if( head == Rf_install(".") ) break ;
// in the Environment -> resolve
try{
Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;
SETCAR( obj, x );
} catch( ...){
// what happens when not found in environment
}
} else {
// in the data frame
proxies.push_back( CallElementProxy( head, obj ) );
}
break ;
}
}
traverse_call( CDR(obj) ) ;
}
}
void ifaGroup::import(SEXP Rlist)
{
SEXP argNames;
Rf_protect(argNames = Rf_getAttrib(Rlist, R_NamesSymbol));
if (Rf_length(Rlist) != Rf_length(argNames)) {
Rf_error("All list elements must be named");
}
std::vector<const char *> dataColNames;
paramRows = -1;
int pmatCols=-1;
int mips = 1;
int dataRows = 0;
SEXP Rmean=0, Rcov=0;
for (int ax=0; ax < Rf_length(Rlist); ++ax) {
const char *key = R_CHAR(STRING_ELT(argNames, ax));
SEXP slotValue = VECTOR_ELT(Rlist, ax);
if (strEQ(key, "spec")) {
importSpec(slotValue);
} else if (strEQ(key, "param")) {
if (!Rf_isReal(slotValue)) Rf_error("'param' must be a numeric matrix of item parameters");
param = REAL(slotValue);
getMatrixDims(slotValue, ¶mRows, &pmatCols);
SEXP dimnames;
Rf_protect(dimnames = Rf_getAttrib(slotValue, R_DimNamesSymbol));
if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) {
SEXP names;
Rf_protect(names = VECTOR_ELT(dimnames, 0));
int nlen = Rf_length(names);
factorNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
factorNames[nx] = CHAR(STRING_ELT(names, nx));
}
Rf_protect(names = VECTOR_ELT(dimnames, 1));
nlen = Rf_length(names);
itemNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
itemNames[nx] = CHAR(STRING_ELT(names, nx));
}
}
} else if (strEQ(key, "mean")) {
Rmean = slotValue;
if (!Rf_isReal(slotValue)) Rf_error("'mean' must be a numeric vector or matrix");
mean = REAL(slotValue);
} else if (strEQ(key, "cov")) {
Rcov = slotValue;
if (!Rf_isReal(slotValue)) Rf_error("'cov' must be a numeric matrix");
cov = REAL(slotValue);
} else if (strEQ(key, "data")) {
Rdata = slotValue;
dataRows = Rf_length(VECTOR_ELT(Rdata, 0));
SEXP names;
Rf_protect(names = Rf_getAttrib(Rdata, R_NamesSymbol));
int nlen = Rf_length(names);
dataColNames.reserve(nlen);
for (int nx=0; nx < nlen; ++nx) {
dataColNames.push_back(CHAR(STRING_ELT(names, nx)));
}
Rf_protect(dataRowNames = Rf_getAttrib(Rdata, R_RowNamesSymbol));
} else if (strEQ(key, "weightColumn")) {
if (Rf_length(slotValue) != 1) {
Rf_error("You can only have one weightColumn");
}
weightColumnName = CHAR(STRING_ELT(slotValue, 0));
} else if (strEQ(key, "qwidth")) {
qwidth = Rf_asReal(slotValue);
} else if (strEQ(key, "qpoints")) {
qpoints = Rf_asInteger(slotValue);
} else if (strEQ(key, "minItemsPerScore")) {
mips = Rf_asInteger(slotValue);
} else {
// ignore
}
}
learnMaxAbilities();
if (itemDims < (int) factorNames.size())
factorNames.resize(itemDims);
if (int(factorNames.size()) < itemDims) {
factorNames.reserve(itemDims);
const int SMALLBUF = 10;
char buf[SMALLBUF];
while (int(factorNames.size()) < itemDims) {
snprintf(buf, SMALLBUF, "s%d", int(factorNames.size()) + 1);
factorNames.push_back(CHAR(Rf_mkChar(buf)));
}
}
if (Rmean) {
if (Rf_isMatrix(Rmean)) {
int nrow, ncol;
getMatrixDims(Rmean, &nrow, &ncol);
if (!(nrow * ncol == itemDims && (nrow==1 || ncol==1))) {
Rf_error("mean must be a column or row matrix of length %d", itemDims);
}
} else {
if (Rf_length(Rmean) != itemDims) {
Rf_error("mean must be a vector of length %d", itemDims);
}
}
verifyFactorNames(Rmean, "mean");
}
if (Rcov) {
if (Rf_isMatrix(Rcov)) {
int nrow, ncol;
getMatrixDims(Rcov, &nrow, &ncol);
if (nrow != itemDims || ncol != itemDims) {
Rf_error("cov must be %dx%d matrix", itemDims, itemDims);
}
} else {
if (Rf_length(Rcov) != 1) {
Rf_error("cov must be %dx%d matrix", itemDims, itemDims);
}
}
verifyFactorNames(Rcov, "cov");
}
setLatentDistribution(mean, cov);
setMinItemsPerScore(mips);
if (numItems() != pmatCols) {
Rf_error("item matrix implies %d items but spec is length %d",
pmatCols, numItems());
}
if (Rdata) {
if (itemNames.size() == 0) Rf_error("Item matrix must have colnames");
for (int ix=0; ix < numItems(); ++ix) {
bool found=false;
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(itemNames[ix], dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (!Rf_isFactor(col)) {
if (TYPEOF(col) == INTSXP) {
Rf_error("Column '%s' is an integer but "
"not an ordered factor",
dataColNames[dc]);
} else {
Rf_error("Column '%s' is of type %s; expecting an "
"ordered factor (integer)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
}
dataColumns.push_back(INTEGER(col));
found=true;
break;
}
}
if (!found) {
Rf_error("Cannot find item '%s' in data", itemNames[ix]);
}
}
if (weightColumnName) {
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(weightColumnName, dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (TYPEOF(col) != REALSXP) {
Rf_error("Column '%s' is of type %s; expecting type numeric (double)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
rowWeight = REAL(col);
break;
}
}
if (!rowWeight) {
Rf_error("Cannot find weight column '%s'", weightColumnName);
}
}
rowMap.reserve(dataRows);
for (int rx=0; rx < dataRows; ++rx) rowMap.push_back(rx);
}
Eigen::Map< Eigen::ArrayXXd > Eparam(param, paramRows, numItems());
Eigen::Map< Eigen::VectorXd > meanVec(mean, itemDims);
Eigen::Map< Eigen::MatrixXd > covMat(cov, itemDims, itemDims);
quad.setStructure(qwidth, qpoints, Eparam, meanVec, covMat);
if (paramRows < impliedParamRows) {
Rf_error("At least %d rows are required in the item parameter matrix, only %d found",
impliedParamRows, paramRows);
}
quad.refresh(meanVec, covMat);
}
// Coordinate descent for logistic models (no active set cycling)
RcppExport SEXP cdfit_binomial_hsr_slores_nac(SEXP X_, SEXP y_, SEXP n_pos_, SEXP ylab_,
SEXP row_idx_, SEXP lambda_, SEXP nlambda_,
SEXP lam_scale_, SEXP lambda_min_,
SEXP alpha_, SEXP user_,
SEXP eps_, SEXP max_iter_, SEXP multiplier_,
SEXP dfmax_, SEXP ncore_, SEXP warn_,
SEXP safe_thresh_, SEXP verbose_) {
XPtr<BigMatrix> xMat(X_);
double *y = REAL(y_);
int n_pos = INTEGER(n_pos_)[0];
IntegerVector ylabel = Rcpp::as<IntegerVector>(ylab_); // label vector of {-1, 1}
int *row_idx = INTEGER(row_idx_);
double lambda_min = REAL(lambda_min_)[0];
double alpha = REAL(alpha_)[0];
int n = Rf_length(row_idx_); // number of observations used for fitting model
int p = xMat->ncol();
int L = INTEGER(nlambda_)[0];
int lam_scale = INTEGER(lam_scale_)[0];
double eps = REAL(eps_)[0];
int max_iter = INTEGER(max_iter_)[0];
double *m = REAL(multiplier_);
int dfmax = INTEGER(dfmax_)[0];
int warn = INTEGER(warn_)[0];
int user = INTEGER(user_)[0];
double slores_thresh = REAL(safe_thresh_)[0]; // threshold for safe test
int verbose = INTEGER(verbose_)[0];
NumericVector lambda(L);
NumericVector Dev(L);
IntegerVector iter(L);
IntegerVector n_reject(L); // number of total rejections;
IntegerVector n_slores_reject(L); // number of safe rejections;
NumericVector beta0(L);
NumericVector center(p);
NumericVector scale(p);
int p_keep = 0; // keep columns whose scale > 1e-6
int *p_keep_ptr = &p_keep;
vector<int> col_idx;
vector<double> z;
double lambda_max = 0.0;
double *lambda_max_ptr = &lambda_max;
int xmax_idx = 0;
int *xmax_ptr = &xmax_idx;
// set up omp
int useCores = INTEGER(ncore_)[0];
#ifdef BIGLASSO_OMP_H_
int haveCores = omp_get_num_procs();
if(useCores < 1) {
useCores = haveCores;
}
omp_set_dynamic(0);
omp_set_num_threads(useCores);
#endif
if (verbose) {
char buff1[100];
time_t now1 = time (0);
strftime (buff1, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now1));
Rprintf("\nPreprocessing start: %s\n", buff1);
}
// standardize: get center, scale; get p_keep_ptr, col_idx; get z, lambda_max, xmax_idx;
standardize_and_get_residual(center, scale, p_keep_ptr, col_idx, z, lambda_max_ptr, xmax_ptr, xMat,
y, row_idx, lambda_min, alpha, n, p);
p = p_keep; // set p = p_keep, only loop over columns whose scale > 1e-6
if (verbose) {
char buff1[100];
time_t now1 = time (0);
strftime (buff1, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now1));
Rprintf("Preprocessing end: %s\n", buff1);
Rprintf("\n-----------------------------------------------\n");
}
arma::sp_mat beta = arma::sp_mat(p, L); //beta
double *a = Calloc(p, double); //Beta from previous iteration
double a0 = 0.0; //beta0 from previousiteration
double *w = Calloc(n, double);
double *s = Calloc(n, double); //y_i - pi_i
double *eta = Calloc(n, double);
// int *e1 = Calloc(p, int); //ever-active set
int *e2 = Calloc(p, int); //strong set
double xwr, xwx, pi, u, v, cutoff, l1, l2, shift, si;
double max_update, update, thresh; // for convergence check
int i, j, jj, l, violations, lstart;
double ybar = sum(y, n) / n;
a0 = beta0[0] = log(ybar / (1-ybar));
double nullDev = 0;
double *r = Calloc(n, double);
for (i = 0; i < n; i++) {
r[i] = y[i];
nullDev = nullDev - y[i]*log(ybar) - (1-y[i])*log(1-ybar);
s[i] = y[i] - ybar;
eta[i] = a0;
}
thresh = eps * nullDev / n;
double sumS = sum(s, n); // temp result sum of s
double sumWResid = 0.0; // temp result: sum of w * r
// set up lambda
if (user == 0) {
if (lam_scale) { // set up lambda, equally spaced on log scale
double log_lambda_max = log(lambda_max);
double log_lambda_min = log(lambda_min*lambda_max);
double delta = (log_lambda_max - log_lambda_min) / (L-1);
for (l = 0; l < L; l++) {
lambda[l] = exp(log_lambda_max - l * delta);
}
} else { // equally spaced on linear scale
double delta = (lambda_max - lambda_min*lambda_max) / (L-1);
for (l = 0; l < L; l++) {
lambda[l] = lambda_max - l * delta;
}
}
Dev[0] = nullDev;
lstart = 1;
n_reject[0] = p;
} else {
lstart = 0;
lambda = Rcpp::as<NumericVector>(lambda_);
}
// Slores variables
vector<double> theta_lam;
double g_theta_lam = 0.0;
double prod_deriv_theta_lam = 0.0;
double *g_theta_lam_ptr = &g_theta_lam;
double *prod_deriv_theta_lam_ptr = &prod_deriv_theta_lam;
vector<double> X_theta_lam_xi_pos;
vector<double> prod_PX_Pxmax_xi_pos;
vector<double> cutoff_xi_pos;
int *slores_reject = Calloc(p, int);
int *slores_reject_old = Calloc(p, int);
for (int j = 0; j < p; j++) slores_reject_old[j] = 1;
int slores; // if 0, don't perform Slores rule
if (slores_thresh < 1) {
slores = 1; // turn on slores
theta_lam.resize(n);
X_theta_lam_xi_pos.resize(p);
prod_PX_Pxmax_xi_pos.resize(p);
cutoff_xi_pos.resize(p);
slores_init(theta_lam, g_theta_lam_ptr, prod_deriv_theta_lam_ptr, cutoff_xi_pos,
X_theta_lam_xi_pos, prod_PX_Pxmax_xi_pos,
xMat, y, z, xmax_idx, row_idx, col_idx,
center, scale, ylabel, n_pos, n, p);
} else {
slores = 0;
}
if (slores == 1 && user == 0) n_slores_reject[0] = p;
for (l = lstart; l < L; l++) {
if(verbose) {
// output time
char buff[100];
time_t now = time (0);
strftime (buff, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now));
Rprintf("Lambda %d. Now time: %s\n", l, buff);
}
if (l != 0) {
// Check dfmax
int nv = 0;
for (j = 0; j < p; j++) {
if (a[j] != 0) {
nv++;
}
}
if (nv > dfmax) {
for (int ll=l; ll<L; ll++) iter[ll] = NA_INTEGER;
Free(slores_reject);
Free(slores_reject_old);
Free_memo_bin_hsr_nac(s, w, a, r, e2, eta);
return List::create(beta0, beta, center, scale, lambda, Dev,
iter, n_reject, Rcpp::wrap(col_idx));
}
cutoff = 2*lambda[l] - lambda[l-1];
} else {
cutoff = 2*lambda[l] - lambda_max;
}
if (slores) {
slores_screen(slores_reject, theta_lam, g_theta_lam, prod_deriv_theta_lam,
X_theta_lam_xi_pos, prod_PX_Pxmax_xi_pos, cutoff_xi_pos,
row_idx, col_idx, center, scale, xmax_idx, ylabel,
lambda[l], lambda_max, n_pos, n, p);
n_slores_reject[l] = sum(slores_reject, p);
// update z[j] for features which are rejected at previous lambda but accepted at current one.
update_zj(z, slores_reject, slores_reject_old, xMat, row_idx, col_idx, center, scale, sumS, s, m, n, p);
#pragma omp parallel for private(j) schedule(static)
for (j = 0; j < p; j++) {
slores_reject_old[j] = slores_reject[j];
// hsr screening
// if (slores_reject[j] == 0 && (fabs(z[j]) > (cutoff * alpha * m[col_idx[j]]))) {
if (fabs(z[j]) > (cutoff * alpha * m[col_idx[j]])) {
e2[j] = 1;
} else {
e2[j] = 0;
}
}
} else {
n_slores_reject[l] = 0;
// hsr screening over all
#pragma omp parallel for private(j) schedule(static)
for (j = 0; j < p; j++) {
if (fabs(z[j]) > (cutoff * alpha * m[col_idx[j]])) {
e2[j] = 1;
} else {
e2[j] = 0;
}
}
}
n_reject[l] = p - sum(e2, p);
while (iter[l] < max_iter) {
while (iter[l] < max_iter) {
while (iter[l] < max_iter) {
iter[l]++;
Dev[l] = 0.0;
for (i = 0; i < n; i++) {
if (eta[i] > 10) {
pi = 1;
w[i] = .0001;
} else if (eta[i] < -10) {
pi = 0;
w[i] = .0001;
} else {
pi = exp(eta[i]) / (1 + exp(eta[i]));
w[i] = pi * (1 - pi);
}
s[i] = y[i] - pi;
r[i] = s[i] / w[i];
if (y[i] == 1) {
Dev[l] = Dev[l] - log(pi);
} else {
Dev[l] = Dev[l] - log(1-pi);
}
}
if (Dev[l] / nullDev < .01) {
if (warn) warning("Model saturated; exiting...");
for (int ll=l; ll<L; ll++) iter[ll] = NA_INTEGER;
Free(slores_reject);
Free(slores_reject_old);
Free_memo_bin_hsr_nac(s, w, a, r, e2, eta);
return List::create(beta0, beta, center, scale, lambda, Dev, iter, n_reject, n_slores_reject, Rcpp::wrap(col_idx));
}
// Intercept
xwr = crossprod(w, r, n, 0);
xwx = sum(w, n);
beta0[l] = xwr / xwx + a0;
si = beta0[l] - a0;
if (si != 0) {
a0 = beta0[l];
for (i = 0; i < n; i++) {
r[i] -= si; //update r
eta[i] += si; //update eta
}
}
sumWResid = wsum(r, w, n); // update temp result: sum of w * r, used for computing xwr;
max_update = 0.0;
for (j = 0; j < p; j++) {
if (e2[j]) {
jj = col_idx[j];
xwr = wcrossprod_resid(xMat, r, sumWResid, row_idx, center[jj], scale[jj], w, n, jj);
v = wsqsum_bm(xMat, w, row_idx, center[jj], scale[jj], n, jj) / n;
u = xwr/n + v * a[j];
l1 = lambda[l] * m[jj] * alpha;
l2 = lambda[l] * m[jj] * (1-alpha);
beta(j, l) = lasso(u, l1, l2, v);
shift = beta(j, l) - a[j];
if (shift != 0) {
// update change of objective function
// update = - u * shift + (0.5 * v + 0.5 * l2) * (pow(beta(j, l), 2) - pow(a[j], 2)) + l1 * (fabs(beta(j, l)) - fabs(a[j]));
update = pow(beta(j, l) - a[j], 2) * v;
if (update > max_update) max_update = update;
update_resid_eta(r, eta, xMat, shift, row_idx, center[jj], scale[jj], n, jj); // update r
sumWResid = wsum(r, w, n); // update temp result w * r, used for computing xwr;
a[j] = beta(j, l); // update a
}
}
}
// Check for convergence
if (max_update < thresh) break;
}
}
// Scan for violations in rest
if (slores) {
violations = check_rest_set_hsr_slores_nac(e2, slores_reject, z, xMat, row_idx, col_idx, center, scale, a, lambda[l], sumS, alpha, s, m, n, p);
} else {
violations = check_rest_set_bin_nac(e2, z, xMat, row_idx, col_idx, center, scale, a, lambda[l], sumS, alpha, s, m, n, p);
}
if (violations == 0) break;
if (n_slores_reject[l] <= p * slores_thresh) {
slores = 0; // turn off slores screening for next iteration if not efficient
}
}
}
Free(slores_reject);
Free(slores_reject_old);
Free_memo_bin_hsr_nac(s, w, a, r, e2, eta);
return List::create(beta0, beta, center, scale, lambda, Dev, iter, n_reject, n_slores_reject, Rcpp::wrap(col_idx));
}
/* These are defaulst that we always want to set */
void set_handle_defaults(reference *ref){
/* the actual curl handle */
CURL *handle = ref->handle;
assert(curl_easy_setopt(handle, CURLOPT_PRIVATE, ref));
/* set the response header collector */
reset_resheaders(ref);
curl_easy_setopt(handle, CURLOPT_HEADERFUNCTION, append_buffer);
curl_easy_setopt(handle, CURLOPT_HEADERDATA, &(ref->resheaders));
#ifdef _WIN32
if(CA_BUNDLE != NULL && strlen(CA_BUNDLE)){
/* on windows a cert bundle is included with R version 3.2.0 */
curl_easy_setopt(handle, CURLOPT_CAINFO, CA_BUNDLE);
} else {
/* disable cert validation for older versions of R */
curl_easy_setopt(handle, CURLOPT_SSL_VERIFYHOST, 0L);
curl_easy_setopt(handle, CURLOPT_SSL_VERIFYPEER, 0L);
}
#endif
/* needed to support compressed responses */
assert(curl_easy_setopt(handle, CURLOPT_ENCODING, "gzip, deflate"));
/* follow redirect */
assert(curl_easy_setopt(handle, CURLOPT_FOLLOWLOCATION, 1L));
assert(curl_easy_setopt(handle, CURLOPT_MAXREDIRS, 10L));
/* a sensible timeout (10s) */
assert(curl_easy_setopt(handle, CURLOPT_CONNECTTIMEOUT, 10L));
/* needed to start the cookie engine */
assert(curl_easy_setopt(handle, CURLOPT_COOKIEFILE, ""));
assert(curl_easy_setopt(handle, CURLOPT_FILETIME, 1L));
/* set the default user agent */
SEXP agent = GetOption1(install("HTTPUserAgent"));
if(isString(agent) && Rf_length(agent)){
assert(curl_easy_setopt(handle, CURLOPT_USERAGENT, CHAR(STRING_ELT(agent, 0))));
} else {
assert(curl_easy_setopt(handle, CURLOPT_USERAGENT, "r/curl/jeroen"));
}
/* allow all authentication methods */
assert(curl_easy_setopt(handle, CURLOPT_HTTPAUTH, CURLAUTH_ANY));
assert(curl_easy_setopt(handle, CURLOPT_UNRESTRICTED_AUTH, 1L));
assert(curl_easy_setopt(handle, CURLOPT_PROXYAUTH, CURLAUTH_ANY));
/* enables HTTP2 on HTTPS (match behavior of curl cmd util) */
#if defined(CURL_VERSION_HTTP2) && defined(HAS_HTTP_VERSION_2TLS)
if(curl_version_info(CURLVERSION_NOW)->features & CURL_VERSION_HTTP2)
assert(curl_easy_setopt(handle, CURLOPT_HTTP_VERSION, CURL_HTTP_VERSION_2TLS));
#endif
/* set an error buffer */
assert(curl_easy_setopt(handle, CURLOPT_ERRORBUFFER, ref->errbuf));
/* dummy readfunction because default can freeze R */
assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION, dummy_read));
/* seems to be needed for native WinSSL */
#ifdef _WIN32
curl_easy_setopt(handle, CURLOPT_SSL_OPTIONS, CURLSSLOPT_NO_REVOKE);
#endif
/* set default headers (disables the Expect: http 100)*/
#ifdef HAS_CURLOPT_EXPECT_100_TIMEOUT_MS
assert(curl_easy_setopt(handle, CURLOPT_EXPECT_100_TIMEOUT_MS, 0L));
#endif
assert(curl_easy_setopt(handle, CURLOPT_HTTPHEADER, default_headers));
/* set default progress printer (disabled by default) */
#ifdef HAS_XFERINFOFUNCTION
assert(curl_easy_setopt(handle, CURLOPT_XFERINFOFUNCTION, xferinfo_callback));
#else
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION, xferinfo_callback));
#endif
}
double asDouble(SEXP x){
if(!(isNumeric(x) && Rf_length(x)==1))error("Element must be a numeric of length 1");
return REAL(x)[0];
}
static int nvimcom_checklibs()
{
const char *libname;
char buf[256];
char *libn;
SEXP a, l;
PROTECT(a = eval(lang1(install("search")), R_GlobalEnv));
int newnlibs = Rf_length(a);
if(nlibs == newnlibs)
return(nlibs);
int k = 0;
for(int i = 0; i < newnlibs; i++){
if(i == 62)
break;
PROTECT(l = STRING_ELT(a, i));
libname = CHAR(l);
libn = strstr(libname, "package:");
if(libn != NULL){
strncpy(loadedlibs[k], libname, 63);
loadedlibs[k+1][0] = 0;
#ifdef WIN32
if(tcltkerr == 0){
if(strstr(libn, "tcltk") != NULL){
REprintf("Error: \"nvimcom\" and \"tcltk\" packages are incompatible!\n");
tcltkerr = 1;
}
}
#endif
k++;
}
UNPROTECT(1);
}
UNPROTECT(1);
for(int i = 0; i < 64; i++){
if(loadedlibs[i][0] == 0)
break;
for(int j = 0; j < 64; j++){
libn = strstr(loadedlibs[i], ":");
libn++;
if(strcmp(builtlibs[j], libn) == 0)
break;
if(builtlibs[j][0] == 0){
strcpy(builtlibs[j], libn);
sprintf(buf, "nvimcom:::nvim.buildomnils('%s')", libn);
nvimcom_eval_expr(buf);
needsfillmsg = 1;
break;
}
}
}
char fn[512];
snprintf(fn, 510, "%s/libnames_%s", tmpdir, getenv("NVIMR_ID"));
FILE *f = fopen(fn, "w");
if(f == NULL){
REprintf("Error: Could not write to '%s'. [nvimcom]\n", fn);
return(newnlibs);
}
for(int i = 0; i < 64; i++){
if(builtlibs[i][0] == 0)
break;
fprintf(f, "%s\n", builtlibs[i]);
}
fclose(f);
return(newnlibs);
}
void *
convertToNative(void **val, SEXP r_val, ffi_type *type) /* need something about copying, to control memory recollection*/
{
void *ans = NULL;
if(type == &ffi_type_sexp) {
SEXP *p = (SEXP *) R_alloc(sizeof(SEXP), 1);
*p = r_val;
ans = p;
} else if(type == &ffi_type_pointer) {
SEXPREC_ALIGN *p;
if(r_val == R_NilValue)
ans = NULL;
else if(IS_S4_OBJECT(r_val) && R_is(r_val, "AddressOf")) {
ans = getAddressOfExtPtr(GET_SLOT(r_val, Rf_install("ref")));
}
else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
ans = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref")));
} else {
/* Should be looking at the element type, not at r_val. */
switch(TYPEOF(r_val)) {
case INTSXP:
case LGLSXP:
{
p = ((SEXPREC_ALIGN *) r_val) + 1;
ans = p;
/* ans = &r_val + sizeof(SEXPREC_ALIGN*); */ /* INTEGER(r_val); */
}
break;
case REALSXP:
p = ((SEXPREC_ALIGN *) r_val) + 1;
ans = p; /* REAL(r_val); */
break;
case STRSXP: /*XXX What should happen is not clear here. The char ** or the single */
ans = Rf_length(r_val) ? CHAR(STRING_ELT(r_val, 0)) : NULL;
break;
case EXTPTRSXP:
ans = R_ExternalPtrAddr(r_val);
break;
case CLOSXP:
ans = r_val;
break;
case RAWSXP:
ans = RAW(r_val);
break;
default:
PROBLEM "unhandled conversion from R type (%d) to native FFI type", TYPEOF(r_val)
ERROR;
break;
}
}
} else {
if(type->type == FFI_TYPE_STRUCT) {
ans = convertRToStruct(r_val, type);
} else if(type == &ffi_type_string) {
const char * * tmp;
tmp = (const char * * ) R_alloc(sizeof(char *), 1);
if(r_val == R_NilValue)
*tmp = NULL;
else
*tmp = CHAR(STRING_ELT(r_val, 0));
ans = tmp;
} else if(type == &ffi_type_double) {
ans = REAL(r_val);
} else if(type == &ffi_type_float) {
/* We allocate a float, populate it with the value and return
a pointer to that new float. It is released when we return from the .Call(). */
float *tmp = (float *) R_alloc(sizeof(float), 1);
*tmp = REAL(r_val)[0];
ans = tmp;
} else if(type == &ffi_type_sint32) {
#if 1
/*experiment*/
if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
void **tmp = (void **) malloc(sizeof(void *));
*tmp = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))) ;
return(tmp);
}
#endif
if(TYPEOF(r_val) == INTSXP) {
ans = INTEGER(r_val);
} else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) {
ans = (int *) R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref")));
} else {
int *i = (int *) R_alloc(sizeof(int), 1);
i[0] = INTEGER(coerceVector(r_val, INTSXP))[0];
ans = i;
}
} else if(type == &ffi_type_sint16) {
short *s = (short *) R_alloc(1, 16);
*s = INTEGER(coerceVector(r_val, INTSXP))[0];
ans = s;
} else if(type == &ffi_type_uint32) {
unsigned int *tmp = (unsigned int *) R_alloc(sizeof(unsigned int), 1);
*tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0];
ans = tmp;
} else if(type == &ffi_type_uint16) {
unsigned short *tmp = (unsigned short *) R_alloc(sizeof(unsigned short), 1);
*tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0];
ans = tmp;
}
}
/* Rprintf("convert->native: %p\n", ans); */
return(ans);
}
SEXP
R_ffi_call(SEXP r_cif, SEXP r_args, SEXP r_sym, SEXP r_sexpType)
{
void *sym = R_ExternalPtrAddr(r_sym);
void **retVal = NULL;
void **args = NULL;
unsigned int nargs, i;
SEXP r_ans = R_NilValue;
int isVoid;
ffi_cif *cif;
if(!sym) {
PROBLEM "NULL value passed for routine to invoke"
ERROR;
}
cif = (ffi_cif *) R_ExternalPtrAddr(r_cif);
if(!cif) {
PROBLEM "NULL value passed for call interface pointer"
ERROR;
}
nargs = Rf_length(r_args);
if(nargs != cif->nargs) {
PROBLEM "incorrect number of arguments in ffi call: %d, should be %d",
(int) nargs, (int) cif->nargs
ERROR;
}
if(nargs > 0) {
void **indirect;
args = (void **) R_alloc(sizeof(void *), nargs);
indirect = (void **) R_alloc(sizeof(void *), nargs);
if(!args || !indirect) {
PROBLEM "cannot allocate space for vector of arguments in ffi call"
ERROR;
}
for(i = 0; i < nargs ; i++) {
void *tmp;
tmp = convertToNative(args + i, VECTOR_ELT(r_args, i), cif->arg_types[i]);
if(cif->arg_types[i] == &ffi_type_pointer) {
args[i] = indirect + i;
indirect[i] = tmp;
} else
args[i] = tmp;
}
}
isVoid = (cif->rtype == &ffi_type_void || cif->rtype->type == ffi_type_void.type);
if(!isVoid)
retVal = (void **) R_alloc(sizeof(void *), cif->rtype->size);
ffi_call(cif, sym, retVal, args);
/*
if(status != FFI_OK) {
PROBLEM "ffi call failed: %s", status == FFI_BAD_TYPEDEF ? "bad typedef" : "bad ABI"
ERROR;
}
*/
if(!isVoid) {
if(cif->rtype == R_ExternalPtrAddr(r_sexpType))
return(*((SEXP *) retVal));
r_ans = convertFromNative(retVal, cif->rtype);
}
return(r_ans);
}
bool CRInterface::run_r_helper(CSGInterface* from_if)
{
char* rfile=NULL;
try
{
for (int i=0; i<from_if->get_nrhs(); i++)
{
int len=0;
char* var_name = from_if->get_string(len);
from_if->SG_DEBUG("var_name = '%s'\n", var_name);
if (strmatch(var_name, "rfile"))
{
len=0;
rfile=from_if->get_string(len);
from_if->SG_DEBUG("rfile = '%s'\n", rfile);
break;
}
else
{
CRInterface* in = new CRInterface(R_NilValue, false);
in->create_return_values(1);
from_if->translate_arg(from_if, in);
setVar(install(var_name), in->get_return_values(), R_GlobalEnv);
delete[] var_name;
SG_UNREF(in);
}
}
}
catch (ShogunException e)
{
from_if->SG_PRINT("%s", e.get_exception_string());
return true;
}
// Find source function
SEXP src = Rf_findFun(Rf_install("source"), R_GlobalEnv);
PROTECT(src);
// Make file argument
SEXP file;
PROTECT(file = NEW_CHARACTER(1));
SET_STRING_ELT(file, 0, COPY_TO_USER_STRING(rfile));
// expression source(file,print.eval=p)
SEXP expr;
PROTECT(expr = allocVector(LANGSXP,2));
SETCAR(expr,src);
SETCAR(CDR(expr),file);
int err=0;
R_tryEval(expr,NULL,&err);
if (err)
{
UNPROTECT(3);
from_if->SG_PRINT("Error occurred\n");
return true;
}
SEXP results;
PROTECT(results=findVar(install("results"), R_GlobalEnv));
from_if->SG_DEBUG("Found type %d\n", TYPEOF(results));
try
{
if (TYPEOF(results)==LISTSXP)
{
int32_t sz=Rf_length(results);
from_if->SG_DEBUG("Found %d args\n", sz);
if (sz>0 && from_if->create_return_values(sz))
{
CRInterface* out = new CRInterface(results, false);
//process d
for (int32_t i=0; i<sz; i++)
from_if->translate_arg(out, from_if);
SG_UNREF(out);
}
else if (sz!=from_if->get_nlhs())
{
UNPROTECT(4);
from_if->SG_PRINT("Number of return values (%d) does not match "
"number of expected return values (%d).\n",
sz, from_if->get_nlhs());
return true;
}
}
}
catch (ShogunException e)
{
UNPROTECT(4);
from_if->SG_PRINT("%s", e.get_exception_string());
}
UNPROTECT(4);
return true;
}
void CRInterface::get_char_string_list(TString<char>*& strings, int32_t& num_str, int32_t& max_string_len)
{
SEXP strs=get_arg_increment();
if (strs == R_NilValue || TYPEOF(strs) != STRSXP)
SG_ERROR("Expected String List as argument %d\n", m_rhs_counter);
SG_DEBUG("nrows=%d ncols=%d Rf_length=%d\n", nrows(strs), ncols(strs), Rf_length(strs));
if (nrows(strs) && ncols(strs)!=1)
{
num_str = ncols(strs);
max_string_len = nrows(strs);
strings=new TString<char>[num_str];
ASSERT(strings);
for (int32_t i=0; i<num_str; i++)
{
char* dst=new char[max_string_len+1];
for (int32_t j=0; j<max_string_len; j++)
{
SEXPREC* s= STRING_ELT(strs,i*max_string_len+j);
if (LENGTH(s)!=1)
SG_ERROR("LENGTH(s)=%d != 1, nrows(strs)=%d ncols(strs)=%d\n", LENGTH(s), nrows(strs), ncols(strs));
dst[j]=CHAR(s)[0];
}
strings[i].string=dst;
strings[i].string[max_string_len]='\0';
strings[i].length=max_string_len;
}
}
else
{
max_string_len=0;
num_str=Rf_length(strs);
strings=new TString<char>[num_str];
ASSERT(strings);
for (int32_t i=0; i<num_str; i++)
{
SEXPREC* s= STRING_ELT(strs,i);
char* c= (char*) CHAR(s);
int32_t len=LENGTH(s);
if (len && c)
{
char* dst=new char[len+1];
strings[i].string=(char*) memcpy(dst, c, len*sizeof(char));
strings[i].string[len]='\0';
strings[i].length=len;
max_string_len=CMath::max(max_string_len, len);
}
else
{
SG_WARNING( "string with index %d has zero length\n", i+1);
strings[i].string=0;
strings[i].length=0;
}
}
}
}
/*
The real invoke mechanism that handles all the details.
*/
SEXP
R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn,
SEXP ids)
{
IDispatch* disp;
SEXP ans = R_NilValue;
int numNamedArgs = 0, *namedArgPositions = NULL, i;
HRESULT hr;
// callGC();
disp = (IDispatch *) getRDCOMReference(obj);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "<COM> %s %d %p\n", CHAR(STRING_ELT(methodName, 0)), (int) callType,
disp);fflush(stderr);
#endif
DISPID *methodIds;
const char *pmname = CHAR(STRING_ELT(methodName, 0));
BSTR *comNames = NULL;
SEXP names = GET_NAMES(args);
int numNames = Rf_length(names) + 1;
SetErrorInfo(0L, NULL);
methodIds = (DISPID *) S_alloc(numNames, sizeof(DISPID));
namedArgPositions = (int*) S_alloc(numNames, sizeof(int)); // we may not use all of these, but we allocate them
if(Rf_length(ids) == 0) {
comNames = (BSTR*) S_alloc(numNames, sizeof(BSTR));
comNames[0] = AsBstr(pmname);
for(i = 0; i < Rf_length(names); i++) {
const char *str = CHAR(STRING_ELT(names, i));
if(str && str[0]) {
comNames[numNamedArgs+1] = AsBstr(str);
namedArgPositions[numNamedArgs] = i;
numNamedArgs++;
}
}
numNames = numNamedArgs + 1;
hr = disp->GetIDsOfNames(IID_NULL, comNames, numNames, LOCALE_USER_DEFAULT, methodIds);
if(FAILED(hr) || hr == DISP_E_UNKNOWNNAME /* || DISPID mid == DISPID_UNKNOWN */) {
PROBLEM "Cannot locate %d name(s) %s in COM object (status = %d)", numNamedArgs, pmname, (int) hr
ERROR;
}
} else {
for(i = 0; i < Rf_length(ids); i++) {
methodIds[i] = (MEMBERID) NUMERIC_DATA(ids)[i];
//XXX What about namedArgPositions here.
}
}
DISPPARAMS params = {NULL, NULL, 0, 0};
if(args != NULL && Rf_length(args) > 0) {
hr = R_getCOMArgs(args, ¶ms, methodIds, numNamedArgs, namedArgPositions);
if(FAILED(hr)) {
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
PROBLEM "Failed in converting arguments to DCOM call"
ERROR;
}
if(callType & DISPATCH_PROPERTYPUT) {
params.rgdispidNamedArgs = (DISPID*) S_alloc(1, sizeof(DISPID));
params.rgdispidNamedArgs[0] = DISPID_PROPERTYPUT;
params.cNamedArgs = 1;
}
}
VARIANT varResult, *res = NULL;
if(doReturn && callType != DISPATCH_PROPERTYPUT)
VariantInit(res = &varResult);
EXCEPINFO exceptionInfo;
memset(&exceptionInfo, 0, sizeof(exceptionInfo));
unsigned int nargErr = 100;
#ifdef RDCOM_VERBOSE
if(params.cNamedArgs) {
errorLog("# of named arguments to %d: %d\n", (int) methodIds[0],
(int) params.cNamedArgs);
for(int p = params.cNamedArgs; p > 0; p--)
errorLog("%d) id %d, type %d\n", p,
(int) params.rgdispidNamedArgs[p-1],
(int) V_VT(&(params.rgvarg[p-1])));
}
#endif
hr = disp->Invoke(methodIds[0], IID_NULL, LOCALE_USER_DEFAULT, callType, ¶ms, res, &exceptionInfo, &nargErr);
if(FAILED(hr)) {
if(hr == DISP_E_MEMBERNOTFOUND) {
errorLog("Error because member not found %d\n", nargErr);
}
#ifdef RDCOM_VERBOSE
errorLog("Error (%d): <in argument %d>, call type = %d, call = \n",
(int) hr, (int)nargErr, (int) callType, pmname);
#endif
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
if(checkErrorInfo(disp, hr, NULL) != S_OK) {
fprintf(stderr, "checkErrorInfo %d\n", (int) hr);fflush(stderr);
COMError(hr);
}
}
if(res) {
ans = R_convertDCOMObjectToR(&varResult);
VariantClear(&varResult);
}
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif
return(ans);
}
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, int add_type_flags, RData *storage, int nesting_depth) {
RK_TRACE (RBACKEND);
bool at_toplevel = (toplevel_value == val);
bool is_function = false;
bool is_container = false;
bool is_environment = false;
bool no_recurse = (nesting_depth >= 2); // TODO: should be configurable
unsigned int type = 0;
RK_DEBUG (RBACKEND, DL_DEBUG, "fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val));
SEXP value = val;
PROTECT_INDEX value_index;
PROTECT_WITH_INDEX (value, &value_index);
// manually resolve any promises
REPROTECT (value = resolvePromise (value), value_index);
bool is_s4 = Rf_isS4 (value);
SEXP baseenv = R_BaseEnv;
if (is_s4) baseenv = R_GlobalEnv;
// first field: get name
RData *namedata = new RData;
namedata->setData (QStringList (name));
// get classes
SEXP classes_s;
if ((TYPEOF (value) == LANGSXP) || (TYPEOF (value) == SYMSXP)) { // if it's a call, we should NEVER send it through eval
extern SEXP R_data_class (SEXP, Rboolean);
classes_s = R_data_class (value, (Rboolean) 0);
REPROTECT (value = Rf_coerceVector (value, EXPRSXP), value_index); // make sure the object is safe for everything to come
PROTECT (classes_s);
} else {
classes_s = RKRSupport::callSimpleFun (class_fun, value, baseenv);
PROTECT (classes_s);
}
QStringList classes = RKRSupport::SEXPToStringList (classes_s);
UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
classdata->setData (classes);
// basic classification
for (int i = classes.size () - 1; i >= 0; --i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
if (RKRSupport::callSimpleBool (is_matrix_fun, value, baseenv)) type |= RObject::Matrix;
if (RKRSupport::callSimpleBool (is_list_fun, value, baseenv)) type |= RObject::List;
if (type != 0) {
is_container = true;
type |= RObject::Container;
} else {
if (RKRSupport::callSimpleBool (is_function_fun, value, baseenv)) {
is_function = true;
type |= RObject::Function;
} else if (RKRSupport::callSimpleBool (is_environment_fun, value, baseenv)) {
is_container = true;
type |= RObject::Environment;
is_environment = true;
} else {
type |= RObject::Variable;
if (RKRSupport::callSimpleBool (is_factor_fun, value, baseenv)) type |= RObject::Factor;
else if (RKRSupport::callSimpleBool (is_numeric_fun, value, baseenv)) type |= RObject::Numeric;
else if (RKRSupport::callSimpleBool (is_character_fun, value, baseenv)) type |= RObject::Character;
else if (RKRSupport::callSimpleBool (is_logical_fun, value, baseenv)) type |= RObject::Logical;
if (RKRSupport::callSimpleBool (is_array_fun, value, baseenv)) type |= RObject::Array;
}
}
type |= add_type_flags;
if (is_container) {
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into %s", name.toLatin1().data ());
}
}
// get meta data, if any
RData *metadata = new RData;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
SEXP meta_s = RKRSupport::callSimpleFun (get_meta_fun, value, R_GlobalEnv);
PROTECT (meta_s);
metadata->setData (RKRSupport::SEXPToStringList (meta_s));
UNPROTECT (1); /* meta_s */
} else {
metadata->setData (QStringList ());
}
// get dims
RData::IntStorage dims;
SEXP dims_s = RKRSupport::callSimpleFun (dims_fun, value, baseenv);
if (!Rf_isNull (dims_s)) {
dims = RKRSupport::SEXPToIntArray (dims_s);
} else {
unsigned int len = Rf_length (value);
if ((len < 2) && (!is_function)) { // suspicious. Maybe some kind of list
SEXP len_s = RKRSupport::callSimpleFun (length_fun, value, baseenv);
PROTECT (len_s);
if (Rf_isNull (len_s)) {
dims.append (len);
} else {
dims = RKRSupport::SEXPToIntArray (len_s);
}
UNPROTECT (1); /* len_s */
} else {
dims.append (len);
}
}
// store dims
RData *dimdata = new RData;
dimdata->setData (dims);
RData *slotsdata = new RData ();
// does it have slots?
if (is_s4) {
type |= RObject::S4Object;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into slots of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
SEXP slots_pseudo_object = RKRSupport::callSimpleFun (rk_get_slots_fun, value, R_GlobalEnv);
PROTECT (slots_pseudo_object);
getStructureSafe (slots_pseudo_object, "SLOTS", RObject::PseudoObject, dummy[0], nesting_depth); // do not increase depth for this pseudo-object
UNPROTECT (1);
slotsdata->setData (dummy);
}
}
// store type
RData *typedata = new RData;
typedata->setData (RData::IntStorage (1, type));
// store everything we have so far
int storage_length = RObject::StorageSizeBasicInfo;
if (is_container) {
storage_length = RObject::StorageSizeBasicInfo + 1;
} else if (is_function) {
storage_length = RObject::StorageSizeBasicInfo + 2;
}
RData::RDataStorage res (storage_length, 0);
res[RObject::StoragePositionName] = namedata;
res[RObject::StoragePositionType] = typedata;
res[RObject::StoragePositionClass] = classdata;
res[RObject::StoragePositionMeta] = metadata;
res[RObject::StoragePositionDims] = dimdata;
res[RObject::StoragePositionSlots] = slotsdata;
// now add the extra info for containers and functions
if (is_container) {
bool do_env = (is_environment && (!no_recurse));
bool do_cont = is_container && (!is_environment) && (!no_recurse);
// fetch list of child names
SEXP childnames_s;
if (do_env) {
childnames_s = R_lsInternal (value, (Rboolean) 1);
} else if (do_cont) {
childnames_s = RKRSupport::callSimpleFun (names_fun, value, baseenv);
} else {
childnames_s = R_NilValue; // dummy
}
PROTECT (childnames_s);
QStringList childnames = RKRSupport::SEXPToStringList (childnames_s);
int childcount = childnames.size ();
if (childcount > NAMED_CHILDREN_LIMIT) {
RK_DEBUG (RBACKEND, DL_WARNING, "object %s has %d named children. Will only retrieve the first %d", name.toLatin1().data (), childcount, NAMED_CHILDREN_LIMIT);
childcount = NAMED_CHILDREN_LIMIT;
}
RData::RDataStorage children (childcount, 0);
for (int i = 0; i < childcount; ++i) {
children[i] = new RData (); // NOTE: RData-ctor pre-initalizes these to empty. Thus, we're safe even if there is an error while fetching one of the children.
}
if (do_env) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into environment %s", name.toLatin1().data ());
if (!Rf_isEnvironment (value)) {
// some classes (ReferenceClasses) are identified as envionments by is.environment(), but are not internally ENVSXPs.
// For these, Rf_findVar would fail.
REPROTECT (value = RKRSupport::callSimpleFun (as_environment_fun, value, R_GlobalEnv), value_index);
}
for (int i = 0; i < childcount; ++i) {
SEXP current_childname = Rf_install(CHAR(STRING_ELT(childnames_s, i))); // ??? Why does simply using STRING_ELT(childnames_i, i) crash?
PROTECT (current_childname);
SEXP child = Rf_findVar (current_childname, value);
PROTECT (child);
bool child_misplaced = false;
if (at_toplevel && with_namespace && (!RKRBackend::this_pointer->RRuntimeIsVersion (2, 14, 0))) {
if (!Rf_isNull (namespace_envir)) {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
}
getStructureSafe (child, childnames[i], child_misplaced ? RObject::Misplaced : 0, children[i], nesting_depth + 1);
UNPROTECT (2); /* current_childname, child */
}
} else if (do_cont) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into list %s", name.toLatin1().data ());
// fewer elements than names() can happen, although I doubt it is supposed to happen.
// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007
bool may_be_special = Rf_length (value) < childcount;
if (Rf_isList (value) && (!may_be_special)) { // old style list
for (int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
CDR (value);
}
} else if (Rf_isNewList (value) && (!may_be_special)) { // new style list
for (int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
PROTECT (index);
for (int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = RKRSupport::callSimpleFun2 (double_brackets_fun, value, index, baseenv);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
UNPROTECT (1); /* index */
}
}
UNPROTECT (1); /* childnames_s */
RData *childdata = new RData;
childdata->setData (children);
res[RObject::StoragePositionChildren] = childdata;
if (is_environment && at_toplevel && with_namespace) {
RData *namespacedata = new RData;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into namespace of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
getStructureSafe (namespace_envir, "NAMESPACE", RObject::PseudoObject, dummy[0], nesting_depth+99); // HACK: By default, do not recurse into the children of the namespace, until dealing with the namespace object itself.
namespacedata->setData (dummy);
}
res.insert (RObject::StoragePositionNamespace, namespacedata);
}
} else if (is_function) {
// TODO: getting the formals is still a bit of a bottleneck, but no idea, how to improve on this, any further
SEXP formals_s;
if (Rf_isPrimitive (value)) formals_s = FORMALS (RKRSupport::callSimpleFun (args_fun, value, baseenv)); // primitives don't have formals, internally
else formals_s = FORMALS (value);
PROTECT (formals_s);
// get the default values
QStringList formals = RKRSupport::SEXPToStringList (formals_s);
// for the most part, the implicit as.character in SEXPToStringList does a good on the formals (and it's the fastest of many options that I have tried).
// Only for naked strings (as in 'function (a="something")'), we're missing the quotes. So we add quotes, after conversion, as needed:
SEXP dummy = formals_s;
const int formals_len = Rf_length (formals_s);
for (int i = 0; i < formals_len; ++i) {
if (TYPEOF (CAR (dummy)) == STRSXP) formals[i] = RKRSharedFunctionality::quote (formals[i]);
dummy = CDR (dummy);
}
RData *funargvaluesdata = new RData;
funargvaluesdata->setData (formals);
// the argument names
SEXP names_s = Rf_getAttrib (formals_s, R_NamesSymbol);
PROTECT (names_s);
RData *funargsdata = new RData;
funargsdata->setData (RKRSupport::SEXPToStringList (names_s));
UNPROTECT (2); /* names_s, formals_s */
res[RObject::StoragePositionFunArgs] = funargsdata;
res[RObject::StoragePositionFunValues] = funargvaluesdata;
}
UNPROTECT (1); /* value */
RK_ASSERT (!res.contains (0));
storage->setData (res);
}
SEXP transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
static void nvimcom_list_env()
{
const char *varName;
SEXP envVarsSEXP, varSEXP;
if(tmpdir[0] == 0)
return;
if(objbr_auto != 1)
return;
#ifndef WIN32
struct timeval begin, middle, end, tdiff1, tdiff2;
if(verbose > 1)
gettimeofday(&begin, NULL);
#endif
memset(obbrbuf2, 0, obbrbufzise);
char *p = nvimcom_strcat(obbrbuf2, ".GlobalEnv | Libraries\n\n");
PROTECT(envVarsSEXP = R_lsInternal(R_GlobalEnv, allnames));
for(int i = 0; i < Rf_length(envVarsSEXP); i++){
varName = CHAR(STRING_ELT(envVarsSEXP, i));
PROTECT(varSEXP = Rf_findVar(Rf_install(varName), R_GlobalEnv));
if (varSEXP != R_UnboundValue) // should never be unbound
{
p = nvimcom_browser_line(&varSEXP, varName, "", " ", p);
} else {
REprintf("Unexpected R_UnboundValue returned from R_lsInternal.\n");
}
UNPROTECT(1);
}
UNPROTECT(1);
#ifndef WIN32
if(verbose > 1)
gettimeofday(&middle, NULL);
#endif
int len1 = strlen(obbrbuf1);
int len2 = strlen(obbrbuf2);
if(len1 != len2){
nvimcom_write_obbr();
} else {
for(int i = 0; i < len1; i++){
if(obbrbuf1[i] != obbrbuf2[i]){
nvimcom_write_obbr();
break;
}
}
}
#ifndef WIN32
if(verbose > 1){
gettimeofday(&end, NULL);
timersub(&middle, &begin, &tdiff1);
timersub(&end, &middle, &tdiff2);
Rprintf("Time to Update the Object Browser: %ld.%06ld + %ld.%06ld\n",
(long int)tdiff1.tv_sec, (long int)tdiff1.tv_usec,
(long int)tdiff2.tv_sec, (long int)tdiff2.tv_usec);
}
#endif
}
SEXP
processJSONNode(JSONNODE *n, int parentType, int simplify, SEXP nullValue, int simplifyWithNames, cetype_t charEncoding,
SEXP r_stringCall, StringFunctionType str_fun_type)
{
if (n == NULL){
PROBLEM "invalid JSON input"
ERROR;
}
JSONNODE *i;
int len = 0, ctr = 0;
int nprotect = 0;
int numNulls = 0;
len = json_size(n);
char startType = parentType; // was 127
int isNullHomogeneous = (TYPEOF(nullValue) == LGLSXP || TYPEOF(nullValue) == REALSXP ||
TYPEOF(nullValue) == STRSXP || TYPEOF(nullValue) == INTSXP);
int numStrings = 0;
int numLogicals = 0;
int numNumbers = 0;
SEXP ans, names = NULL;
PROTECT(ans = NEW_LIST(len)); nprotect++;
int homogeneous = 0;
int elType = NILSXP;
while (ctr < len){ // i != json_end(n)
i = json_at(n, ctr);
if (i == NULL){
PROBLEM "Invalid JSON Node"
ERROR;
}
json_char *node_name = json_name(i);
char type = json_type(i);
if(startType == 127)
startType = type;
SEXP el;
switch(type) {
case JSON_NULL:
el = nullValue; /* R_NilValue; */
numNulls++;
if(isNullHomogeneous) {
homogeneous++;
elType = setType(elType, TYPEOF(nullValue));
} else
elType = TYPEOF(nullValue);
break;
case JSON_ARRAY:
case JSON_NODE:
el = processJSONNode(i, type, simplify, nullValue, simplifyWithNames, charEncoding, r_stringCall, str_fun_type);
if(Rf_length(el) > 1)
elType = VECSXP;
else
elType = setType(elType, TYPEOF(el));
break;
case JSON_NUMBER:
el = ScalarReal(json_as_float(i));
homogeneous++;
elType = setType(elType, REALSXP);
numNumbers++;
break;
case JSON_BOOL:
el = ScalarLogical(json_as_bool(i));
elType = setType(elType, LGLSXP);
numLogicals++;
break;
case JSON_STRING:
{
//XXX Garbage collection
#if 0 //def JSON_UNICODE
wchar_t *wtmp = json_as_string(i);
char *tmp;
int len = wcslen(wtmp);
int size = sizeof(char) * (len * MB_LEN_MAX + 1);
tmp = (char *)malloc(size);
if (tmp == NULL) {
PROBLEM "Cannot allocate memory"
ERROR;
}
wcstombs(tmp, wtmp, size);
#else
char *tmp = json_as_string(i);
// tmp = reEnc(tmp, CE_BYTES, CE_UTF8, 1);
#endif
if(r_stringCall != NULL && TYPEOF(r_stringCall) == EXTPTRSXP) {
if(str_fun_type == SEXP_STR_ROUTINE) {
SEXPStringRoutine fun;
fun = (SEXPStringRoutine) R_ExternalPtrAddr(r_stringCall);
el = fun(tmp, charEncoding);
} else {
char *tmp1;
StringRoutine fun;
fun = (StringRoutine) R_ExternalPtrAddr(r_stringCall);
tmp1 = fun(tmp);
if(tmp1 != tmp)
json_free(tmp);
tmp = tmp1;
el = ScalarString(mkCharCE(tmp, charEncoding));
}
} else {
el = ScalarString(mkCharCE(tmp, charEncoding));
/* Call the R function if there is one. */
if(r_stringCall != NULL) {
SETCAR(CDR(r_stringCall), el);
el = Rf_eval(r_stringCall, R_GlobalEnv);
}
/* XXX compute with elType. */
}
json_free(tmp);
elType = setType(elType,
/* If we have a class, not a primitive type */
Rf_length(getAttrib(el, Rf_install("class"))) ? LISTSXP : TYPEOF(el));
if(r_stringCall != NULL && str_fun_type != NATIVE_STR_ROUTINE) {
switch(TYPEOF(el)) {
case REALSXP:
numNumbers++;
break;
case LGLSXP:
numLogicals++;
break;
case STRSXP:
numStrings++;
break;
}
} else if(TYPEOF(el) == STRSXP)
numStrings++;
}
break;
default:
PROBLEM "shouldn't be here"
WARN;
el = R_NilValue;
break;
}
SET_VECTOR_ELT(ans, ctr, el);
if(parentType == JSON_NODE || (node_name && node_name[0])) {
if(names == NULL) {
PROTECT(names = NEW_CHARACTER(len)); nprotect++;
}
if(node_name && node_name[0])
SET_STRING_ELT(names, ctr, mkChar(node_name));
}
json_free(node_name);
ctr++;
}
/* If we have an empty object, we try to make it into a form equivalent to emptyNamedList
if it is a {}, or as an AsIs object in R if an empty array. */
if(len == 0 && (parentType == -1 || parentType == JSON_ARRAY || parentType == JSON_NODE)) {
if(parentType == -1)
parentType = startType;
if(parentType == JSON_NODE)
SET_NAMES(ans, NEW_CHARACTER(0));
else {
SET_CLASS(ans, ScalarString(mkChar("AsIs")));
}
} else if(simplifyWithNames || names == NULL || Rf_length(names) == 0) {
int allSame = (numNumbers == len || numStrings == len || numLogicals == len) ||
((TYPEOF(nullValue) == LGLSXP && LOGICAL(nullValue)[0] == NA_INTEGER) &&
((numNumbers + numNulls) == len || (numStrings + numNulls) == len || (numLogicals + numNulls) == len));
homogeneous = allSame || ( (numNumbers + numStrings + numLogicals + numNulls) == len);
if(simplify == NONE) {
} else if(allSame &&
(numNumbers == len && (simplify & STRICT_NUMERIC)) ||
((numLogicals == len) && (simplify & STRICT_LOGICAL)) ||
( (numStrings == len) && (simplify & STRICT_CHARACTER))) {
ans = makeVector(ans, len, elType, nullValue);
} else if((simplify == ALL && homogeneous) || (simplify == STRICT && allSame)) {
ans = makeVector(ans, len, elType, nullValue);
}
}
if(names)
SET_NAMES(ans, names);
UNPROTECT(nprotect);
return(ans);
}
static void nvimcom_list_libs()
{
int newnlibs;
if(tmpdir[0] == 0)
return;
newnlibs = nvimcom_checklibs();
if(newnlibs == nlibs && openclosel == 0)
return;
nlibs = newnlibs;
openclosel = 0;
if(objbr_auto != 2)
return;
int len, len1;
char *libn;
char prefixT[64];
char prefixL[64];
char libasenv[64];
SEXP x, oblist, obj;
memset(obbrbuf2, 0, obbrbufzise);
char *p = nvimcom_strcat(obbrbuf2, "Libraries | .GlobalEnv\n\n");
strcpy(prefixT, " ");
strcpy(prefixL, " ");
strcat(prefixT, strT);
strcat(prefixL, strL);
int save_opendf = opendf;
int save_openls = openls;
opendf = 0;
openls = 0;
int i = 0;
while(loadedlibs[i][0] != 0){
libn = loadedlibs[i] + 8;
p = nvimcom_strcat(p, " ##");
p = nvimcom_strcat(p, libn);
p = nvimcom_strcat(p, "\t\n");
if(nvimcom_get_list_status(loadedlibs[i], "library") == 1){
#ifdef WIN32
if(tcltkerr){
REprintf("Error: Cannot open libraries due to conflict between \"nvimcom\" and \"tcltk\" packages.\n");
i++;
continue;
}
#endif
PROTECT(x = allocVector(STRSXP, 1));
SET_STRING_ELT(x, 0, mkChar(loadedlibs[i]));
PROTECT(oblist = eval(lang2(install("objects"), x), R_GlobalEnv));
len = Rf_length(oblist);
len1 = len - 1;
for(int j = 0; j < len; j++){
PROTECT(obj = eval(lang3(install("get"), ScalarString(STRING_ELT(oblist, j)), x), R_GlobalEnv));
snprintf(libasenv, 63, "%s-", loadedlibs[i]);
if(j == len1)
p = nvimcom_browser_line(&obj, CHAR(STRING_ELT(oblist, j)), libasenv, prefixL, p);
else
p = nvimcom_browser_line(&obj, CHAR(STRING_ELT(oblist, j)), libasenv, prefixT, p);
UNPROTECT(1);
}
UNPROTECT(2);
}
i++;
}
FILE *f = fopen(liblist, "w");
if(f == NULL){
REprintf("Error: Could not write to '%s'. [nvimcom]\n", liblist);
return;
}
fprintf(f, "%s", obbrbuf2);
fclose(f);
opendf = save_opendf;
openls = save_openls;
nvimcom_nvimclient("UpdateOB('libraries')", edsrvr);
}
void omxCompleteExpectation(omxExpectation *ox) {
if(ox->isComplete) return;
if (ox->rObj) {
omxState *os = ox->currentState;
SEXP rObj = ox->rObj;
SEXP slot;
{ScopedProtect(slot, R_do_slot(rObj, Rf_install("container")));
if (Rf_length(slot) == 1) {
int ex = INTEGER(slot)[0];
ox->container = os->expectationList.at(ex);
}
}
{ScopedProtect(slot, R_do_slot(rObj, Rf_install("submodels")));
if (Rf_length(slot)) {
int numSubmodels = Rf_length(slot);
int *submodel = INTEGER(slot);
for (int ex=0; ex < numSubmodels; ex++) {
int sx = submodel[ex];
ox->submodels.push_back(omxExpectationFromIndex(sx, os));
}
}
}
}
omxExpectationProcessDataStructures(ox, ox->rObj);
int numSubmodels = (int) ox->submodels.size();
for (int ex=0; ex < numSubmodels; ex++) {
omxCompleteExpectation(ox->submodels[ex]);
}
ox->initFun(ox);
if(ox->computeFun == NULL) {
if (isErrorRaised()) {
Rf_error("Failed to initialize '%s' of type %s: %s", ox->name, ox->expType, Global->getBads());
} else {
Rf_error("Failed to initialize '%s' of type %s", ox->name, ox->expType);
}
}
if (OMX_DEBUG) {
omxData *od = ox->data;
omxState *state = ox->currentState;
std::string msg = string_snprintf("Expectation '%s' of type '%s' has"
" %d definition variables:\n", ox->name, ox->expType,
int(od->defVars.size()));
for (int dx=0; dx < int(od->defVars.size()); ++dx) {
omxDefinitionVar &dv = od->defVars[dx];
msg += string_snprintf("[%d] column '%s' ->", dx, omxDataColumnName(od, dv.column));
for (int lx=0; lx < dv.numLocations; ++lx) {
msg += string_snprintf(" %s[%d,%d]", state->matrixToName(~dv.matrices[lx]),
dv.rows[lx], dv.cols[lx]);
}
msg += "\n dirty:";
for (int mx=0; mx < dv.numDeps; ++mx) {
msg += string_snprintf(" %s", state->matrixToName(dv.deps[mx]));
}
msg += "\n";
}
mxLogBig(msg);
}
ox->isComplete = TRUE;
}
SEXP
R_ocr_boundingBoxes(SEXP filename, SEXP r_vars, SEXP r_level, SEXP r_names)
{
SEXP ans = R_NilValue;
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
if(api->Init(NULL, "eng")) {
PROBLEM "could not intialize tesseract engine."
ERROR;
}
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0]; //RIL_WORD;
if(ri != 0) {
int n = 1, i;
while(ri->Next(level)) n++;
ri = api->GetIterator();
SEXP names, tmp;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_LIST(n));
i = 0;
int x1, y1, x2, y2;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
ri->BoundingBox(level, &x1, &y1, &x2, &y2);
SET_STRING_ELT(names, i, Rf_mkChar(word));
SET_VECTOR_ELT(ans, i, tmp = NEW_NUMERIC(5));
REAL(tmp)[0] = conf;
REAL(tmp)[1] = x1;
REAL(tmp)[2] = y1;
REAL(tmp)[3] = x2;
REAL(tmp)[4] = y2;
SET_NAMES(tmp, r_names);
delete[] word;
i++;
} while (ri->Next(level));
SET_NAMES(ans, names);
UNPROTECT(2);
}
pixDestroy(&image);
return(ans);
}
SEXP R_handle_setopt(SEXP ptr, SEXP keys, SEXP values){
CURL *handle = get_handle(ptr);
SEXP prot = R_ExternalPtrProtected(ptr);
SEXP optnames = PROTECT(getAttrib(values, R_NamesSymbol));
if(!isInteger(keys))
error("keys` must be an integer");
if(!isVector(values))
error("`values` must be a list");
for(int i = 0; i < length(keys); i++){
int key = INTEGER(keys)[i];
const char* optname = CHAR(STRING_ELT(optnames, i));
SEXP val = VECTOR_ELT(values, i);
if(val == R_NilValue){
assert(curl_easy_setopt(handle, key, NULL));
#ifdef HAS_XFERINFOFUNCTION
} else if (key == CURLOPT_XFERINFOFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_XFERINFOFUNCTION,
(curl_progress_callback) R_curl_callback_xferinfo));
assert(curl_easy_setopt(handle, CURLOPT_XFERINFODATA, val));
assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0));
SET_VECTOR_ELT(prot, 1, val); //protect gc
#endif
} else if (key == CURLOPT_PROGRESSFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION,
(curl_progress_callback) R_curl_callback_progress));
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSDATA, val));
assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0));
SET_VECTOR_ELT(prot, 2, val); //protect gc
} else if (key == CURLOPT_READFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION,
(curl_read_callback) R_curl_callback_read));
assert(curl_easy_setopt(handle, CURLOPT_READDATA, val));
SET_VECTOR_ELT(prot, 3, val); //protect gc
} else if (key == CURLOPT_DEBUGFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_DEBUGFUNCTION,
(curl_debug_callback) R_curl_callback_debug));
assert(curl_easy_setopt(handle, CURLOPT_DEBUGDATA, val));
SET_VECTOR_ELT(prot, 4, val); //protect gc
} else if (key == CURLOPT_URL) {
/* always use utf-8 for urls */
const char * url_utf8 = translateCharUTF8(STRING_ELT(val, 0));
assert(curl_easy_setopt(handle, CURLOPT_URL, url_utf8));
} else if (opt_is_linked_list(key)) {
error("Option %s (%d) not supported.", optname, key);
} else if(key < 10000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (long) asInteger(val)));
} else if(key < 20000){
switch (TYPEOF(val)) {
case RAWSXP:
if(key == CURLOPT_POSTFIELDS || key == CURLOPT_COPYPOSTFIELDS)
assert(curl_easy_setopt(handle, CURLOPT_POSTFIELDSIZE_LARGE, (curl_off_t) Rf_length(val)));
assert(curl_easy_setopt(handle, key, RAW(val)));
break;
case STRSXP:
if (length(val) != 1)
error("Value for option %s (%d) must be length-1 string", optname, key);
assert(curl_easy_setopt(handle, key, CHAR(STRING_ELT(val, 0))));
break;
default:
error("Value for option %s (%d) must be a string or raw vector.", optname, key);
}
} else if(key >= 30000 && key < 40000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (curl_off_t) asReal(val)));
} else {
error("Option %s (%d) not supported.", optname, key);
}
}
UNPROTECT(1);
return ScalarLogical(1);
}
