several R functions, for completeness (tests pending)

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/interaction.R

+#  File src/library/base/R/interaction.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program 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 General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+
+### This is almost like the Primitive ":" for factors
+### but with drop=TRUE, used in reshape
+interaction <- function(..., drop = FALSE, sep = ".", lex.order = FALSE)
+{
+    args <- list(...)
+    narg <- length(args)
+    if (narg == 1L && is.list(args[[1L]])) {
+        args <- args[[1L]]
+        narg <- length(args)
+    }
+    for(i in narg:1L) {
+        f <- as.factor(args[[i]])[, drop = drop]
+        l <- levels(f)
+        if1 <- as.integer(f) - 1L
+        if(i == narg) {
+            ans <- if1
+            lvs <- l
+        } else {
+            if(lex.order) {
+                ll <- length(lvs)
+                ans <- ans + ll * if1
+                lvs <- paste(rep(l, each = ll), rep(lvs, length(l)), sep=sep)
+            } else {
+                ans <- ans * length(l) + if1
+                lvs <- paste(rep(l, length(lvs)),
+                        rep(lvs, each = length(l)), sep=sep)
+            }
+            if(anyDuplicated(lvs)) { ## fix them up
+                ulvs <- unique(lvs)
+                while((i <- anyDuplicated(flv <- match(lvs, ulvs)))) {
+                    lvs <- lvs[-i]
+                    ans[ans+1L == i] <- match(flv[i], flv[1:(i-1)]) - 1L
+                    ans[ans+1L > i] <- ans[ans+1L > i] - 1L
+                }
+                lvs <- ulvs
+            }
+            if(drop) {
+                olvs <- lvs
+                lvs <- lvs[sort(unique(ans+1L))]
+                ans <- match(olvs[ans+1L], lvs) - 1L
+            }
+        }
+    }
+    structure(as.integer(ans+1L), levels=lvs, class = "factor")
+}

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/tapply.R

+#  File src/library/base/R/tapply.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program 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 General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+
+tapply <- function (X, INDEX, FUN = NULL, ..., simplify = TRUE)
+{
+    FUN <- if (!is.null(FUN)) match.fun(FUN)
+    if (!is.list(INDEX)) INDEX <- list(INDEX)
+    nI <- length(INDEX)
+    if (!nI) stop("'INDEX' is of length zero")
+    namelist <- vector("list", nI)
+    names(namelist) <- names(INDEX)
+    extent <- integer(nI)
+    nx <- length(X)
+    one <- 1L
+    group <- rep.int(one, nx) #- to contain the splitting vector
+    ngroup <- one
+    for (i in seq_along(INDEX)) {
+        index <- as.factor(INDEX[[i]])
+        if (length(index) != nx)
+            stop("arguments must have same length")
+        namelist[[i]] <- levels(index)#- all of them, yes !
+        extent[i] <- nlevels(index)
+        group <- group + ngroup * (as.integer(index) - one)
+        ngroup <- ngroup * nlevels(index)
+    }
+    if (is.null(FUN)) return(group)
+    ans <- lapply(X = split(X, group), FUN = FUN, ...)
+    index <- as.integer(names(ans))
+    if (simplify && all(unlist(lapply(ans, length)) == 1L)) {
+        ansmat <- array(dim = extent, dimnames = namelist)
+        ans <- unlist(ans, recursive = FALSE)
+    } else {
+        ansmat <- array(vector("list", prod(extent)),
+                dim = extent, dimnames = namelist)
+    }
+    if(length(index)) {
+        names(ans) <- NULL
+        ansmat[index] <- ans
+    }
+    ansmat
+}

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R

+#  File src/library/stats/R/approx.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program 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 General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+
+### approx() and approxfun() are *very similar* -- keep in sync!
+
+## This function is used in approx, approxfun, spline, and splinefun
+## to massage the input (x,y) pairs into standard form:
+## x values unique and increasing, y values collapsed to match
+## (except if ties=="ordered", then not unique)
+
+regularize.values <- function(x, y, ties) {
+        x <- xy.coords(x, y) # -> (x,y) numeric of same length
+        y <- x$y
+        x <- x$x
+        if(any(na <- is.na(x) | is.na(y))) {
+                ok <- !na
+                x <- x[ok]
+                y <- y[ok]
+        }
+        nx <- length(x)
+        if (!identical(ties, "ordered")) {
+                o <- order(x)
+                x <- x[o]
+                y <- y[o]
+                if (length(ux <- unique(x)) < nx) {
+                        if (missing(ties))
+                                warning("collapsing to unique 'x' values")
+                        # tapply bases its uniqueness judgement on character representations;
+                        # we want to use values (PR#14377)
+                        y <- as.vector(tapply(y,match(x,x),ties))# as.v: drop dim & dimn.
+                        x <- ux
+                        stopifnot(length(y) == length(x))# (did happen in 2.9.0-2.11.x)
+                }
+        }
+        list(x=x, y=y)
+}
+
+#approx <- function(x, y = NULL, xout, method = "linear", n = 50,
+#                yleft, yright, rule = 1, f = 0, ties = mean)
+#{
+#        method <- pmatch(method, c("linear", "constant"))
+#        if (is.na(method)) stop("invalid interpolation method")
+#        stopifnot(is.numeric(rule), (lenR <- length(rule)) >= 1L, lenR <= 2L)
+#        if(lenR == 1) rule <- rule[c(1,1)]
+#        x <- regularize.values(x, y, ties) # -> (x,y) numeric of same length
+#        y <- x$y
+#        x <- x$x
+#        nx <- as.integer(length(x))
+#        if (is.na(nx)) stop("invalid length(x)")
+#        if (nx <= 1) {
+#                if(method == 1)# linear
+#                        stop("need at least two non-NA values to interpolate")
+#                if(nx == 0) stop("zero non-NA points")
+#        }
+#        
+#        if (missing(yleft))
+#                yleft <- if (rule[1L] == 1) NA else y[1L]
+#        if (missing(yright))
+#                yright <- if (rule[2L] == 1) NA else y[length(y)]
+#        stopifnot(length(yleft) == 1L, length(yright) == 1L, length(f) == 1L)
+#        if (missing(xout)) {
+#                if (n <= 0) stop("'approx' requires n >= 1")
+#                xout <- seq.int(x[1L], x[nx], length.out = n)
+#        }
+#        x <- as.double(x); y <- as.double(y)
+#        .Call(C_ApproxTest, x, y, method, f)
+#        yout <- .Call(C_Approx, x, y, xout, method, yleft, yright, f)
+#        list(x = xout, y = yout)
+#}
+#
+#approxfun <- function(x, y = NULL, method = "linear",
+#                yleft, yright, rule = 1, f = 0, ties = mean)
+#{
+#        method <- pmatch(method, c("linear", "constant"))
+#        if (is.na(method)) stop("invalid interpolation method")
+#        stopifnot(is.numeric(rule), (lenR <- length(rule)) >= 1L, lenR <= 2L)
+#        if(lenR == 1) rule <- rule[c(1,1)]
+#        x <- regularize.values(x, y, ties) # -> (x,y) numeric of same length
+#        y <- x$y
+#        x <- x$x
+#        n <- as.integer(length(x))
+#        if (is.na(n)) stop("invalid length(x)")
+#        
+#        if (n <= 1) {
+#                if(method == 1)# linear
+#                        stop("need at least two non-NA values to interpolate")
+#                if(n == 0) stop("zero non-NA points")
+#        }
+#        if (missing(yleft))
+#                yleft <- if (rule[1L] == 1) NA else y[1L]
+#        if (missing(yright))
+#                yright <- if (rule[2L] == 1) NA else y[length(y)]
+#        force(f)
+#        stopifnot(length(yleft) == 1L, length(yright) == 1L, length(f) == 1L)
+#        rm(rule, ties, lenR, n) # we do not need n, but summary.stepfun did.
+#        
+#        ## 1. Test input consistency once
+#        x <- as.double(x); y <- as.double(y)
+#        .Call(C_ApproxTest, x, y, method, f)
+#        
+#        ## 2. Create and return function that does not test input validity...
+#        function(v) .approxfun(x, y, v, method, yleft, yright, f)
+#}
+#
+## avoid capturing internal calls
+#.approxfun <- function(x, y, v,  method, yleft, yright, f)
+#        .Call(C_Approx, x, y, v, method, yleft, yright, f)