@@ -1,31 +1,31 @@

-setGeneric('get_color_mapping_list', function(object, ...) standardGeneric('get_color_mapping_list'))

-setGeneric('set_component_height', function(object, ...) standardGeneric('set_component_height'))

 setGeneric('map_to_colors', function(object, ...) standardGeneric('map_to_colors'))

-setGeneric('draw_heatmap_legend', function(object, ...) standardGeneric('draw_heatmap_legend'))

-setGeneric('draw_heatmap_list', function(object, ...) standardGeneric('draw_heatmap_list'))

-setGeneric('set_component_width', function(object, ...) standardGeneric('set_component_width'))

-setGeneric('make_column_cluster', function(object, ...) standardGeneric('make_column_cluster'))

-setGeneric('draw', function(object, ...) standardGeneric('draw'))

+setGeneric('set_component_height', function(object, ...) standardGeneric('set_component_height'))

+setGeneric('draw_heatmap_body', function(object, ...) standardGeneric('draw_heatmap_body'))

 setGeneric('component_height', function(object, ...) standardGeneric('component_height'))

-setGeneric('row_dend', function(object, ...) standardGeneric('row_dend'))

+setGeneric('re_size', function(object, ...) standardGeneric('re_size'))

+setGeneric('make_layout', function(object, ...) standardGeneric('make_layout'))

+setGeneric('heatmap_legend_size', function(object, ...) standardGeneric('heatmap_legend_size'))

+setGeneric('get_legend_param_list', function(object, ...) standardGeneric('get_legend_param_list'))

 setGeneric('color_mapping_legend', function(object, ...) standardGeneric('color_mapping_legend'))

-setGeneric('annotation_legend_size', function(object, ...) standardGeneric('annotation_legend_size'))

-setGeneric('draw_heatmap_body', function(object, ...) standardGeneric('draw_heatmap_body'))

+setGeneric('make_column_cluster', function(object, ...) standardGeneric('make_column_cluster'))

 setGeneric('column_dend', function(object, ...) standardGeneric('column_dend'))

 setGeneric('row_order', function(object, ...) standardGeneric('row_order'))

-setGeneric('prepare', function(object, ...) standardGeneric('prepare'))

-setGeneric('draw_title', function(object, ...) standardGeneric('draw_title'))

-setGeneric('draw_annotation', function(object, ...) standardGeneric('draw_annotation'))

+setGeneric('draw_heatmap_list', function(object, ...) standardGeneric('draw_heatmap_list'))

+setGeneric('row_dend', function(object, ...) standardGeneric('row_dend'))

 setGeneric('add_heatmap', function(object, ...) standardGeneric('add_heatmap'))

-setGeneric('get_legend_param_list', function(object, ...) standardGeneric('get_legend_param_list'))

-setGeneric('draw_annotation_legend', function(object, ...) standardGeneric('draw_annotation_legend'))

-setGeneric('heatmap_legend_size', function(object, ...) standardGeneric('heatmap_legend_size'))

+setGeneric('set_component_width', function(object, ...) standardGeneric('set_component_width'))

 setGeneric('column_order', function(object, ...) standardGeneric('column_order'))

+setGeneric('draw_annotation_legend', function(object, ...) standardGeneric('draw_annotation_legend'))

+setGeneric('draw_heatmap_legend', function(object, ...) standardGeneric('draw_heatmap_legend'))

+setGeneric('annotation_legend_size', function(object, ...) standardGeneric('annotation_legend_size'))

+setGeneric('draw_annotation', function(object, ...) standardGeneric('draw_annotation'))

+setGeneric('prepare', function(object, ...) standardGeneric('prepare'))

 setGeneric('draw_dimnames', function(object, ...) standardGeneric('draw_dimnames'))

+setGeneric('draw', function(object, ...) standardGeneric('draw'))

+setGeneric('draw_title', function(object, ...) standardGeneric('draw_title'))

 setGeneric('make_row_cluster', function(object, ...) standardGeneric('make_row_cluster'))

 setGeneric('component_width', function(object, ...) standardGeneric('component_width'))

-setGeneric('re_size', function(object, ...) standardGeneric('re_size'))

+setGeneric('get_color_mapping_list', function(object, ...) standardGeneric('get_color_mapping_list'))

+setGeneric('draw_dend', function(object, ...) standardGeneric('draw_dend'))

 setGeneric('adjust_heatmap_list', function(object, ...) standardGeneric('adjust_heatmap_list'))

 setGeneric('copy_all', function(object, ...) standardGeneric('copy_all'))

-setGeneric('draw_dend', function(object, ...) standardGeneric('draw_dend'))

-setGeneric('make_layout', function(object, ...) standardGeneric('make_layout'))

@@ -53,7 +53,7 @@ anno_width_and_height = function(which, width = NULL, height = NULL,

 			if(!is_abs_unit(height)) {

 				stop_wrap("height of the annotation can only be an absolute unit.")

 			} else {

-				height = convertHeight(height, "mm")

+				# height = convertHeight(height, "mm")

 			}

 		}

 		if(is.null(width)) {

@@ -67,7 +67,7 @@ anno_width_and_height = function(which, width = NULL, height = NULL,

 			if(!is_abs_unit(width)) {

 				stop_wrap("width of the annotation can only be an absolute unit.")

 			} else {

-				width = convertWidth(width, "mm")

+				# width = convertWidth(width, "mm")

 			}

 		}

 		if(is.null(height)) {

@@ -398,7 +398,6 @@ setMethod(f = "show",

 			cat(" ", as.character(object@extended[i]), "extension on the", dirt[i], "\n")

 		}

 	}

-	

 })

 # == title

@@ -647,12 +647,17 @@ anno_points = function(x, which = c("column", "row"), border = TRUE, gp = gpar()

 		}

 	}

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	if(is.data.frame(x)) x = as.matrix(x)

 	if(is.matrix(x)) {

 		if(ncol(x) == 1) {

@@ -831,12 +836,17 @@ anno_lines = function(x, which = c("column", "row"), border = TRUE, gp = gpar(),

 	extend = 0.05, axis = TRUE, axis_param = default_axis_param(which),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	if(is.data.frame(x)) x = as.matrix(x)

 	if(is.matrix(x)) {

 		if(ncol(x) == 1) {

@@ -1102,12 +1112,17 @@ anno_barplot = function(x, baseline = 0, which = c("column", "row"), border = TR

 		}

 	}

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))

 	if(nc == 1) {

@@ -1251,12 +1266,17 @@ anno_boxplot = function(x, which = c("column", "row"), border = TRUE,

 		}

 	}

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))

 	## convert matrix all to list (or data frame)

@@ -1451,12 +1471,17 @@ anno_histogram = function(x, which = c("column", "row"), n_breaks = 11,

 	axis = TRUE, axis_param = default_axis_param(which), 

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))

 	## convert matrix all to list (or data frame)

@@ -1617,12 +1642,17 @@ anno_density = function(x, which = c("column", "row"),

 	axis = TRUE, axis_param = default_axis_param(which),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))

 	## convert matrix all to list (or data frame)

@@ -1877,12 +1907,17 @@ anno_text = function(x, which = c("column", "row"), gp = gpar(),

 	offset = guess_location(), location = guess_location(),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	n = length(x)

 	gp = recycle_gp(gp, n)

@@ -2023,12 +2058,17 @@ anno_joyplot = function(x, which = c("column", "row"), gp = gpar(fill = "#000000

 	axis = TRUE, axis_param = default_axis_param(which),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))

 	## convert matrix all to list (or data frame)

@@ -2219,12 +2259,17 @@ anno_horizon = function(x, which = c("column", "row"),

 	axis = TRUE, axis_param = default_axis_param(which),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))

 	## convert matrix all to list (or data frame)

@@ -2818,12 +2863,17 @@ anno_summary = function(which = c("column", "row"), border = TRUE, bar_width = 0

 	pch = 1, size = unit(2, "mm"), gp = gpar(),

 	width = NULL, height = NULL) {

+	ef = function() NULL

 	if(is.null(.ENV$current_annotation_which)) {

 		which = match.arg(which)[1]

+		dev.null()

+		ef = dev.off2

 	} else {

 		which = .ENV$current_annotation_which

 	}

+	on.exit(ef())

+

 	anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))

 	axis_param = validate_axis_param(axis_param, which)

@@ -2981,10 +3031,10 @@ anno_block = function(gp = gpar(), labels = NULL, labels_gp = gpar(), labels_rot

 	if(length(labels)) {

 		if(which == "column") {

 			height = grobHeight(textGrob(labels, rot = labels_rot, gp = labels_gp))

-			height = convertHeight(height, "mm") + unit(5, "mm")

+			height = height + unit(5, "mm")

 		} else {

 			width = grobWidth(textGrob(labels, rot = labels_rot, gp = labels_gp))

-			width = convertWidth(width, "mm") + unit(5, "mm")

+			width = width + unit(5, "mm")

 		}

 	}

@@ -272,6 +272,9 @@ Heatmap = function(matrix, col, name,

     post_fun = NULL) {

+    dev.null()

+    on.exit(dev.off2())

+

     verbose = ht_opt("verbose")

     .Object = new("Heatmap")

@@ -164,9 +164,7 @@ annotation_axis_grob = function(at = NULL, labels = at, labels_rot = 0, gp = gpa

 		h = unit(1, "npc")

 		attr(gb, "width") = w

 		attr(gb, "height") = h

-	}

-

-	if(side == "top" && facing == "inside") {

+	} else if(side == "top" && facing == "inside") {

 		gl = gList(

 			linesGrob(unit(c(0, 1), "npc"), unit(c(1, 1), "npc"), gp = gp),

 			segmentsGrob(at, unit(1, "npc") - unit(1, "mm"), at, unit(1, "npc"), 

deleted file mode 100644

@@ -1,112 +0,0 @@

- 

-graphicsDevice = function(name, dim = c(1024, 768), col = "black", fill = "transparent", ps = 10, ..., 

-	funcs = list(...), ipr = rep(1/72.27, 2)) {

-

-	

-    dim = as.integer(dim)

-    

-    col = as(col, "RGBInt")

-    fill = as(fill, "RGBInt")

-

-	dev = .Call("R_createGraphicsDevice",  funcs, as.character(name), dim, col, fill, as.integer(ps),

-	                 list(funcs@initDevice, funcs@GEInitDevice), ipr)

-	invisible(dev)

-})

-

-empty_dev = function() {

-	funs = dummyDevice()

-	graphicsDevice(name = "empty_dev", funcs = funs)

-}

-

-

-dummy_dev = 

-

-> funs

-An object of class "RDevDescMethods"

-Slot "activate":

-NULL

-

-Slot "circle":

-NULL

-

-Slot "clip":

-NULL

-

-Slot "close":

-NULL

-

-Slot "deactivate":

-NULL

-

-Slot "locator":

-NULL

-

-Slot "line":

-NULL

-

-Slot "metricInfo":

-function (char, gc, ascent, descent, width, dev) 

-{

-    width[1] = gc$ps * gc$cex

-    ascent[1] = 1

-    descent[1] = 0.25

-}

-<environment: 0x2351d48>

-

-Slot "mode":

-NULL

-

-Slot "newPage":

-NULL

-

-Slot "polygon":

-NULL

-

-Slot "polyline":

-NULL

-

-Slot "rect":

-NULL

-

-Slot "size":

-function (left, right, bottom, top, dev) 

-{

-    right[1] = dev$right

-    bottom[1] = dev$bottom

-}

-<environment: 0x2266248>

-

-Slot "strWidth":

-function (str, gc, dev) 

-{

-    gc$cex * gc$ps * nchar(str)

-}

-<environment: 0x2351d48>

-

-Slot "text":

-NULL

-

-Slot "onExit":

-NULL

-

-Slot "getEvent":

-NULL

-

-Slot "newFrameConfirm":

-NULL

-

-Slot "textUTF8":

-NULL

-

-Slot "strWidthUTF8":

-NULL

-

-Slot "initDevice":

-NULL

-

-Slot "GEInitDevice":

-NULL

-

-Slot "state":

-NULL

-

@@ -819,5 +819,3 @@ to_unit = function(str) {

     unit(as.numeric(d), u)

 }

-

-

@@ -11,8 +11,8 @@ Method dispatch page for \code{add_heatmap}.

 \itemize{

 \item \code{\link{add_heatmap,HeatmapAnnotation-method}}, \code{\link{HeatmapAnnotation-class}} class method

-\item \code{\link{add_heatmap,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{add_heatmap,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{add_heatmap,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,8 +10,8 @@ Method dispatch page for \code{column_order}.

 \code{column_order} can be dispatched on following classes:

 \itemize{

-\item \code{\link{column_order,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{column_order,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{column_order,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,8 +10,8 @@ Method dispatch page for \code{component_height}.

 \code{component_height} can be dispatched on following classes:

 \itemize{

-\item \code{\link{component_height,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{component_height,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{component_height,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,8 +10,8 @@ Method dispatch page for \code{copy_all}.

 \code{copy_all} can be dispatched on following classes:

 \itemize{

-\item \code{\link{copy_all,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

 \item \code{\link{copy_all,AnnotationFunction-method}}, \code{\link{AnnotationFunction-class}} class method

+\item \code{\link{copy_all,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

 }

 }

 \examples{

@@ -10,12 +10,12 @@ Method dispatch page for \code{draw}.

 \code{draw} can be dispatched on following classes:

 \itemize{

-\item \code{\link{draw,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

-\item \code{\link{draw,Heatmap-method}}, \code{\link{Heatmap-class}} class method

-\item \code{\link{draw,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

-\item \code{\link{draw,Legends-method}}, \code{\link{Legends-class}} class method

 \item \code{\link{draw,AnnotationFunction-method}}, \code{\link{AnnotationFunction-class}} class method

+\item \code{\link{draw,Legends-method}}, \code{\link{Legends-class}} class method

 \item \code{\link{draw,HeatmapAnnotation-method}}, \code{\link{HeatmapAnnotation-class}} class method

+\item \code{\link{draw,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

+\item \code{\link{draw,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{draw,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,8 +10,8 @@ Method dispatch page for \code{draw_title}.

 \code{draw_title} can be dispatched on following classes:

 \itemize{

-\item \code{\link{draw_title,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{draw_title,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{draw_title,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,8 +10,8 @@ Method dispatch page for \code{make_layout}.

 \code{make_layout} can be dispatched on following classes:

 \itemize{

-\item \code{\link{make_layout,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{make_layout,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{make_layout,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

@@ -10,12 +10,12 @@ Method dispatch page for \code{show}.

 \code{show} can be dispatched on following classes:

 \itemize{

-\item \code{\link{show,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

-\item \code{\link{show,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

 \item \code{\link{show,ColorMapping-method}}, \code{\link{ColorMapping-class}} class method

-\item \code{\link{show,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 \item \code{\link{show,AnnotationFunction-method}}, \code{\link{AnnotationFunction-class}} class method

 \item \code{\link{show,HeatmapAnnotation-method}}, \code{\link{HeatmapAnnotation-class}} class method

+\item \code{\link{show,SingleAnnotation-method}}, \code{\link{SingleAnnotation-class}} class method

+\item \code{\link{show,HeatmapList-method}}, \code{\link{HeatmapList-class}} class method

+\item \code{\link{show,Heatmap-method}}, \code{\link{Heatmap-class}} class method

 }

 }

 \examples{

deleted file mode 100644

@@ -1,566 +0,0 @@

-#include "RConverters.h"

-#include "Rdefines.h"

-

-#include <stdio.h>

-

-int

-R_isVariableReference(SEXP arg)

-{

-    SEXP e, ans;

-    int val;

-    

-    PROTECT(e = allocVector(LANGSXP, 3));

-    SETCAR(e, Rf_install("is"));

-    SETCAR(CDR(e), arg);

-    SETCAR(CDR(CDR(e)), mkString("VariableReference"));

-    ans = Rf_eval(e, R_GlobalEnv);

-    val = INTEGER(ans)[0];

-    UNPROTECT(1);

-    return(val);

-}

-

-void *

-getVariableReference(SEXP arg, SEXP el, const char *type, const char *tag)

-{

-    char tmp[256];

-    sprintf(tmp, "%sRef", tag);

-    return(R_getNativeReference(el, type, tmp));

-}

-

-SEXP

-R_make_var_reference(void *ref, const char * const type)

-{

-    SEXP ans;

-    SEXP klass = MAKE_CLASS("VariableReference");

-    PROTECT(klass);

-    PROTECT(ans = NEW(klass));

-#ifdef DEBUG_R_RUNTIME

-    fprintf(stderr, "variable reference %p\n", ref);

-#endif

-    SET_SLOT(ans, Rf_install("ref"), R_createNativeReference(ref, type, type));

-    UNPROTECT(2);

-

-    return(ans);

-}

-

-

-SEXP

-R_createArrayReference(const void * ref, const char * const className, const char * const alias, 

-		       int *dims, unsigned int numDims,   size_t sizeofElement)

-{

-    SEXP ans, r_dims;

-    SEXP klass = MAKE_CLASS(className);

-    int i;

-

-    PROTECT(klass);

-    PROTECT(ans = NEW(klass));

-    SET_SLOT(ans, Rf_install("ref"), R_MakeExternalPtr((void *) ref, Rf_install(alias), R_NilValue));

-    PROTECT(r_dims = NEW_INTEGER(numDims));

-    for(i = 0; i < numDims; i++) INTEGER(r_dims)[i] = dims[i];

-    SET_SLOT(ans, Rf_install("length"), r_dims);

-    SET_SLOT(ans, Rf_install("elementSize"), ScalarInteger(sizeofElement));

-    UNPROTECT(3);

-

-    return(ans);

-}

-

-

-

-

-SEXP

-R_createNativeReference(const void *val, const char *className, const char *tagName)

-{

- SEXP ans;

- SEXP klass = MAKE_CLASS((char *) className);

-

- if(klass == R_NilValue) {

-	 PROBLEM "Can't find class %s", className

-    ERROR;

- }

-

- /* should check this extends RC++Reference.. */

- PROTECT(klass);

- PROTECT(ans = NEW(klass));

-

- ans = SET_SLOT(ans, Rf_install("ref"),  R_MakeExternalPtr((void *) val, Rf_install(tagName), R_NilValue));

-

- UNPROTECT(2);

- return(ans);

-}

-

-void *

-R_getNativeReference(SEXP arg, const char *type, const char *tag)

-{

- SEXP el, elTag; 

- void *ans;

-

- el = GET_SLOT(arg, Rf_install("ref"));

- if(R_isVariableReference(arg)) {

-     void *tmp;

-     tmp = getVariableReference(arg, el, type, tag);

-     if(!tmp) {

-        PROBLEM "Got null value for variable reference %s", type

-        ERROR;

-     }

-     return(tmp);

- }

-

-

-/* XXX added allow through if the TAG is null on the object. Just for now. */

- if(tag && tag[0] && (elTag = R_ExternalPtrTag(el)) && elTag != Rf_install(tag)) {

-

-        /* So not a direct match. Now see if it is from a derived class

-           by comparing the value in the object to the name of each of the

-           ancestor classes.

-         */

-    SEXP ancestors = GET_SLOT(arg, Rf_install("classes"));

-    int n, i;

-    n = Rf_length(ancestors);

-    for(i = 0; i < n  ; i ++) {

-        if(strcmp(CHAR(STRING_ELT(ancestors, i)), tag) == 0)

-  	   break;

-    }

-    if(i == n) {

-      PROBLEM "Looking for %s, got %s",

-	      tag, elTag != R_NilValue ? CHAR(PRINTNAME(elTag)) : "NULL"

-      ERROR;

-    }

- }

-

- ans = R_ExternalPtrAddr(el);

-

- if(!ans) {

-   PROBLEM "NULL value passed to R_getNativeReference. This may not be an error, but it could be.\n      Have you loaded an object from a previous R session?"

-   ERROR;

- }

- return(ans);

-}

-

-

-int

-convertFromRToInt(SEXP obj)

-{

-    return(INTEGER(obj)[0]);

-}

-

-

-SEXP

-convertIntToR(int x)

-{

-    SEXP ans;

-    ans = allocVector(INTSXP, 1);

-    INTEGER(ans)[0] = x;

-    return(ans);

-}

-

-SEXP

-convertDoubleToR(double x)

-{

-    SEXP ans;

-    ans = allocVector(REALSXP, 1);

-    REAL(ans)[0] = x;

-    return(ans);

-}

-

-SEXP

-convertDoubleArrayToR(int len, const double *x, int copy, int start, int end)

-{

-    SEXP ans;

-    int i, num;

-    

-    num = end  - start + 1;

-    ans = allocVector(REALSXP, num);

-    for(i = 0; i < num ; i++)

-	REAL(ans)[i] = x[i + start];

-    return(ans);

-}

-

-#define MIN(a, b)  ((a) < (b) ? (a) : (b))

-

-void

-convertRCharacterToCharArray(char *dest, SEXP r_value, int array_len)

-{

-    int i;

-    int len;

-

-    len = MIN(Rf_length(r_value), array_len);

-    for(i = 0; i < len; i++)

-	dest[i] = CHAR(STRING_ELT(r_value, i))[0];

-}

-

-SEXP

-convertCharArrayToR(int dim, const char *x, int copy, int start, int end)

-{

-    SEXP ans;

-    int i, num;

-    char buf[2];

-

-    buf[1] = '\0';

-    num = end - start + 1;

-    PROTECT(ans = allocVector(STRSXP, num));

-    for(i = 0; i < num ; i++) {

-        buf[0] = x[i + start];

-	SET_STRING_ELT(ans, i, mkChar(buf));

-    }

-    UNPROTECT(1);

-    return(ans);

-}

-

-

-#if 0

-/* Why are these commented out? Because we generate them programmatically.

-  

-   convertDoubleArrayToR.

-*/

-SEXP

-convertIntArrayToR(const int *x, int len, int start, int end)

-{

-    SEXP ans;

-    int i;

-

-    

-    ans = allocVector(INTSXP, len);

-    for(i = 0; i < len ; i++)

-	INTEGER(ans)[i] = x[i];

-    return(ans);

-}

-

-

-SEXP

-convertUnsignedIntArrayToR(const unsigned int *x, int len)

-{

-    SEXP ans;

-    int i;

-    

-    ans = allocVector(REALSXP, len);

-    for(i = 0; i < len ; i++)

-	REAL(ans)[i] = x[i];

-    return(ans);

-}

-#endif

-

-

-

-SEXP

-convertStringArrayToR(const char * const *x, int len)

-{

-    SEXP ans;

-    int i;

-

-    PROTECT(ans = allocVector(STRSXP, len));

-    for(i = 0; i < len ; i++)

-	SET_STRING_ELT(ans, i, mkChar(x[i] ? x[i] : ""));

-    UNPROTECT(1);

-    return(ans);

-}

-

-

-

-SEXP

-createREnumerationValue(int val, const char * const *names, const int *values, int namesLength, const char *name)

-{

-    SEXP ans;

-    int i;

-

-    PROTECT(ans =allocVector(INTSXP, 1));

-    INTEGER(ans)[0] = val;

-    

-    for(i = 0; i < namesLength; i++) {

-	if(val == values[i]) {

-	    SET_NAMES(ans, mkString(names[i]));

-	    break;

-	}

-    }

-

-    if(i == namesLength) {

-	PROBLEM "Unrecognized value (%d) in enumeration %s", val, name

-        ERROR;

-    }

-    /* Do we want an enumeration value element here also. */

-    SET_CLASS(ans, mkString(name));

-

-    UNPROTECT(1);

-    return(ans);

-}

-

-

-/*

-  Finalize for deallocating the space we allocate for references to structures

-  created in S as part of the automatically generated code.

- */

-void

-SimpleAllocFinalizer(SEXP ans)

-{

-    void *ptr = R_ExternalPtrAddr(ans);

-    if(ptr) {

-#ifdef DEBUG_R_RUNTIME

-	fprintf(stderr, "Finalizing %p\n", ptr); fflush(stderr);

-#endif

-	free(ptr);

-	R_ClearExternalPtr(ans);

-    }

-}

-

-/**

-  Convert R object into either a function or the address of a C routine.

-  For a C routine, the caller can specify the name of the typedef which is

-  checked using the TAG for the external pointer.

-*/

-void *

-Rfrom_Callbable(SEXP obj, const char * const TypeDefName, CallableType *type) 

-{

-

-           /* If TypeDefName is NULL, we don't bother checking*/

-        if(TYPEOF(obj) == EXTPTRSXP) {

-	    if(TypeDefName && R_ExternalPtrTag(obj) != Rf_install(TypeDefName)) {

-   	         PROBLEM "[RfromCallbable] incorrect type name for a native routine pointer %s, not %s",

-		    CHAR(asChar(R_ExternalPtrTag(obj))), TypeDefName

-		 ERROR;

-	    }

-

-	    if(type) 

-		*type = NATIVE_ROUTINE;

-

-	    return(R_ExternalPtrAddr(obj));

-        } else if(TYPEOF(obj) == CLOSXP) {

-	    if(type) 

-		*type = R_FUNCTION;

-	    return(obj);

-	}

-

-	PROBLEM  "the Rfrom_Callable routine only handles native routines and "

-        ERROR;

-

-	return((void *) NULL);

-   }

-

-

-SEXP

-R_makeNames(const char *names[], int len)

-{

-  SEXP ans;

-  int i;

-  PROTECT(ans = NEW_CHARACTER(len));

-  for(i = 0; i < len; i++) 

-    SET_STRING_ELT(ans, i, mkChar(names[i]));

-  UNPROTECT(1);

-

-  return(ans);

-}

-

-typedef struct {

-    void **els;

-    unsigned long length;

-} RPointerList;

-

-SEXP

-R_listToRefArray(SEXP r_els, SEXP r_type)

-{

-    const char *type;

-    SEXP el;

-    int i, n;

-    void *tmp;