Merge pull request #177 from SebKrantz/development

Development

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: collapse
 Title: Advanced and Fast Data Transformation
-Version: 1.6.4
-Date: 2021-07-09
+Version: 1.6.5
+Date: 2021-07-24
 Authors@R: c(
            person("Sebastian", "Krantz", role = c("aut", "cre"), 
                   email = "sebastian.krantz@graduateinstitute.ch"),
@@ -55,8 +55,8 @@ LazyData: true
 Depends: R (>= 2.10)
 Imports: Rcpp (>= 1.0.1)
 LinkingTo: Rcpp
-Suggests: plm, data.table, sf, matrixStats, magrittr, fixest, lfe, vars, weights, kit, 
-          RcppArmadillo, RcppEigen, dplyr, ggplot2, scales, microbenchmark, testthat, covr, knitr, rmarkdown
+Suggests: data.table, sf, matrixStats, magrittr, kit, plm, fixest, vars, weights, RcppArmadillo, 
+          RcppEigen, dplyr, ggplot2, scales, microbenchmark, testthat, covr, knitr, rmarkdown
 SystemRequirements: C++11
 VignetteBuilder: knitr
 

NEWS.md

@@ -1,8 +1,11 @@
+# collapse 1.6.5
+* Use of `VECTOR_PTR` in C API now gives an error on R-devel even if `USE_RINTERNALS` is defined. Thus this patch gets rid of all remaining usage of this macro to avoid errors on CRAN checks using the development version of R. 
+
+* The print method for `qsu` now uses an apostrophe (') to designate million digits, instead of a comma (,). This is to avoid confusion with the decimal point, and the typical use of (,) for thousands (which I don't like). 
+
 # collapse 1.6.4
 Checks on the gcc11 compiler flagged an additional issue with a pointer pointing to element -1 of a C array (which I had done on purpose to index it with an R integer vector). 
 
-Please note that nothing added in 1.6.1-1.6.4 affects in any way the operation of the package (except for the functions added in 1.6.1). This is just pleasing CRAN's strict conventions on how C code should be written.
-
 # collapse 1.6.3
 CRAN checks flagged a valgrind issue because of comparing an uninitialized value to something. 
 

R/GRP.R

@@ -72,8 +72,8 @@ GRP.default <- function(X, by = NULL, sort = TRUE, decreasing = FALSE, na.last =
 
   if(return.groups) {
       ust <- if(sorted) st else o[st]
-      groups <- if(is.list(X)) .Call(C_subsetDT, X, ust, by) else
-        `names<-`(list(.Call(C_subsetVector, X, ust)), namby) # subsetVector preserves attributes (such as "label")
+      groups <- if(is.list(X)) .Call(C_subsetDT, X, ust, by, FALSE) else
+        `names<-`(list(.Call(C_subsetVector, X, ust, FALSE)), namby) # subsetVector preserves attributes (such as "label")
   } else groups <- NULL
 
   return(`oldClass<-`(list(N.groups = length(st),
@@ -421,10 +421,9 @@ GRP.grouped_df <- function(X, ..., return.groups = TRUE, call = TRUE) {
 is_qG <- function(x) inherits(x, "qG")
 is.qG <- is_qG
 
-# TODO: fix na_rm speed for character data...
 na_rm2 <- function(x, sort) {
   if(sort) return(if(is.na(x[length(x)])) x[-length(x)] else x)
-  if(anyNA(x)) x[!is.na(x)] else x # use na_rm here when speed fixed.. (get rid of anyNA then ...)
+  na_rm(x) # if(anyNA(x)) x[!is.na(x)] else x # use na_rm here when speed fixed..
 }
 
 # What about NA last option to radixsort ? -> Nah, vector o becomes too short...
@@ -437,20 +436,18 @@ radixfact <- function(x, sort, ord, fact, naincl, keep, retgrp = FALSE) {
   if(fact) {
     if(keep) duplattributes(f, x) else attributes(f) <- NULL
     if(naincl) {
-      attr(f, "levels") <- if(attr(o, "sorted")) unattrib(tochar(.Call(C_subsetVector, x, st))) else
-            unattrib(tochar(.Call(C_subsetVector, x, o[st]))) # use C_subsetvector ?
+      attr(f, "levels") <- unattrib(tochar(.Call(C_subsetVector, x, if(attr(o, "sorted")) st else o[st], FALSE)))
     } else {
-      attr(f, "levels") <- if(attr(o, "sorted")) unattrib(tochar(na_rm2(.Call(C_subsetVector, x, st), sort))) else
-            unattrib(tochar(na_rm2(.Call(C_subsetVector, x, o[st]), sort)))
+      attr(f, "levels") <- unattrib(tochar(na_rm2(.Call(C_subsetVector, x, if(attr(o, "sorted")) st else o[st], FALSE), sort)))
     }
     oldClass(f) <- c(if(ord) "ordered", "factor", if(naincl) "na.included")
   } else {
     if(naincl) attr(f, "N.groups") <- length(st) # the order is important, this before retgrp !!
     if(retgrp) {
       if(naincl) {
-         attr(f, "groups") <- if(attr(o, "sorted")) .Call(C_subsetVector, x, st) else .Call(C_subsetVector, x, o[st])
+         attr(f, "groups") <- .Call(C_subsetVector, x, if(attr(o, "sorted")) st else o[st], FALSE)
       } else {
-         attr(f, "groups") <- if(attr(o, "sorted")) na_rm2(.Call(C_subsetVector, x, st), sort) else na_rm2(.Call(C_subsetVector, x, o[st]), sort)
+         attr(f, "groups") <- na_rm2(.Call(C_subsetVector, x, if(attr(o, "sorted")) st else o[st], FALSE), sort)
       }
     }
     oldClass(f) <- c(if(ord) "ordered", "qG", if(naincl) "na.included")
@@ -543,8 +540,7 @@ qG <- function(x, ordered = FALSE, na.exclude = TRUE, sort = TRUE, return.groups
 radixuniquevec <- function(x, sort, na.last = TRUE, decreasing = FALSE) {
   o <- .Call(C_radixsort, na.last, decreasing, TRUE, FALSE, sort, pairlist(x))
   if(attr(o, "maxgrpn") == 1L && (!sort || attr(o, "sorted"))) return(x)
-  if(attr(o, "sorted")) .Call(C_subsetVector, x, attr(o, "starts")) else
-    .Call(C_subsetVector, x, o[attr(o, "starts")])
+  .Call(C_subsetVector, x, if(attr(o, "sorted")) attr(o, "starts") else o[attr(o, "starts")], FALSE)
 }
 
 funique <- function(x, ...) UseMethod("funique")
@@ -569,8 +565,8 @@ funique.data.frame <- function(x, cols = NULL, sort = FALSE, ...) {
      return(if(inherits(x, "data.table")) alc(x) else x)
   st <- if(attr(o, "sorted")) attr(o, "starts") else o[attr(o, "starts")]
   rn <- attr(x, "row.names")
-  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, st, seq_along(unclass(x))))
-  return(`attr<-`(.Call(C_subsetDT, x, st, seq_along(unclass(x))), "row.names", rn[st]))
+  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, st, seq_along(unclass(x)), FALSE))
+  return(`attr<-`(.Call(C_subsetDT, x, st, seq_along(unclass(x)), FALSE), "row.names", rn[st]))
 }
 
 funique.list <- function(x, cols = NULL, sort = FALSE, ...) funique.data.frame(x, cols, sort, ...)
@@ -582,8 +578,8 @@ funique.sf <- function(x, cols = NULL, sort = FALSE, ...) {
   if(attr(o, "maxgrpn") == 1L && (!sort || attr(o, "sorted"))) return(x)
   st <- if(attr(o, "sorted")) attr(o, "starts") else o[attr(o, "starts")]
   rn <- attr(x, "row.names")
-  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, st, seq_along(unclass(x))))
-  return(`attr<-`(.Call(C_subsetDT, x, st, seq_along(unclass(x))), "row.names", rn[st]))
+  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, st, seq_along(unclass(x)), FALSE))
+  return(`attr<-`(.Call(C_subsetDT, x, st, seq_along(unclass(x)), FALSE), "row.names", rn[st]))
 }
 
 fdroplevels <- function(x, ...) UseMethod("fdroplevels")

R/fHDbetween_fHDwithin.R

@@ -166,22 +166,22 @@ getfl <- function(mf) {
 subsetfl <- function(fl, cc) {
   slopes <- attr(fl, "slope.vars") # fl could be a data.frame, slope vars not (getfl() unclasses)
   if(is.null(names(fl))) names(fl) <- seq_along(unclass(fl))
-  if(is.null(slopes)) return(.Call(C_subsetDT, fl, cc, seq_along(unclass(fl))))
+  if(is.null(slopes)) return(.Call(C_subsetDT, fl, cc, seq_along(unclass(fl)), FALSE))
   attr(fl, "slope.vars") <- NULL
   if(is.null(names(slopes))) names(slopes) <- seq_along(slopes)
-  res <- .Call(C_subsetDT, fl, cc, seq_along(fl))
-  attr(res, "slope.vars") <- .Call(C_subsetDT, slopes, cc, seq_along(slopes)) # fdroplevels ??
+  res <- .Call(C_subsetDT, fl, cc, seq_along(fl), FALSE)
+  attr(res, "slope.vars") <- .Call(C_subsetDT, slopes, cc, seq_along(slopes), FALSE) # fdroplevels ??
   res
 }
 
 # Old version:
 # subsetfl <- function(fl, cc) {
 #   lapply(fl, function(f) { # use CsubsetDT or CsubsetVector ?? also check NA in regressors ??
 #     x <- attr(f, "x")
-#     if(is.null(x)) return(.Call(C_subsetVector, f, cc)) else
-#       return(`attr<-`(.Call(C_subsetVector, f, cc), "x",
+#     if(is.null(x)) return(.Call(C_subsetVector, f, cc, FALSE)) else
+#       return(`attr<-`(.Call(C_subsetVector, f, cc, FALSE), "x",
 #                       if(is.matrix(x)) x[cc, , drop = FALSE] else
-#                         .Call(C_subsetVector, x, cc)))
+#                         .Call(C_subsetVector, x, cc, FALSE)))
 #   })
 # }
 
@@ -332,7 +332,7 @@ fhdwithin.pseries <- function(x, effect = seq_col(attr(x, "index")), w = NULL, n
   effect <- cols2int(effect, ix, namix)
   g <- .subset(ix, effect)
   if(na.rm && length(cc <- which(!is.na(x))) != length(x)) {
-     g <- .Call(C_subsetDT, g, cc, seq_along(g)) # lapply(g, `[`, cc) -> slower !
+     g <- .Call(C_subsetDT, g, cc, seq_along(g), FALSE) # lapply(g, `[`, cc) -> slower !
     if(fill) {
       x[cc] <- demean(.subset(`names<-`(x, NULL), cc), g, w[cc], ...) # keeps attributes ?? -> Yes !!
       return(x)
@@ -341,7 +341,7 @@ fhdwithin.pseries <- function(x, effect = seq_col(attr(x, "index")), w = NULL, n
     nix <- length(unclass(ix))
     if(nix != length(g)) {
       toss <- seq_len(nix)[-effect]
-      reix <- copyMostAttributes(c(.Call(C_subsetDT, ix, cc, toss), g)[namix], ix)
+      reix <- copyMostAttributes(c(.Call(C_subsetDT, ix, cc, toss, FALSE), g)[namix], ix)
     } else reix <- copyMostAttributes(g, ix)
     attr(reix, "row.names") <- .set_row_names(length(cc))
     return(setAttributes(demean(xcc, g, w[cc], ...),
@@ -425,8 +425,8 @@ fhdwithin.pdata.frame <- function(x, effect = seq_col(attr(x, "index")), w = NUL
     return(setAttributes(varwisecomp(x, g, w, ...), ax))
   } else if(na.rm && any(miss <- .Call(C_dt_na, x, seq_along(unclass(x))))) {
     cc <- which(!miss)
-    gcc <- .Call(C_subsetDT, g, cc, seq_along(g))
-    Y <- demean(.Call(C_subsetDT, x, cc, seq_along(unclass(x))), gcc, w[cc], ...)
+    gcc <- .Call(C_subsetDT, g, cc, seq_along(g), FALSE)
+    Y <- demean(.Call(C_subsetDT, x, cc, seq_along(unclass(x)), FALSE), gcc, w[cc], ...)
     if(fill) {
       ax <- attributes(x)
       ax[["na.rm"]] <- which(miss)
@@ -436,7 +436,7 @@ fhdwithin.pdata.frame <- function(x, effect = seq_col(attr(x, "index")), w = NUL
     nix <- length(unclass(ix))
     if(nix != length(g)) {
       toss <- seq_len(nix)[-effect]
-      reix <- copyMostAttributes(c(.Call(C_subsetDT, ix, cc, toss), gcc)[namix], ix)
+      reix <- copyMostAttributes(c(.Call(C_subsetDT, ix, cc, toss, FALSE), gcc)[namix], ix)
     } else reix <- copyMostAttributes(gcc, ix)
     attr(reix, "row.names") <- .set_row_names(length(cc))
     attr(Y, "index") <- reix
@@ -457,7 +457,7 @@ fhdwithin.data.frame <- function(x, fl, w = NULL, na.rm = TRUE, fill = FALSE, va
       w <- w[cc]
       if(!variable.wise) {
         if(fill) nrx <- fnrow2(x) else ax[["row.names"]] <- ax[["row.names"]][cc] # best ??
-        x <- .Call(C_subsetDT, x, cc, seq_along(unclass(x)))
+        x <- .Call(C_subsetDT, x, cc, seq_along(unclass(x)), FALSE)
       }
     } else na.rm <- FALSE
   }
@@ -558,7 +558,7 @@ HDW.data.frame <- function(x, fl, w = NULL, cols = is.numeric, na.rm = TRUE, fil
     }
 
     xmat <- NULL
-    list2env(getfl(myModFrame(fl, if(na.rm) .Call(C_subsetDT, x, cc, fvars) else .subset(x, fvars))), envir = environment())
+    list2env(getfl(myModFrame(fl, if(na.rm) .Call(C_subsetDT, x, cc, fvars, FALSE) else .subset(x, fvars))), envir = environment())
     fcl <- !is.null(fl)
     nallfc <- fcl && !is.null(xmat)
     if(nallfc) xmat <- demean(xmat, fl, w, ...)
@@ -583,7 +583,7 @@ HDW.data.frame <- function(x, fl, w = NULL, cols = is.numeric, na.rm = TRUE, fil
         return(y)
       }), ax))
     } else { # at this point missing values are already removed from  fl !!
-      Y <- if(na.rm) .Call(C_subsetDT, x, cc, Xvars) else .subset(x, Xvars)
+      Y <- if(na.rm) .Call(C_subsetDT, x, cc, Xvars, FALSE) else .subset(x, Xvars)
       Y <- if(nallfc || !fcl) flmres(if(nallfc) demean(Y, fl, w, ...) else Y, xmat, w, lm.method, ...) else demean(Y, fl, w, ...)
       if(na.rm && fill)  # x[cc, ] <- Y; x[-cc, ] <- NA
         return(setAttributes(.Call(C_lassign, Y, nrx, cc, NA_real_), ax))
@@ -751,7 +751,7 @@ fhdbetween.data.frame <- function(x, fl, w = NULL, na.rm = TRUE, fill = FALSE, v
       w <- w[cc]
       if(!variable.wise) {
         if(fill) nrx <- fnrow2(x) else ax[["row.names"]] <- ax[["row.names"]][cc] # best ??
-        x <- .Call(C_subsetDT, x, cc, seq_along(unclass(x)))
+        x <- .Call(C_subsetDT, x, cc, seq_along(unclass(x)), FALSE)
       }
     } else na.rm <- FALSE
   }
@@ -855,7 +855,7 @@ HDB.data.frame <- function(x, fl, w = NULL, cols = is.numeric, na.rm = TRUE, fil
     }
 
     xmat <- NULL
-    list2env(getfl(myModFrame(fl, if(na.rm) .Call(C_subsetDT, x, cc, fvars) else .subset(x, fvars))), envir = environment())
+    list2env(getfl(myModFrame(fl, if(na.rm) .Call(C_subsetDT, x, cc, fvars, FALSE) else .subset(x, fvars))), envir = environment())
     fcl <- !is.null(fl)
     nallfc <- fcl && !is.null(xmat)
     if(nallfc) xmat <- demean(xmat, fl, w, ...)
@@ -884,7 +884,7 @@ HDB.data.frame <- function(x, fl, w = NULL, cols = is.numeric, na.rm = TRUE, fil
         return(y)
       }), ax))
     } else { # at this point missing values are already removed from  fl !!
-      x <- if(na.rm) .Call(C_subsetDT, x, cc, Xvars) else .subset(x, Xvars)
+      x <- if(na.rm) .Call(C_subsetDT, x, cc, Xvars, FALSE) else .subset(x, Xvars)
       if(nallfc || !fcl) {
         Y <- if(nallfc) x - flmres(demean(x, fl, w, ...), xmat, w, lm.method, ...) else flmres(x, xmat, w, lm.method, FALSE, ...)
       } else Y <- demean(x, fl, w, ..., means = TRUE)

R/fsubset_ftransform.R

@@ -7,8 +7,8 @@ sbt <- fsubset
 fsubset.default <- function(x, subset, ...) {
   if(is.matrix(x) && !inherits(x, "matrix")) return(fsubset.matrix(x, subset, ...))
   if(!missing(...)) unused_arg_action(match.call(), ...)
-  if(is.logical(subset)) return(.Call(C_subsetVector, x, which(subset)))
-  .Call(C_subsetVector, x, subset)
+  if(is.logical(subset)) return(.Call(C_subsetVector, x, which(subset), FALSE))
+  .Call(C_subsetVector, x, subset, TRUE)
 }
 
 fsubset.matrix <- function(x, subset, ..., drop = FALSE) {
@@ -35,17 +35,19 @@ ss <- function(x, i, j) {
      j <- if(any(j < 0)) seq_along(unclass(x))[j] else as.integer(j)
     } else stop("j needs to be supplied integer indices, character column names, or a suitable logical vector")
   }
+  checkrows <- TRUE
   if(!is.integer(i)) {
     if(is.numeric(i)) i <- as.integer(i) else if(is.logical(i)) {
       nr <- fnrow2(x)
       if(length(i) != nr) stop("i needs to be integer or logical(nrow(x))") # which(r & !is.na(r)) not needed !
       i <- which(i)
       if(length(i) == nr) if(mj) return(x) else return(.Call(C_subsetCols, x, j, TRUE))
+      checkrows <- FALSE
     } else stop("i needs to be integer or logical(nrow(x))")
   }
   rn <- attr(x, "row.names")
-  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, i, j))
-  return(`attr<-`(.Call(C_subsetDT, x, i, j), "row.names", rn[i]))
+  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, i, j, checkrows))
+  return(`attr<-`(.Call(C_subsetDT, x, i, j, checkrows), "row.names", rn[i]))
 }
 
 fsubset.data.frame <- function(x, subset, ...) {
@@ -67,16 +69,18 @@ fsubset.data.frame <- function(x, subset, ...) {
       attr(x, "names")[vars[nonmiss]] <- nam_vars[nonmiss]
     }
   }
+  checkrows <- TRUE
   if(is.logical(r)) {
     nr <- fnrow2(x)
     if(length(r) != nr) stop("subset needs to be an expression evaluating to logical(nrow(x)) or integer") # which(r & !is.na(r)) not needed !
     r <- which(r)
     if(length(r) == nr) if(missing(...)) return(x) else return(.Call(C_subsetCols, x, vars, TRUE))
+    checkrows <- FALSE
   } else if(is.numeric(r)) r <- as.integer(r) else
     stop("subset needs to be an expression evaluating to logical(nrow(x)) or integer")
   rn <- attr(x, "row.names")
-  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, r, vars))
-  return(`attr<-`(.Call(C_subsetDT, x, r, vars), "row.names", rn[r]))
+  if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, r, vars, checkrows))
+  return(`attr<-`(.Call(C_subsetDT, x, r, vars, checkrows), "row.names", rn[r]))
 }
 
 # Example:
@@ -243,7 +247,7 @@ fcomputev <- function(.data, vars, FUN, ..., apply = TRUE, keep = NULL) {
 #   ax[["dimnames"]][[1L]] <- ax[["dimnames"]][[1L]][subset]
 #   ax[["dim"]] <- c(length(subset), d[2L])
 #   ic <- seq_len(d[2L]) * d[1L] - d[1L]
-#   setAttributes(.Call(C_subsetVector, x, outer(subset, ic, FUN = "+")), ax)
+#   setAttributes(.Call(C_subsetVector, x, outer(subset, ic, FUN = "+"), TRUE), ax)
 # }
 
 # Older version: But classes for [ can also be very useful for certain objects !!
@@ -279,8 +283,8 @@ fcomputev <- function(.data, vars, FUN, ..., apply = TRUE, keep = NULL) {
 #     if(is.logical(r)) r <- which(r) # which(r & !is.na(r)) is.na not needed !!
 #   } # improve qDF !!!
 #   rn <- attr(x, "row.names") # || is.integer(rn) # maybe many have character converted integers ??
-#   if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, r, vars))
-#   return(`attr<-`(.Call(C_subsetDT, x, r, vars), "row.names", rn[r])) # fast ?? scalable ??
+#   if(is.numeric(rn) || is.null(rn) || rn[1L] == "1") return(.Call(C_subsetDT, x, r, vars, TRUE))
+#   return(`attr<-`(.Call(C_subsetDT, x, r, vars, TRUE), "row.names", rn[r])) # fast ?? scalable ??
 # }
 
 

R/pwcor_pwcov_pwNobs.R

@@ -210,7 +210,7 @@ print.pwcor <- function(x, digits = 2L, sig.level = 0.05, show = c("all","lower.
 
 print.pwcov <- function(x, digits = 2L, sig.level = 0.05, show = c("all","lower.tri","upper.tri"), spacing = 1L, ...) {
   formfun <- function(x, adj = FALSE) {
-    xx <- format(round(x, digits), digits = 9, big.mark = ",", big.interval = 6)
+    xx <- format(round(x, digits), digits = 9, big.mark = "'", big.interval = 6)
     # xx <- sub("(-?)0\\.", "\\1.", xx) # Not needed here...
     if(adj) {
       xna <- is.na(x)
@@ -261,4 +261,4 @@ print.pwcov <- function(x, digits = 2L, sig.level = 0.05, show = c("all","lower.
 
 
 # print.pwcov <- function(x, digits = 2, ...) print.default(formatC(round(x, digits), format = "g",
-#                         digits = 9, big.mark = ",", big.interval = 6), quote = FALSE, right = TRUE, ...)
+#                         digits = 9, big.mark = "'", big.interval = 6), quote = FALSE, right = TRUE, ...)

R/qsu.R

@@ -231,7 +231,7 @@ print.qsu <- function(x, digits = 4, nonsci.digits = 9, na.print = "-", return =
   formatfun <- function(x) { # , drop0trailing = FALSE redundat ??
     class(x) <- NULL
     xx <- formatC(vec2mat(round(x, digits)), format = "g", flag = "#",
-                  digits = nonsci.digits, big.mark = ",", big.interval = 6,
+                  digits = nonsci.digits, big.mark = "'", big.interval = 6, # "\u2009": https://stackoverflow.com/questions/30555232/using-a-half-space-as-a-big-mark-for-knitr-output
                   drop0trailing = TRUE, preserve.width = "individual") # format(unclass(round(x,2)), digits = digits, drop0trailing = TRUE, big.mark = ",", big.interval = 6, scientific = FALSE)
     if(any(ina <- is.na(x))) xx[ina] <- na.print
     xx <- gsub(" ", "", xx, fixed = TRUE) # remove some weird white space (qsu(GGDS10S))