0.99.54.8

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: DescTools
 Type: Package
 Title: Tools for Descriptive Statistics
-Version: 0.99.54.7
-Date: 2024-03-17
+Version: 0.99.54.8
+Date: 2024-04-11
 Authors@R: c(
   person("Andri", "Signorell", email = "andri@signorell.net", role = c("aut", "cre")),
   person("Ken"           , "Aho",                 role = c("ctb")),

NEWS

@@ -15,9 +15,11 @@ UPDATED FUNCTIONS:
     (See discussion with MrJerryTAO in 
     https://github.com/AndriSignorell/DescTools/issues/109)
   * Some first helpfiles are generated by roxygen2 now.  
-  * The arguments in Winsorize() have been condensed to a single one with an 
+  * The arguments in Winsorize() have been condensed to a single one with  
     extended flexibility. 
   * Closest() vectorizes the value to be found (argument a).
+  * Unwhich() checks its arguments now and got a default value for the argument n.
+  * TOne() gets an improved print routine.
 
 BUGFIXES:
   * The text for prop.diff will be displayed in Desc.table().

R/Desc.R

@@ -2724,7 +2724,7 @@ plot.Desc.xtabs <- function(x, main = NULL, col1 = NULL, col2 = NULL,
 
 
 plot.Desc.table <- function(x, main = NULL, col1 = NULL, col2 = NULL,
-                            horiz = TRUE, ..., xlab = NULL, ylab = NULL) {
+                            horiz = TRUE, ..., xlab = NULL, ylab = NULL, which = c(1,2)) {
   opt <- DescToolsOptions(stamp = NULL)
 
   oldpar <- par(no.readonly = TRUE)
@@ -2763,32 +2763,39 @@ plot.Desc.table <- function(x, main = NULL, col1 = NULL, col2 = NULL,
       )
     }
 
-    if (horiz) {
-      # width <- 16
-      # height <- 6.5  # dimension for 2 mosaicplots
-      par(mfrow = c(1, 2))
-      par(oma = c(1.1, 2.1, ifelse(is.na(main), 0, 2.1), 0))
-    } else {
-      # width <- 7
-      # height <- 14  # dimension for 2 mosaicplots
-      par(mfrow = c(2, 1), xpd = TRUE)
-      par(oma = c(3.1, 1.1, ifelse(is.na(main), 0, 2), 0))
+    if(length(which) == 2){
+      if (horiz) {
+        # width <- 16
+        # height <- 6.5  # dimension for 2 mosaicplots
+        par(mfrow = c(1, 2))
+        par(oma = c(1.1, 2.1, ifelse(is.na(main), 0, 2.1), 0))
+      } else {
+        # width <- 7
+        # height <- 14  # dimension for 2 mosaicplots
+        par(mfrow = c(2, 1), xpd = TRUE)
+        par(oma = c(3.1, 1.1, ifelse(is.na(main), 0, 2), 0))
+      }
     }
-
-    PlotMosaic(x$tab, main = NA, xlab = NA, ylab = NA, horiz = TRUE, cols = col1)
-    PlotMosaic(x$tab, main = NA, xlab = NA, ylab = NA, horiz = FALSE, cols = col2)
+
+    if(any(which==1))
+      PlotMosaic(x$tab, main = NA, xlab = NA, ylab = NA, horiz = TRUE, cols = col1)
+
+    if(any(which==2))
+      PlotMosaic(x$tab, main = NA, xlab = NA, ylab = NA, horiz = FALSE, cols = col2)
 
     title(xlab = xlab, outer = TRUE, line = -1, font = 2)
     title(ylab = ylab, outer = TRUE, line = 0, font = 2)
   }
 
-  if (!is.na(main) && (length(dim(x$tab)) == 2)) title(main, outer = TRUE)
+  if (!is.na(main) && (length(dim(x$tab)) == 2)) 
+    title(main, outer = ifelse(length(which)==2, TRUE, FALSE))
 
   options(opt)
   if (!is.null(DescToolsOptions("stamp"))) Stamp()
 
   # invisible(list(width=width, height=height))
   invisible()
+
 }
 
 

R/DescTools.r

@@ -1356,7 +1356,7 @@ PercentRank <- function(x)
 
 
 
-Unwhich <- function(idx, n, useNames=TRUE){
+Unwhich <- function(idx, n = max(idx), useNames=TRUE){
 
   # Author: Nick Sabbe
 
@@ -1365,8 +1365,13 @@ Unwhich <- function(idx, n, useNames=TRUE){
   # less performant, but oneliner:
   #   is.element(seq_len(n), i)
 
+  if(n < max(idx)){
+    warning(gettextf("n=%s must not be less than max(idx)=%s, which currently is the case", n, max(idx)))
+    return(NA)
+  }
+
   res <- logical(n)
-
+  
   if(length(idx) > 0L) {
     res[idx] <- TRUE
     if(useNames) names(res)[idx] <- names(idx)

R/TOne.R

@@ -494,18 +494,56 @@ TOne <- function(x, grp = NA, add.length=TRUE,
 }
 
 
+
+# Old, replaced by 0.99.54.6:
+# print.TOne <- function(x, ...){
+#   
+#   cat("\n")
+#   
+#   write.table(format(rbind(colnames(x), x), justify="left"),
+#               row.names=FALSE, col.names=FALSE, quote=FALSE)
+#   
+#   if(!is.null(attr(x, "legend"))){
+#     cat("---\n")
+#     cat(attr(x, "legend"), "\n")
+#   }
+#   cat("\n")
+#   
+# }
+
 print.TOne <- function(x, ...){
 
   cat("\n")
 
-  write.table(format(rbind(colnames(x), x), justify="left"),
-              row.names=FALSE, col.names=FALSE, quote=FALSE)
-
-  if(!is.null(attr(x, "legend"))){
-    cat("---\n")
-    cat(attr(x, "legend"), "\n")
-  }
-  cat("\n")
+  if(.has_color()){
+
+    t1 <- as.data.frame.matrix(x)
+    colnames(t1) <- colnames(x)
+
+    out <- capture.output(print((t1), right=FALSE, sep="   ", 
+                                print.gap=3, col.names=F))
+    cat(cli::style_bold(out[1]))
+    print(unname(t1), right=FALSE, sep="   ", print.gap=3, col.names=F)
+
+    if(!is.null(attr(x, "legend"))){
+      cat(cli::col_silver("---\n"))
+      cat(cli::col_silver(attr(x, "legend"), "\n"))
+    }
+    cat("\n")
+
+
+  } else {
+
+    write.table(format(rbind(colnames(x), x), justify="left"),
+                row.names=FALSE, col.names=FALSE, quote=FALSE)
+
+    if(!is.null(attr(x, "legend"))){
+      cat("---\n")
+      cat(attr(x, "legend"), "\n")
+    }
+    cat("\n")
+
+  } 
 
 }
 

man/Unwhich.Rd

@@ -9,14 +9,14 @@ vector/matrix from indices.
 %%  ~~ A concise (1-5 lines) description of what the function does. ~~
 }
 \usage{
-Unwhich(idx, n, useNames = TRUE)
+Unwhich(idx, n = max(idx), useNames = TRUE)
 }
 %- maybe also 'usage' for other objects documented here.
 \arguments{
   \item{idx}{the indices as returned by \code{\link{which}}.
 %%     ~~Describe \code{idx} here~~
 }
-  \item{n}{integer, the length of the original vector.
+  \item{n}{integer, the length of the original vector. This must not be less than \code{max(idx)}, which is also the default.
 %%     ~~Describe \code{n} here~~
 }
   \item{useNames}{logical, determining if the names of the indices should be preserved.