alexgutteridge-rsruby 0.5

data/ext/Converters.h

@@ -0,0 +1,77 @@
+/*
+* == Author
+* Alex Gutteridge
+*
+* == Copyright
+*Copyright (C) 2006 Alex Gutteridge
+*
+* The Original Code is the RPy python module.
+*
+* The Initial Developer of the Original Code is Walter Moreira.
+* Portions created by the Initial Developer are Copyright (C) 2002
+* the Initial Developer. All Rights Reserved.
+*
+* Contributor(s):
+*    Gregory R. Warnes <greg@warnes.net> (RPy Maintainer)
+*
+*This library is free software; you can redistribute it and/or
+*modify it under the terms of the GNU Lesser General Public
+*License as published by the Free Software Foundation; either
+*version 2.1 of the License, or (at your option) any later version.
+*
+*This library is distributed in the hope that it will be useful,
+*but WITHOUT ANY WARRANTY; without even the implied warranty of
+*MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+*Lesser General Public License for more details.
+*
+*You should have received a copy of the GNU Lesser General Public
+*License along with this library; if not, write to the Free Software
+*Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef R_RUBY_CONVERTERS_H
+#define R_RUBY_CONVERTERS_H
+
+#include "rsruby.h"
+
+//Converters for Ruby to R
+SEXP ruby_to_R(VALUE val);
+
+SEXP array_to_R(VALUE obj);
+SEXP hash_to_R(VALUE obj);
+int type_to_int(VALUE obj);
+
+//Converters for R to Ruby
+VALUE to_ruby_with_mode(SEXP robj, int mode);
+
+int to_ruby_basic(SEXP robj, VALUE *obj);
+int to_ruby_vector(SEXP robj, VALUE *obj, int mode);
+int to_ruby_proc(SEXP robj, VALUE *obj);
+int to_ruby_class(SEXP robj, VALUE *obj);
+int from_proc_table(SEXP robj, VALUE *fun);
+VALUE from_class_table(SEXP robj);
+
+VALUE call_proc(VALUE data);
+VALUE reset_mode(VALUE mode);
+
+VALUE to_ruby_hash(VALUE obj, SEXP names);
+VALUE to_ruby_array(VALUE obj, int *dims, int l);
+
+VALUE ltranspose(VALUE list, int *dims, int *strides,
+		 int pos, int shift, int len);
+
+//Macros for quick checks
+#define Robj_Check(v) (rb_obj_is_instance_of(v,rb_const_get(rb_cObject,rb_intern("RObj"))))
+#define RubyComplex_Check(v) (rb_obj_is_instance_of(v,rb_const_get(rb_cObject,rb_intern("Complex"))))
+
+/* These are auxiliaries for a state machine for converting Python
+   list to the coarsest R vector type */
+#define ANY_T 0
+#define BOOL_T 1
+#define INT_T 2
+#define FLOAT_T 3
+#define COMPLEX_T 4
+#define STRING_T 5
+#define ROBJ_T 6
+
+#endif

data/ext/R_eval.c

@@ -0,0 +1,144 @@
+/*
+* == Author
+* Alex Gutteridge
+*
+* == Copyright
+*Copyright (C) 2006 Alex Gutteridge
+*
+* The Original Code is the RPy python module.
+*
+* The Initial Developer of the Original Code is Walter Moreira.
+* Portions created by the Initial Developer are Copyright (C) 2002
+* the Initial Developer. All Rights Reserved.
+*
+* Contributor(s):
+*    Gregory R. Warnes <greg@warnes.net> (RPy Maintainer)
+*
+*This library is free software; you can redistribute it and/or
+*modify it under the terms of the GNU Lesser General Public
+*License as published by the Free Software Foundation; either
+*version 2.1 of the License, or (at your option) any later version.
+*
+*This library is distributed in the hope that it will be useful,
+*but WITHOUT ANY WARRANTY; without even the implied warranty of
+*MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+*Lesser General Public License for more details.
+*
+*You should have received a copy of the GNU Lesser General Public
+*License along with this library; if not, write to the Free Software
+*Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include <rsruby.h>
+#include <R_eval.h>
+
+int interrupted = 0;
+
+/* Abort the current R computation due to a SIGINT */
+void interrupt_R(int signum)
+{
+  interrupted = 1;
+  error("Interrupted");
+}
+
+
+/* Evaluate a SEXP. It must be constructed by hand. It raises a Ruby
+   exception if an error ocurred in the evaluation */
+SEXP do_eval_expr(SEXP e) {
+  SEXP res;
+  VALUE rb_eRException;
+  int error = 0;
+
+  signal(SIGINT, interrupt_R);
+  interrupted = 0;
+
+  res = R_tryEval(e, R_GlobalEnv, &error);
+
+  if (error) {
+    if (interrupted) {
+      rb_raise(rb_eInterrupt,"RSRuby interrupted");
+    }
+    else {
+      rb_eRException = rb_const_get(rb_cObject, 
+				    rb_intern("RException"));
+      rb_raise(rb_eRException, get_last_error_msg());
+      return NULL;
+    }
+  }
+
+  return res;
+
+}
+
+/* Evaluate a function given by a name (without arguments) */
+SEXP do_eval_fun(char *name) {
+  SEXP exp, fun, res;
+
+  fun = get_fun_from_name(name);
+  if (!fun)
+    return NULL;
+
+  PROTECT(fun);
+  PROTECT(exp = allocVector(LANGSXP, 1));
+  SETCAR(exp, fun);
+
+  PROTECT(res = do_eval_expr(exp));
+  UNPROTECT(3);
+  return res;
+}
+
+/*
+ * Get an R **function** object by its name. When not found, an exception is
+ * raised. The checking of the length of the identifier is needed to
+ * avoid R raising an error.
+ */
+SEXP get_fun_from_name(char *ident) {
+  SEXP obj;
+
+  /* For R not to throw an error, we must check the identifier is
+     neither null nor greater than MAXIDSIZE */
+  if (!*ident) {
+    rb_raise(rb_eRuntimeError, "Attempt to use zero-length variable name");
+    return NULL;
+  }
+  if (strlen(ident) > MAXIDSIZE) {
+    rb_raise(rb_eRuntimeError, "symbol print-name too long");
+    return NULL;
+  }
+  
+#if R_VERSION < 0x20000
+  obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
+#else
+  /*
+   * For R-2.0.0 and later, it is necessary to use findFun to get
+   * functions.  Unfortunately, calling findFun on an undefined name
+   * causes a segfault!
+   *
+   * Solution:
+   *
+   * 1) Call findVar on the name
+   *
+   * 2) If something has the name, call findFun
+   *
+   * 3) Raise an error if either step 1 or 2 fails.
+   */
+  obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
+
+  if (obj != R_UnboundValue)
+      obj = Rf_findFun(Rf_install(ident), R_GlobalEnv);
+#endif
+  
+  if (obj == R_UnboundValue) {
+    rb_raise(rb_eNoMethodError, "R Function \"%s\" not found", ident);
+    return NULL;
+  }
+  return obj;
+}
+
+/* Obtain the text of the last R error message */
+char *get_last_error_msg() {
+  SEXP msg;
+
+  msg = do_eval_fun("geterrmessage");
+  return CHARACTER_VALUE(msg);
+}

data/ext/R_eval.h

@@ -0,0 +1,40 @@
+/*
+* == Author
+* Alex Gutteridge
+*
+* == Copyright
+*Copyright (C) 2006 Alex Gutteridge
+*
+* The Original Code is the RPy python module.
+*
+* The Initial Developer of the Original Code is Walter Moreira.
+* Portions created by the Initial Developer are Copyright (C) 2002
+* the Initial Developer. All Rights Reserved.
+*
+* Contributor(s):
+*    Gregory R. Warnes <greg@warnes.net> (RPy Maintainer)
+*
+*This library is free software; you can redistribute it and/or
+*modify it under the terms of the GNU Lesser General Public
+*License as published by the Free Software Foundation; either
+*version 2.1 of the License, or (at your option) any later version.
+*
+*This library is distributed in the hope that it will be useful,
+*but WITHOUT ANY WARRANTY; without even the implied warranty of
+*MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+*Lesser General Public License for more details.
+*
+*You should have received a copy of the GNU Lesser General Public
+*License along with this library; if not, write to the Free Software
+*Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+/* R Evaluation */
+SEXP do_eval_expr(SEXP e);
+SEXP do_eval_fun(char *);
+SEXP get_fun_from_name(char *);
+
+/* Interrupt the R interpreter */
+void interrupt_R(int);
+
+char *get_last_error_msg(void);

data/ext/extconf.rb

@@ -0,0 +1,13 @@
+require 'mkmf'
+
+dir_config('R')
+unless have_library("R")
+  $stderr.puts "\nERROR: Cannot find the R library, aborting."
+  exit 1
+end
+unless have_header("R.h")
+  $stderr.puts "\nERROR: Cannot find the R header, aborting."
+  exit 1
+end
+
+create_makefile("rsruby_c")

data/ext/robj.c

@@ -0,0 +1,205 @@
+/*
+* == Author
+* Alex Gutteridge
+*
+* == Copyright
+*Copyright (C) 2006 Alex Gutteridge
+*
+* The Original Code is the RPy python module.
+*
+* The Initial Developer of the Original Code is Walter Moreira.
+* Portions created by the Initial Developer are Copyright (C) 2002
+* the Initial Developer. All Rights Reserved.
+*
+* Contributor(s):
+*    Gregory R. Warnes <greg@warnes.net> (RPy Maintainer)
+*
+*This library is free software; you can redistribute it and/or
+*modify it under the terms of the GNU Lesser General Public
+*License as published by the Free Software Foundation; either
+*version 2.1 of the License, or (at your option) any later version.
+*
+*This library is distributed in the hope that it will be useful,
+*but WITHOUT ANY WARRANTY; without even the implied warranty of
+*MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+*Lesser General Public License for more details.
+*
+*You should have received a copy of the GNU Lesser General Public
+*License along with this library; if not, write to the Free Software
+*Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "rsruby.h"
+
+/* Methods for the 'Robj' type */
+
+/* Explicitly call an R object with a list containing (name, value) *
+ * argument pairs.  'name' can be None or '' to provide unnamed
+ * arguments.  This function is necessary when the *order* of named
+ * arguments needs to be preserved.
+ */
+
+VALUE RObj_lcall(VALUE self, VALUE args){
+  SEXP  exp, e, res;
+  SEXP  r_obj;
+  int conv, default_mode;
+  VALUE obj;
+
+  //Ensure we have an array
+  args = rb_check_array_type(args);
+
+  // A SEXP with the function to call and the arguments
+  PROTECT(exp = allocVector(LANGSXP, (RARRAY(args)->len)+1));
+  e = exp;
+
+  Data_Get_Struct(self, struct SEXPREC, r_obj);
+
+  SETCAR(e, r_obj);
+  e = CDR(e);
+
+  // Add the arguments to the SEXP
+  if (!make_argl(args, &e)) {
+    UNPROTECT(1);
+    return Qnil;
+  }
+
+  // Evaluate
+  PROTECT(res = do_eval_expr(exp));
+  if (!res) {
+    UNPROTECT(2);
+    return Qnil;
+  }
+
+  default_mode = NUM2INT(rb_iv_get(RSRUBY,"@default_mode"));
+
+  // Convert
+  if (default_mode < 0){
+    conv = NUM2INT(rb_iv_get(self,"@conversion"));
+  } else {
+    conv = default_mode;
+  }
+
+  obj = to_ruby_with_mode(res, conv);
+
+  UNPROTECT(2);
+
+  return obj;
+}
+
+
+//lcall method that is safe to call during RSRuby initialisation
+VALUE RObj_init_lcall(VALUE self, VALUE args){
+  SEXP  exp, e, res;
+  SEXP  r_obj;
+  VALUE obj;
+
+  //Ensure we have an array
+  args = rb_check_array_type(args);
+
+  // A SEXP with the function to call and the arguments
+  PROTECT(exp = allocVector(LANGSXP, (RARRAY(args)->len)+1));
+  e = exp;
+
+  Data_Get_Struct(self, struct SEXPREC, r_obj);
+
+  SETCAR(e, r_obj);
+  e = CDR(e);
+
+  // Add the arguments to the SEXP
+  if (!make_argl(args, &e)) {
+    UNPROTECT(1);
+    return Qnil;
+  }
+
+  // Evaluate
+  PROTECT(res = do_eval_expr(exp));
+  if (!res) {
+    UNPROTECT(2);
+    return Qnil;
+  }
+
+  obj = to_ruby_with_mode(res, BASIC_CONVERSION);
+
+  UNPROTECT(2);
+
+  return obj;
+}
+
+/* Convert a sequence of (name, value) pairs to arguments to an R
+   function call */
+int
+make_argl(VALUE args, SEXP *e)
+{
+  SEXP rvalue;
+  int i;
+  VALUE pair, name, value;
+
+  //Ensure we have an array
+  args = rb_check_array_type(args);
+  
+  for (i=0; i<RARRAY(args)->len; i++) {
+    pair = rb_ary_entry(args, i);
+    pair = rb_check_array_type(pair);
+    if(RARRAY(pair)->len != 2)
+      rb_raise(rb_eArgError,"Misformed argument in lcall\n");
+
+    /* Name must be a string. If it is empty string '' then no name*/
+    name = rb_ary_entry(pair, 0);
+    name = StringValue(name);
+    name = rb_funcall(rb_const_get(rb_cObject, 
+				   rb_intern("RSRuby")),
+		      rb_intern("convert_method_name"),1,name);
+
+    /* Value can be anything. */
+    value  = rb_ary_entry(pair, 1);
+    rvalue = ruby_to_R(value);
+
+    /* Add parameter value to call */
+    SETCAR(*e, rvalue);
+
+    /* Add name (if present) */
+    if (RSTRING(name)->len > 0) 
+      {
+        SET_TAG(*e, Rf_install(RSTRING(name)->ptr));
+      }
+
+    /* Move index to new end of call */
+    *e = CDR(*e);
+  }
+  return 1;
+}
+
+VALUE RObj_to_ruby(VALUE self, VALUE args){
+
+  int conv;
+  VALUE obj;
+  SEXP robj;
+
+  args = rb_check_array_type(args);
+
+  if (RARRAY(args)->len > 1){
+    rb_raise(rb_eArgError,"Too many arguments in to_ruby\n");
+  }
+
+  if (RARRAY(args)->len == 0){
+    conv = NUM2INT(rb_iv_get(RSRUBY,"@default_mode"));
+  } else {
+    conv = NUM2INT(rb_ary_entry(args,0));
+  }
+
+  if (conv <= -2 || conv > TOP_MODE) {
+    rb_raise(rb_eArgError, "Wrong mode\n");
+    return Qnil;
+  }
+
+  if (conv < 0)
+    conv = TOP_MODE;
+
+  Data_Get_Struct(self, struct SEXPREC, robj);
+
+  obj = to_ruby_with_mode(robj, conv);
+  return obj;
+
+}
+
+