use .Call in findInterval()

git-svn-id: https://svn.r-project.org/R/trunk@60071 00db46b3-68df-0310-9c12-caf00c1e9a41

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)

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);

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

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);
 

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}
 };

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;
+}