From c5a1f8abb402c53d29f76e53ac8383700a2e97d1 Mon Sep 17 00:00:00 2001
From: ripley <ripley@00db46b3-68df-0310-9c12-caf00c1e9a41>
Date: Wed, 1 Aug 2012 12:54:39 +0000
Subject: [PATCH] use .Call in findInterval()

git-svn-id: https://svn.r-project.org/R/trunk@60071 00db46b3-68df-0310-9c12-caf00c1e9a41
---
 src/appl/interv.c            |  4 +++-
 src/include/R_ext/Applic.h   |  3 ++-
 src/library/base/R/findInt.R |  4 ++++
 src/main/basedecl.h          |  1 +
 src/main/registration.c      |  1 +
 src/main/util.c              | 21 +++++++++++++++++++++
 6 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/src/appl/interv.c b/src/appl/interv.c
index a4436b233bb..fb2043deedd 100644
--- a/src/appl/interv.c
+++ b/src/appl/interv.c
@@ -36,7 +36,9 @@ int F77_SUB(interv)(double *xt, int *n, double *x,
 }
 
 /* This one to be called from R {via .C(..)} :
- * FIXME: Replace by a .Call()able version!
+   FIXME: Replace by a .Call()able version!
+
+   Done for R 2.15.2, no longer used in R, but used in IBDsim and timeSeries
  */
 void find_interv_vec(double *xt, int *n,	double *x,  int *nx,
 		     int *rightmost_closed, int *all_inside, int *indx)
diff --git a/src/include/R_ext/Applic.h b/src/include/R_ext/Applic.h
index a364cc666cb..fca68c3c8d6 100644
--- a/src/include/R_ext/Applic.h
+++ b/src/include/R_ext/Applic.h
@@ -156,9 +156,10 @@ double Brent_fmin(double ax, double bx, double (*f)(double, void *),
 int F77_SUB(interv)(double *xt, int *n, double *x,
 		    Rboolean *rightmost_closed, Rboolean *all_inside,
 		    int *ilo, int *mflag);
+/* Non-API No longer used */
 void find_interv_vec(double *xt, int *n, double *x, int *nx,
 		     int *rightmost_closed, int *all_inside, int *indx);
-/* used in package eco */
+/* API, used in package eco */
 int findInterval(double *xt, int n, double x,
 		 Rboolean rightmost_closed,  Rboolean all_inside, int ilo,
 		 int *mflag);
diff --git a/src/library/base/R/findInt.R b/src/library/base/R/findInt.R
index ae804b98a69..f6e07397344 100644
--- a/src/library/base/R/findInt.R
+++ b/src/library/base/R/findInt.R
@@ -35,6 +35,9 @@ findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
     inside <- as.logical(all.inside)
     if (is.na(right) || is.na(inside))
         stop("NA logical arguments", domain = NA)
+    index <- .Call("FindIntervVec", as.double(vec), as.double(x),
+                   right, inside, PACKAGE = "base")
+    if(FALSE) {
     index <- integer(nx)
     ## NB: this is naughty, and changes index in-place.
     .C("find_interv_vec",
@@ -43,6 +46,7 @@ findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
        right, inside,
        index, DUP = FALSE, NAOK = TRUE, # NAOK: 'Inf' only
        PACKAGE = "base")
+}
     if(has.na) {
 	ii <- as.integer(ix)
 	ii[ix] <- NA
diff --git a/src/main/basedecl.h b/src/main/basedecl.h
index d088678d0be..90247ba5db1 100644
--- a/src/main/basedecl.h
+++ b/src/main/basedecl.h
@@ -98,4 +98,5 @@ SEXP crc64ToString(SEXP);
 
 SEXP BinCode(SEXP x, SEXP breaks, SEXP right, SEXP lowest);
 SEXP R_Tabulate(SEXP in, SEXP nbin);
+SEXP FindIntervVec(SEXP xt, SEXP x, SEXP right, SEXP inside);
 
diff --git a/src/main/registration.c b/src/main/registration.c
index 0bb9fdf7223..ce6ed6a3a6e 100644
--- a/src/main/registration.c
+++ b/src/main/registration.c
@@ -211,6 +211,7 @@ static R_CallMethodDef callMethods [] = {
     CALLDEF(crc64ToString, 1),
     CALLDEF(BinCode, 4),
     CALLDEF(R_Tabulate, 2),
+    CALLDEF(FindIntervVec, 4),
 
     {NULL, NULL, 0}
 };
diff --git a/src/main/util.c b/src/main/util.c
index 72dadb6e79d..9dc1cd064c4 100644
--- a/src/main/util.c
+++ b/src/main/util.c
@@ -1926,3 +1926,24 @@ SEXP R_Tabulate(SEXP in, SEXP nbin)
 	if (x[i] != NA_INTEGER && x[i] > 0 && x[i] <= nb) y[x[i] - 1]++;
     return ans;
 }
+
+/* x can be a long vector but xt cannot since the result is integer */
+SEXP FindIntervVec(SEXP xt, SEXP x, SEXP right, SEXP inside)
+{
+    if(TYPEOF(xt) != REALSXP || TYPEOF(x) != REALSXP) error("invalid input");
+    int n = LENGTH(xt);
+    if (n == NA_INTEGER) error("invalid input");
+    R_xlen_t nx = XLENGTH(x);
+    int sr = asLogical(right), si = asLogical(inside);
+    if (sr == NA_INTEGER || si == NA_INTEGER) error("invalid input");
+    SEXP ans;
+    PROTECT(ans = allocVector(INTSXP, nx));  // not currently needed
+    int ii = 1;
+    for(R_xlen_t i = 0; i < nx; i++) {
+	int mfl = si;
+	ii = findInterval(REAL(xt), n, REAL(x)[i], sr, si, ii,  &mfl);
+	INTEGER(ans)[i] = ii;
+    }
+    UNPROTECT(1);
+    return ans;
+}