GForce min/max for characters, #523.

Rdatatable · Jan 26, 2015 · a18d624 · a18d624
1 parent acc4290
commit a18d624
Show file tree

Hide file tree

Showing 2 changed files with 85 additions and 0 deletions.
diff --git a/inst/tests/tests.Rraw b/inst/tests/tests.Rraw
@@ -4625,6 +4625,19 @@ test(1313.20, DT[, list(y=max(y)), by=x], DT[c(1,6)])
 test(1313.21, DT[, list(y=min(y, na.rm=TRUE)), by=x], DT[c(2,7)])
 test(1313.22, DT[, list(y=max(y, na.rm=TRUE)), by=x], DT[c(5,10)])
 
+# for character
+set.seed(1L)
+DT <- data.table(x=rep(1:6, each=3), y=sample(c("", letters[1:3], NA), 18, TRUE))
+test(1313.23, DT[, min(y), by=x], DT[, base:::min(y), by=x])
+test(1313.24, DT[, max(y), by=x], DT[, base:::max(y), by=x])
+test(1313.25, DT[, min(y, na.rm=TRUE), by=x], DT[, base:::min(y, na.rm=TRUE), by=x])
+test(1313.26, DT[, max(y, na.rm=TRUE), by=x], DT[, base:::max(y, na.rm=TRUE), by=x])
+DT[x==6, y := NA_character_]
+test(1313.27, DT[, min(y), by=x], DT[, base:::min(y), by=x])
+test(1313.28, DT[, max(y), by=x], DT[, base:::max(y), by=x])
+test(1313.29, DT[, min(y, na.rm=TRUE), by=x], data.table(x=1:6, V1=c("a","a","c","","a",NA)), warning="No non-missing")
+test(1313.30, DT[, max(y, na.rm=TRUE), by=x], data.table(x=1:6, V1=c("b","a","c","a","c",NA)), warning="No non-missing")
+
 # bug git #693 - dcast error message improvement:
 dt <- data.table(x=c(1,1), y=c(2,2), z = 3:4)
 test(1314, dcast(dt, x ~ y, value.var="z", fun.aggregate=identity), error="Aggregating function provided to argument 'fun.aggregate' should always return a length 1 vector")

diff --git a/src/gsumm.c b/src/gsumm.c
@@ -218,6 +218,42 @@ SEXP gmin(SEXP x, SEXP narm)
                     for (i=0; i<ngrp; i++) {
                         if (update[i] != 1) REAL(ans)[i] = R_PosInf;
                     }
+                    break;
+                }
+            }
+        }
+        break;
+    case STRSXP:
+        ans = PROTECT(allocVector(STRSXP, ngrp));
+        for (i=0; i<ngrp; i++) SET_STRING_ELT(ans, i, mkChar(""));
+        if (!LOGICAL(narm)[0]) {
+            for (i=0; i<n; i++) {
+                thisgrp = grp[i];
+                if (STRING_ELT(x, i) != NA_STRING && STRING_ELT(ans, thisgrp) != NA_STRING) {
+                    if ( update[thisgrp] != 1 || strcmp(CHAR(STRING_ELT(ans, thisgrp)), CHAR(STRING_ELT(x, i))) > 0 ) {
+                        SET_STRING_ELT(ans, thisgrp, STRING_ELT(x, i));
+                        if (update[thisgrp] != 1) update[thisgrp] = 1;
+                    }
+                } else SET_STRING_ELT(ans, thisgrp, NA_STRING);
+            }
+        } else {
+            for (i=0; i<n; i++) {
+                thisgrp = grp[i];
+                if (STRING_ELT(x, i) != NA_STRING) {
+                    if ( update[thisgrp] != 1 || strcmp(CHAR(STRING_ELT(ans, thisgrp)), CHAR(STRING_ELT(x, i))) > 0 ) {
+                        SET_STRING_ELT(ans, thisgrp, STRING_ELT(x, i));
+                        if (update[thisgrp] != 1) update[thisgrp] = 1;
+                    }
+                } else {
+                    if (update[thisgrp] != 1) {
+                        SET_STRING_ELT(ans, thisgrp, NA_STRING);
+                    }
+                }
+            }
+            for (i=0; i<ngrp; i++) {
+                if (update[i] != 1)  {// equivalent of INTEGER(ans)[thisgrp] == NA_INTEGER
+                    warning("No non-missing values found in at least one group. Returning 'NA' for such groups to be consistent with base");
+                    break;
                 }
             }
         }
@@ -316,10 +352,46 @@ SEXP gmax(SEXP x, SEXP narm)
                     for (i=0; i<ngrp; i++) {
                         if (update[i] != 1) REAL(ans)[i] = -R_PosInf;
                     }
+                    break;
                 }
             }
         }
         break;
+    case STRSXP:
+        ans = PROTECT(allocVector(STRSXP, ngrp));
+        for (i=0; i<ngrp; i++) SET_STRING_ELT(ans, i, mkChar(""));
+        if (!LOGICAL(narm)[0]) { // simple case - deal in a straightforward manner first
+            for (i=0; i<n; i++) {
+                thisgrp = grp[i];
+                if (STRING_ELT(x,i) != NA_STRING && STRING_ELT(ans, thisgrp) != NA_STRING) {
+                    if ( update[thisgrp] != 1 || strcmp(CHAR(STRING_ELT(ans, thisgrp)), CHAR(STRING_ELT(x,i))) < 0 ) {
+                        SET_STRING_ELT(ans, thisgrp, STRING_ELT(x, i));
+                        if (update[thisgrp] != 1) update[thisgrp] = 1;
+                    }
+                } else  SET_STRING_ELT(ans, thisgrp, NA_STRING);
+            }
+        } else {
+            for (i=0; i<n; i++) {
+                thisgrp = grp[i];
+                if (STRING_ELT(x, i) != NA_STRING) {
+                    if ( update[thisgrp] != 1 || strcmp(CHAR(STRING_ELT(ans, thisgrp)), CHAR(STRING_ELT(x, i))) < 0 ) {
+                        SET_STRING_ELT(ans, thisgrp, STRING_ELT(x, i));
+                        if (update[thisgrp] != 1) update[thisgrp] = 1;
+                    }
+                } else {
+                    if (update[thisgrp] != 1) {
+                        SET_STRING_ELT(ans, thisgrp, NA_STRING);
+                    }
+                }
+            }
+            for (i=0; i<ngrp; i++) {
+                if (update[i] != 1)  {// equivalent of INTEGER(ans)[thisgrp] == NA_INTEGER
+                    warning("No non-missing values found in at least one group. Returning 'NA' for such groups to be consistent with base");
+                    break;
+                }
+            }
+        }    
+        break;
     case REALSXP:
         ans = PROTECT(allocVector(REALSXP, ngrp));
         for (i=0; i<ngrp; i++) REAL(ans)[i] = 0;