remove fortify_upset function

DESCRIPTION

@@ -77,7 +77,6 @@ Collate:
     'dendrogram.R'
     'fortify-data-frame.R'
     'fortify-matrix.R'
-    'fortify-upset.R'
     'geom-draw.R'
     'geom-draw2.R'
     'geom-pie.R'

NAMESPACE

@@ -140,11 +140,11 @@ S3method(fortify_matrix,MAF_pathways)
 S3method(fortify_matrix,default)
 S3method(fortify_matrix,formula)
 S3method(fortify_matrix,ggalign_tune)
+S3method(fortify_matrix,list_upset)
 S3method(fortify_matrix,matrix)
+S3method(fortify_matrix,matrix_upset)
 S3method(fortify_matrix,phylo)
 S3method(fortify_matrix,waiver)
-S3method(fortify_upset,list)
-S3method(fortify_upset,matrix)
 S3method(free_align,alignpatches)
 S3method(free_align,default)
 S3method(free_align,free_align)
@@ -344,6 +344,8 @@ S3method(stack_discrete,"function")
 S3method(stack_discrete,default)
 S3method(stack_discrete,formula)
 S3method(tune,MAF)
+S3method(tune,list)
+S3method(tune,matrix)
 S3method(update_design,CircleLayout)
 S3method(update_design,QuadLayout)
 S3method(update_design,StackCross)
@@ -432,7 +434,6 @@ export(element_vec_rep_each)
 export(element_vec_slice)
 export(fortify_data_frame)
 export(fortify_matrix)
-export(fortify_upset)
 export(free_align)
 export(free_border)
 export(free_guide)

R/align-phylo.R

@@ -182,12 +182,13 @@ AlignPhylo <- ggproto("AlignPhylo", Align,
     summary_align = function(self) c(TRUE, FALSE)
 )
 
-#' @inheritParams rlang::args_dots_empty
-#' @inherit fortify_matrix title
+#' Build a matrix from `phylo` object
+#'
 #' @description This method allows a [`phylo`][ape::as.phylo] object to be
 #' directly input into `stack_discrete()` or `circle_discrete()`. This makes it
 #' possible to add [`align_phylo()`] to the stack independently, as
 #' [`align_phylo()`] requires the layout to have labels.
+#' @inheritParams rlang::args_dots_empty
 #' @param data A [`phylo`][ape::as.phylo] object.
 #' @inheritParams fortify_matrix
 #' @return A one-column matrix where the tip labels are the values, and the row

R/fortify-matrix.R

@@ -3,7 +3,8 @@
 #' @description
 #' `r lifecycle::badge('stable')`
 #'
-#' This function converts various objects into a matrix format.
+#' This function converts various objects into a matrix format. By default, it
+#' calls [`as.matrix()`] to build a matrix.
 #'
 #' @param data An object to be converted into a matrix.
 #' @param ... Additional arguments passed to methods.
@@ -17,18 +18,19 @@
 #' - [`fortify_matrix.default()`]
 #' - [`fortify_matrix.MAF()`]
 #' - [`fortify_matrix.GISTIC()`]
-#' - [`fortify_matrix.phylo()`]
+#' - [`fortify_matrix.list_upset()`]
+#' - [`fortify_matrix.matrix_upset()`]
 #' @export
 fortify_matrix <- function(data, ..., data_arg = caller_arg(data),
                            call = NULL) {
     UseMethod("fortify_matrix")
 }
 
 #' @inheritParams rlang::args_dots_empty
-#' @inherit fortify_matrix title description return
-#' @inheritParams fortify_matrix
-#' @details
+#' @inherit fortify_matrix title return
+#' @description
 #' By default, it calls [`as.matrix()`] to build a matrix.
+#' @inheritParams fortify_matrix
 #' @family fortify_matrix methods
 #' @importFrom rlang try_fetch
 #' @export
@@ -52,21 +54,18 @@ fortify_matrix.default <- function(data, ..., data_arg = caller_arg(data),
 }
 
 #' @export
-fortify_matrix.matrix <- function(data, ..., data_arg = caller_arg(data),
+fortify_matrix.waiver <- function(data, ..., data_arg = caller_arg(data),
                                   call = NULL) {
     call <- call %||% current_call()
     rlang::check_dots_empty(call = call)
     data
 }
 
 #' @export
-fortify_matrix.waiver <- fortify_matrix.matrix
+fortify_matrix.NULL <- fortify_matrix.waiver
 
 #' @export
-fortify_matrix.NULL <- fortify_matrix.matrix
-
-#' @export
-fortify_matrix.function <- fortify_matrix.matrix
+fortify_matrix.function <- fortify_matrix.waiver
 
 #' @export
 fortify_matrix.formula <- function(data, ..., data_arg = caller_arg(data),
@@ -75,3 +74,183 @@ fortify_matrix.formula <- function(data, ..., data_arg = caller_arg(data),
     rlang::check_dots_empty(call = call)
     rlang::as_function(data)
 }
+
+#' Build a matrix from a matrix
+#' @param data A matrix object.
+#' @inheritParams rlang::args_dots_empty
+#' @inheritParams fortify_matrix
+#' @section shape:
+#'  - `upset`: [`fortify_matrix.matrix_upset`]
+#' @family fortify_matrix methods
+#' @export
+fortify_matrix.matrix <- fortify_matrix.waiver
+
+#' @inherit fortify_matrix.list_upset title
+#' @description
+#' Converts a matrix suitable for creating an UpSet plot. [`tune.matrix()`]
+#' helps convert `matrix` object to a `matrix_upset` object.
+#' @param data A matrix where each row represents an element, and each column
+#' defines a set. The values in the matrix indicate whether the element is part
+#' of the set. Any non-missing value signifies that the element exists in the
+#' set.
+#' @inheritParams fortify_matrix.list_upset
+#' @inheritDotParams fortify_matrix.list_upset
+#' @inheritSection fortify_matrix.list_upset ggalign attributes
+#' @seealso [`tune.matrix()`]
+#' @family fortify_matrix methods
+#' @export
+fortify_matrix.matrix_upset <- function(data, ..., data_arg = caller_arg(data),
+                                        call = NULL) {
+    call <- call %||% current_call()
+    data <- !is.na(tune_data(data))
+    elements <- vec_seq_along(data)
+    fortify_matrix.list_upset(
+        lapply(seq_len(ncol(data)), function(i) {
+            .subset(elements, data[, i, drop = TRUE])
+        }),
+        ...,
+        data_arg = data_arg,
+        call = call
+    )
+}
+
+#' Convert the shape of a matrix for fortify method
+#'
+#' @param data A matrix.
+#' @param shape Not used currently.
+#' @seealso
+#' - [`fortify_matrix.matrix()`]
+#' - [`fortify_matrix.matrix_upset()`]
+#' @family tune methods
+#' @export
+tune.matrix <- function(data, shape = NULL) {
+    if (!is.null(shape)) {
+        cli_abort("{.arg shape} cannot be used currently for {.cls matrix} object")
+    }
+    new_tune(data, class = "matrix_upset")
+}
+
+#' Build a Matrix for UpSet plot
+#'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
+#' This function converts a list into a matrix format suitable for creating an
+#' UpSet plot. It always returns a matrix for a `horizontal` UpSet plot.
+#' @inheritParams rlang::args_dots_empty
+#' @param data A list of sets.
+#' @param mode A string of `r oxford_or(c("distinct", "intersect", "union"))`
+#' indicates the mode to define the set intersections. Check
+#' <https://jokergoo.github.io/ComplexHeatmap-reference/book/upset-plot.html#upset-mode>
+#' for details.
+#' @inheritParams fortify_matrix
+#' @section ggalign attributes:
+#'  - `intersection_sizes`: An integer vector indicating the size of each
+#'    intersection.
+#'  - `set_sizes`: An integer vector indicating the size of each set.
+#' @seealso [`tune.list()`]
+#' @family fortify_matrix methods
+#' @aliases fortify_matrix.list
+#' @export
+fortify_matrix.list_upset <- function(data, mode = "distinct", ...,
+                                      data_arg = caller_arg(data),
+                                      call = NULL) {
+    call <- call %||% current_call()
+    rlang::check_dots_empty(call = call)
+    mode <- arg_match0(mode, c("distinct", "intersect", "union"),
+        error_call = call
+    )
+    data <- lapply(tune_data(data), function(x) {
+        vec_unique(vec_slice(x, !vec_detect_missing(x)))
+    })
+    data <- list_drop_empty(data)
+
+    # Based on the explanation from
+    # https://jokergoo.github.io/ComplexHeatmap-reference/book/upset-plot.html
+    action <- switch(mode,
+        distinct = function(data, intersection) {
+            out <- NULL
+            for (i in which(intersection)) {
+                if (is.null(out)) {
+                    out <- .subset2(data, i)
+                } else if (vec_size(out) == 0L) { # early exit for empty items
+                    return(out)
+                } else {
+                    out <- vec_set_intersect(out, .subset2(data, i))
+                }
+            }
+            for (i in which(!intersection)) {
+                if (vec_size(out) == 0L) { # early exit for empty items
+                    return(out)
+                }
+                out <- vec_set_difference(out, .subset2(data, i))
+            }
+            return(out)
+        },
+        intersect = function(data, intersection) {
+            out <- NULL
+            for (i in which(intersection)) {
+                if (is.null(out)) {
+                    out <- .subset2(data, i)
+                } else if (vec_size(out) == 0L) { # early exit for empty items
+                    return(out)
+                } else {
+                    out <- vec_set_intersect(out, .subset2(data, i))
+                }
+            }
+            out
+        },
+        union = function(data, intersection) {
+            Reduce(vec_set_union, .subset(data, intersection))
+        }
+    )
+
+    intersection <- logical(vec_size(data)) # template
+    intersection_and_size <- lapply(
+        seq_len(vec_size(intersection)),
+        function(n) {
+            # generate all possible intersections
+            utils::combn(vec_size(intersection), n, function(index) {
+                intersection[index] <- TRUE
+                list(
+                    intersection = intersection,
+                    # for each intersection, we define the size
+                    size = vec_size(action(data, intersection))
+                )
+            }, simplify = FALSE)
+        }
+    )
+
+    # https://en.wikipedia.org/wiki/UpSet_plot
+    # UpSets can be used horizontally and vertically.
+    # In a vertical UpSet plot, the columns of the matrix correspond to the
+    # sets, the rows correspond to the intersections.
+    # we by default use `horizontal` upset, the rows of the matrix correspond
+    # to the sets, the columns correspond to the intersections.
+    ans <- list_transpose(unlist(intersection_and_size, FALSE, FALSE))
+    intersections <- inject(cbind(!!!.subset2(ans, "intersection")))
+    rownames(intersections) <- names(data)
+    intersection_sizes <- unlist(.subset2(ans, "size"), FALSE, FALSE)
+    keep <- intersection_sizes > 0L # remove intersection without items
+    intersections <- intersections[, keep, drop = FALSE]
+    intersection_sizes <- intersection_sizes[keep]
+    ggalign_data_set(intersections,
+        intersection_sizes = intersection_sizes,
+        set_sizes = list_sizes(data),
+        upset_mode = mode
+    )
+}
+
+#' Convert the shape of a list for fortify method
+#'
+#' @param data A list
+#' @param shape Not used currently.
+#' @seealso [`fortify_matrix.list_upset()`]
+#' @family tune methods
+#' @export
+tune.list <- function(data, shape = NULL) {
+    if (!is.null(shape)) {
+        cli_abort("{.arg shape} cannot be used currently for {.cls list} object")
+    }
+    new_tune(data, class = "list_upset")
+}