Fix+Feat

2005m · Sep 25, 2021 · 0333c57 · 0333c57
1 parent 4354338
commit 0333c57
Show file tree

Hide file tree

Showing 7 changed files with 57 additions and 24 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: kit
 Type: Package
 Title: Data Manipulation Functions Implemented in C
-Version: 0.0.9
+Version: 0.0.10
 Date: 2021-09-12
 Authors@R: c(person("Morgan", "Jacob", role = c("aut", "cre", "cph"), email = "[email protected]"))
 Author: Morgan Jacob [aut, cre, cph]

diff --git a/MD5 b/MD5
@@ -1,7 +1,7 @@
 6071edd604dbeb75308cfbedc7790398 *cleanup
 66d4daddd0163539f19e2cb783fc3bb9 *configure
-032f497563062c67c360f2cbbabad526 *DESCRIPTION
-5c267ba48bdd845348c286ec3b08f5c1 *inst/NEWS.Rd
+8ff1b02f18a64c7d6b963beddf1191cf *DESCRIPTION
+214838f2ee26d214e4f364864f7bed44 *inst/NEWS.Rd
 a87b0f223435ed35607e8514562b8bfe *LICENSE
 6375b9e30533e0495b98f4b5b829706b *man/charToFact.Rd
 8f19a2c9feb2f352580fd4892650f285 *man/count.Rd
@@ -16,7 +16,7 @@ a137f7855b41b074e2babaf8a1562551 *man/shareData.Rd
 54f91d543a10f8c9aef7082da2b86de7 *man/topn.Rd
 3c628c2a27764ec5df2b4980921c310f *man/vswitch.Rd
 640100c58f36cf06c14aacd7ff7a946a *NAMESPACE
-a93eb67d15da2c12dde6b9a6de93e10b *R/call.R
+7d7d1d54ca3f9f17e4141de6c2b1ce34 *R/call.R
 34ba4d931a5bd0ba120ddef7e5327313 *README.md
 4826023c3ffe528db5e2af5db2a84b5a *src/dup.c
 e86a1960c335e7d534a4683b52d8b70c *src/dupLen.c
@@ -30,8 +30,8 @@ a52426250b954a335b1121948e057ee7 *src/Makevars.in
 ab9528d1b24d71ed2080743331b8a012 *src/psort.c
 44018b12fca6cccaabcd0f10deb421e4 *src/psum.c
 bafdafd654269acd054525571dbe1b44 *src/share.c
-e998e820fea6aa677e78a8cb1f7ba74c *src/topn.c
+53711690f6c15f3f36edb4b9360043a4 *src/topn.c
 c0f3fe6fca4e8492277a0d5f87528ce5 *src/utils.c
 3476a1e2381bb86f68a72844ee61bc7b *src/vswitch.c
-010429797d86eda96db95a459823d629 *tests/test_kit.R
-cb2f4f0290154a7a8525b3bfb3a812e3 *tests/test_kit.Rout.save
+336bd08ef00d953278cf64a00a000ac9 *tests/test_kit.R
+f871740ade1b3172748d7b1f63586098 *tests/test_kit.Rout.save
diff --git a/R/call.R b/R/call.R
@@ -9,18 +9,18 @@ funique     = function(x, fromLast = FALSE) .Call(CdupR, x, TRUE, fromLast)
 iif         = function(test, yes, no, na=NULL, tprom=FALSE, nThread=getOption("kit.nThread")) .Call(CiifR, test, yes, no, na, tprom, nThread)
 nif         = function(..., default=NULL) .Call(CnifR, default, parent.frame(), as.list(substitute(...())))
 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(a <- list(...)) == 1 && is.data.frame(a[[1]])) a[[1]] else a)
-pany        = function(..., na.rm=FALSE) .Call(CpanyR, na.rm, if (length(a <- list(...)) == 1 && is.data.frame(a[[1]])) a[[1]] else a)
+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(a <- list(...)) == 1 && is.data.frame(a[[1]])) a[[1]] else a)
-pprod       = function(..., na.rm=FALSE) .Call(CpprodR, na.rm, if (length(a <- list(...)) == 1 && is.data.frame(a[[1]])) a[[1]] else a)
-psum        = function(..., na.rm=FALSE) .Call(CpsumR,  na.rm, if (length(a <- list(...)) == 1 && is.data.frame(a[[1]])) a[[1]] else a)
+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(...))
 setlevels   = function(x, old = levels(x), new, skip_absent=FALSE) invisible(.Call(CsetlevelsR, x, old, new, skip_absent))
 topn        = function(vec, n=6L, decreasing=TRUE, hasna=TRUE,index=TRUE) if(index) .Call(CtopnR, vec, n, decreasing, hasna, parent.frame()) else vec[.Call(CtopnR, vec, n, decreasing, hasna, parent.frame())]
 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.9 (OPENMP ",if(.Call(CompEnabledR)) "enabled" else "disabled"," using 1 thread)"))
+.onAttach   = function(libname, pkgname) packageStartupMessage(paste0("Attaching kit 0.0.10 (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
 

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.10 (2021-09-25)}{
+  \subsection{New Features}{
+    \itemize{
+      \item Function \code{\strong{psum}}, \code{\strong{pmean}}, \code{\strong{pprod}}, \code{\strong{pany}} and \code{\strong{pall}} now support lists. Thanks to Sebastian Krantz for the request and code suggestion.
+    }
+  }
+  \subsection{Bug Fixes}{
+    \itemize{
+      \item Function \code{\strong{topn}} should now work for ALTREP object. Thanks to @ben-schwen for raising an issue.
+    }
+  }
+}
+
 \section{version 0.0.9 (2021-09-12)}{
   \subsection{Notes}{
     \itemize{

diff --git a/src/topn.c b/src/topn.c
@@ -41,9 +41,17 @@ SEXP topnR(SEXP vec, SEXP n, SEXP dec, SEXP hasna, SEXP env) {
   const SEXPTYPE tvec = UTYPEOF(vec);
   const Rboolean vhasna = asLogical(hasna);
   if ( ((len0 > 2000 && vhasna == FALSE) || (len0 > 1500 && vhasna == TRUE)) && (tvec == INTSXP || tvec == REALSXP)) {
-    SEXP ans = PROTECT(callToOrder(vec, "radix", dcr, TRUE, env));
-    SETLENGTH(ans, len0);
-    UNPROTECT(1);
+    SEXP prem = PROTECT(callToOrder(vec, "radix", dcr, TRUE, env));
+    SEXP ans = PROTECT(allocVector(UTYPEOF(prem), len0));
+    switch(UTYPEOF(prem)) {
+    case INTSXP: {
+      memcpy(INTEGER(ans), INTEGER(prem), len0 *sizeof(int));
+    } break;
+    case REALSXP: {
+      memcpy(REAL(ans), REAL(prem), len0 *sizeof(double));
+    } break;
+    }
+    UNPROTECT(2);
     return ans;
   }
   SEXP ans = PROTECT(allocVector(INTSXP, len0));

diff --git a/tests/test_kit.R b/tests/test_kit.R
@@ -73,6 +73,7 @@ x5 = sample(c(1:1000),3e3,TRUE)
 x6 = sample(as.numeric(c(1:1000)),1e3,TRUE)
 class2134 = setClass("class2134", slots=list(x="numeric"))
 s1 = class2134(x=20191231)
+x7 = seq.int(1e4)
 
 check("0001.001", topn(x0, 1L, decreasing=FALSE), order(x0)[1:1])
 check("0001.002", topn(x0, 2L, decreasing=FALSE), order(x0)[1:2])
@@ -202,8 +203,10 @@ check("0001.126", topn(x4, 2L, decreasing = TRUE,hasna = FALSE), error = "Type r
 check("0001.127", topn(x4, 2L, decreasing=FALSE,hasna = FALSE), error = "Type raw is not supported.")
 check("0001.128", topn(c(1,2,4,10,2,3), 2L, hasna=c(FALSE,TRUE)), error = "Argument 'hasna' must be TRUE or FALSE and length 1.")
 check("0001.129", topn(x5, 2001L,decreasing = FALSE), order(x5, decreasing=FALSE)[1:2001])
+check("0001.130", topn(x7,1e4,decreasing=FALSE), order(x7, decreasing=FALSE))
+check("0001.131", topn(as.numeric(x7),1e4,decreasing=FALSE), order(as.numeric(x7), decreasing=FALSE))
 
-rm(s1, class2134, x0, x1, x2, x3, x4, x5, x6)
+rm(s1, class2134, x0, x1, x2, x3, x4, x5, x6, x7)
 
 # --------------------------------------------------------------------------------------------------
 #                                   iif 
@@ -703,6 +706,7 @@ check("0005.025", psum(NA_complex_, na.rm = TRUE), 0+0i)
 check("0005.026", psum(iris[,1:2]), rowSums(iris[,1:2]))
 check("0005.027", psum(iris[,1:2],iris[,1:2]), error = "Argument 1 is of type list. Only integer, double and complex types are supported.Data.frame (of the previous types) is also supported as a single input.")
 check("0005.028", psum(1:150,iris$Species, na.rm = FALSE), error="Function 'psum' is not meaningful for factors.")
+check("0005.029", psum(unclass(mtcars)),psum(mtcars))
 
 # --------------------------------------------------------------------------------------------------
 #                                   pprod 
@@ -735,7 +739,8 @@ check("0006.024", pprod(NA_real_, na.rm = TRUE), 1)
 check("0006.025", pprod(NA_complex_, na.rm = TRUE), 1+0i)
 check("0006.026", pprod(iris[,1:2]), iris$Sepal.Length*iris$Sepal.Width)
 check("0006.027", pprod(iris[,1:2],iris[,1:2]), error = "Argument 1 is of type list. Only integer, double and complex types are supported.Data.frame (of the previous types) is also supported as a single input.")
-check("0005.028", pprod(1:150,iris$Species, na.rm = FALSE), error="Function 'pprod' is not meaningful for factors.")
+check("0006.028", pprod(1:150,iris$Species, na.rm = FALSE), error="Function 'pprod' is not meaningful for factors.")
+check("0006.029", pprod(unclass(mtcars)),pprod(mtcars))
 
 rm(x, y, z, x0, y0, z0)
 
@@ -1113,7 +1118,8 @@ check("0011.022", pmean(x1, y1, z1, na.rm = TRUE), sapply(1:100, function(i) mea
 check("0011.023", pmean(NA_integer_, na.rm = TRUE), mean(NA_integer_,na.rm = TRUE))
 check("0011.024", pmean(NA_real_, na.rm = TRUE), mean(NA_real_,na.rm = TRUE))
 check("0011.025", pmean(data.frame(x,y,z), na.rm = TRUE), pmean(x,y,z,na.rm = TRUE))
-check("0005.026", pmean(1:150,iris$Species, na.rm = FALSE), error="Function 'pmean' is not meaningful for factors.")
+check("0011.026", pmean(1:150,iris$Species, na.rm = FALSE), error="Function 'pmean' is not meaningful for factors.")
+check("0011.027", pmean(unclass(mtcars)),pmean(mtcars))
 
 rm(x, y, z, x0, y0, z0, x1, y1, z1)
 

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.9 (OPENMP enabled using 1 thread)
+Attaching kit 0.0.10 (OPENMP enabled using 1 thread)
 > 
 > topn        = kit::topn
 > setlevels   = kit::setlevels
@@ -93,6 +93,7 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > x6 = sample(as.numeric(c(1:1000)),1e3,TRUE)
 > class2134 = setClass("class2134", slots=list(x="numeric"))
 > s1 = class2134(x=20191231)
+> x7 = seq.int(1e4)
 > 
 > check("0001.001", topn(x0, 1L, decreasing=FALSE), order(x0)[1:1])
 > check("0001.002", topn(x0, 2L, decreasing=FALSE), order(x0)[1:2])
@@ -222,8 +223,10 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > check("0001.127", topn(x4, 2L, decreasing=FALSE,hasna = FALSE), error = "Type raw is not supported.")
 > check("0001.128", topn(c(1,2,4,10,2,3), 2L, hasna=c(FALSE,TRUE)), error = "Argument 'hasna' must be TRUE or FALSE and length 1.")
 > check("0001.129", topn(x5, 2001L,decreasing = FALSE), order(x5, decreasing=FALSE)[1:2001])
+> check("0001.130", topn(x7,1e4,decreasing=FALSE), order(x7, decreasing=FALSE))
+> check("0001.131", topn(as.numeric(x7),1e4,decreasing=FALSE), order(as.numeric(x7), decreasing=FALSE))
 > 
-> rm(s1, class2134, x0, x1, x2, x3, x4, x5, x6)
+> rm(s1, class2134, x0, x1, x2, x3, x4, x5, x6, x7)
 > 
 > # --------------------------------------------------------------------------------------------------
 > #                                   iif 
@@ -723,6 +726,7 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > check("0005.026", psum(iris[,1:2]), rowSums(iris[,1:2]))
 > check("0005.027", psum(iris[,1:2],iris[,1:2]), error = "Argument 1 is of type list. Only integer, double and complex types are supported.Data.frame (of the previous types) is also supported as a single input.")
 > check("0005.028", psum(1:150,iris$Species, na.rm = FALSE), error="Function 'psum' is not meaningful for factors.")
+> check("0005.029", psum(unclass(mtcars)),psum(mtcars))
 > 
 > # --------------------------------------------------------------------------------------------------
 > #                                   pprod 
@@ -755,7 +759,8 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > check("0006.025", pprod(NA_complex_, na.rm = TRUE), 1+0i)
 > check("0006.026", pprod(iris[,1:2]), iris$Sepal.Length*iris$Sepal.Width)
 > check("0006.027", pprod(iris[,1:2],iris[,1:2]), error = "Argument 1 is of type list. Only integer, double and complex types are supported.Data.frame (of the previous types) is also supported as a single input.")
-> check("0005.028", pprod(1:150,iris$Species, na.rm = FALSE), error="Function 'pprod' is not meaningful for factors.")
+> check("0006.028", pprod(1:150,iris$Species, na.rm = FALSE), error="Function 'pprod' is not meaningful for factors.")
+> check("0006.029", pprod(unclass(mtcars)),pprod(mtcars))
 > 
 > rm(x, y, z, x0, y0, z0)
 > 
@@ -1133,7 +1138,8 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > check("0011.023", pmean(NA_integer_, na.rm = TRUE), mean(NA_integer_,na.rm = TRUE))
 > check("0011.024", pmean(NA_real_, na.rm = TRUE), mean(NA_real_,na.rm = TRUE))
 > check("0011.025", pmean(data.frame(x,y,z), na.rm = TRUE), pmean(x,y,z,na.rm = TRUE))
-> check("0005.026", pmean(1:150,iris$Species, na.rm = FALSE), error="Function 'pmean' is not meaningful for factors.")
+> check("0011.026", pmean(1:150,iris$Species, na.rm = FALSE), error="Function 'pmean' is not meaningful for factors.")
+> check("0011.027", pmean(unclass(mtcars)),pmean(mtcars))
 > 
 > rm(x, y, z, x0, y0, z0, x1, y1, z1)
 > 
@@ -1696,4 +1702,4 @@ Attaching kit 0.0.9 (OPENMP enabled using 1 thread)
 > 
 > proc.time()
    user  system elapsed 
-  4.169   0.504   4.671 
+  4.251   0.614   4.957