Merge pull request #796 from SebKrantz/development

Fixes #794

Author: SebKrantz

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: collapse
 Title: Advanced and Fast Data Transformation
-Version: 2.1.3.9000
-Date: 2025-08-19
+Version: 2.1.4
+Date: 2025-10-22
 Authors@R: c(
            person("Sebastian", "Krantz", role = c("aut", "cre"), 
                   email = "[email protected]", 

NEWS.md

@@ -1,7 +1,9 @@
-# collapse 2.1.3.9000
+# collapse 2.1.4
 
 * *collapse* now has a custom internal version of `unlist()` with better attribute preservation capabilities and a slight speed improvement. Thanks @aidanhorn (#785).
 
+* Fixes (#794) -- thanks @kendonB for reporting and making an effort to create a reprex. 
+
 # collapse 2.1.3
 
 * Various bug fixes (#769, #772 and #779).

R/descr.R

@@ -300,7 +300,7 @@ print_descr_default <- function(x, n = 14, perc = TRUE, digits = 2, t.table = TR
         t <- unclass(xi[[4L]])
         if(length(t) <= n) {
           if(perc) print.default(cb(t, round(t/bsum(t)*100, digits)), right = TRUE, print.gap = 2, quote = FALSE) else
-            print.table(ct(t))
+            print.table(ct(t), digits = digits)
         } else {
           t1 <- t[seq_len(n)]
           st <- bsum(t)
@@ -310,7 +310,7 @@ print_descr_default <- function(x, n = 14, perc = TRUE, digits = 2, t.table = TR
             print.default(cb(c(t1, rem), round(c(pct, 100-bsum(pct)), digits)), right = TRUE, print.gap = 2, quote = FALSE)
             # cat("...\n")
           } else {
-            print.table(ct(c(t1, rem)))
+            print.table(ct(c(t1, rem)), digits = digits)
             # cat("...\n")
           }
           if(summary) {
@@ -398,7 +398,7 @@ print_descr_grouped <- function(x, n = 14, perc = TRUE, digits = 2, t.table = TR
           if(perc) pct <- tab %r/% st * 100 # dimnames(tab)[[2L]] <- paste0(dimnames(tab)[[2L]], "\nFreq  Perc")
         }
         if(perc) {
-          tab <- duplAttributes(paste(tab, format(pct, digits = digits, justify = "right")), tab)
+          tab <- duplAttributes(paste(format(tab, digits = digits, justify = "right"), format(pct, digits = digits, justify = "right")), tab)
           print.default(if(t.table) tab else t(tab), right = TRUE, print.gap = 2, quote = FALSE)
         } else print.table(if(t.table) tab else t(tab), digits = digits)
         if(summary && nrow(t) > n) {

src/fmean.c

@@ -577,14 +577,15 @@ SEXP fmeanlC(SEXP x, SEXP Rng, SEXP g, SEXP gs, SEXP w, SEXP Rnarm, SEXP Rdrop,
           if(ATTRIB(xj) != R_NilValue && !(isObject(xj) && inherits(xj, "ts"))) copyMostAttrib(xj, outj);
           if(TYPEOF(xj) != REALSXP) {
             if(TYPEOF(xj) != INTSXP && TYPEOF(xj) != LGLSXP) error("Unsupported SEXP type: '%s'", type2char(TYPEOF(xj)));
-            if(dup == 0) {x = PROTECT(shallow_duplicate(x)); ++nprotect; px = SEXPPTR_RO(x); dup = 1;}
+            if(dup == 0) {x = PROTECT(shallow_duplicate(x)); ++nprotect; dup = 1;}
             SET_VECTOR_ELT(x, j, coerceVector(xj, REALSXP));
+            px = SEXPPTR_RO(x); // Fix suggested by ChatGPT
           }
         }
         #pragma omp parallel for num_threads(nthreads)
         for(int j = 0; j < l; ++j) fmean_weights_g_impl(REAL(pout[j]), REAL(px[j]), ng, pg, pw, narm, nrx);
       } else {
-        for(int j = 0; j != l; ++j) pout[j] = fmean_wg_impl(px[j], ng, pg, pw, narm);
+        for(int j = 0; j != l; ++j) SET_VECTOR_ELT(out, j, fmean_wg_impl(px[j], ng, pg, pw, narm));
       }
     }
   }

src/fsum.c

@@ -680,14 +680,15 @@ SEXP fsumlC(SEXP x, SEXP Rng, SEXP g, SEXP w, SEXP Rnarm, SEXP fill, SEXP Rdrop,
           if(ATTRIB(xj) != R_NilValue && !(isObject(xj) && inherits(xj, "ts"))) copyMostAttrib(xj, outj);
           if(TYPEOF(xj) != REALSXP) {
             if(TYPEOF(xj) != INTSXP && TYPEOF(xj) != LGLSXP) error("Unsupported SEXP type: '%s'", type2char(TYPEOF(xj)));
-            if(dup == 0) {x = PROTECT(shallow_duplicate(x)); ++nprotect; px = SEXPPTR_RO(x); dup = 1;}
+            if(dup == 0) {x = PROTECT(shallow_duplicate(x)); ++nprotect; dup = 1;}
             SET_VECTOR_ELT(x, j, coerceVector(xj, REALSXP));
+            px = SEXPPTR_RO(x); // Fix suggested by ChatGPT
           }
         }
         #pragma omp parallel for num_threads(nthreads)
         for(int j = 0; j < l; ++j) fsum_weights_g_impl(REAL(pout[j]), REAL(px[j]), ng, pg, pw, narm, nrx);
       } else {
-        for(int j = 0; j != l; ++j) pout[j] = fsum_wg_impl(px[j], ng, pg, pw, narm);
+        for(int j = 0; j != l; ++j) SET_VECTOR_ELT(out, j, fsum_wg_impl(px[j], ng, pg, pw, narm));
       }
     }
   }