RSRuby 0.4.0

data/ext/rsruby/Converters.h

@@ -0,0 +1,74 @@
+/*
+* == 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);
+
+static SEXP array_to_R(VALUE obj);
+static SEXP hash_to_R(VALUE obj);
+static 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);
+
+static VALUE to_ruby_hash(VALUE obj, SEXP names);
+static VALUE to_ruby_array(VALUE obj, int *dims, int l);
+
+static 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/rsruby/R_eval.c

@@ -0,0 +1,138 @@
+/*
+* == 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>
+
+/* 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;
+
+  res = R_tryEval(e, R_GlobalEnv, &error);
+
+  if (error) {
+    //if (interrupted) {
+    //  rb_raise(rb_eInterrupt);
+    //}
+    //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/rsruby/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/rsruby/extconf.rb

@@ -0,0 +1,20 @@
+require 'mkmf'
+require 'rbconfig'
+
+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")
+#create_makefile("robj")
+
+File.open("Makevars","w") do |file|
+  file.puts "PKG_CPPFLAGS = -I#{Config::CONFIG["archdir"]} -D_R_=1 -DUSE_R=1 -DUSE_TOPLEVEL_EXEC=1"
+  file.puts "PKG_LIBS     =   #{Config::CONFIG["LIBRUBYARG_SHARED"]}"
+end

data/ext/rsruby/robj.c

@@ -0,0 +1,169 @@
+/*
+* == 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_cvar_get(rb_const_get(rb_cObject, 
+						  rb_intern("RSRuby")),
+				     rb_intern("@@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;
+}
+
+/* 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_cvar_get(rb_const_get(rb_cObject, 
+					    rb_intern("RSRuby")),
+			       rb_intern("@@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;
+
+}
+

data/ext/rsruby/rsruby.c

@@ -0,0 +1,183 @@
+/*
+* == 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"
+
+//TODO - Cleanup and shutdown functions need implementing  
+//static PyObject *
+//r_cleanup(void)
+//{
+//  r_cleanup();
+//  Py_INCREF(Py_None);
+//  return Py_None;
+//}
+
+/* Global list to protect R objects from garbage collection */
+/* This is inspired in $R_SRC/src/main/memory.c */
+static SEXP R_References;
+
+static SEXP
+RecursiveRelease(SEXP obj, SEXP list)
+{
+  if (!isNull(list)) {
+    if (obj == CAR(list))
+      return CDR(list);
+    else
+      SETCDR(list, RecursiveRelease(obj, CDR(list)));
+  }
+  return list;
+}
+
+/* TODO: This needs implementing as a Ruby destructor for each RObj */
+static void
+Robj_dealloc(VALUE self)
+{
+  /* Remove the object from the list of protected objects */
+  SEXP robj;
+
+  Data_Get_Struct(self, struct SEXPREC, robj);
+
+  R_References = RecursiveRelease(robj, R_References);
+  SET_SYMVALUE(install("R.References"), R_References);
+
+  return;
+}
+
+/*
+ * Initialises the R interpreter.
+ */
+void init_R(int argc, char **argv){
+
+  int   defaultArgc = 2;
+  char *defaultArgv[] = {"Rtest","--silent"};
+
+  if(argc == 0 || argv == NULL) {
+      argc = defaultArgc;
+      argv = defaultArgv;
+  }
+  Rf_initEmbeddedR(argc, argv);
+}
+
+
+/* Obtain an R object via its name.
+ * This is only used to get the 'get' function.
+ * All subsequent calls go via the 'get' function itself
+ */
+VALUE get_fun(VALUE self, VALUE name){
+
+  VALUE str;
+  int conversion=TOP_MODE;
+  SEXP robj;
+  VALUE  rubyobj;
+  VALUE  params[2];
+  char* cstr_name;
+
+  str = StringValue(name);
+
+  cstr_name = RSTRING(str)->ptr;
+
+  robj = (SEXP)get_fun_from_name(cstr_name);
+  if (!robj)
+    return Qnil;
+
+  /* Wrap the returned R object as a ruby Object */
+  rubyobj = Data_Wrap_Struct(rb_const_get(rb_cObject, 
+					  rb_intern("RObj")), 0, 0, robj);
+  rb_iv_set(rubyobj,"@conversion",INT2FIX(conversion));
+
+  return rubyobj;
+
+}
+
+//TODO - This function does not appear to be working correctly
+void r_finalize(void)
+{
+  unsigned char buf[1024];
+  char * tmpdir;
+  
+  R_dot_Last();           
+  R_RunExitFinalizers();  
+  CleanEd();              
+  KillAllDevices();       
+  if((tmpdir = getenv("R_SESSION_TMPDIR"))) {          
+    snprintf((char *)buf, 1024, "rm -rf %s", tmpdir); 
+    R_system((char *)buf);                            
+  }
+  
+  PrintWarnings();	/* from device close and .Last */
+  R_gc();  /* Remove any remaining R objects from memory */
+}
+
+//TODO - Shutdown is not working correctly
+VALUE cShutdown(VALUE self){
+
+  r_finalize();
+
+  self = Qnil;
+  return Qtrue;
+
+}
+
+/*
+ * Starts the R interpreter.
+ */
+VALUE rr_init(VALUE self){
+
+  SEXP R_References;
+
+  init_R(0,NULL);
+  // Initialize the list of protected objects
+  R_References = R_NilValue;
+  SET_SYMVALUE(install("R.References"), R_References);
+
+  return self;
+
+}
+
+/* Ruby code */
+
+VALUE cRRuby;
+VALUE cRObj;
+
+void Init_rsruby(){
+
+  cRRuby = rb_define_class("RSRuby",rb_cObject);
+  cRObj  = rb_const_get(rb_cObject,rb_intern("RObj"));
+
+  rb_define_method(cRRuby, "initialize", rr_init, 0);
+  rb_define_method(cRRuby, "get_fun", get_fun, 1);
+  rb_define_method(cRRuby, "shutdown", cShutdown, 0);
+
+  //Add the lcall method to RObj
+  rb_define_method(cRObj, "lcall", RObj_lcall, 1);
+  rb_define_method(cRObj, "to_ruby", RObj_to_ruby, -2);
+
+}