From 026f5880ca3d8376e78ee53f03304ff1692ac13b Mon Sep 17 00:00:00 2001
From: Michael Haupt <michael.haupt@oracle.com>
Date: Tue, 11 Nov 2014 15:41:54 +0100
Subject: [PATCH] several R functions, for completeness (tests pending)
---
.../r/nodes/builtin/base/R/interaction.R | 63 +++++++++
.../truffle/r/nodes/builtin/base/R/tapply.R | 56 ++++++++
.../truffle/r/nodes/builtin/stats/R/approx.R | 122 ++++++++++++++++++
3 files changed, 241 insertions(+)
create mode 100644 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/interaction.R
create mode 100644 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/tapply.R
create mode 100644 com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/interaction.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/interaction.R
new file mode 100644
index 0000000000..0aec057324
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/interaction.R
@@ -0,0 +1,63 @@
+# 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")
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/tapply.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/tapply.R
new file mode 100644
index 0000000000..2b0fb66e67
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/tapply.R
@@ -0,0 +1,56 @@
+# 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
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R
new file mode 100644
index 0000000000..f03230b028
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R
@@ -0,0 +1,122 @@
+# 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)
--
GitLab