few changes

2005m · Mar 19, 2022 · 03f2b6c · 03f2b6c
1 parent 5ffbe2e
commit 03f2b6c
Show file tree

Hide file tree

Showing 9 changed files with 225 additions and 17 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: kit
 Type: Package
 Title: Data Manipulation Functions Implemented in C
-Version: 0.0.10
-Date: 2021-11-28
+Version: 0.0.11
+Date: 2022-03-19
 Authors@R: c(person("Morgan", "Jacob", role = c("aut", "cre", "cph"), email = "[email protected]"))
 Author: Morgan Jacob [aut, cre, cph]
 Maintainer: Morgan Jacob <[email protected]>

diff --git a/MD5 b/MD5
@@ -1,7 +1,7 @@
 6071edd604dbeb75308cfbedc7790398 *cleanup
 66d4daddd0163539f19e2cb783fc3bb9 *configure
-605e6204374516c0de6e469b20fe6e94 *DESCRIPTION
-076ff1db625e3c31447a692ff9fbd665 *inst/NEWS.Rd
+8f0d23884ad1cce08b347b8ffb408fc6 *DESCRIPTION
+90a9d0d38d3c9bcd9ce3a481c11e68d1 *inst/NEWS.Rd
 a87b0f223435ed35607e8514562b8bfe *LICENSE
 6375b9e30533e0495b98f4b5b829706b *man/charToFact.Rd
 8f19a2c9feb2f352580fd4892650f285 *man/count.Rd
@@ -16,22 +16,22 @@ a137f7855b41b074e2babaf8a1562551 *man/shareData.Rd
 54f91d543a10f8c9aef7082da2b86de7 *man/topn.Rd
 3c628c2a27764ec5df2b4980921c310f *man/vswitch.Rd
 640100c58f36cf06c14aacd7ff7a946a *NAMESPACE
-7d7d1d54ca3f9f17e4141de6c2b1ce34 *R/call.R
+4ee9cafbcfe244008724abc4a9be9d77 *R/call.R
 34ba4d931a5bd0ba120ddef7e5327313 *README.md
 4826023c3ffe528db5e2af5db2a84b5a *src/dup.c
 e86a1960c335e7d534a4683b52d8b70c *src/dupLen.c
 84dc17b4330566e5beb69626ad9d268e *src/fpos.c
 c362509861cd6835c1d8adbb0dce02b4 *src/iif.c
-253a8c2c729dc6e0557dd70cf6e7f530 *src/init.c
-4f0b51d262c28db77550bca462b21ffa *src/kit.h
+d4bb3a264eeb1057c8a6063395518adb *src/init.c
+e863c7a65694fd614f9fb33b0cc9ca25 *src/kit.h
 a52426250b954a335b1121948e057ee7 *src/Makevars.in
 95e3011e37d9dde0d75f3a3819b2acd3 *src/Makevars.win
 8e997b5d5d44af5cea7eafb48a4b9745 *src/nswitch.c
 ab9528d1b24d71ed2080743331b8a012 *src/psort.c
-44018b12fca6cccaabcd0f10deb421e4 *src/psum.c
+e4e5b46734dfaa690cf9f8889a415a8d *src/psum.c
 bafdafd654269acd054525571dbe1b44 *src/share.c
 53711690f6c15f3f36edb4b9360043a4 *src/topn.c
 c0f3fe6fca4e8492277a0d5f87528ce5 *src/utils.c
 3476a1e2381bb86f68a72844ee61bc7b *src/vswitch.c
-336bd08ef00d953278cf64a00a000ac9 *tests/test_kit.R
-f871740ade1b3172748d7b1f63586098 *tests/test_kit.Rout.save
+0b70b926bee3387b548fc0ac0ee48b30 *tests/test_kit.R
+a9113c4b07bf0ce9653b5143d1f159af *tests/test_kit.Rout.save
diff --git a/R/call.R b/R/call.R
@@ -11,7 +11,6 @@ nif         = function(..., default=NULL) .Call(CnifR, default, parent.frame(),
 nswitch     = function(x, ..., default=NULL, nThread=getOption("kit.nThread"), checkEnc = TRUE) .Call(CnswitchR, x, default, nThread, checkEnc, list(...))
 pall        = function(..., na.rm=FALSE) .Call(CpallR, na.rm, if (...length() == 1L && is.list(..1)) ..1 else list(...))
 pany        = function(..., na.rm=FALSE) .Call(CpanyR, na.rm, if (...length() == 1L && is.list(..1)) ..1 else list(...))
-pcount      = function(..., value) .Call(CpcountR, value, list(...))
 pmean       = function(..., na.rm=FALSE) .Call(CpmeanR, na.rm, if (...length() == 1L && is.list(..1)) ..1 else list(...))
 pprod       = function(..., na.rm=FALSE) .Call(CpprodR, na.rm, if (...length() == 1L && is.list(..1)) ..1 else list(...))
 psum        = function(..., na.rm=FALSE) .Call(CpsumR,  na.rm, if (...length() == 1L && is.list(..1)) ..1 else list(...))
@@ -20,10 +19,18 @@ topn        = function(vec, n=6L, decreasing=TRUE, hasna=TRUE,index=TRUE) if(ind
 uniqLen     = function(x) .Call(CdupLenR, x)
 vswitch     = function(x, values, outputs, default=NULL, nThread=getOption("kit.nThread"), checkEnc = TRUE) .Call(CvswitchR, x, values, outputs, default, nThread, checkEnc)
 
-.onAttach   = function(libname, pkgname) packageStartupMessage(paste0("Attaching kit 0.0.10 (OPENMP ",if(.Call(CompEnabledR)) "enabled" else "disabled"," using 1 thread)"))
+.onAttach   = function(libname, pkgname) packageStartupMessage(paste0("Attaching kit 0.0.11 (OPENMP ",if(.Call(CompEnabledR)) "enabled" else "disabled"," using 1 thread)"))
 .onLoad     = function(libname, pkgname) options("kit.nThread"=1L)   #nocov
 .onUnload   = function(libpath) library.dynam.unload("kit", libpath) #nocov
 
+pcount      = function(..., value) {
+  if(is.na(value[1])) {
+    .Call(CpcountNAR, value, if (...length() == 1L && is.list(..1)) ..1 else list(...))
+  } else {
+    .Call(CpcountR, value, if (...length() == 1L && is.list(..1)) ..1 else list(...))
+  }
+}
+
 psort = function(x, decreasing = FALSE, na.last = NA, nThread=getOption("kit.nThread"), c.locale = TRUE) {
   if (typeof(x) == "character") {
     return(.Call(CcpsortR, x, decreasing, nThread, na.last,parent.frame(), FALSE, c.locale))

diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd
@@ -4,6 +4,19 @@
 
 \newcommand{\CRANpkg}{\href{https://CRAN.R-project.org/package=#1}{\pkg{#1}}}
 
+\section{version 0.0.11 (2022-03-19)}{
+  \subsection{New Features}{
+    \itemize{
+      \item Function \code{\strong{pcount}} now supports data.frame.
+    }
+  }
+  \subsection{Bug Fixes}{
+    \itemize{
+      \item Function \code{\strong{pcount}} now works with specific NA values, i.e. NA_real_, NA_character_ etc...
+    }
+  }
+}
+
 \section{version 0.0.10 (2021-11-28)}{
   \subsection{New Features}{
     \itemize{

diff --git a/src/init.c b/src/init.c
@@ -16,6 +16,7 @@ static const R_CallMethodDef CallEntries[] = {
   {"CpanyR",                   (DL_FUNC) &panyR,                   -1},
   {"CpallR",                   (DL_FUNC) &pallR,                   -1},
   {"CpcountR",                 (DL_FUNC) &pcountR,                 -1},
+  {"CpcountNAR",               (DL_FUNC) &pcountNAR,               -1},
   {"CpmeanR",                  (DL_FUNC) &pmeanR,                  -1},
   {"CpprodR",                  (DL_FUNC) &pprodR,                  -1},
   {"CpsumR",                   (DL_FUNC) &psumR,                   -1},
@@ -45,6 +46,7 @@ void R_init_kit(DllInfo *dll) {
   R_RegisterCCallable("kit", "CpanyR",                   (DL_FUNC) &panyR);
   R_RegisterCCallable("kit", "CpallR",                   (DL_FUNC) &pallR);
   R_RegisterCCallable("kit", "CpcountR",                 (DL_FUNC) &pcountR);
+  R_RegisterCCallable("kit", "CpcountNAR",               (DL_FUNC) &pcountNAR);
   R_RegisterCCallable("kit", "CpmeanR",                  (DL_FUNC) &pmeanR);
   R_RegisterCCallable("kit", "CpprodR",                  (DL_FUNC) &pprodR);
   R_RegisterCCallable("kit", "CpsumR",                   (DL_FUNC) &psumR);

diff --git a/src/kit.h b/src/kit.h
@@ -93,6 +93,7 @@ extern SEXP ompEnabledR();
 extern SEXP pallR(SEXP na, SEXP args);
 extern SEXP panyR(SEXP na, SEXP args);
 extern SEXP pcountR(SEXP x, SEXP args);
+extern SEXP pcountNAR(SEXP x, SEXP args);
 extern SEXP pmeanR(SEXP na, SEXP args);
 extern SEXP pprodR(SEXP na, SEXP args);
 extern SEXP psumR(SEXP na, SEXP args);

diff --git a/src/psum.c b/src/psum.c
@@ -678,3 +678,188 @@ SEXP pcountR(SEXP x, SEXP args) {
   UNPROTECT(1);
   return ans;
 }
+
+SEXP pcountNAR(SEXP x, SEXP args) {
+  if (xlength(x) != 1 || isNull(x)) {
+    error("Argument 'value' must be non NULL and length 1.");
+  }
+  const int n=length(args);
+  if (n < 1) {
+    error("Please supply at least 1 argument. (%d argument supplied)", n);
+  }
+  const SEXP args0 = PTR_ETL(args, 0);
+  SEXPTYPE anstype = UTYPEOF(args0);
+  const R_xlen_t len0 = xlength(args0);
+  if (anstype != LGLSXP && anstype != INTSXP && anstype != REALSXP &&
+      anstype != CPLXSXP && anstype != STRSXP) {
+    error("Argument %d is of type %s. Only logical, integer, double, complex and"
+            " character types are supported.", 1, type2char(anstype));
+  }
+  SEXPTYPE tx = UTYPEOF(x);
+  if (anstype != tx) {
+    error("Type of 'value' (%s) is different than type of Argument %d (%s). "
+            "Please make sure both have the same type.", type2char(tx), 1, type2char(anstype));
+  }
+  SEXP classx = PROTECT(getAttrib(x, R_ClassSymbol));
+  if(!R_compute_identical(PROTECT(getAttrib(args0, R_ClassSymbol)), classx, 0)) {
+    error("Class of 'value' is different than class of Argument %d. "
+            "Please make sure both have the same class.", 1);
+  }
+  UNPROTECT(1);
+  int nprotect = 0;
+  const bool xf = isFactor(x);
+  SEXP levelsx;
+  if (xf) {
+    levelsx = PROTECT(getAttrib(x, R_LevelsSymbol)); nprotect++;
+    if (!R_compute_identical(levelsx, PROTECT(getAttrib(args0, R_LevelsSymbol)), 0)) {
+      error("Levels of 'value' are different than levels of Argument %d. "
+              "Please make sure both have the same levels.", 1);
+    }
+    UNPROTECT(1);
+  }
+  for (int i = 1; i < n; ++i) {
+    SEXPTYPE type = UTYPEOF(PTR_ETL(args, i));
+    R_xlen_t len1 = xlength(PTR_ETL(args, i));
+    if (type != anstype) {
+      error("Type of argument %d is %s but argument %d is of type %s. "
+              "Please make sure both have the same type.", i+1,
+              type2char(type), 1, type2char(anstype));
+    }
+    if(!R_compute_identical(PROTECT(getAttrib(PTR_ETL(args, i), R_ClassSymbol)), classx, 0)) {
+      error("Class of 'value' is different than class of Argument %d. "
+              "Please make sure both have the same class.", i+1);
+    }
+    UNPROTECT(1);
+    if (xf) {
+      if (!R_compute_identical(levelsx, PROTECT(getAttrib(PTR_ETL(args, i), R_LevelsSymbol)), 0)) {
+        error("Levels of 'value' are different than levels of Argument %d. "
+                "Please make sure both have the same levels.", i + 1);
+      }
+      UNPROTECT(1);
+    }
+    if (len1 != len0) {
+      error("Argument %d is of length %zu but argument %d is of length %zu. "
+              "If you wish to 'recycle' your argument, please use rep() to make this intent "
+              "clear to the readers of your code.", i+1, len1, 1, len0);
+    }
+  }
+  UNPROTECT(1 + nprotect);
+  SEXP ans;
+  if (len0 > INT_MAX) {
+    ans = PROTECT(allocVector(REALSXP, len0)); // # nocov start
+    double *restrict pans = REAL(ans);
+    memset(pans, 0, (unsigned)len0*sizeof(double));
+    switch(anstype) {
+    case LGLSXP: {
+      for (int i = 0; i < n; ++i) {
+        int *pa = LOGICAL(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (pa[j] == NA_LOGICAL) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case INTSXP: {
+      for (int i = 0; i < n; ++i) {
+        int *pa = INTEGER(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (pa[j] == NA_INTEGER) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case REALSXP: {
+      for (int i = 0; i < n; ++i) {
+        double *pa = REAL(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (ISNAN(pa[j])) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case CPLXSXP: {
+      for (int i = 0; i < n; ++i) {
+        Rcomplex *pa = COMPLEX(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (ISNAN_COMPLEX(pa[j])) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case STRSXP: {
+      for (int i = 0; i < n; ++i) {
+        const SEXP pa = PTR_ETL(args, i);
+        const SEXP *restrict px = STRING_PTR(pa);
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (px[j] == NA_STRING) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    } // # nocov end
+  } else {
+    ans = PROTECT(allocVector(INTSXP, len0));
+    int *restrict pans = INTEGER(ans);
+    memset(pans, 0, (unsigned)len0*sizeof(int));
+    switch(anstype) {
+    case LGLSXP: {
+      for (int i = 0; i < n; ++i) {
+        int *pa = LOGICAL(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (pa[j] == NA_LOGICAL) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case INTSXP: {
+      for (int i = 0; i < n; ++i) {
+        int *pa = INTEGER(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (pa[j] == NA_INTEGER) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case REALSXP: {
+      for (int i = 0; i < n; ++i) {
+        double *pa = REAL(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (ISNAN(pa[j])) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case CPLXSXP: {
+      for (int i = 0; i < n; ++i) {
+        Rcomplex *pa = COMPLEX(PTR_ETL(args, i));
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (ISNAN_COMPLEX(pa[j])) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    case STRSXP: {
+      for (int i = 0; i < n; ++i) {
+        const SEXP pa = PTR_ETL(args, i);
+        const SEXP *restrict px = STRING_PTR(pa);
+        for (ssize_t j = 0; j < len0; ++j) {
+          if (px[j] == NA_STRING) {
+            pans[j]++;
+          }
+        }
+      }
+    } break;
+    }
+  }
+  UNPROTECT(1);
+  return ans;
+}
diff --git a/tests/test_kit.R b/tests/test_kit.R
@@ -1184,8 +1184,8 @@ check("0014.002", pcount(as.integer(x), value = 3L), sapply(1:4, function(i) cou
 check("0014.003", pcount(as.character(x), value = "3"), sapply(1:4, function(i) count(as.character(x[i]), "3")))
 check("0014.004", pcount(as.complex(x), value = 3+0i), sapply(1:4, function(i) count(as.complex(x[i]), 3+0i)))
 check("0014.005", pcount(as.logical(x), value = TRUE), sapply(1:4, function(i) count(as.logical(x[i]), TRUE)))
-check("0014.006", pcount(as.logical(x), value = NULL), error = "Argument 'value' must be non NULL and length 1.")
-check("0014.007", pcount(as.logical(x), value = c(TRUE,FALSE)), error = "Argument 'value' must be non NULL and length 1.")
+check("0014.006", pcount(as.logical(x), value = NULL), error = "argument is of length zero")
+check("0014.007", pcount(x, value = NA_real_), c(0L,0L,1L,0L))
 check("0014.008", pcount(value = TRUE), error = "Please supply at least 1 argument. (0 argument supplied)")
 check("0014.009", pcount(x,y,z,value = 3), c(1L,1L,0L,0L))
 check("0014.010", pcount(x,y,z,value = 4), c(0L,1L,2L,0L))

diff --git a/tests/test_kit.Rout.save b/tests/test_kit.Rout.save
@@ -53,7 +53,7 @@ Type 'q()' to quit R.
 + }
 > 
 > library(kit); unloadNamespace("kit")
-Attaching kit 0.0.10 (OPENMP enabled using 1 thread)
+Attaching kit 0.0.11 (OPENMP enabled using 1 thread)
 > 
 > topn        = kit::topn
 > setlevels   = kit::setlevels
@@ -1204,8 +1204,8 @@ Attaching kit 0.0.10 (OPENMP enabled using 1 thread)
 > check("0014.003", pcount(as.character(x), value = "3"), sapply(1:4, function(i) count(as.character(x[i]), "3")))
 > check("0014.004", pcount(as.complex(x), value = 3+0i), sapply(1:4, function(i) count(as.complex(x[i]), 3+0i)))
 > check("0014.005", pcount(as.logical(x), value = TRUE), sapply(1:4, function(i) count(as.logical(x[i]), TRUE)))
-> check("0014.006", pcount(as.logical(x), value = NULL), error = "Argument 'value' must be non NULL and length 1.")
-> check("0014.007", pcount(as.logical(x), value = c(TRUE,FALSE)), error = "Argument 'value' must be non NULL and length 1.")
+> check("0014.006", pcount(as.logical(x), value = NULL), error = "argument is of length zero")
+> check("0014.007", pcount(x, value = NA_real_), c(0L,0L,1L,0L))
 > check("0014.008", pcount(value = TRUE), error = "Please supply at least 1 argument. (0 argument supplied)")
 > check("0014.009", pcount(x,y,z,value = 3), c(1L,1L,0L,0L))
 > check("0014.010", pcount(x,y,z,value = 4), c(0L,1L,2L,0L))