bool
RwxHtmlWinTagHandler::HandleTag(const wxHtmlTag & varib)
{
SEXP r_this, r_info, r_parser;
PROTECT(r_this = R_make_wxWidget_Ref(this, "RwxHtmlWinTagHandler"));
PROTECT(r_info = R_make_wxWidget_Ref( &varib, "wxHtmlTag"));
PROTECT(r_parser = R_make_wxWidget_Ref(m_WParser, "wxHtmlParser"));
SEXP r_ans;
bool ans = true;
r_ans = invoke(handler, r_this, r_info, r_parser);
UNPROTECT(3);
if(r_ans == NULL) {
ans = false;
} else if(TYPEOF(r_ans) == LGLSXP) {
ans = LOGICAL(r_ans)[0];
}
else if(IS_S4_OBJECT(r_ans)) {
/* insert the widget for the user. */
if(Rf_inherits(r_ans, "wxWindow")) {
wxWindow *w = (wxWindow *) R_get_wxWidget_Ref(r_ans, "wxWindow");
wxHtmlWidgetCell *cell = new wxHtmlWidgetCell(w);
wxHtmlContainerCell *container = m_WParser->GetContainer();
container->InsertCell(cell);
}
}
return(ans);
}
SEXP cr_close(SEXP sc) {
rconn_t *c;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
rc_close(c);
return R_NilValue;
}
inline SWMat<T> asSWMat(SEXP x){
if (!Rf_inherits(x, "swmat")) Rcpp::stop("the given object does not inherit from swmat");
Rcpp::List list = Rcpp::as<Rcpp::List>(x);
//you must make sure that no memory is allocated here. The pointers won't be valid otherwise
Vec<T> vec((SEXP)list["vec"]);
int step = list["step"];
int nrow = list["nrow"];
return SWMat<T>(vec, nrow, step);
}
inline GapMat<T> asGapMat(SEXP x){
if (!Rf_inherits(x, "gapmat")) Rcpp::stop("the given object does not inherit from gapmat");
Rcpp::List list = Rcpp::as<Rcpp::List>(x);
//you must make sure that no memory is allocated here. The pointers won't be valid otherwise
Vec<T> vec((SEXP)list["vec"]);
Vec<int> colset((SEXP)list["colset"]);
int nrow = list["nrow"];
return GapMat<T>(vec.ptr, colset.ptr, nrow, colset.len);
}
SEXP R_mpc_imag(SEXP e1) {
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (mpfr_fits_sint_p(mpc_imagref(*z1), GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(mpc_imagref(*z1),
GMP_RNDN));
} else {
Rf_error("Imaginary part doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
Error jsonValueFromList(SEXP listSEXP, core::json::Value* pValue)
{
if (isNamedList(listSEXP))
{
if (Rf_inherits(listSEXP, "data.frame"))
return jsonObjectArrayFromDataFrame(listSEXP, pValue);
else
return jsonObjectFromList(listSEXP, pValue);
}
else
{
return jsonValueArrayFromList(listSEXP, pValue);
}
}
SEXP R_mpc_arg(SEXP e1) {
mpfr_t x;
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_arg(x, *z1, GMP_RNDN);
if (mpfr_fits_sint_p(x, GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(x, GMP_RNDN));
} else {
Rf_error("Arg doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
SEXP R_mpc_conj(SEXP x) {
if (!Rf_inherits(x, "mpc")) {
Rf_error("Invalid operand for conj.mpc");
}
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(x);
mpc_init2(*z, mpc_get_prec(*z1));
mpc_conj(*z, *z1, Rmpc_get_rounding());
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
/* issuue one command with one key paratemer and return the result */
SEXP cr_cmd(SEXP sc, SEXP sArgs) {
rconn_t *c;
const char **argv = argbuf;
int n, i;
redisReply *reply;
SEXP res;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(sArgs) != STRSXP || LENGTH(sArgs) < 1)
Rf_error("invalid command - must be a string");
n = LENGTH(sArgs);
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
for (i = 0; i < n; i++)
argv[i] = CHAR(STRING_ELT(sArgs, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, 2, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("%s error: %s and re-connect failed", argv[0], CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("%s error: %s", argv[0], CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
res = rc_reply2R(reply);
freeReplyObject(reply);
return res;
}
SEXP cr_del(SEXP sc, SEXP keys) {
rconn_t *c;
int n, i;
const char **argv = argbuf;
redisReply *reply;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
argv[0] = "DEL";
for (i = 0; i < n; i++)
argv[i + 1] = CHAR(STRING_ELT(keys, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("DEL error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("DEL error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
freeReplyObject(reply);
return R_NilValue;
}
SEXP R_mpc_neg(SEXP e1) {
/* Garbage collector will be confused if we just call
* mpc_neg(*z, *z, ...) */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_init2(*z, mpc_get_prec(*z1));
mpc_neg(*z, *z1, Rmpc_get_rounding());
} else {
Rf_error("Invalid operands for mpc negation.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP cr_keys(SEXP sc, SEXP sPattern) {
rconn_t *c;
int n, i;
const char *pattern = "*";
redisReply *reply;
SEXP res;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(sPattern) == STRSXP && LENGTH(sPattern) > 0)
pattern = CHAR(STRING_ELT(sPattern, 0));
reply = redisCommand(c->rc, "KEYS %s", pattern);
if (!reply && (c->flags & RCF_RETRY)) {
rc_close(c);
rc_validate_connection(c, 0);
reply = redisCommand(c->rc, "KEYS %s", pattern);
}
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("KEYS error: %s", CHAR(es));
}
if (reply->type != REDIS_REPLY_ARRAY) {
freeReplyObject(reply);
Rf_error("unexpected result type");
}
res = PROTECT(Rf_allocVector(STRSXP, (n = reply->elements)));
for (i = 0; i < n; i++) {
if (reply->element[i]->type == REDIS_REPLY_STRING)
SET_STRING_ELT(res, i, Rf_mkCharLenCE(reply->element[i]->str, reply->element[i]->len, CE_UTF8));
else if (reply->element[i]->type == REDIS_REPLY_NIL)
SET_STRING_ELT(res, i, R_NaString);
else {
freeReplyObject(reply);
Rf_error("invalid element (non-string) in the keys array");
}
}
freeReplyObject(reply);
UNPROTECT(1);
return res;
}
Error evaluateString(const std::string& str,
SEXP* pSEXP,
sexp::Protect* pProtect)
{
// refresh source if necessary (no-op in production)
r::sourceManager().reloadIfNecessary();
// surrond the string with try in silent mode so we can capture error text
std::string rCode = "try(" + str + ", TRUE)";
// parse expression
SEXP ps;
Error parseError = parseString(rCode, &ps, pProtect);
if (parseError)
return parseError;
// evaluate the expression
Error evalError = evaluateExpressions(ps, pSEXP, pProtect);
if (evalError)
{
evalError.addProperty("code", str);
return evalError;
}
// check for try-error
if (Rf_inherits(*pSEXP, "try-error"))
{
// get error message (merely log on failure so we can continue
// and return the real error)
std::string errorMsg ;
Error extractError = sexp::extract(*pSEXP, &errorMsg);
if (extractError)
LOG_ERROR(extractError);
// add it to the error
return rCodeExecutionError(errorMsg, ERROR_LOCATION);
}
return Success();
}
SEXP R_mpc_add(SEXP e1, SEXP e2) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_prec_t real_prec, imag_prec;
Rmpc_get_max_prec(&real_prec, &imag_prec, *z1, *z2);
mpc_init3(*z, real_prec, imag_prec);
mpc_add(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_add_ui(*z, *z1, INTEGER(e2)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
// We use GMP_RNDN rather than MPFR_RNDN for compatibility
// with mpfr 2.4.x and earlier as well as more modern versions.
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
/* Max of mpc precision z2 and 53 from e2. */
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_add_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
/* TODO(mstokely): Add support for mpfr types here. */
free(z);
Rf_error("Invalid second operand for mpc addition.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_sub(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e1, "mpc")) {
Rprintf("It's an mpc");
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_sub(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_sub_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_sub_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operand 2 of MPC subtraction.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_sub(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e1)[0], GMP_RNDN);
mpc_fr_sub(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else {
/* TODO(mstokely): Add support for mpfr types here. */
Rprintf("It's unknown");
free(z);
Rf_error("Invalid second operand for mpc subtraction.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
JoinVisitor* join_visitor(SEXP left, SEXP right, const SymbolString& name_left, const SymbolString& name_right, bool warn_) {
// handle Date separately
bool lhs_date = Rf_inherits(left, "Date");
bool rhs_date = Rf_inherits(right, "Date");
switch (lhs_date + rhs_date) {
case 2:
return date_join_visitor<ACCEPT_NA_MATCH>(left, right);
case 1:
stop("cannot join a Date object with an object that is not a Date object");
case 0:
break;
default:
break;
}
bool lhs_time = Rf_inherits(left, "POSIXct");
bool rhs_time = Rf_inherits(right, "POSIXct");
switch (lhs_time + rhs_time) {
case 2:
return new POSIXctJoinVisitor<ACCEPT_NA_MATCH>(left, right);
case 1:
stop("cannot join a POSIXct object with an object that is not a POSIXct object");
case 0:
break;
default:
break;
}
switch (TYPEOF(left)) {
case CPLXSXP:
{
switch (TYPEOF(right)) {
case CPLXSXP:
return new JoinVisitorImpl<CPLXSXP, CPLXSXP, ACCEPT_NA_MATCH>(left, right);
default:
break;
}
break;
}
case INTSXP:
{
bool lhs_factor = Rf_inherits(left, "factor");
switch (TYPEOF(right)) {
case INTSXP:
{
bool rhs_factor = Rf_inherits(right, "factor");
if (lhs_factor && rhs_factor) {
if (same_levels(left, right)) {
return new JoinVisitorImpl<INTSXP, INTSXP, ACCEPT_NA_MATCH>(left, right);
} else {
if (warn_) Rf_warning("joining factors with different levels, coercing to character vector");
return new JoinVisitorImpl<STRSXP, STRSXP, ACCEPT_NA_MATCH>(reencode_char(left), reencode_char(right));
}
} else if (!lhs_factor && !rhs_factor) {
return new JoinVisitorImpl<INTSXP, INTSXP, ACCEPT_NA_MATCH>(left, right);
}
break;
}
case REALSXP:
{
if (!lhs_factor && is_bare_vector(right)) {
return new JoinVisitorImpl<INTSXP, REALSXP, ACCEPT_NA_MATCH>(left, right);
}
break;
// what else: perhaps we can have INTSXP which is a Date and REALSXP which is a Date too ?
}
case LGLSXP:
{
if (!lhs_factor) {
return new JoinVisitorImpl<INTSXP, LGLSXP, ACCEPT_NA_MATCH>(left, right);
}
break;
}
case STRSXP:
{
if (lhs_factor) {
if (warn_) Rf_warning("joining factor and character vector, coercing into character vector");
return new JoinVisitorImpl<STRSXP, STRSXP, ACCEPT_NA_MATCH>(reencode_char(left), reencode_char(right));
}
}
default:
break;
}
break;
}
case REALSXP:
{
switch (TYPEOF(right)) {
case REALSXP:
return new JoinVisitorImpl<REALSXP, REALSXP, ACCEPT_NA_MATCH>(left, right);
case INTSXP:
return new JoinVisitorImpl<REALSXP, INTSXP, ACCEPT_NA_MATCH>(left, right);
default:
break;
}
}
case LGLSXP:
{
switch (TYPEOF(right)) {
case LGLSXP:
return new JoinVisitorImpl<LGLSXP, LGLSXP, ACCEPT_NA_MATCH> (left, right);
case INTSXP:
return new JoinVisitorImpl<LGLSXP, INTSXP, ACCEPT_NA_MATCH>(left, right);
case REALSXP:
return new JoinVisitorImpl<LGLSXP, REALSXP, ACCEPT_NA_MATCH>(left, right);
default:
break;
}
break;
}
case STRSXP:
{
switch (TYPEOF(right)) {
case INTSXP:
{
if (Rf_inherits(right, "factor")) {
if (warn_) Rf_warning("joining character vector and factor, coercing into character vector");
return new JoinVisitorImpl<STRSXP, STRSXP, ACCEPT_NA_MATCH>(reencode_char(left), reencode_char(right));
}
break;
}
case STRSXP:
{
return new JoinVisitorImpl<STRSXP, STRSXP, ACCEPT_NA_MATCH>(reencode_char(left), reencode_char(right));
}
default:
break;
}
break;
}
default:
break;
}
stop("Can't join on '%s' x '%s' because of incompatible types (%s / %s)",
name_left.get_utf8_cstring(), name_right.get_utf8_cstring(), get_single_class(left), get_single_class(right)
);
return 0;
}
JoinVisitor* join_visitor( SEXP left, SEXP right, const std::string& name_left, const std::string& name_right){
switch( TYPEOF(left) ){
case INTSXP:
{
bool lhs_factor = Rf_inherits( left, "factor" ) ;
switch( TYPEOF(right) ){
case INTSXP:
{
bool rhs_factor = Rf_inherits( right, "factor" ) ;
if( lhs_factor && rhs_factor){
return new JoinFactorFactorVisitor(left, right) ;
} else if( !lhs_factor && !rhs_factor) {
return new JoinVisitorImpl<INTSXP, INTSXP>( left, right ) ;
}
break ;
}
case REALSXP:
{
if( lhs_factor ){
incompatible_join_visitor(left, right, name_left, name_right) ;
} else if( is_bare_vector(right) ) {
return new JoinVisitorImpl<INTSXP, REALSXP>( left, right) ;
} else {
incompatible_join_visitor(left, right, name_left, name_right) ;
}
break ;
// what else: perhaps we can have INTSXP which is a Date and REALSXP which is a Date too ?
}
case LGLSXP:
{
if( lhs_factor ){
incompatible_join_visitor(left, right, name_left, name_right) ;
} else {
return new JoinVisitorImpl<INTSXP, LGLSXP>( left, right) ;
}
break ;
}
case STRSXP:
{
if( lhs_factor ){
return new JoinFactorStringVisitor( left, right );
}
}
default: break ;
}
break ;
}
case REALSXP:
{
bool lhs_date = Rf_inherits( left, "Date" ) ;
bool lhs_time = Rf_inherits( left, "POSIXct" );
switch( TYPEOF(right) ){
case REALSXP:
{
if( Rf_inherits( right, "Date") ){
if(lhs_date) return new DateJoinVisitor(left, right ) ;
incompatible_join_visitor(left, right, name_left, name_right) ;
}
if( Rf_inherits( right, "POSIXct" ) ){
if( lhs_time ) return new POSIXctJoinVisitor(left, right ) ;
incompatible_join_visitor(left, right, name_left, name_right) ;
}
if( is_bare_vector( right ) ){
return new JoinVisitorImpl<REALSXP, REALSXP>( left, right) ;
}
break ;
}
case INTSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<REALSXP, INTSXP>( left, right) ;
}
}
default: break ;
}
}
case LGLSXP:
{
switch( TYPEOF(right) ){
case LGLSXP:
{
return new JoinVisitorImpl<LGLSXP,LGLSXP> ( left, right ) ;
}
case INTSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<LGLSXP, INTSXP>( left, right ) ;
}
break ;
}
case REALSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<LGLSXP, REALSXP>( left, right ) ;
}
}
default: break ;
}
break ;
}
case STRSXP:
{
switch( TYPEOF(right) ){
case INTSXP:
{
if( Rf_inherits(right, "factor" ) ){
return new JoinStringFactorVisitor( left, right ) ;
}
break ;
}
case STRSXP:
{
return new JoinVisitorImpl<STRSXP,STRSXP> ( left, right ) ;
}
default: break ;
}
break ;
}
default: break ;
}
incompatible_join_visitor(left, right, name_left, name_right) ;
return 0 ;
}
static cl_kernel getKernel(SEXP k) {
if (!Rf_inherits(k, "clKernel") ||
TYPEOF(k) != EXTPTRSXP)
Rf_error("invalid OpenCL kernel");
return (cl_kernel)R_ExternalPtrAddr(k);
}
#include <stdlib.h>
#ifdef __APPLE__
#include <OpenCL/opencl.h>
#else
#include <CL/opencl.h>
#endif
#define USE_RINTERNALS 1
#include <Rinternals.h>
void ocl_err(const char *str) {
Rf_error("%s failed", str);
}
static void clFreeFin(SEXP ref) {
free(R_ExternalPtrAddr(ref));
}
static SEXP mkPlatformID(cl_platform_id id) {
SEXP ptr;
cl_platform_id *pp = (cl_platform_id*) malloc(sizeof(cl_platform_id));
pp[0] = id;
ptr = PROTECT(R_MakeExternalPtr(pp, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeFin, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clPlatformID"));
UNPROTECT(1);
return ptr;
}
static cl_platform_id getPlatformID(SEXP platform) {
if (!Rf_inherits(platform, "clPlatformID") || TYPEOF(platform) != EXTPTRSXP)
Rf_error("invalid platform");
return ((cl_platform_id*)R_ExternalPtrAddr(platform))[0];
}
static SEXP mkDeviceID(cl_device_id id) {
SEXP ptr;
cl_device_id *pp = (cl_device_id*) malloc(sizeof(cl_device_id));
pp[0] = id;
ptr = PROTECT(R_MakeExternalPtr(pp, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeFin, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clDeviceID"));
UNPROTECT(1);
return ptr;
}
static cl_device_id getDeviceID(SEXP device) {
if (!Rf_inherits(device, "clDeviceID") ||
TYPEOF(device) != EXTPTRSXP)
Rf_error("invalid device");
return ((cl_device_id*)R_ExternalPtrAddr(device))[0];
}
static void clFreeContext(SEXP ctx) {
clReleaseContext((cl_context)R_ExternalPtrAddr(ctx));
}
static SEXP mkContext(cl_context ctx) {
SEXP ptr;
ptr = PROTECT(R_MakeExternalPtr(ctx, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeContext, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clContext"));
UNPROTECT(1);
return ptr;
}
#if 0 /* currently unused so disable for now to avoid warnings ... */
static cl_context getContext(SEXP ctx) {
if (!Rf_inherits(ctx, "clContext") ||
TYPEOF(ctx) != EXTPTRSXP)
Rf_error("invalid OpenCL context");
return (cl_context)R_ExternalPtrAddr(ctx);
}
SEXP ocl_collect_call(SEXP octx, SEXP wait) {
SEXP res = R_NilValue;
ocl_call_context_t *occ;
int on;
cl_int err;
if (!Rf_inherits(octx, "clCallContext"))
Rf_error("Invalid call context");
occ = (ocl_call_context_t*) R_ExternalPtrAddr(octx);
if (!occ || occ->finished)
Rf_error("The call results have already been collected, they cannot be retrieved twice");
if (Rf_asInteger(wait) == 0 && occ->event) {
cl_int status;
if ((err = clGetEventInfo(occ->event, CL_EVENT_COMMAND_EXECUTION_STATUS, sizeof(status), &status, NULL)) != CL_SUCCESS)
Rf_error("OpenCL error 0x%x while querying event object for the supplied context", (int) err);
if (status < 0)
Rf_error("Asynchronous call failed with error code 0x%x", (int) -status);
if (status != CL_COMPLETE)
return R_NilValue;
}
clFinish(occ->commands);
occ->finished = 1;
/* we can release input memory objects now */
if (occ->mem_objects) {
arg_free(occ->mem_objects, (afin_t) clReleaseMemObject);
occ->mem_objects = 0;
}
if (occ->float_args) {
arg_free(occ->float_args, 0);
occ->float_args = 0;
}
on = occ->on;
res = occ->ftres ? Rf_allocVector(RAWSXP, on * sizeof(float)) : Rf_allocVector(REALSXP, on);
if (occ->ftype == FT_SINGLE) {
if (occ->ftres) {
if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(float) * on, RAW(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
PROTECT(res);
Rf_setAttrib(res, R_ClassSymbol, mkString("clFloat"));
UNPROTECT(1);
} else {
/* float - need a temporary buffer */
float *fr = (float*) malloc(sizeof(float) * on);
double *r = REAL(res);
int i;
if (!fr)
Rf_error("unable to allocate memory for temporary single-precision output buffer");
occ->float_out = fr;
if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(float) * on, fr, 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
for (i = 0; i < on; i++)
r[i] = fr[i];
}
} else if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(double) * on, REAL(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d double elements, oclError %d)", on, err);
ocl_call_context_fin(octx);
return res;
}
static cl_device_id getDeviceID(SEXP device) {
if (!Rf_inherits(device, "clDeviceID") ||
TYPEOF(device) != EXTPTRSXP)
Rf_error("invalid device");
return ((cl_device_id*)R_ExternalPtrAddr(device))[0];
}
static cl_platform_id getPlatformID(SEXP platform) {
if (!Rf_inherits(platform, "clPlatformID") || TYPEOF(platform) != EXTPTRSXP)
Rf_error("invalid platform");
return ((cl_platform_id*)R_ExternalPtrAddr(platform))[0];
}
SEXP cr_get(SEXP sc, SEXP keys, SEXP asList) {
rconn_t *c;
int n, i, use_list = Rf_asInteger(asList);
const char **argv = argbuf;
redisReply *reply;
SEXP res;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (use_list < 0) /* asList == NA -> list for non scalar results only */
use_list = (n == 1) ? 0 : 1;
if (n != 1 && !use_list) Rf_error("exaclty one key must be specified with list=FALSE");
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
argv[0] = "MGET";
for (i = 0; i < n; i++)
argv[i + 1] = CHAR(STRING_ELT(keys, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("MGET error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("MGET error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
if (reply->type != REDIS_REPLY_ARRAY) {
freeReplyObject(reply);
Rf_error("unexpected result type");
}
if (reply->elements != n) {
freeReplyObject(reply);
Rf_error("unexpected result length - should be %d but is %d", n, (int) reply->elements);
}
if (use_list) {
int n = reply->elements;
res = PROTECT(Rf_allocVector(VECSXP, n));
Rf_setAttrib(res, R_NamesSymbol, keys);
for (i = 0; i < n; i++)
SET_VECTOR_ELT(res, i, rc_reply2R(reply->element[i]));
UNPROTECT(1);
} else
res = rc_reply2R(reply->element[0]);
freeReplyObject(reply);
return res;
}
SEXP cr_set(SEXP sc, SEXP keys, SEXP values) {
rconn_t *c;
int n, i;
const char **argv = argbuf;
size_t *argsz = argszbuf;
redisReply *reply;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (n < 1) return R_NilValue;
/* FIXME: we check only the first ... in the hope that we support more formats later */
if (TYPEOF(values) != VECSXP || TYPEOF(VECTOR_ELT(values, 0)) != RAWSXP)
Rf_error ("Sorry, values can only be a list of raw vectors for now");
if (LENGTH(values) != n) Rf_error("keys/values length mismatch");
if (2 * n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (2 * n + 2));
if (!argv)
Rf_error("out of memory");
argsz = malloc(sizeof(size_t) * (2 * n + 2));
if (!argsz) {
free(argv);
Rf_error("out of memory");
}
}
argv[0] = "MSET"; argsz[0] = strlen(argv[0]);
for (i = 0; i < n; i++) {
argv [2 * i + 1] = CHAR(STRING_ELT(keys, i));
argsz[2 * i + 1] = strlen(argv[2 * i + 1]);
argv [2 * i + 2] = (char*) RAW(VECTOR_ELT(values, i));
argsz[2 * i + 2] = LENGTH(VECTOR_ELT(values, i));
}
reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
else {
if (argv != argbuf) {
free(argv);
free(argsz);
}
Rf_error("MGET error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf) {
free(argv);
free(argsz);
}
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("MSET error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
/* Note: the result is normally "status" - probably nothing useful we can do with that? */
freeReplyObject(reply);
return R_NilValue;
}
Rconnection get_connection(SEXP con) {
if (!Rf_inherits(con, "connection"))
Rcpp::stop("invalid connection");
return getConnection(Rf_asInteger(con));
}
JoinVisitor* join_visitor( SEXP left, SEXP right, const std::string& name_left, const std::string& name_right, bool warn_ ){
// handle Date separately
bool lhs_date = Rf_inherits( left, "Date") ;
bool rhs_date = Rf_inherits( right, "Date") ;
switch( lhs_date + rhs_date ){
case 2: return new DateJoinVisitor( left, right ) ;
case 1: stop( "cannot join a Date object with an object that is not a Date object" ) ;
case 0: break ;
default: break ;
}
bool lhs_time = Rf_inherits( left, "POSIXct" );
bool rhs_time = Rf_inherits( right, "POSIXct" );
switch( lhs_time + rhs_time ){
case 2: return new POSIXctJoinVisitor( left, right) ;
case 1: stop( "cannot join a POSIXct object with an object that is not a POSIXct object" ) ;
case 0: break;
default: break ;
}
switch( TYPEOF(left) ){
case CPLXSXP:
{
switch( TYPEOF(right) ){
case CPLXSXP: return new JoinVisitorImpl<CPLXSXP, CPLXSXP>( left, right ) ;
default:
break ;
}
break ;
}
case INTSXP:
{
bool lhs_factor = Rf_inherits( left, "factor" ) ;
switch( TYPEOF(right) ){
case INTSXP:
{
bool rhs_factor = Rf_inherits( right, "factor" ) ;
if( lhs_factor && rhs_factor){
if( same_levels(left, right) ){
return new JoinFactorFactorVisitor_SameLevels(left, right) ;
} else {
if(warn_) Rf_warning( "joining factors with different levels, coercing to character vector" );
return new JoinFactorFactorVisitor(left, right) ;
}
} else if( !lhs_factor && !rhs_factor) {
return new JoinVisitorImpl<INTSXP, INTSXP>( left, right ) ;
}
break ;
}
case REALSXP:
{
if( lhs_factor ){
incompatible_join_visitor(left, right, name_left, name_right) ;
} else if( is_bare_vector(right) ) {
return new JoinVisitorImpl<INTSXP, REALSXP>( left, right) ;
} else {
incompatible_join_visitor(left, right, name_left, name_right) ;
}
break ;
// what else: perhaps we can have INTSXP which is a Date and REALSXP which is a Date too ?
}
case LGLSXP:
{
if( lhs_factor ){
incompatible_join_visitor(left, right, name_left, name_right) ;
} else {
return new JoinVisitorImpl<INTSXP, LGLSXP>( left, right) ;
}
break ;
}
case STRSXP:
{
if( lhs_factor ){
if(warn_) Rf_warning( "joining factor and character vector, coercing into character vector" ) ;
return new JoinFactorStringVisitor( left, right );
}
}
default: break ;
}
break ;
}
case REALSXP:
{
switch( TYPEOF(right) ){
case REALSXP:
{
if( is_bare_vector( right ) ){
return new JoinVisitorImpl<REALSXP, REALSXP>( left, right) ;
}
break ;
}
case INTSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<REALSXP, INTSXP>( left, right) ;
}
}
default: break ;
}
}
case LGLSXP:
{
switch( TYPEOF(right) ){
case LGLSXP:
{
return new JoinVisitorImpl<LGLSXP,LGLSXP> ( left, right ) ;
}
case INTSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<LGLSXP, INTSXP>( left, right ) ;
}
break ;
}
case REALSXP:
{
if( is_bare_vector(right) ){
return new JoinVisitorImpl<LGLSXP, REALSXP>( left, right ) ;
}
}
default: break ;
}
break ;
}
case STRSXP:
{
switch( TYPEOF(right) ){
case INTSXP:
{
if( Rf_inherits(right, "factor" ) ){
if(warn_) Rf_warning( "joining character vector and factor, coercing into character vector" ) ;
return new JoinStringFactorVisitor( left, right ) ;
}
break ;
}
case STRSXP:
{
return new JoinStringStringVisitor( left, right ) ;
}
default: break ;
}
break ;
}
default: break ;
}
incompatible_join_visitor(left, right, name_left, name_right) ;
return 0 ;
}
