Merge pull request #678 from SebKrantz/development

Fixing #675.
SebKrantz · Dec 12, 2024 · ea70bad · ea70bad
2 parents 4e36844 + 90f0623
commit ea70bad
Show file tree

Hide file tree

Showing 4 changed files with 50 additions and 5 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: collapse
 Title: Advanced and Fast Data Transformation
-Version: 2.0.18
-Date: 2024-11-23
+Version: 2.0.18.9000
+Date: 2024-12-12
 Authors@R: c(
            person("Sebastian", "Krantz", role = c("aut", "cre"), 
                   email = "[email protected]", 

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,7 @@
+# collapse 2.0.18.9000
+
+* `fmatch(factor(NA), NA)` now gives `1` instead of `NA`. Thanks @NicChr (#675).
+
 # collapse 2.0.18
 
 * Cases in `pivot(..., how = "longer")` with no `values` columns now no longer give an error. Thanks @alvarocombo for flagging this (#663).

diff --git a/src/match.c b/src/match.c
@@ -42,14 +42,52 @@ SEXP match_single(SEXP x, SEXP table, SEXP nomatch) {
     if(tx < tt) { // table could be integer, double, complex, character....
       if(tx == INTSXP-1) { // For factors there is a shorthand: just match the levels against table...
         SEXP nmvint = PROTECT(ScalarInteger(nmv)); ++nprotect;
-        PROTECT(table = match_single(getAttrib(x, R_LevelsSymbol), table, nmvint)); ++nprotect;
-        int *pans = INTEGER(ans), *pt = INTEGER(table)-1, *px = INTEGER(x);
+        SEXP tab = PROTECT(match_single(getAttrib(x, R_LevelsSymbol), table, nmvint)); ++nprotect;
+        int *pans = INTEGER(ans), *pt = INTEGER(tab)-1, *px = INTEGER(x);
         if(inherits(x, "na.included")) {
           #pragma omp simd
           for(int i = 0; i < n; ++i) pans[i] = pt[px[i]];
         } else {
+          int na_ind = 0;
+          // Need to take care of possible NA matches in table..
+          switch(tt) {
+            case INTSXP: {
+              const int *ptt = INTEGER_RO(table);
+              for(int i = 0; i != nt; ++i) {
+                if(ptt[i] == NA_INTEGER) {
+                  na_ind = i+1; break;
+                }
+              }
+            } break;
+            case REALSXP: {
+              const double *ptt = REAL_RO(table);
+              for(int i = 0; i != nt; ++i) {
+                if(ISNAN(ptt[i])) {
+                  na_ind = i+1; break;
+                }
+              }
+            } break;
+            case STRSXP: {
+              const SEXP *ptt = STRING_PTR_RO(table);
+              for(int i = 0; i != nt; ++i) {
+                if(ptt[i] == NA_STRING) {
+                  na_ind = i+1; break;
+                }
+              }
+            } break;
+            case CPLXSXP: {
+              const Rcomplex *ptt = COMPLEX_RO(table);
+              for(int i = 0; i != nt; ++i) {
+                if(C_IsNA(ptt[i]) || C_IsNaN(ptt[i])) {
+                  na_ind = i+1; break;
+                }
+              }
+            } break;
+            default: error("Type %s for 'table' is not supported.", type2char(tt));
+          }
+          if(na_ind == 0) na_ind = nmv;
           #pragma omp simd
-          for(int i = 0; i < n; ++i) pans[i] = px[i] == NA_INTEGER ? nmv : pt[px[i]];
+          for(int i = 0; i < n; ++i) pans[i] = px[i] == NA_INTEGER ? na_ind : pt[px[i]];
         }
         UNPROTECT(nprotect);
         return ans;

diff --git a/tests/testthat/test-miscellaneous-issues.R b/tests/testthat/test-miscellaneous-issues.R
@@ -467,6 +467,9 @@ test_that("fmedian ties handled properly with weights", {
 
 test_that("Misc bugs", {
   expect_visible(qF(c(4L, 1L, NA), sort = FALSE))
+  expect_equal(fmatch(factor(NA, exclude = NULL), NA), 1L) # #675
+  expect_equal(fmatch(factor(NA), NA), 1L)
 })
 
+
 options(warn = 1)