better sort unique_numeric

thanks to burgled gtools::mixedorder() v3.9.2

R/crosstable.R

@@ -41,6 +41,7 @@ utils::globalVariables(c("x", "y", "ct", "col_keys", "p_col", "where"))
 #' @importFrom tidyselect vars_select eval_select everything any_of 
 #' @importFrom dplyr select mutate_if n_distinct across
 #' @importFrom purrr map map_lgl map_chr map_dfc pmap_dfr
+#' @importFrom forcats as_factor
 #' @importFrom stringr str_detect str_split
 #' @importFrom glue glue
 #' @importFrom lifecycle deprecated is_present deprecate_warn deprecate_stop
@@ -267,8 +268,8 @@ crosstable = function(data, cols=NULL, ..., by=NULL,
                    ~ .x %>% as.character() %>% set_label(get_label(.x))),
             across(where(~is.numeric.and.not.surv(.x) && n_distinct(.x, na.rm=TRUE)<=unique_numeric),
                    ~{
-                       .x = as.character(.x) %>% set_label(get_label(.x))
-                       class(.x) = c("unique_numeric", "character")
+                       .x = mixedsort(.x) %>% as_factor() %>% set_label(get_label(.x))
+                       class(.x) = c("unique_numeric", class(.x))
                        .x
                    }),
         )
@@ -280,8 +281,8 @@ crosstable = function(data, cols=NULL, ..., by=NULL,
                    ~ .x %>% as.character() %>% set_label(get_label(.x))),
             across(where(~is.numeric.and.not.surv(.x) && n_distinct(.x, na.rm=TRUE)<=unique_numeric), 
                    ~{
-                       .x = as.character(.x) %>% set_label(get_label(.x))
-                       class(.x) = c("unique_numeric", "character")
+                       .x = mixedsort(.x) %>% as_factor() %>% set_label(get_label(.x))
+                       class(.x) = c("unique_numeric", class(.x))
                        .x
                    })
         )

R/utils.R

@@ -406,6 +406,90 @@ str_wrap2 = function(x, width, ...){
 }
 
 
+
+#' @source adapted from gtools::mixedorder() v3.9.2
+#' @keywords internal
+#' @noRd
+mixedsort = function(x, decreasing=FALSE, na.last=TRUE, blank.last=FALSE, 
+                     numeric.type=c("decimal", "roman"), 
+                     roman.case=c("upper", "lower", "both"), 
+                     scientific=TRUE){
+    numeric.type <- match.arg(numeric.type)
+    roman.case <- match.arg(roman.case)
+    if(length(x)==0) return(NULL)
+    if(length(x)==1) return(x)
+    if(!is.character(x)) {
+        return(x[order(x, decreasing=decreasing, na.last=na.last)])
+    }
+
+    delim <- "\\$\\@\\$"
+    if(numeric.type == "decimal") {
+        if(scientific) {
+            regex <- "((?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[eE])(?:(?:[-+]?)(?:[0123456789]+))|)))"
+        }
+        else {
+            regex <- "((?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)))"
+        }
+        numeric <- function(x) as.numeric(x)
+    } else if(numeric.type == "roman") {
+        regex <- switch(roman.case, both = "([IVXCLDMivxcldm]+)", 
+                        upper = "([IVXCLDM]+)", lower = "([ivxcldm]+)")
+        numeric <- function(x) roman2int(x)
+    } else {
+        stop("Unknown value for numeric.type: ", numeric.type)
+    }
+    nonnumeric <- function(x) ifelse(is.na(numeric(x)), toupper(x), NA)
+    x <- as.character(x)
+    which.nas <- which(is.na(x))
+    which.blanks <- which(x == "")
+    delimited <- gsub(regex, paste(delim, "\\1", delim, sep = ""), 
+                      x, perl = TRUE)
+    step1 <- strsplit(delimited, delim)
+    step1 <- lapply(step1, function(x) x[x > ""])
+    step1.numeric <- suppressWarnings(lapply(step1, numeric))
+    step1.character <- suppressWarnings(lapply(step1, nonnumeric))
+    maxelem <- max(sapply(step1, length))
+    step1.numeric.t <- lapply(1:maxelem, function(i) {
+        sapply(step1.numeric, function(x) x[i])
+    })
+    step1.character.t <- lapply(1:maxelem, function(i) {
+        sapply(step1.character, function(x) x[i])
+    })
+    rank.numeric <- sapply(step1.numeric.t, rank)
+    rank.character <- sapply(step1.character.t, function(x) as.numeric(factor(x)))
+    rank.numeric[!is.na(rank.character)] <- 0
+    rank.character <- t(t(rank.character) + apply(matrix(rank.numeric), 
+                                                  2, max, na.rm = TRUE))
+    rank.overall <- ifelse(is.na(rank.character), rank.numeric, 
+                           rank.character)
+    order.frame <- as.data.frame(rank.overall)
+    if(length(which.nas) > 0) {
+        if(is.na(na.last)) {
+            order.frame[which.nas, ] <- NA
+        } else if(na.last) {
+            order.frame[which.nas, ] <- Inf
+        } else {
+            order.frame[which.nas, ] <- -Inf
+        }
+    }
+    if(length(which.blanks) > 0) {
+        if(is.na(blank.last)) {
+            order.frame[which.blanks, ] <- NA
+        } else if(blank.last) {
+            order.frame[which.blanks, ] <- 1e+99
+        } else {
+            order.frame[which.blanks, ] <- -1e+99
+        }
+    }
+    order.frame <- as.list(order.frame)
+    order.frame$decreasing <- decreasing
+    order.frame$na.last <- NA
+    ord <- do.call("order", order.frame)
+
+    x[ord]
+}
+
+
 # dplyr -------------------------------------------------------------------
 
 #' @source https://github.com/tidyverse/dplyr/issues/5563#issuecomment-721769342