Converters.c

/*
* == 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"Converters.h"


// ************** Converters from Ruby to R *********//


VALUEruby_to_Robj(VALUEself, VALUEargs){

SEXProbj;
VALUEval;
robj=ruby_to_R(args);
val=to_ruby_with_mode(robj,NO_CONVERSION);
returnval;
}
SEXPruby_to_R(VALUEobj)
{
SEXProbj;
VALUEstr;
charbuf [100];

//Return nil if object is nil
if (obj==Qnil) {
returnR_NilValue;
 }

//If object has 'as_r' then call it and use 
//returned value subsequently
if (rb_respond_to(obj, rb_intern("as_r"))){
obj=rb_funcall(obj,rb_intern("as_r"),0);
if (!obj)
returnNULL;
 }

if (Robj_Check(obj))
 {
Data_Get_Struct(obj, structSEXPREC, robj);
PROTECT(robj);
 }
elseif (obj==Qtrue||obj==Qfalse)
 {
PROTECT(robj=NEW_LOGICAL(1));
if (obj==Qtrue){
LOGICAL_DATA(robj)[0] = TRUE;
 } else {
LOGICAL_DATA(robj)[0] = FALSE;
 }

 }
elseif (TYPE(obj) ==T_FIXNUM||
TYPE(obj) ==T_BIGNUM)
 {
PROTECT(robj=NEW_INTEGER(1));
INTEGER_DATA(robj)[0] =NUM2LONG(obj);
 }
elseif (TYPE(obj) ==T_FLOAT)
 {
PROTECT(robj=NEW_NUMERIC(1));
NUMERIC_DATA(robj)[0] =NUM2DBL(obj);
 }
elseif (RubyComplex_Check(obj)) 
 {
PROTECT(robj=NEW_COMPLEX(1));
COMPLEX_DATA(robj)[0].r=NUM2DBL(rb_funcall(obj,rb_intern("real"),0));
COMPLEX_DATA(robj)[0].i=NUM2DBL(rb_funcall(obj,rb_intern("image"),0));
 }
elseif (!NIL_P(rb_check_string_type(obj))) 
 {
PROTECT(robj=NEW_STRING(1));
SET_STRING_ELT(robj, 0, COPY_TO_USER_STRING(RSTRING_PTR(obj)));
 }
elseif (!NIL_P(rb_check_array_type(obj))) 
 {
PROTECT(robj=array_to_R(obj));
 }
elseif (TYPE(obj) ==T_HASH) 
 {
PROTECT(robj=hash_to_R(obj));
 }
else
 {
str=rb_funcall(obj,rb_intern("inspect"),0);
str=rb_funcall(str,rb_intern("slice"),2,INT2NUM(0),INT2NUM(60));
sprintf(buf,"Unsupported object '%s' passed to R.\n",RSTRING_PTR(str));
rb_raise(rb_eArgError,buf);
PROTECT(robj=NULL); /* Protected to avoid stack inbalance */
 }

UNPROTECT(1);
returnrobj;
}

/* Make a R list or vector from a Ruby array */
SEXParray_to_R(VALUEobj)
{
VALUEit;
SEXProbj, rit;
inti, state;

/* This matrix defines what mode a vector should take given what
 it already contains and a new item

 E.g. Row 0 indicates that if we've seen an any, the vector will
 always remain an any. Row 3 indicates that if we've seen a
 float, then seeing an boolean, integer, or float will preserve
 the vector as a float vector, while seeing a string or an Robj will
 convert it into an any vector.
 */
intfsm[7][7] = {
 {0, 0, 0, 0, 0, 0, 0}, // any
 {0, 1, 2, 3, 4, 0, 0}, // bool
 {0, 2, 2, 3, 4, 0, 0}, // int
 {0, 3, 3, 3, 4, 0, 0}, // float
 {0, 4, 4, 4, 4, 0, 0}, // complex
 {0, 0, 0, 0, 0, 5, 0}, // string
 {0, 0, 0, 0, 0, 0, 6} // RObj
 };

//Probably unnessecary but just in case
obj=rb_check_array_type(obj);

if (RARRAY_LEN(obj) ==0)
returnR_NilValue;

PROTECT(robj=NEW_LIST(RARRAY_LEN(obj)));

state=-1;
for (i=0; i<RARRAY_LEN(obj); i++) {

it=rb_ary_entry(obj, i);

if (state<0)
state=type_to_int(it);
else
state=fsm[state][type_to_int(it)];

if (!(rit=ruby_to_R(it)))
 goto exception;

SET_VECTOR_ELT(robj, i, rit);
 }

switch(state)
 {
caseINT_T:
robj=AS_INTEGER(robj);
break;
caseBOOL_T:
robj=AS_LOGICAL(robj);
break;
caseFLOAT_T:
robj=AS_NUMERIC(robj);
break;
caseCOMPLEX_T:
robj=AS_COMPLEX(robj);
break;
caseSTRING_T:
robj=AS_CHARACTER(robj);
break;
default:;
/* Otherwise, it's either an ANY_T or ROBJ_T - we want ANY */
 }

UNPROTECT(1);
returnrobj;

exception:
UNPROTECT(1);
rb_raise(rb_eArgError,"Error converting Array to R\n");
returnNULL;
}

/* Make a R named list or vector from a Ruby Hash */
SEXP
hash_to_R(VALUEobj)
{
VALUEkeys, values;
SEXProbj, names;

if (FIX2INT(rb_funcall(obj,rb_intern("size"),0)) ==0)
returnR_NilValue;

/* If 'keys' succeed and 'values' fails this leaks */
if (!(keys=rb_funcall(obj,rb_intern("keys"),0)))
returnNULL;
if (!(values=rb_funcall(obj,rb_intern("values"),0)))
returnNULL;

if (!(robj=array_to_R(values)))
 goto fail;
if (!(names=array_to_R(keys)))
 goto fail;

PROTECT(robj);
SET_NAMES(robj, names);
UNPROTECT(1);

returnrobj;

fail:
returnNULL;
}

int
type_to_int(VALUEobj)
{
if (obj==Qtrue||obj==Qfalse)
returnBOOL_T;
elseif (TYPE(obj) ==T_FIXNUM||
TYPE(obj) ==T_BIGNUM)
returnINT_T;
elseif (TYPE(obj) ==T_FLOAT)
returnFLOAT_T;
elseif (RubyComplex_Check(obj))
returnCOMPLEX_T;
//NB (TODO): This line means that objects are coerced into
//String form if possible rather than leaving them as RObj
elseif (!NIL_P(rb_check_string_type(obj)))
returnSTRING_T;
elseif (Robj_Check(obj))
returnROBJ_T;
else
returnANY_T;
}

// ************** Converters from R to Ruby *********//

VALUEto_ruby_with_mode(SEXProbj, intmode)
{
VALUEobj;
inti;

switch (mode)
 {
casePROC_CONVERSION:
i=to_ruby_proc(robj, &obj);
if (i<0) returnQnil;
if (i==1) break;
caseCLASS_CONVERSION:
i=to_ruby_class(robj, &obj);
if (i<0) returnQnil;
if (i==1) break;
caseBASIC_CONVERSION:
i=to_ruby_basic(robj, &obj);
if (i<0) returnQnil;
if (i==1) break;
caseVECTOR_CONVERSION:
i=to_ruby_vector(robj, &obj, mode=VECTOR_CONVERSION);
if (i<0) returnQnil;
if (i==1) break;
default:
protect_robj(robj);
obj=Data_Wrap_Struct(rb_const_get(rb_cObject, 
rb_intern("RObj")), 0, &Robj_dealloc, robj);
rb_iv_set(obj,"@conversion",INT2FIX(TOP_MODE));
rb_iv_set(obj,"@wrap",Qfalse);
 }

returnobj;
}

/* Convert an R object to a 'basic' Ruby object (mode 2) */
/* NOTE: R vectors of length 1 will yield a Ruby scalar */
int
to_ruby_basic(SEXProbj, VALUE*obj)
{
intstatus;
VALUEtmp;

status=to_ruby_vector(robj, &tmp, BASIC_CONVERSION);

if(status==1&&TYPE(tmp) ==T_ARRAY&&RARRAY_LEN(tmp) ==1)
 {
*obj=rb_ary_entry(tmp, 0);
 }
else
*obj=tmp;

returnstatus;
}


/* Convert an R object to a 'vector' Ruby object (mode 1) */
/* NOTE: R vectors of length 1 will yield a Ruby array of length 1*/
int
to_ruby_vector(SEXProbj, VALUE*obj, intmode)
{
VALUEit, tmp;
VALUEparams[2];
SEXPnames, dim;
intlen, *integers, i, type;
char*strings, *thislevel;
double*reals;
Rcomplex*complexes;

if (!robj)
return-1; /* error */

if (robj==R_NilValue) {
*obj=Qnil;
return1; /* succeed */
 }

len=GET_LENGTH(robj);
tmp=rb_ary_new2(len);
type=TYPEOF(robj);

for (i=0; i<len; i++) {
switch (type)
 {
caseLGLSXP:
integers=INTEGER(robj);
if(integers[i]==NA_INTEGER) /* watch out for NA's */
 {
if (!(it=INT2NUM(integers[i])))
return-1;
 }
//TODO - not sure of the conversion here.
elseif (integers[i] !=0){
it=Qtrue;
 } elseif (integers[i] ==0){
it=Qfalse;
 } else {
return-1;
 }
break;
caseINTSXP:
integers=INTEGER(robj);
if(isFactor(robj)) {
/* Watch for NA's! */
if(integers[i]==NA_INTEGER)
it=rb_external_str_new_cstr(CHAR(NA_STRING));
else
 {
thislevel=CHAR(STRING_ELT(GET_LEVELS(robj), integers[i]-1));
if (!(it=rb_external_str_new_cstr(thislevel)))
return-1;
 }
 }
else {
if (!(it=LONG2NUM(integers[i])))
return-1;
 }
break;
caseREALSXP:
reals=REAL(robj);
if (!(it=rb_float_new(reals[i])))
return-1;
break;
caseCPLXSXP:
complexes=COMPLEX(robj);

if (!(it=rb_complex_new(rb_float_new(complexes[i].r),
rb_float_new(complexes[i].i))))

return-1;
break;
caseSTRSXP:
if(STRING_ELT(robj, i)==R_NaString)
it=rb_external_str_new_cstr(CHAR(NA_STRING));
else
 {
strings=CHAR(STRING_ELT(robj, i));
if (!(it=rb_external_str_new_cstr(strings)))
return-1;
 }
break;
caseLISTSXP:
if (!(it=to_ruby_with_mode(elt(robj, i), mode)))
return-1;
break;
caseVECSXP:
if (!(it=to_ruby_with_mode(VECTOR_ELT(robj, i), mode)))
return-1;
break;
default:
return0; /* failed */
 }
rb_ary_store(tmp, i, it);
 }

dim=GET_DIM(robj);
if (dim!=R_NilValue) {
*obj=to_ruby_array(tmp, robj);
return1;
 }

names=GET_NAMES(robj);
if (names==R_NilValue)
*obj=tmp;
else {
*obj=to_ruby_hash(tmp, names);
 }

return1;
}

/* Search a conversion procedure from the proc table */
int
from_proc_table(SEXProbj, VALUE*fun)
{
VALUEproc_table, procs, proc, funs, res, obj, mode;
VALUEargs[2];
inti, l, error;

proc_table=rb_iv_get(RSRUBY,"@proc_table");

proc=Qnil;

//TODO - Baffling. Not sure what's wrong with these functions?
//procs = rb_hash_keys(proc_table);
//funs = rb_hash_values(proc_table);
//l = FIX2INT(rb_hash_size(proc_table));

procs=rb_funcall(proc_table,rb_intern("keys"),0);
funs=rb_funcall(proc_table,rb_intern("values"),0);
l=FIX2INT(rb_funcall(proc_table,rb_intern("size"),0));

obj=Data_Wrap_Struct(rb_const_get(rb_cObject, 
rb_intern("RObj")), 0, &Robj_dealloc, robj);
rb_iv_set(obj,"@conversion",INT2FIX(TOP_MODE));
rb_iv_set(obj,"@wrap",Qfalse);

error=0;
for (i=0; i<l; i++) {
proc=rb_ary_entry(procs, i);

mode=rb_iv_get(RSRUBY,"@default_mode");
rb_iv_set(RSRUBY,
"@default_mode",
INT2FIX(BASIC_CONVERSION));

//New safe code
args[0] =proc;
args[1] =obj;
res=rb_ensure(call_proc,(VALUE) &args[0],reset_mode,mode);

if (RTEST(res)) {
*fun=rb_ary_entry(funs, i);
break;
 }
 }

returnerror;
}

VALUEcall_proc(VALUEdata){
VALUE*args= (VALUE*) data;
returnrb_funcall(args[0], rb_intern("call"), 1, args[1]);
}

VALUEreset_mode(VALUEmode){

rb_iv_set(RSRUBY,
"@default_mode",
mode); 

returnQnil;

}

int
to_ruby_proc(SEXProbj, VALUE*obj)
{
VALUEfun=Qnil, tmp, mode;
VALUEargs[2];
inti;

//Find function from proc table. integer is returned
//to indicate success/failure

i=from_proc_table(robj, &fun);

if (i<0)
return-1; /* an error occurred */

if (fun==Qnil)
return0; /* conversion failed */

//Create new object based on robj and call the function
//found above with it as argument
tmp=Data_Wrap_Struct(rb_const_get(rb_cObject, 
rb_intern("RObj")), 0, &Robj_dealloc, robj);
rb_iv_set(tmp,"@conversion",INT2FIX(TOP_MODE));
rb_iv_set(tmp,"@wrap",Qfalse);

//Again set conversion mode to basic to prevent recursion
mode=rb_iv_get(RSRUBY,"@default_mode");
rb_iv_set(RSRUBY, "@default_mode", INT2FIX(BASIC_CONVERSION));

//New safe code
args[0] =fun;
args[1] =tmp;
*obj=rb_ensure(call_proc,(VALUE) &args[0],reset_mode,mode);

return1; /* conversion succeed */
}

/* Search a conversion procedure from the class attribute */
VALUEfrom_class_table(SEXProbj)
{
SEXPrclass;
VALUEkey, fun, class_table;
inti;

class_table=rb_iv_get(RSRUBY, "@class_table");

PROTECT(rclass=GET_CLASS(robj));

fun=Qnil;
if (rclass!=R_NilValue) {

//key may be an array or string depending on
//the class specification
key=to_ruby_with_mode(rclass, BASIC_CONVERSION);
fun=rb_hash_aref(class_table, key);

//If we haven't found a function then go through
//each class in rclass and look for a match
if (fun==Qnil) {

for (i=0; i<GET_LENGTH(rclass); i++){
fun=rb_hash_aref(class_table,
rb_external_str_new_cstr(CHAR(STRING_ELT(rclass, i))));
if (fun!=Qnil){
break;
 }
 }
 }
 }
UNPROTECT(1);
returnfun;
}

/* Convert a Robj to a Ruby object via the class table (mode 3) */
/* See the docs for conversion rules */
int
to_ruby_class(SEXProbj, VALUE*obj)
{
VALUEfun, tmp, mode;
VALUEargs[2];

fun=from_class_table(robj);

if (fun==Qnil)
return0; /* conversion failed */

tmp=Data_Wrap_Struct(rb_const_get(rb_cObject, 
rb_intern("RObj")), 0, &Robj_dealloc, robj);
rb_iv_set(tmp,"@conversion",INT2FIX(TOP_MODE)); 
rb_iv_set(tmp,"@wrap",Qfalse);

//Again set conversion mode to basic to prevent recursion
mode=rb_iv_get(RSRUBY, "@default_mode");
rb_iv_set(RSRUBY, "@default_mode", INT2FIX(BASIC_CONVERSION));

//New safe code
args[0] =fun;
args[1] =tmp;
*obj=rb_ensure(call_proc,(VALUE) &args[0],reset_mode,mode);
//*obj = rb_funcall(fun, rb_intern("call"), 1, tmp);

return1; /* conversion succeed */
}

/* Convert a R named vector or list to a Ruby Hash */
VALUEto_ruby_hash(VALUEobj, SEXPnames)
{
intlen, i;
VALUEit, hash;
char*name;

if ((len=RARRAY_LEN(obj)) <0)
returnQnil;

hash=rb_hash_new();
for (i=0; i<len; i++) {
it=rb_ary_entry(obj, i);
name=CHAR(STRING_ELT(names, i));
rb_hash_aset(hash, rb_external_str_new_cstr(name), it);
 }

returnhash;
}

/* We need to transpose the list because R makes array by the
 * fastest index */
VALUEltranspose(VALUElist, int*dims, int*strides,
intpos, intshift, intlen)
{
VALUEnl, it;
inti;

if (!(nl=rb_ary_new2(dims[pos])))
returnQnil;

if (pos==len-1) {
for (i=0; i<dims[pos]; i++) {
if (!(it=rb_ary_entry(list, i*strides[pos]+shift)))
returnQnil;
rb_ary_store(nl, i, it); 
 }
returnnl;
 }

for (i=0; i<dims[pos]; i++) {
if (!(it=ltranspose(list, dims, strides, pos+1, shift, len)))
returnQnil;
rb_ary_store(nl, i, it);
shift+=strides[pos];
 }

returnnl;
}

/* Convert a R Array to a Ruby Array (in the form of
 * array of arrays of ...) */
VALUEto_ruby_array(VALUEobj, SEXProbj)
{
VALUErarrayComponents[3]; //values, dimnames, dimnamesnames
VALUEcRArray;
VALUErarray;
SEXPdim;
inti, c, *strides,l;
int*dims;
intstatus;
dim=GET_DIM(robj);
dims=INTEGER(dim);
l=GET_LENGTH(dim);
status=to_ruby_vector(GET_DIMNAMES(robj),&rarrayComponents[1],VECTOR_CONVERSION);
if (!status)
rb_raise(rb_eRuntimeError,"Could not convert dimnames\n");
status=to_ruby_vector(GET_NAMES(GET_DIMNAMES(robj)),&rarrayComponents[2],VECTOR_CONVERSION);
if (!status)
rb_raise(rb_eRuntimeError,"Could not convert dimnames names\n");

strides= (int*)ALLOC_N(int,l);
if (!strides)
rb_raise(rb_eRuntimeError,"Could not allocate memory for array\n");

c=1;
for (i=0; i<l; i++) {
strides[i] =c;
c *= dims[i];
 }

rarrayComponents[0] =ltranspose(obj, dims, strides, 0, 0, l);
free(strides);

cRArray=rb_const_get(rb_cObject,rb_intern("RArray"));
rarray=rb_class_new_instance(3,rarrayComponents,cRArray);

returnrarray;
}