re-enable match(<Date>, <char>) (wrt 88356)

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

Author: maechler

doc/NEWS.Rd

@@ -144,22 +144,17 @@
       \PR{18885} (differently than the fix for \PR{15770}), with thanks to
       \I{Ivan Krylov}.
 
-      \item \code{t.test(c(1:3, Inf))} and similar no longer produce an error but
-      return a (still not so useful) \code{"htest"} result, fixing
-      \PR{18901}, thanks to \I{Jesse Alderliesten}.
-
       \item \code{text()} now truncates \code{labels} to maximum length
       of \code{x} and \code{y} (if it is longer), fixing \PR{7084}.
       Thanks to \I{Heather Turner}, \I{Ella Kaye}, and
       \I{Philippe Grosjean}.
 
-      \item \code{attr(., "tsp") <- val} now uses \code{getOption("ts.eps")}
-      instead of hardwired \code{1e-5}; consequently, \code{ts(.., ts.eps=*)}
-      now passes \code{ts.eps} to the \code{"tsp"} setting C code;
-      both fixing a long-standing \sQuote{\I{FIXME}}.
-
       \item \code{<Date> \%in\% set} has become as fast again, as it was
       before \R 4.3.0, via new S3 method \code{mtfrm.Date}.
+      Additionally, \code{<character> \%in\% <Date>} and vice versa are
+      documented to work in concordance with \code{==} and as an exception
+      to the typical \code{match()} behaviour which relies on
+      \dQuote{univariate} \code{mtfrm()} alone.
     }
   }
 }
@@ -176,7 +171,14 @@
 
   \subsection{BUG FIXES}{
     \itemize{
-      \item .
+      \item \code{t.test(c(1:3, Inf))} and similar no longer produce an error but
+      return a (still not so useful) \code{"htest"} result, fixing
+      \PR{18901}, thanks to \I{Jesse Alderliesten}.
+
+      \item \code{attr(., "tsp") <- val} now uses \code{getOption("ts.eps")}
+      instead of hardwired \code{1e-5}; consequently, \code{ts(.., ts.eps=*)}
+      now passes \code{ts.eps} to the \code{"tsp"} setting C code;
+      both fixing a long-standing \sQuote{\I{FIXME}}.
     }
   }
 }

src/library/base/man/match.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/match.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2017 R Core Team
+% Copyright 1995-2025 R Core Team
 % Distributed under GPL 2 or later
 
 \name{match}
@@ -58,6 +58,12 @@ x \%in\% table
   complex < character) before matching.  If \code{incomparables} has
   positive length it is coerced to the common type.
 
+  One exception to the above happens when \code{match()}ing
+  \code{\link{Date}} objects and \code{\link{character}}s.  There, the
+  character argument is coerced to \code{"Date"} (via
+  \code{\link{as.Date.character}()}) before the above \code{mtfrm()} is
+  applied.
+
   Matching for lists is potentially very slow and best avoided except in
   simple cases.
 

src/main/unique.c

@@ -599,7 +599,7 @@ static Rboolean duplicatedInit(SEXP x, HashData *d)
     } else if (TYPEOF(x) == CLOSXP) {
 	if (duplicatedInit(BODY_EXPR(x), d))
 	    stop = TRUE;
-    }	
+    }
     return stop;
 }
 
@@ -801,7 +801,7 @@ static SEXP sorted_Duplicated(SEXP x, Rboolean from_last, int nmax)
 		SORTED_DUP_NANS(PARTIAL, 0, i < nb, i++);
 	    } // from_last
 	} // numnas > 0
-	
+
 	if(numnas < n) {
 	    startpos = nas1st ? numnas : 0;
 	    SORTED_DUP_NONNANS(startpos, n - numnas - 1, rtmp, double, REAL);
@@ -818,7 +818,7 @@ static SEXP sorted_Duplicated(SEXP x, Rboolean from_last, int nmax)
 #undef SORTED_DUP_NANS
 #undef DUP_DO_ONE
 
-/* to add sorted fastpass support for new SEXP types modify sorted_Duplicated 
+/* to add sorted fastpass support for new SEXP types modify sorted_Duplicated
    and sorted_any_Duplicated then add them here */
 #define DUP_KNOWN_SORTED(x)						\
     ((TYPEOF(x) == INTSXP && KNOWN_SORTED(INTEGER_IS_SORTED(x))) ||	\
@@ -835,7 +835,7 @@ static SEXP Duplicated(SEXP x, Rboolean from_last, int nmax)
 	return allocVector(LGLSXP, 0);
     else if (n == 1)
 	return ScalarLogical(FALSE);
-    
+
     if(DUP_KNOWN_SORTED(x)) {
     	return sorted_Duplicated(x, from_last, nmax);
     }
@@ -866,7 +866,7 @@ attribute_hidden R_xlen_t sorted_any_duplicated(SEXP x, Rboolean from_last) {
     int itmp, sorted;
     double rtmp;
     Rboolean seen_na = FALSE, seen_nan = FALSE, na1st = FALSE;
-    
+
 #define SORTED_ANYDUP_NONNANS_FROM_LAST(start, count, tmpvar, eetype, vvtype) do { \
 	if (count > 1) {							\
 	    tmpvar = vvtype##_ELT(x, start + count - 1);			\
@@ -944,7 +944,7 @@ attribute_hidden R_xlen_t sorted_any_duplicated(SEXP x, Rboolean from_last) {
 	R_xlen_t numnas = sorted_real_count_NANs(x), napivot;
 	napivot = XLENGTH(x) - numnas;
 	na1st = KNOWN_NA_1ST(sorted);
-	
+
 	if(from_last) {
 	    if(na1st) {
 		SORTED_ANYDUP_NONNANS_FROM_LAST(numnas, napivot, rtmp, double,
@@ -1112,7 +1112,7 @@ attribute_hidden SEXP do_duplicated(SEXP call, SEXP op, SEXP args, SEXP env)
 
     /* handle zero length vectors, and NULL */
     R_xlen_t n = xlength(x);
-    if (n == 0) 
+    if (n == 0)
 	return(PRIMVAL(op) <= 1
 	       ? allocVector(PRIMVAL(op) != 1 ? LGLSXP : TYPEOF(x), 0)
 	       : ScalarInteger(0));
@@ -1161,7 +1161,7 @@ attribute_hidden SEXP do_duplicated(SEXP call, SEXP op, SEXP args, SEXP env)
 	    for(R_xlen_t j=0; j < nb; j++)
 		if(duptr[j] == 0) k++;
 	});
-    
+
     SEXP ans = PROTECT(allocVector(TYPEOF(x), k));
 
     k = 0;
@@ -1291,7 +1291,7 @@ static SEXP match_transform(SEXP s, SEXP env)
 	if(inherits(s, "factor")) return asCharacterFactor(s);
 	/*
 	else if(inherits(s, "POSIXlt")) { // and maybe more classes in the future:
-					  // Call R's (generic) as.character(s): 
+					  // Call R's (generic) as.character(s):
 	    SEXP call, r;
 	    PROTECT(call = lang2(R_AsCharacterSymbol, s));
 	    r = eval(call, env);
@@ -1334,7 +1334,7 @@ static SEXP asUTF8(SEXP x)
     } else
 	return x;
 }
-    
+
 // workhorse of R's match() and hence also  " ix %in% itable "
 static /* or attribute_hidden? */
 SEXP match5(SEXP itable, SEXP ix, int nmatch, SEXP incomp, SEXP env)
@@ -1351,10 +1351,37 @@ SEXP match5(SEXP itable, SEXP ix, int nmatch, SEXP incomp, SEXP env)
 	return ans;
     }
 
-    int nprot = 0;
-    SEXP x     = PROTECT(match_transform(ix,     env)); nprot++;
-    SEXP table = PROTECT(match_transform(itable, env)); nprot++;
-    /* or should we use PROTECT_WITH_INDEX and REPROTECT below ? */
+    SEXP x, table;
+    int nprot = 2; /* x, table */
+    PROTECT_INDEX xpi, tbpi;
+
+    bool D1; /* special case  <Date> o <character> */
+    if ((D1 = isObject(ix)     && inherits(ix,     "Date") && isValidString(itable)) ||
+	(     isObject(itable) && inherits(itable, "Date") && isValidString(ix))) {
+	/* Do *not* translate the <Date> to integer below (which later would be coerced
+	 * to character: e.g, as.character(as.vector(as.Date("2025-06-26"))) |--> "20265"
+	 * but rather *do*  as.Date(<character>) for the other, and then compare (the numbers of)
+	 * as.vector(<Date>).
+	*/
+	SEXP call, form_Ymd = PROTECT(mkString("%Y-%m-%d"));
+	nprot += 2; /* form_Ymd, call */
+	if(D1) { // table := as.Date.character(itable, "%Y-%m-%d")
+	    PROTECT(call = lang3(install("as.Date.character"), itable, form_Ymd));
+	    PROTECT_WITH_INDEX(table = eval(call, env), &tbpi);
+
+	    REPROTECT(         table = match_transform(table, env), tbpi);
+	    PROTECT_WITH_INDEX(x     = match_transform(ix,    env), &xpi);
+	} else { // x := as.Date.character(ix, "%Y-%m-%d")
+	    PROTECT(call = lang3(install("as.Date.character"), ix, form_Ymd));
+	    PROTECT_WITH_INDEX(x = eval(call, env), &xpi);
+
+	    REPROTECT(         x     = match_transform(x,      env),   xpi);
+	    PROTECT_WITH_INDEX(table = match_transform(itable, env), &tbpi);
+	}
+    } else { /* regular cases */
+	PROTECT_WITH_INDEX(x     = match_transform(ix,     env),  &xpi);
+        PROTECT_WITH_INDEX(table = match_transform(itable, env), &tbpi);
+    }
 
     SEXPTYPE type;
     /* Coerce to a common type; type == NILSXP is ok here.
@@ -1363,8 +1390,8 @@ SEXP match5(SEXP itable, SEXP ix, int nmatch, SEXP incomp, SEXP env)
      * (given that we have "Vector" or NULL) */
     if(TYPEOF(x) >= STRSXP || TYPEOF(table) >= STRSXP) type = STRSXP;
     else type = TYPEOF(x) < TYPEOF(table) ? TYPEOF(table) : TYPEOF(x);
-    PROTECT(x	  = coerceVector(x,	type)); nprot++;
-    PROTECT(table = coerceVector(table, type)); nprot++;
+    REPROTECT(x	    = coerceVector(x,	  type),  xpi);
+    REPROTECT(table = coerceVector(table, type), tbpi);
 
     // special case scalar x -- for speed only :
     if(XLENGTH(x) == 1 && !incomp) {
@@ -2406,7 +2433,7 @@ static void rehash(R_hashtab_type h, int resize)
 
     HT_COUNT(h) = 0;
     HT_VALIDATE(h);
-    
+
     SET_HT_TABLE(h, allocVector(VECSXP, new_size));
     if (resize) HT_TABLE_K(h)++;
 
@@ -2436,7 +2463,7 @@ static SEXP getcell(R_hashtab_type h, SEXP key, int *pidx)
 	chain = CDR(chain);
     }
     return R_NilValue;
-}    
+}
 
 
 /*
@@ -2557,7 +2584,7 @@ SEXP R_maphash(R_hashtab_type h, SEXP FUN)
     SEXP env = PROTECT(R_NewEnv(R_GlobalEnv, FALSE, 0));
     SEXP call = PROTECT(lang3(FUN_sym, key_sym, val_sym));
     defvar(FUN_sym, FUN, env);
-    
+
     SEXP table = PROTECT(HT_TABLE(h)); // PROTECT in case FUN causes a rehash
     int size = LENGTH(table);
     for (int i = 0; i < size; i++) {

tests/reg-tests-1e.R

@@ -2002,6 +2002,25 @@ assertErrV(     ts(1:711, frequency=2*pi, start = 1, end = 114, ts.eps = 1e-6) )
 ## did *not* error in R <= 4.5.1, as 'ts.eps' was *not* passed to C code
 
 
+## match(<Date>, <character>) and vice versa
+date_seq <- seq(as.Date("1705-01-01"), as.Date("2024-12-31"), by="days")
+dt1 <- as.Date("2024-05-01")
+dt3 <- c(dt1, as.Date(c("1800-01-01", "2025-02-02")))
+system.time({
+ tmp <- dt1 %in% date_seq
+ tm3 <- dt3 %in% date_seq
+})# 0.260 in R 4.3.0 ff
+##  0.003 or so after fixing
+stopifnot(tmp, identical(tm3, c(TRUE, TRUE, FALSE)))
+## The 1-1 case (fast branch in C's match5()):
+ch <- "2025-05-05" ; D <- as.Date(ch)
+c2 <- "1925-05-05"
+c(cDT = ch %in% D, DcT = D %in% ch,
+  cDF = c2 %in% D, DcF = D %in% c2)
+stopifnot(ch %in% D, D %in% ch, !(c2 %in% D), !(D %in% c2))
+## had failed in R-devel around 2025-06-26 (and before R 4.3.0)
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,