# `assert_*()` functions will do the side effects
# `check_*()` functions will return the arguments
#' @importFrom rlang caller_arg caller_call
assert_gp <- function(gp, arg = caller_arg(gp), call = caller_call()) {
    assert_s3_class(gp, "gpar", arg = arg, call = call)
}

#' @importFrom rlang caller_arg caller_call
assert_mapping <- function(mapping, arg = caller_arg(mapping),
                           call = caller_call()) {
    if (!inherits(mapping, "uneval")) {
        cli_abort(c("{.arg {arg}} must be created with {.fn aes}.",
            x = "You've supplied {.obj_type_friendly {mapping}}."
        ), call = call)
    }
}

assert_mismatch_nobs <- function(align, n, nobs, arg) {
    if (n != nobs) {
        cli_abort(sprintf(
            "{.arg %s} (nobs: %d) of %s is not compatible with the %s (nobs: %d)",
            arg, nobs, object_name(align), align$layout_name, n
        ))
    }
}

assert_sub_split <- function(align, panel) {
    if (!is.null(panel)) {
        cli_abort(c(
            sprintf("%s cannot do sub-split", object_name(align)),
            i = sprintf(
                "Group of layout %s-axis already exists",
                to_coord_axis(align$direction)
            )
        ), call = align$call)
    }
}

assert_reorder <- function(align, panel, index, strict) {
    if (!is.null(panel) && nlevels(panel) > 1L && strict &&
        !all(index == reorder_index(panel, index))) {
        layout_name <- align$layout_name
        object_name <- object_name(align)
        cli_abort(c(
            sprintf("Cannot add %s to %s", object_name, layout_name),
            i = sprintf(
                "Group of %s will disrupt the ordering index of %s", layout_name, object_name
            ),
            i = "try to set {.code strict = FALSE} to reorder within each group"
        ), call = align$call)
    }
}

assert_position <- function(position, arg = caller_arg(position),
                            call = caller_call()) {
    assert_string(position, empty_ok = FALSE, arg = arg, call = call)
    if (grepl("[^tlbr]", position)) {
        cli_abort(sprintf(
            "{.arg {arg}} can only contain the %s characters",
            oxford_and(.tlbr)
        ), call = call)
    }
}

assert_guides <- function(guides, arg = caller_arg(guides),
                          call = caller_call()) {
    assert_string(guides, empty_ok = FALSE, arg = arg, call = call)
    if (grepl("[^tlbri]", guides)) {
        cli_abort(sprintf(
            "{.arg {arg}} can only contain the %s characters",
            oxford_and(c(.tlbr, "i"))
        ), call = call)
    }
}

assert_layout_position <- function(position, arg = caller_arg(position),
                                   call = caller_call()) {
    if (!is.waive(position) && !is.null(position)) {
        assert_position(position, arg = arg, call = call)
    }
}

assert_layout_guides <- function(guides, arg = caller_arg(guides),
                                 call = caller_call()) {
    if (!is.waive(guides) && !is.null(guides)) {
        assert_guides(guides, arg = arg, call = call)
    }
}

#' @importFrom grid is.unit
check_stack_sizes <- function(sizes, arg = caller_arg(sizes),
                              call = caller_call()) {
    if (!(all(is.na(sizes)) || is.numeric(sizes) || is.unit(sizes))) {
        cli_abort(
            "{.arg {arg}} must be a numeric or {.cls unit} object",
            call = call
        )
    }
    l <- length(sizes)
    if (l != 1L && l != 3L) {
        cli_abort(
            "{.arg {arg}} must have size `1` or `3`, not size {l}",
            call = call
        )
    }
    if (!is.unit(sizes)) sizes <- unit(sizes, "null")
    sizes
}

#' @importFrom rlang arg_match0
check_direction <- function(direction, arg = caller_arg(direction),
                            call = caller_call()) {
    direction <- arg_match0(direction, c("h", "v"),
        arg_nm = arg, error_call = call
    )
    switch(direction, h = "horizontal", v = "vertical") # styler: off
}

assert_limits <- function(limits, allow_null = TRUE, arg = caller_arg(limits),
                          call = caller_call()) {
    if (is.null(limits) && allow_null) {
        return(invisible(NULL))
    }
    if (!inherits(limits, "continuous_limits")) {
        cli_abort(
            "{.arg {arg}} must be specified with {.fn continuous_limits}",
            call = call
        )
    }
    if (rlang::is_named(limits)) {
        cli_abort(
            "{.arg {arg}} shouldn't be created with {.arg x}/{.arg y} argument in {.fn continuous_limits}",
            call = call
        )
    }
}

#' @importFrom grid is.unit
check_size <- function(size, arg = caller_arg(size), call = caller_call()) {
    if (!is_scalar(size) &&
        !(is.na(size) || is.numeric(size) || is.unit(size))) {
        cli_abort(
            "{.arg {arg}} must be a single numeric or unit object",
            call = call
        )
    }
    if (!is.unit(size)) size <- unit(size, "null")
    size
}

check_scheme_data <-

check_stack_context <- function(what, arg = caller_arg(what),
                                call = caller_call()) {
    if (is.null(what)) return(what) # styler: off
    if (.rlang_check_number(what, allow_decimal = FALSE, min = 1) != 0L &&
        !is_string(what)) {
        cli_abort(
            "{.arg {arg}} must be a single positive integer number or string",
            call = call
        )
    }
    what
}

check_order <- function(order, arg = caller_arg(order), call = caller_call()) {
    if (is.null(order)) {
        NA_integer_
    } else if (.rlang_check_number(order, allow_decimal = FALSE) == 0L) {
        as.integer(order)
    } else {
        cli_abort("{.arg {arg}} must be single integer number", call = call)
    }
}

assert_align <- function(x, arg = caller_arg(x), call = caller_call()) {
    if (!inherits(x, "scheme_align")) {
        cli_abort(
            "{.arg {arg}} must be created by {.fn scheme_align}",
            call = call
        )
    }
}

assert_active <- function(x, allow_null = TRUE,
                          arg = caller_arg(x), call = caller_call()) {
    if (is.null(x) && allow_null) {
        return(invisible(NULL))
    }
    if (!inherits(x, "ggalign_active")) {
        cli_abort(
            "{.arg {arg}} must be created by {.fn active}",
            call = call
        )
    }
}

assert_obs_size <- function(obs_size, arg = caller_arg(obs_size),
                            call = caller_call()) {
    if (.rlang_check_number(obs_size, allow_decimal = TRUE,  # styler: off
                            .Machine$double.eps, 1) != 0L) { # styler: off
        cli_abort(
            "{.arg {arg}} must be a single number in `(0, 1]`",
            call = call
        )
    }
}

function(data, arg = caller_arg(data),
                              call = caller_call()) {
    if (!is.waive(data) && !is.null(data) &&
        !is.function(data <- allow_lambda(data))) {
        cli_abort(paste(
            "{.arg {arg}} must be a function,",
            "{.code NULL} or {.fn waiver}"
        ), call = call)
    }
    data
}

# Standalone file: do not edit by hand
# Source: https://github.com/Yunuuuu/standalone/blob/HEAD/R/standalone-assert.R
# Generated by: usethis::use_standalone("Yunuuuu/standalone", "assert")
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-assert.R
# last-updated: 2025-04-16
# license: https://unlicense.org
# dependencies: [standalone-obj-type.R]
# imports: rlang
# ---

# ## Changelog
# 2025-04-16:
# - `assert_number_whole` gains `allow_infinite` argument
#
# 2025-04-11:
# - new `.rlang_allow_number`
# - new `.rlang_check_number`
# - new `.rlang_check_bool`
# - new `.rlang_check_string`
#
# 2024-11-10:
# - Added support for S3 object
#
# nocov start
# Following codes were modified from `rlang` package

#' Report if an argument is a specific class
#'
#' @param x The object type which does not conform to `what`. Its
#'   `obj_type_friendly()` is taken and mentioned in the error message.
#' @param what The friendly expected type as a string. Can be a
#'   character vector of expected types, in which case the error
#'   message mentions all of them in an "or" enumeration.
#' @param show_value Passed to `value` argument of `obj_type_friendly()`.
#' @param show_length Passed to `length` argument of `obj_type_friendly()`.
#' @param ... Arguments passed to [rlang::abort()].
#' @importFrom rlang is_missing
#' @noRd
assert_ <- function(x, check, what,
                    allow_null = FALSE,
                    allow_na = FALSE,
                    show_value = TRUE,
                    show_length = FALSE,
                    ...,
                    arg = caller_arg(x),
                    call = caller_env()) {
    if (!is_missing(x) && (
        (allow_null && is.null(x)) || check(x)
    )) {
        return(invisible(NULL))
    }
    stop_input_type(x, what,
        allow_na = allow_na,
        allow_null = allow_null,
        show_value = show_value,
        show_length = show_length,
        ...,
        arg = arg, call = call
    )
}

IS_NUMBER_true <- 0
IS_NUMBER_false <- 1
IS_NUMBER_oob <- 2

.standalone_types_check_assert_call <- .Call

#' @importFrom rlang ffi_standalone_check_number_1.0.7
.rlang_check_number <- function(x, allow_decimal,
                                min = NULL,
                                max = NULL,
                                allow_infinite = allow_decimal,
                                allow_na = FALSE,
                                allow_null = FALSE) {
    .standalone_types_check_assert_call(
        ffi_standalone_check_number_1.0.7,
        x,
        allow_decimal,
        min,
        max,
        allow_infinite,
        allow_na,
        allow_null
    )
}

#' @importFrom rlang ffi_standalone_is_bool_1.0.7
.rlang_check_bool <- function(x, allow_na = FALSE, allow_null = FALSE) {
    .standalone_types_check_assert_call(
        ffi_standalone_is_bool_1.0.7,
        x,
        allow_na,
        allow_null
    )
}

#' @importFrom rlang is_string
.rlang_check_string <- function(x, allow_empty = TRUE,
                                allow_na = FALSE, allow_null = FALSE) {
    if (is_string(x) && !is.na(x)) {
        if (allow_empty || x != "") {
            return(TRUE)
        }
    }

    if (allow_null && is.null(x)) {
        return(TRUE)
    }

    if (allow_na && (identical(x, NA) || identical(x, NA_character_))) {
        return(TRUE)
    }

    FALSE
}

#' @importFrom rlang abort
.rlang_allow_number <- function(x, exit_code, allow_decimal,
                                min = NULL,
                                max = NULL,
                                allow_na = FALSE,
                                allow_null = FALSE) {
    if (allow_decimal) {
        what <- "a number"
    } else {
        what <- "a whole number"
    }
    if (exit_code == IS_NUMBER_oob) {
        min <- min %||% -Inf
        max <- max %||% Inf

        if (min > -Inf && max < Inf) {
            what <- sprintf("%s between %s and %s", what, min, max)
        } else if (x < min) {
            what <- sprintf("%s larger than or equal to %s", what, min)
        } else if (x > max) {
            what <- sprintf("%s smaller than or equal to %s", what, max)
        } else {
            abort("Unexpected state in OOB check", .internal = TRUE)
        }
    }
    allow_what_type(what, allow_na = allow_na, allow_null = allow_null)
}

# scalar object ----------------------------------
assert_string <- function(x,
                          ...,
                          allow_empty = TRUE,
                          allow_na = FALSE,
                          allow_null = FALSE,
                          arg = caller_arg(x),
                          call = caller_env()) {
    assert_(
        x = x,
        check = function(x) {
            .rlang_check_string(
                x,
                allow_empty = allow_empty,
                allow_na = allow_na,
                allow_null = allow_null
            )
        },
        what = "a single string",
        ...,
        allow_na = allow_na,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

#' @importFrom rlang abort
.stop_not_number <- function(x,
                             exit_code,
                             allow_decimal,
                             ...,
                             min = NULL,
                             max = NULL,
                             allow_na = FALSE,
                             allow_null = FALSE,
                             show_value = TRUE,
                             show_length = FALSE,
                             arg = caller_arg(x),
                             call = caller_env()) {
    what <- .rlang_allow_number(
        x = x,
        exit_code = exit_code,
        allow_decimal = allow_decimal,
        min = min, max = max,
        allow_na = allow_na,
        allow_null = allow_null
    )
    if (inherits(arg, "AsIs")) {
        format_arg <- identity
    } else {
        format_arg <- function(x) sprintf("`%s`", x)
    }
    message <- sprintf(
        "%s must be %s, not %s.",
        format_arg(arg), what,
        obj_type_friendly(x, value = show_value, length = show_length)
    )
    abort(message, ..., call = call, arg = arg)
}

#' @importFrom rlang is_missing
assert_number_decimal <- function(x,
                                  ...,
                                  min = NULL,
                                  max = NULL,
                                  allow_infinite = TRUE,
                                  allow_na = FALSE,
                                  allow_null = FALSE,
                                  arg = caller_arg(x),
                                  call = caller_env()) {
    if (is_missing(x)) {
        exit_code <- IS_NUMBER_false
    } else if (0 == (exit_code <- .rlang_check_number(
        x,
        allow_decimal = TRUE,
        min = min,
        max = max,
        allow_infinite = allow_infinite,
        allow_na = allow_na,
        allow_null = allow_null
    ))) {
        return(invisible(NULL))
    }

    .stop_not_number(
        x,
        ...,
        exit_code = exit_code,
        allow_decimal = TRUE,
        min = min,
        max = max,
        allow_na = allow_na,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

#' @importFrom rlang is_missing
assert_number_whole <- function(x,
                                ...,
                                min = NULL,
                                max = NULL,
                                allow_infinite = FALSE,
                                allow_na = FALSE,
                                allow_null = FALSE,
                                arg = caller_arg(x),
                                call = caller_env()) {
    if (is_missing(x)) {
        exit_code <- IS_NUMBER_false
    } else if (0 == (exit_code <- .rlang_check_number(
        x,
        allow_decimal = FALSE,
        min = min,
        max = max,
        allow_infinite = allow_infinite,
        allow_na = allow_na,
        allow_null = allow_null
    ))) {
        return(invisible(NULL))
    }

    .stop_not_number(
        x,
        ...,
        exit_code = exit_code,
        allow_decimal = FALSE,
        min = min,
        max = max,
        allow_na = allow_na,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

#' @importFrom rlang ffi_standalone_is_bool_1.0.7
assert_bool <- function(x,
                        ...,
                        allow_na = FALSE,
                        allow_null = FALSE,
                        arg = caller_arg(x),
                        call = caller_env()) {
    if (!missing(x) && .rlang_check_bool(x, allow_na, allow_null)) {
        return(invisible(NULL))
    }

    stop_input_type(
        x,
        c("`TRUE`", "`FALSE`"),
        ...,
        allow_na = allow_na,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

# atomic vector ------------------------------------
#' @importFrom rlang abort
assert_character <- function(x,
                             ...,
                             allow_na = TRUE,
                             allow_null = FALSE,
                             arg = caller_arg(x),
                             call = caller_env()) {
    if (!missing(x)) {
        if (is.character(x)) {
            if (!allow_na && anyNA(x)) {
                abort(
                    sprintf("`%s` can't contain NA values.", arg),
                    arg = arg, call = call
                )
            }
            return(invisible(NULL))
        }

        if (allow_null && is.null(x)) {
            return(invisible(NULL))
        }
    }
    stop_input_type(
        x,
        "a character vector",
        ...,
        allow_na = FALSE,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

#' @importFrom rlang abort
assert_logical <- function(x,
                           ...,
                           allow_na = TRUE,
                           allow_null = FALSE,
                           arg = caller_arg(x),
                           call = caller_env()) {
    if (!missing(x)) {
        if (is.logical(x)) {
            if (!allow_na && anyNA(x)) {
                abort(
                    sprintf("`%s` can't contain NA values.", arg),
                    arg = arg, call = call
                )
            }
            return(invisible(NULL))
        }
        if (allow_null && is.null(x)) {
            return(invisible(NULL))
        }
    }

    stop_input_type(
        x,
        "a logical vector",
        ...,
        allow_na = FALSE,
        allow_null = allow_null,
        arg = arg,
        call = call
    )
}

# S3 object ----------------------------------------
#' @importFrom rlang is_string is_missing
assert_s3_class <- function(x, is_class, what, ...,
                            arg = caller_arg(x),
                            call = caller_env()) {
    if (is.character(is_class)) {
        class <- is_class
        is_class <- function(x) inherits(x, what = class)
        if (is_missing(what)) what <- sprintf("a <%s>", class)
    }
    assert_(
        x = x, check = is_class,
        what = what,
        ...,
        arg = arg, call = call
    )
}

# nocov end

#' Reorder or Group observations based on hierarchical clustering
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' This function aligns observations within the layout according to a
#' hierarchical clustering tree, enabling reordering or grouping of elements
#' based on clustering results.
#'
#' @param data A matrix-like object. By default, it inherits from the layout
#'   `matrix`.
#' @inheritParams align
#' @inheritParams hclust2
#' @param reorder_dendrogram A single boolean value indicating whether to
#' reorder the dendrogram based on the means. Alternatively, you can provide a
#' custom function that accepts an [`hclust`][stats::hclust] object and the data
#' used to generate the tree, returning either an [`hclust`][stats::hclust] or
#' [`dendrogram`][stats::as.dendrogram] object. Default is `FALSE`.
#' @param reorder_group A single boolean value, indicates whether we should do
#' Hierarchical Clustering between groups, only used when previous groups have
#' been established. Default: `FALSE`.
#' @param k An integer scalar indicates the desired number of groups.
#' @param h A numeric scalar indicates heights where the tree should be cut.
#' @param cutree A function used to cut the [`hclust`][stats::hclust] tree. It
#' should accept four arguments: the [`hclust`][stats::hclust] tree object,
#' `distance` (only applicable when `method` is a string or a function for
#' performing hierarchical clustering), `k` (the number of clusters), and `h`
#' (the height at which to cut the tree). By default,
#' [`cutree()`][stats::cutree()] is used.
#' @inheritSection align Discrete Axis Alignment
#' @seealso [`hclust2()`]
#' @examples
#' # align_hclust won't add a dendrogram
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     align_hclust(k = 3L)
#' @export
align_hclust <- function(distance = "euclidean",
                         method = "complete",
                         use_missing = "pairwise.complete.obs",
                         reorder_dendrogram = FALSE,
                         reorder_group = FALSE,
                         k = NULL, h = NULL, cutree = NULL,
                         data = NULL, active = NULL) {
    assert_active(active)
    active <- update_active(active, new_active(use = FALSE))
    .align_hclust(
        align = AlignHclust,
        distance = distance,
        method = method,
        use_missing = use_missing,
        reorder_dendrogram = reorder_dendrogram,
        reorder_group = reorder_group,
        k = k, h = h, cutree = cutree, data = data, active = active
    )
}

.align_hclust <- function(align, ..., plot = NULL,
                          distance = "euclidean",
                          method = "complete",
                          use_missing = "pairwise.complete.obs",
                          reorder_dendrogram = FALSE,
                          reorder_group = FALSE,
                          k = NULL, h = NULL, cutree = NULL,
                          data = NULL, schemes = NULL, active = NULL,
                          call = caller_call()) {
    reorder_dendrogram <- allow_lambda(reorder_dendrogram)
    if (!rlang::is_bool(reorder_dendrogram) &&
        !is.null(reorder_dendrogram) &&
        !is.function(reorder_dendrogram)) {
        cli_abort(
            "{.arg reorder_dendrogram} must be a single boolean value or a function",
            call = call
        )
    }
    assert_number_whole(k, allow_null = TRUE, call = call)
    assert_number_decimal(h, allow_null = TRUE, call = call)
    assert_bool(reorder_group, call = call)
    cutree <- allow_lambda(cutree)
    assert_(cutree, is.function, "a function", allow_null = TRUE, call = call)
    if (inherits(method, "hclust")) {
        if (vec_size(.subset2(method, "order")) == 0L) {
            cli_abort("{.cls hclust} defined in {.arg method} cannot be empty",
                call = call
            )
        }
    } else if (inherits(method, "dendrogram")) {
        if (stats::nobs(method) == 0L) {
            cli_abort(
                "{.cls dendrogram} defined in {.arg method} cannot be empty",
                call = call
            )
        }
    }

    if (isTRUE(reorder_dendrogram)) {
        reorder_dendrogram <- function(tree, data) {
            if (!inherits(tree, "dendrogram")) {
                tree <- stats::as.dendrogram(tree)
            }
            reorder(x = tree, wts = rowMeans(data), agglo.FUN = mean)
        }
    } else if (is.function(reorder_dendrogram)) {
        user_reorder <- reorder_dendrogram
        reorder_dendrogram <- function(tree, data) {
            # we ensure, what we input for user is a `hclust` object.
            if (!inherits(tree, "hclust")) tree <- stats::as.hclust(tree)
            ans <- user_reorder(tree, data)
            if (!inherits(ans, "hclust") &&
                !inherits(ans, "dendrogram")) {
                cli_abort(
                    "{.fn reorder_dendrogram} must return a {.cls hclust} or {.cls dendrogram} object",
                    call = call
                )
            }
            ans
        }
    }

    align(
        align = align,
        distance = distance, method = method,
        use_missing = use_missing,
        reorder_dendrogram = reorder_dendrogram,
        reorder_group = reorder_group,
        k = k, h = h, cutree = cutree,
        active = active,
        ..., # additional fields to be added, used by align_dendro
        schemes = schemes %||% default_schemes(),
        data = data,
        plot = plot,
        call = call
    )
}

#' @importFrom ggplot2 ggproto aes
AlignHclust <- ggproto("AlignHclust", CraftAlign,
    interact_layout = function(self, layout) {
        if (inherits(self$method, "hclust") ||
            inherits(self$method, "dendrogram")) {
            layout <- ggproto_parent(CraftAlign, self)$interact_layout(layout)
            if (inherits(self$method, "hclust")) {
                nobs <- vec_size(.subset2(self$method, "order"))
            } else {
                nobs <- stats::nobs(self$method)
            }

            if (is.null(layout_nobs <- .subset2(layout@design, "nobs"))) {
                layout@design["nobs"] <- list(nobs)
            } else {
                assert_mismatch_nobs(self, layout_nobs, nobs, arg = "method")
            }
        } else {
            layout <- ggproto_parent(AlignOrder2, self)$interact_layout(layout)
        }

        # initialize the internal parameters
        self$multiple_tree <- FALSE
        self$height <- NULL
        self$panel <- NULL
        layout
    },
    compute = function(self, panel, index) {
        if (!is.null(self$data) && vec_size(self$data) < 2L) {
            cli_abort(c(
                "Cannot do Hierarchical Clustering",
                i = "must have >= 2 observations to cluster"
            ), call = self$call)
        }

        # if the old panel exist, we do sub-clustering
        if (!is.null(panel) && is.null(self$k) && is.null(self$h) &&
            is.null(self$cutree)) {
            # in this way, we prevent sub-clustering
            if (inherits(self$method, "hclust") ||
                inherits(self$method, "dendrogram")) {
                cli_abort(
                    "{.arg method} cannot be a {.cls hclust} or {.cls dendrogram} when previous layout panel groups exist",
                    call = self$call
                )
            }
            children <- vector("list", nlevels(panel))
            names(children) <- levels(panel)
            labels <- vec_names(self$data)

            # we do clustering within each group ---------------
            for (g in levels(panel)) {
                idx <- which(panel == g)
                gdata <- vec_slice(self$data, idx)
                if (vec_size(gdata) == 1L) {
                    children[[g]] <- tree_one_node(idx, .subset(labels, idx))
                } else {
                    child <- stats::as.dendrogram(hclust2(
                        gdata,
                        distance = self$distance,
                        method = self$method,
                        use_missing = self$use_missing
                    ))
                    # we restore the actual index of the original matrix
                    child <- stats::dendrapply(child, function(x) {
                        if (stats::is.leaf(x)) {
                            ans <- .subset(idx, x)
                            attributes(ans) <- attributes(x)
                            ans
                        } else {
                            x
                        }
                    })
                    if (is.function(self$reorder_dendrogram)) {
                        child <- self$reorder_dendrogram(child, gdata)
                    }
                    children[[g]] <- child
                }
            }
            return(children) # can be a list of `dendrogram` or `hclust` or mix
        }
        hclust2(self$data, self$distance, self$method, self$use_missing)
    },
    #' @importFrom stats order.dendrogram
    align = function(self, panel, index) {
        statistics <- self$statistics
        if (!is.null(panel) && is.null(self$k) && is.null(self$h) &&
            is.null(self$cutree)) {
            # reordering the dendrogram ------------------------
            if (nlevels(panel) > 1L && self$reorder_group) {
                parent_levels <- levels(panel)
                parent_data <- t(sapply(parent_levels, function(g) {
                    colMeans(vec_slice(self$data, panel == g), na.rm = TRUE)
                }))
                rownames(parent_data) <- parent_levels
                parent <- hclust2(
                    parent_data,
                    distance = self$distance,
                    method = self$method,
                    use_missing = self$use_missing
                )
                # reorder parent based on the parent tree
                if (is.function(self$reorder_dendrogram)) {
                    parent <- self$reorder_dendrogram(parent, parent_data)
                }
                # we always ensure the parent is a dendrogram
                # since we'll call `merge_dendrogram()` which requires a
                # dendrogram
                parent <- stats::as.dendrogram(parent)
                panel <- factor(panel, parent_levels[order.dendrogram(parent)])
                # we don't cutree, so we won't draw the height line
                # self$draw_params$height <- attr(ans, "cutoff_height")
            } else {
                parent <- NULL
            }

            # merge children tree ------------------------------
            if (nlevels(panel) == 1L) {
                statistics <- .subset2(statistics, 1L)
            } else if (isTRUE(self$merge_dendro)) {
                # we have a function named merge_dendrogram(), so we use
                # `merge_dendro` as the argument name
                # `merge_dendrogram` will follow the order of the parent
                statistics <- lapply(statistics, stats::as.dendrogram)
                statistics <- merge_dendrogram(parent, statistics)
            } else {
                # if no parent tree, and we havn't merged the tree
                # we must manually reorder the dendrogram
                if (!is.null(parent)) {
                    statistics <- .subset(statistics, levels(panel))
                }
                self$multiple_tree <- TRUE
            }
        } else {
            # hclust2() will attach the distance used
            distance <- attr(statistics, "distance")
            if (is.function(self$reorder_dendrogram)) {
                statistics <- self$reorder_dendrogram(statistics, self$data)
            }
            if (!is.null(self$k) || !is.null(self$h) || !is.null(self$cutree)) {
                if (is.null(cutree <- self$cutree)) {
                    cutree <- function(tree, dist, k, h) {
                        if (!is.null(k)) {
                            stats::cutree(tree, k = k)
                        } else {
                            stats::cutree(tree, h = h)
                        }
                    }
                }
                # we need `hclust` object to cutree
                statistics <- stats::as.hclust(statistics)
                panel <- cutree(statistics, distance, self$k, self$h)
                # For `cutree`, we always respect the height user specified
                # For user defined function, we always calculate
                # height from the number of `panels`
                if (isTRUE(self$plot_cut_height)) {
                    self$height <- self$h %||% cutree_k_to_h(
                        statistics, vec_unique_count(panel)
                    )
                }
            }
        }
        # save the modified `statistics`
        self$statistics <- statistics
        if (self$multiple_tree) {
            index <- unlist(lapply(statistics, order2), FALSE, FALSE)
        } else {
            index <- order2(statistics)
        }
        # reorder panel factor levels to following the dendrogram order
        if (!is.null(panel)) {
            panel <- factor(panel, unique(panel[index]))
            # save panel information, in case of user change it
            self$panel <- panel
        }
        list(panel, index)
    },
    summary_align = function(self, ...) {
        c(TRUE, !is.null(self$k) || !is.null(self$h) || !is.null(self$cutree))
    }
)

#' Generate Tree Structures with Hierarchical Clustering
#'
#' @param matrix A numeric matrix, or data frame.
#' @param distance A string of distance measure to be used. This must be one of
#' `"euclidean"`, `"maximum"`, `"manhattan"`, `"canberra"`, `"binary"` or
#' `"minkowski"`.  Correlation coefficient can be also used, including
#' `"pearson"`, `"spearman"` or `"kendall"`. In this way, `1 - cor` will be used
#' as the distance. In addition, you can also provide a [`dist`][stats::dist]
#' object directly or a function return a [`dist`][stats::dist] object. Use
#' `NULL`, if you don't want to calculate the distance.
#' @param method A string of the agglomeration method to be used. This should be
#' (an unambiguous abbreviation of) one of `"ward.D"`, `"ward.D2"`, `"single"`,
#' `"complete"`, `"average"` (= UPGMA), `"mcquitty"` (= WPGMA), `"median"` (=
#' WPGMC) or `"centroid"` (= UPGMC). You can also provide a function which
#' accepts the calculated distance (or the input matrix if `distance` is `NULL`)
#' and returns a [`hclust`][stats::hclust] object. Alternative, you can supply
#' an object which can be coerced to [`hclust`][stats::hclust].
#' @param use_missing An optional character string giving a method for computing
#' covariances in the presence of missing values. This must be (an abbreviation
#' of) one of the strings `"everything"`, `"all.obs"`, `"complete.obs"`,
#' `"na.or.complete"`, or `"pairwise.complete.obs"`. Only used when `distance`
#' is a correlation coefficient string.
#' @seealso
#'  - [cor()][stats::cor]
#'  - [dist()][stats::dist]
#'  - [hclust()][stats::hclust]
#' @examples
#' hclust2(dist(USArrests), method = "ward.D")
#' @return A [hclust][stats::hclust] object.
#' @importFrom rlang is_string try_fetch
#' @export
hclust2 <- function(matrix, distance = "euclidean", method = "complete",
                    use_missing = "pairwise.complete.obs") {
    method <- allow_lambda(method)
    if (!is_string(method) && !is.function(method)) {
        ans <- try_fetch(
            stats::as.hclust(method),
            error = function(cnd) {
                cli_abort(paste(
                    "{.arg method} can only be a {.cls string},",
                    "{.cls function} or an object which can be coerced to",
                    "{.cls hclust}."
                ), parent = cnd)
            }
        )
        return(ans)
    }
    if (is.null(distance)) {
        d <- matrix
    } else {
        d <- make_dist(matrix, distance, use_missing)
    }
    if (is_string(method)) {
        ans <- stats::hclust(d, method = method)
    } else if (is.function(method)) {
        ans <- method(d)
        ans <- try_fetch(
            stats::as.hclust(ans),
            error = function(cnd) {
                cli_abort(paste(
                    "{.arg method} must return an object which",
                    "can be coerced to {.cls hclust}"
                ), parent = cnd)
            }
        )
    }
    if (!is.null(distance)) attr(ans, "distance") <- d
    ans
}

#' @importFrom rlang arg_match0
make_dist <- function(matrix, distance, use_missing,
                      arg = caller_arg(distance), call = caller_call()) {
    distance <- allow_lambda(distance)
    if (is_string(distance)) {
        distance <- arg_match0(distance, c(
            "euclidean", "maximum", "manhattan", "canberra",
            "binary", "minkowski", "pearson", "spearman", "kendall"
        ), arg_nm = arg, error_call = call)
        d <- switch(distance,
            euclidean = ,
            maximum = ,
            manhattan = ,
            canberra = ,
            binary = ,
            minkowski = stats::dist(matrix, method = distance),
            pearson = ,
            spearman = ,
            kendall = stats::as.dist(
                1 - stats::cor(t(matrix), use = use_missing, method = distance)
            ),
            cli_abort("Unsupported {.arg {arg}} specified", call = call)
        )
    } else if (is.function(distance)) {
        if (!inherits(d <- distance(matrix), "dist")) {
            cli_abort(
                "{.arg {arg}} must return a {.cls dist} object",
                call = call
            )
        }
    } else if (inherits(distance, "dist")) {
        d <- distance
    } else {
        cli_abort(paste(
            "{.arg {arg}} can only be a {.cls string}, {.cls dist}",
            "object, or a {.cls function} return {.cls dist}"
        ), call = call)
    }
    d
}

cutree_k_to_h <- function(tree, k) {
    if (is.null(n1 <- nrow(tree$merge)) || n1 < 1) {
        cli_abort("invalid {.arg tree} ({.field merge} component)")
    }
    n <- n1 + 1
    if (is.unsorted(tree$height)) {
        cli_abort(
            "the 'height' component of 'tree' is not sorted (increasingly)"
        )
    }
    mean(tree$height[c(n - k, n - k + 1L)])
}

#' Plot Phylogenetics tree
#'
#' @param phylo A [`phylo`][ape::as.phylo] object.
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' [`geom_segment()`][ggplot2::geom_segment].
#' @param ladderize A single string of `r oxford_or(c("left", "right"))`,
#' indicating whether to ladderize the tree. Ladderizing arranges the tree so
#' that the smallest clade is positioned on the `"right"` or the `"left"`. By
#' default, `NULL` means the tree will not be ladderized.
#' @inheritParams fortify_data_frame.phylo
#' @inheritParams ggalign
#' @export
align_phylo <- function(phylo, ..., ladderize = NULL, type = "rectangle",
                        center = FALSE, tree_type = NULL,
                        no_axes = NULL, active = NULL,
                        size = NULL) {
    if (!is.null(ladderize)) {
        ladderize <- arg_match0(ladderize, c("left", "right"))
        rlang::check_installed("ape", "to ladderize phylogenetics tree")
    }
    assert_s3_class(phylo, "phylo")
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    align(
        align = AlignPhylo,
        phylo = phylo,
        ladderize = ladderize,
        no_axes = no_axes,
        plot = ggplot() +
            ggplot2::geom_segment(
                mapping = aes(
                    x = .data$x, y = .data$y,
                    xend = .data$xend, yend = .data$yend
                ),
                ...,
                stat = "identity",
                data = function(data) ggalign_attr(data, "edge")
            ),
        data_params = list(type = type, center = center, tree_type = tree_type),
        active = active,
        size = size
    )
}

AlignPhylo <- ggproto("AlignPhylo", CraftAlign,
    interact_layout = function(self, layout) {
        layout <- ggproto_parent(CraftAlign, self)$interact_layout(layout)

        # we keep the names from the layout data for usage
        tip_labels <- self$phylo$tip.label
        if (is.null(tip_labels)) {
            cli_abort(
                "{.arg phylo} must have tip labels to match the layout data",
                call = self$call
            )
        } else if (vec_duplicate_any(tip_labels)) {
            cli_abort(
                "{.arg phylo} cannot have duplicated tip labels",
                call = self$call
            )
        }

        # we ensure the layout data has names to match the phylo tree
        if (is.null(layout_labels <- vec_names(layout@data))) {
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s", object_name(self),
                    self$layout_name
                ),
                i = sprintf(
                    "%s has no labels (rownames) to match {.arg phylo}",
                    self$layout_name
                )
            ))
        } else if (vec_duplicate_any(layout_labels)) {
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s", object_name(self),
                    self$layout_name
                ),
                i = sprintf("%s has duplicated labels", self$layout_name)
            ))
        }
        assert_mismatch_nobs(
            self, .subset2(layout@design, "nobs"), vec_size(tip_labels),
            arg = "phylo"
        )

        # we keep the names from the layout data for usage
        self$labels <- layout_labels
        layout
    },
    compute = function(self, panel, index) {
        phylo <- self$phylo
        # R CMD check won't give error even we don't add `ape` to the dependency
        if (!is.null(self$ladderize)) {
            phylo <- ape::ladderize(phylo,
                right = identical(self$ladderize, "right")
            )
        }
        inject(fortify_data_frame.phylo(
            data = phylo, !!!self$data_params,
            data_arg = "phylo", call = self$call
        ))
    },
    align = function(self, panel, index) {
        data <- self$statistics
        tip <- vec_slice(data, .subset2(data, "tip"))
        ordered <- .subset2(tip, "label")[order(.subset2(tip, "x"))]
        index <- match(ordered, self$labels)
        if (!is.null(panel) && nlevels(panel) > 1L &&
            !all(index == reorder_index(panel, index))) {
            layout_name <- self$layout_name
            object_name <- object_name(self)
            cli_abort(c(
                sprintf("Cannot add %s to %s", object_name, layout_name),
                i = sprintf(
                    "Group of %s will disrupt the ordering index of %s", layout_name, object_name
                )
            ), call = self$call)
        }
        list(panel, index)
    },
    setup_plot = function(self, plot) {
        ggadd_default(plot, aes(x = .data$x, y = .data$y)) + switch_direction(
            self$direction,
            ggplot2::labs(x = "timing"),
            ggplot2::labs(y = "timing")
        )
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (!is.null(panel <- .subset2(design, "panel")) &&
            nlevels(panel) > 1L) {
            layout_name <- self$layout_name
            object_name <- object_name(self)
            cli_abort(c(
                sprintf("Cannot add %s to %s", object_name, layout_name),
                i = sprintf("%s cannot span multiple panels", object_name)
            ))
        }

        data <- self$statistics
        edge <- ggalign_attr(data, "edge")
        node <- data
        node$.panel <- unique(panel)
        edge$.panel <- unique(panel)

        # add names
        if (!is.null(node$label)) {
            node$.names <- node$label
        }
        if (!is.null(edge$label)) {
            edge$.names <- edge$label
        }
        if (is_horizontal(self$direction)) {
            edge <- rename(
                edge,
                c(x = "y", xend = "yend", y = "x", yend = "xend")
            )
            node <- rename(node, c(x = "y", y = "x"))
        }
        plot <- gguse_data(plot, ggalign_data_set(node, edge = edge))
        position <- self$position
        if (!self$in_linear || # for circular layout
            # for top annotation, reverse y-axis
            (!is.null(position) && position == "top")) {
            plot <- reverse_continuous_axis(plot, "y")
        } else if (!is.null(position) && position == "right") {
            # for right annotation, reverse x-axis
            plot <- reverse_continuous_axis(plot, "x")
        }

        # always turn off clip, this is what dendrogram dependends on
        old_coord <- plot$coordinates
        if (!identical(old_coord$clip, "off")) {
            # to prevent from changing the input of user.
            plot$coordinates <- ggproto(NULL, old_coord, clip = "off")
        }
        plot
    },
    summary_align = function(self) c(TRUE, FALSE)
)

#' 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
#' names will also be the tip labels.
#' @family fortify_matrix
#' @export
fortify_matrix.phylo <- function(data, ..., data_arg = caller_arg(data),
                                 call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    if (is.null(labels <- data$tip.label)) {
        cli_abort(
            "{.arg {data_arg}} must have tip labels to match the layout data",
            call = call
        )
    }
    as.matrix(vec_set_names(labels, labels))
}

#' @inherit fortify_data_frame.default title description
#' @inheritParams rlang::args_dots_empty
#' @inheritParams fortify_data_frame.dendrogram
#' @param tree_type A single string, one of
#' `r oxford_or(c("phylogram", "cladogram"))`, indicating the type of tree.
#' - `phylogram`: Represents a phylogenetic tree where branch lengths indicate
#'   evolutionary distance or time.
#' - `cladogram`: Represents a tree where branch lengths are not used, or the
#'   branches do not reflect evolutionary time.
#'
#' Usually, you don't need to modify this.
#'
#' @param tip_pos The x-coordinates of the tip. Must be the same length
#' of the number of tips in `tree`.
#' @return A `data frame` with the node coordinates:
#'   - `.index`: the original index in the tree for the the tip/node.
#'   - `label`: the tip/node label text.
#'   - `x` and `y`: x-axis and y-axis coordinates for the tip/node.
#'   - `tip`: A logical value indicates whether current node is a tip.
#' @section ggalign attributes:
#'  `edge`: A `data frame` for edge coordinates:
#'
#'  - `x` and `y`: x-axis and y-axis coordinates for the start node of the edge.
#'  - `xend` and `yend`: the x-axis and y-axis coordinates of the terminal node
#'                       for edge.
#' @family fortify_data_frame
#' @export
fortify_data_frame.phylo <- function(data, ..., type = "rectangle",
                                     center = FALSE,
                                     tree_type = NULL, tip_pos = NULL,
                                     data_arg = NULL, call = NULL) {
    call <- call %||% current_call()
    data_arg <- data_arg %||% "data"
    rlang::check_dots_empty(call = call)
    type <- arg_match0(type, c("rectangle", "triangle"))
    rectangle <- type == "rectangle"
    edge <- data$edge
    edge_lengths <- data$edge.length
    if (!is.null(tree_type)) {
        tree_type <- arg_match0(tree_type,
            c("phylogram", "cladogram"),
            error_call = call
        )
        if (tree_type == "phylogram" && is.null(edge_lengths)) {
            cli_warn(c(
                "Cannot use {.code tree_type = 'phylogram'}",
                "No branch length found in {.arg {data_arg}}"
            ))
            tree_type <- "cladogram"
        }
    }
    if (identical(tree_type, "cladogram")) {
        edge_lengths <- NULL
    }
    parent <- edge[, 1L, drop = TRUE]
    child <- edge[, 2L, drop = TRUE]
    tip_labels <- data$tip.label
    node_labels <- data$node.label
    N <- length(tip_labels)
    if (is.null(tip_pos)) {
        tip_pos <- seq_len(N)
    } else if (length(tip_pos) != N) {
        cli_abort(
            "{.arg tip_pos} must have the same length as the number of tips in {.arg {data_arg}}",
            call = call
        )
    }
    i <- 0L # tip index
    phylo_data <- function(index, level, timing) {
        if (any(select <- parent == index)) {
            # recursively for each child
            data <- list(index = child[select])
            # if we have edge length, timing should be available
            if (!is.null(edge_lengths)) {
                data <- c(data, list(timing = timing + edge_lengths[select]))
            }
            data <- list_transpose(.mapply(
                function(index, timing = NULL) {
                    phylo_data(index, level = level + 1L, timing = timing)
                },
                data, NULL
            ))

            # integrate the data for each child
            node <- vec_rbind(!!!.subset2(data, "node"))
            edge <- vec_rbind(!!!.subset2(data, "edge"))

            # all coordinate for direct children nodes -------------
            direct_leaves_x <- unlist(
                .subset2(data, "x"),
                recursive = FALSE, use.names = FALSE
            )
            direct_leaves_y <- unlist(
                .subset2(data, "y"),
                recursive = FALSE, use.names = FALSE
            )

            # prepare node data ------------------------------------
            # all x coordinate for children nodes ------------------
            # used if center is `TRUE`, we'll calculate the center position
            # among all children nodes
            leaves <- vec_slice(node, .subset2(node, "tip")) # all leaves

            # x coordinate for current node: the midpoint
            if (center) {
                x <- sum(range(.subset2(leaves, "x"))) / 2L
            } else {
                x <- sum(range(direct_leaves_x)) / 2L
            }

            # y coordinate for current node
            if (is.null(edge_lengths) && is.null(timing)) {
                y <- min(direct_leaves_y) * level / (level + 1L)
            } else {
                y <- timing
            }

            # there is no node data for the root
            node <- vec_rbind(data_frame0(
                .index = index,
                label = node_labels[index - N],
                x = x, y = y, tip = FALSE
            ), node)

            # if it's the `rectangle`
            if (rectangle) {
                # vertical lines
                vertical_lines <- data_frame0(
                    x = direct_leaves_x,
                    xend = direct_leaves_x,
                    y = y,
                    yend = direct_leaves_y
                )
                added_edge <- vec_rbind(
                    vertical_lines,
                    # horizontal line
                    data_frame0(
                        x = x,
                        xend = direct_leaves_x,
                        y = y,
                        yend = y
                    )
                )
            } else {
                added_edge <- data_frame0(
                    x = x,
                    xend = direct_leaves_x,
                    y = y,
                    yend = direct_leaves_y
                )
            }
            if (is.null(edge)) {
                edge <- added_edge
            } else {
                edge <- vec_rbind(added_edge, edge)
            }
            list(node = node, edge = edge, x = x, y = y)
        } else if (any(select <- child == index)) { # for the tip
            i <<- i + 1L
            x <- tip_pos[i]
            if (is.null(edge_lengths)) {
                y <- 1L
            } else {
                y <- timing
            }

            list(
                node = data_frame0(
                    .index = index,
                    label = tip_labels[index],
                    x = x,
                    y = y,
                    tip = TRUE
                ),
                edge = NULL,
                x = x, y = y
            )
        } else {
            cli_abort("Invalid {.cls phylo} provided in {.arg {data_arg}}",
                call = call
            )
        }
    }

    # from ape::is.rooted, this should be the most ancester
    ans <- phylo_data(N + 1L, 0L, timing = 0)
    ggalign_data_set(.subset2(ans, "node"), edge = .subset2(ans, "edge"))
}

#' Helper function to create pairs of observation groups
#'
#' @description
#' [`ggmark()`] and [`cross_link()`] allow users to add links between
#' observations. These functions help define the linked observations. The
#' selected pairs will either be linked together, or each group in the pair will
#' be linked separately to the same plot area.
#'
#' - `pair_links`: Helper function to create pairs of observation groups.
#' - `range_link`: Helper function to create a range of observations.
#'
#' @param ... <[dyn-dots][rlang::dyn-dots]> A list of formulas, where each side
#'   of the formula should be an `integer` or `character` index of the original
#'   data, or a `range_link()` object defining the linked observations. Use
#'   `NULL` to indicate no link on that side. You can also combine these by
#'   wrapping them into a single `list()`. If only the left-hand side of the
#'   formula exists, you can input it directly. For integer indices, wrap them
#'   with [`I()`] to use the ordering from the layout. You can also use
#'   [`waiver()`][ggplot2::waiver()] to inherit values from the other group.
#' @param .handle_missing A string of `r oxford_or(c("error", "remove"))`
#' indicates the action for handling missing observations.
#' @param .reorder A string of `r oxford_or(c("hand1", "hand2"))` indicating
#'   whether to reorder the input links to follow the specified layout ordering.
#' @examples
#' x <- pair_links(
#'     # group on the left hand only
#'     c("a", "b"),
#'     # normally, integer index will be interpreted as the index of the
#'     # origianl data
#'     1:2,
#'     # wrapped with `I()` indicate` the integer index is ordering of the
#'     # layout
#'     I(1:2),
#'     range_link(1, 6),
#'     range_link("a", "b"),
#'     # group on the right hand only
#'     ~ 1:2,
#'     ~ c("a", "b"),
#'     ~ range_link(1, 6),
#'     # group on the both side
#'     range_link(1, 6) ~ c("a", "b"),
#'     # waiver() indicates the right hand is the same of the left hand
#'     range_link(1, 6) ~ waiver(),
#'     # the same for the left hand
#'     waiver() ~ 1:2,
#'     ~NULL # an empty link
#' )
#' x
#'
#' # we can modify it as usual list
#' x[[1]] <- NULL # remove the first link
#' x$a <- ~LETTERS
#' x
#'
#' # modify with a list
#' x[1:2] <- list(~ c("a", "b"), ~ range_link("a", "b"))
#' x
#' @export
pair_links <- function(..., .handle_missing = "error", .reorder = NULL) {
    .handle_missing <- arg_match0(.handle_missing, c("error", "remove"))
    if (!is.null(.reorder)) {
        .reorder <- arg_match0(.reorder, c("hand1", "hand2"))
    }
    pairs <- rlang::dots_list(..., .ignore_empty = "all", .named = NULL)
    new_pair_links(
        lapply(pairs, as_pair_link, x_arg = "...", call = current_call()),
        handle_missing = .handle_missing, reorder = .reorder
    )
}

new_pair_links <- function(x = list(), ..., class = character()) {
    new_vctr(x, ..., class = c(class, "ggalign_pair_links"))
}

#' @export
obj_print_header.ggalign_pair_links <- function(x, ...) {
    cat("<", vec_ptype_full(x), ">", "\n", sep = "")
    cat(
        sprintf(
            "A total of %d pair%s of link groups",
            vec_size(x), if (vec_size(x) > 1L) "s" else ""
        ),
        "\n",
        sep = ""
    )
    invisible(x)
}

#' @export
obj_print_data.ggalign_pair_links <- function(x, ...) {
    if (vec_size(x) > 0L) {
        hand1 <- vapply(x, function(hand) {
            deparse_link(hand, ..., hand = "hand1")
        }, character(1L), USE.NAMES = FALSE)
        hand2 <- vapply(x, function(hand) {
            deparse_link(hand, ..., hand = "hand2")
        }, character(1L), USE.NAMES = FALSE)
        nms <- c("", paste0(names_or_index(x), ":  "))
        nms <- format(nms, justify = "right")
        empty <- character(vec_size(hand2))
        empty[hand1 == "" & hand2 == ""] <- "  <empty>"
        empty <- format(c("", empty), justify = "left")
        hand1 <- format(c("hand1", hand1), justify = "right")
        hand2 <- format(c("hand2", hand2), justify = "left")
        cat("\n")
        cat(paste0("  ", nms, hand1, " ~ ", hand2, empty), sep = "\n")
        cat("\n")
    }
    invisible(x)
}

#' @export
obj_print_footer.ggalign_pair_links <- function(x, ...) {
    NextMethod()
    # `lengths`: will call `length.ggalign_pair_link()` method
    n <- sum(lengths(x, use.names = FALSE))
    cat(
        sprintf(
            "A total of %d link group%s", n,
            if (n > 1L) "s" else ""
        ),
        "\n",
        sep = ""
    )
    invisible(x)
}

#' @export
`[<-.ggalign_pair_links` <- function(x, i, value) {
    value <- lapply(value, as_pair_link, x_arg = "value", call = current_call())
    NextMethod()
}

#' @export
`[[<-.ggalign_pair_links` <- function(x, i, value) {
    # let `NULL` to remove the link
    if (!is.null(value)) value <- as_pair_link(value)
    NextMethod()
}

#' @export
`$<-.ggalign_pair_links` <- function(x, i, value) {
    # let `NULL` to remove the link
    if (!is.null(value)) value <- as_pair_link(value)
    NextMethod()
}

#' @export
vec_ptype2.ggalign_pair_links.list <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.list.ggalign_pair_links <- function(x, y, ...) {
    y
}

#' @export
vec_cast.ggalign_pair_links.list <- function(x, to, ...,
                                             x_arg = caller_arg(x),
                                             to_arg = "",
                                             call = caller_env()) {
    new_pair_links(lapply(x, as_pair_link, x_arg = x_arg, call = call))
}

#########################################################
#' @param point1,point2 A single integer or character index, defining the lower
#'   and higher bounds of the range. For integer indices, wrap them with [`I()`]
#'   to indicate the ordered index by the layout.
#' @export
#' @rdname pair_links
range_link <- function(point1, point2) {
    if (!is_scalar(point1) ||
        (!is.character(point1) && !is.numeric(point1))) {
        cli_abort("{.arg point1} must be a single numeric or character index")
    }
    if (!is_scalar(point2) ||
        (!is.character(point2) && !is.numeric(point2))) {
        cli_abort("{.arg point2} must be a single numeric or character index")
    }
    point1 <- as_obs_link(point1)
    point2 <- as_obs_link(point2)
    structure(list(point1 = point1, point2 = point2),
        class = "ggalign_range_link"
    )
}

is_range_link <- function(x) inherits(x, "ggalign_range_link")

########################################################
new_pair_link <- function(hand1 = NULL, hand2 = NULL,
                          ..., class = character()) {
    structure(
        .Data = list(hand1 = hand1, hand2 = hand2),
        ...,
        class = c(class, "ggalign_pair_link")
    )
}

#' @export
vec_proxy.ggalign_pair_link <- function(x, ...) x

#' @export
print.ggalign_pair_link <- function(x, ...) obj_print(x, ...)

#' @export
obj_print_header.ggalign_pair_link <- function(x, ...) {
    cat(sprintf("<%s>", vec_ptype_full(x)), "\n", sep = "")
    invisible(x)
}

#' @export
obj_print_data.ggalign_pair_link <- function(x, ...) {
    if (length(x) > 0L) {
        cat(c(
            sprintf("  hand1: %s", deparse_link(.subset2(x, "hand1"), ...)),
            sprintf("  hand2: %s", deparse_link(.subset2(x, "hand2"), ...))
        ), sep = "\n")
    }
    invisible(x)
}

#' @param x A `ggalign_pair_link` object.
#' @noRd
#' @export
length.ggalign_pair_link <- function(x) {
    sum(!vapply(x, is.null, logical(1L), USE.NAMES = FALSE))
}

##################################################
#' @export
vec_ptype2.ggalign_pair_link.ggalign_pair_link <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.ggalign_pair_link.NULL <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.NULL.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.numeric <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.numeric.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.integer <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.integer.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.double <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.double.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.character <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.character.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.formula <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.formula.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.waiver <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.waiver.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.ggalign_range_link <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.ggalign_range_link.ggalign_pair_link <- function(x, y, ...) {
    y
}

#' @export
vec_ptype2.ggalign_pair_link.AsIs <- function(x, y, ...) {
    vec_ptype2(x, remove_class(y, "AsIs"), ...)
}

#' @export
vec_ptype2.AsIs.ggalign_pair_link <- function(x, y, ...) {
    vec_ptype2(remove_class(x, "AsIs"), y, ...)
}

#' @export
vec_ptype2.ggalign_pair_link.list <- function(x, y, ...) {
    x
}

#' @export
vec_ptype2.list.ggalign_pair_link <- function(x, y, ...) {
    y
}

#############################################################
#' @export
vec_cast.ggalign_pair_link.numeric <- function(x, to, ...,
                                               x_arg = caller_arg(x),
                                               to_arg = "",
                                               call = caller_env()) {
    new_pair_link(as_obs_link(x, arg = x_arg, call = call))
}

#' @export
vec_cast.ggalign_pair_link.double <- vec_cast.ggalign_pair_link.numeric

#' @export
vec_cast.ggalign_pair_link.integer <- vec_cast.ggalign_pair_link.numeric

#' @export
vec_cast.ggalign_pair_link.character <- vec_cast.ggalign_pair_link.numeric

#' @export
vec_cast.ggalign_pair_link.ggalign_range_link <-
    vec_cast.ggalign_pair_link.integer

#' @export
vec_cast.ggalign_pair_link.list <- vec_cast.ggalign_pair_link.numeric

#' @export
vec_cast.ggalign_pair_link.AsIs <- function(x, to, ...,
                                            x_arg = caller_arg(x),
                                            to_arg = "",
                                            call = caller_env()) {
    I(vec_cast(
        remove_class(x, "AsIs"),
        to = to, ...,
        x_arg = x_arg, call = call
    ))
}

#' @export
vec_cast.ggalign_pair_link.formula <- function(x, to, ...,
                                               x_arg = caller_arg(x),
                                               to_arg = "",
                                               call = caller_env()) {
    hand1 <- rlang::eval_tidy(rlang::f_lhs(x), env = rlang::f_env(x))
    hand1 <- as_obs_link(hand1, arg = x_arg, call = call)
    hand2 <- rlang::eval_tidy(rlang::f_rhs(x), env = rlang::f_env(x))
    hand2 <- as_obs_link(hand2, arg = x_arg, call = call)
    new_pair_link(hand1, hand2)
}

as_pair_link <- function(x, ...) {
    if (is.null(x)) { # vec_cast() cannot convert `NULL`
        new_pair_link()
    } else {
        vec_cast(x, to = new_pair_link(), ...)
    }
}

########################################################
as_obs_link <- function(x, ..., arg = caller_arg(x), call = caller_env()) {
    UseMethod("as_obs_link")
}

#' @export
as_obs_link.NULL <- function(x, ...) x

#' @export
as_obs_link.AsIs <- function(x, ...) {
    I(as_obs_link(remove_class(x, "AsIs"), ...))
}

#' @export
as_obs_link.numeric <- function(x, ..., arg = caller_arg(x),
                                call = caller_env()) {
    vec_cast(x, integer(), x_arg = arg, call = call)
}

#' @export
as_obs_link.integer <- as_obs_link.NULL

#' @export
as_obs_link.double <- as_obs_link.numeric

#' @export
as_obs_link.character <- function(x, ..., arg = caller_arg(x),
                                  call = caller_env()) {
    if (any(x == "")) {
        cli_abort("empty string is not allowed", call = call)
    }
    x
}

#' @export
as_obs_link.waiver <- as_obs_link.NULL

#' @export
as_obs_link.list <- function(x, ..., arg = caller_arg(x),
                             call = caller_env()) {
    x <- x[!vapply(x, is.null, logical(1L), USE.NAMES = FALSE)]
    if (is_empty(x)) return(NULL) # styler: off
    lapply(x, as_obs_link, arg = arg, call = call)
}

#' @export
as_obs_link.ggalign_range_link <- as_obs_link.NULL

#' @export
as_obs_link.default <- function(x, ..., arg = caller_arg(x),
                                call = caller_env()) {
    stop_incompatible_cast(
        x, new_pair_link(),
        x_arg = arg, to_arg = "",
        call = call
    )
}

#' @export
print.ggalign_range_link <- function(x, ...) {
    cat(deparse_link(x))
    invisible(x)
}

###########################################################
#' @return A single string
#' @noRd
deparse_link <- function(x, ...) deparse_link2(x, ...) %||% ""

#' @return A single string or `NULL`
#' @noRd
deparse_link2 <- function(x, ...) UseMethod("deparse_link2")

# Basic object
#' @export
deparse_link2.integer <- function(x, trunc = 3L, head = trunc - 1L,
                                  tail = 1L, ...) {
    l <- length(x)
    ans <- paste(
        deparse(x, control = c("keepNA", "niceNames", "showAttributes")),
        collapse = " "
    )
    if (l > trunc && startsWith(ans, "c")) {
        ans <- sprintf("c(%s)", paste(c(
            x[seq_len(head)], "...", x[seq.int(l - tail + 1L, l)]
        ), collapse = ", "))
    }
    ans
}

#' @export
deparse_link2.character <- function(x, trunc = 3L, head = trunc - 1L,
                                    tail = 1L, ...) {
    l <- length(x)
    if (l <= trunc) {
        ans <- paste(deparse(x), collapse = " ")
    } else {
        ans <- sprintf("c(%s)", paste(c(
            x[seq_len(head)], "...", x[seq.int(l - tail + 1L, l)]
        ), collapse = ", "))
    }
    ans
}

#' @export
deparse_link2.waiver <- function(x, ...) "waiver()"

#' @export
deparse_link2.NULL <- function(x, ...) NULL

# To allow `I()` to be used to the whole formula, we must define the method for
# this, though `ggalign_pair_link` shouldn't be considered as an observation
#' @export
deparse_link2.ggalign_pair_link <- function(x, ..., hand) {
    deparse_link2(.subset2(x, hand), ...)
}

#' @export
deparse_link2.AsIs <- function(x, ...) {
    ans <- deparse_link2(remove_class(x, "AsIs"), ...)
    if (!is.null(ans)) ans <- sprintf("I(%s)", ans)
    ans
}

# Recurse version
#' @export
deparse_link2.ggalign_range_link <- function(x, ...) {
    sprintf(
        "range_link(%s, %s)",
        deparse_link(.subset2(x, "point1"), ...),
        deparse_link(.subset2(x, "point2"), ...)
    )
}

#' @export
deparse_link2.list <- function(x, trunc = 3L, head = trunc - 1L,
                               tail = 1L, ...) {
    l <- length(x)
    if (l <= trunc) {
        ans <- vapply(x, deparse_link, character(1L), ...,
            trunc = trunc, head = head, tail = tail,
            USE.NAMES = FALSE
        )
    } else {
        ans <- c(
            vapply(x[seq_len(head)],
                deparse_link, character(1L), ...,
                trunc = trunc, head = head, tail = tail,
                USE.NAMES = FALSE
            ),
            "...",
            vapply(x[seq.int(l - tail + 1L, l)],
                deparse_link, character(1L), ...,
                trunc = trunc, head = head, tail = tail,
                USE.NAMES = FALSE
            )
        )
    }
    sprintf("list(%s)", paste(ans, collapse = ", "))
}

###################################################
make_links_data <- function(links, design1, design2,
                            labels1, labels2) {
    link_index_list <- lapply(
        links, make_pair_link_index,
        design1 = design1, design2 = design2,
        labels1 = labels1, labels2 = labels2,
        handle_missing = attr(links, "handle_missing")
    )
    names(link_index_list) <- names_or_index(links)
    if (!is.null(reorder <- attr(links, "reorder"))) {
        index <- vapply(link_index_list, function(link_index) {
            if (is.null(link_index) ||
                is.null(index <- .subset2(link_index, reorder))) {
                NA_integer_
            } else {
                vec_slice(index, 1L)
            }
        }, integer(1L), USE.NAMES = FALSE)
        link_index_list <- link_index_list[order(index)]
    }
    link_index_list
}

make_pair_link_index <- function(pair_link, design1, design2,
                                 labels1, labels2, handle_missing) {
    input1 <- .subset2(pair_link, 1L)
    input2 <- .subset2(pair_link, 2L)

    # make the data
    hand1 <- make_link_index(input1,
        design = design1, labels = labels1,
        other = input2, data_index = !inherits(pair_link, "AsIs"),
        handle_missing = handle_missing
    )
    hand2 <- make_link_index(input2,
        design = design2, labels = labels2,
        other = input1, data_index = !inherits(pair_link, "AsIs"),
        handle_missing = handle_missing
    )
    if (is.null(hand1) && is.null(hand2)) {
        return(NULL)
    }
    list(hand1 = hand1, hand2 = hand2)
}

make_link_index <- function(link, design, labels, other, data_index,
                            handle_missing, arg = caller_arg(link),
                            call = caller_call()) {
    link <- link_to_location(
        link,
        n = .subset2(design, "nobs"),
        labels = labels,
        index = .subset2(design, "index"),
        other = other,
        data_index = data_index,
        handle_missing = handle_missing,
        arg = arg, call = call
    )
    if (is_empty(link)) {
        return(NULL)
    }
    # always use integer, otherwise, will cause error when drawing
    # due to loss of precision, I don't know why, it should be integer already?
    vec_unique(vec_cast(link, integer()))
}

link_to_location <- function(x, ...) UseMethod("link_to_location")

#' @export
link_to_location.AsIs <- function(x, ..., data_index) {
    link_to_location(remove_class(x, "AsIs"), ..., data_index = FALSE)
}

#' @export
link_to_location.character <- function(x, ..., n, labels, index, handle_missing,
                                       arg = caller_arg(x),
                                       call = caller_call()) {
    if (identical(handle_missing, "remove") && !is.null(labels)) {
        x <- x[x %in% labels]
    }
    ans <- vec_as_location(x, n = n, names = labels, arg = arg, call = call)
    match(ans, index) # character always match the original data
}

#' @export
link_to_location.integer <- function(x, ..., n, index, data_index,
                                     handle_missing, arg = caller_arg(x),
                                     call = caller_call()) {
    ans <- num_as_location(x,
        n = n,
        arg = arg, call = call,
        negative = "error",
        zero = "error",
        oob = handle_missing
    )
    # integer index by default match the original data
    if (isTRUE(data_index)) match(ans, index) else ans
}

#' @export
link_to_location.ggalign_range_link <- function(x, ..., arg = caller_arg(x),
                                                call = caller_call()) {
    point1 <- link_to_location(
        .subset2(x, "point1"),
        ...,
        arg = "point1",
        call = quote(range_link())
    )
    point2 <- link_to_location(
        .subset2(x, "point2"),
        ...,
        arg = "point2",
        call = quote(range_link())
    )
    point1:point2
}

#' @export
link_to_location.list <- function(x, ...) {
    unlist(lapply(x, link_to_location, ...), FALSE, FALSE)
}

#' @export
link_to_location.waiver <- function(x, ..., other) {
    link_to_location(other %|w|% NULL, ...)
}

#' @export
link_to_location.NULL <- function(x, ...) NULL

#' Set Expansion for the Layout
#'
#' @description
#' To align axes, it is important to keep the expansion consistent across all
#' plots in the layout. You can add a `layout_expand` object to the layout. For
#' the `quad_layout()` function, you must specify `x` and `y` arguments. For
#' other layouts, you can pass the expansion values using `...` directly.
#'
#' @param ... A list of range expansion constants, used to add padding around
#' the data to ensure they are placed some distance away from the axes. Use the
#' convenience function [`expansion()`][ggplot2::expansion()] to generate the
#' values.
#' @param x,y Same as `...`, but specifically for `quad_layout()`.
#'
#' @importFrom rlang list2
#' @keywords internal
layout_expand <- function(..., x = waiver(), y = waiver()) {
    if (...length() > 0L && (!is.waive(x) || !is.waive(y))) {
        cli_abort(
            "Cannot mix the usage of {.arg ...} with {.arg x}/{.arg y} argument"
        )
    }
    if (...length() > 0L) {
        ans <- list2(...)
        names(ans) <- NULL
    } else {
        ans <- list(x = x, y = y)
    }
    structure(ans, class = "ggalign_layout_expand")
}

#' Set continuous limits for the layout
#'
#' @description
#' To align continuous axes, it is important to keep the limits consistent
#' across all plots in the layout. You can set the limits by passing a function
#' directly to the `limits` or `xlim`/`ylim` argument, using `...` only.
#' Alternatively, you can add a `continuous_limits()` object to the layout. For
#' the `quad_layout()` function, you must specify `x`/`y` arguments. For other
#' layouts, you should pass the limits using `...` directly.
#'
#' @param ... A list of two numeric values, specifying the left/lower limit and
#' the right/upper limit of the scale.
#' @inheritParams layout_expand
#' @importFrom rlang list2
#' @export
continuous_limits <- function(..., x = waiver(), y = waiver()) {
    if (...length() > 0L && (!is.waive(x) || !is.waive(y))) {
        cli_abort(
            "Cannot mix the usage of {.arg ...} with {.arg x}/{.arg y} argument"
        )
    }
    if (...length() > 0L) {
        ans <- list2(...)
        names(ans) <- NULL
    } else {
        ans <- list(x = x, y = y)
    }
    structure(ans, class = c("continuous_limits", "layout_design"))
}

# layout params are used to align the observations
discrete_design <- function(panel = NULL, index = NULL, nobs = NULL) {
    structure(
        list(panel = panel, index = index, nobs = nobs),
        class = c("discrete_design", "layout_design")
    )
}

################################################################
is_continuous_design <- function(x) {
    is.null(x) || inherits(x, "continuous_limits")
}

is_discrete_design <- function(x) inherits(x, "discrete_design")

#' Layout can align ordinal variable or continuous variable
#'
#' @param x A `LayoutProto` object.
#' @noRd
is_layout_discrete <- function(x, ...) UseMethod("is_layout_discrete")

is_layout_continuous <- function(x, ...) UseMethod("is_layout_continuous")

################################################################
# Initialize the index and panel
# Reorder the panel based the ordering index and
setup_design <- function(design) {
    # for continuous axis, do noting special
    if (is_continuous_design(design)) return(design) # styler: off
    # if `nobs` is not initialized, it means no `Align` object exist
    # it's not necessary to initialize the `panel` and `index`
    # this is for `stack_layout` which may have no data
    if (is.null(nobs <- .subset2(design, "nobs"))) {
        return(design)
    }
    panel <- .subset2(design, "panel") %||% factor(rep_len(1L, nobs))
    index <- .subset2(design, "index") %||% reorder_index(panel)
    discrete_design(panel[index], index, nobs)
}

reorder_index <- function(panel, index = NULL) {
    index <- index %||% seq_along(panel)
    unlist(split(index, panel[index]), recursive = FALSE, use.names = FALSE)
}

############################################################
#' @keywords internal
update_design <- function(layout, ..., design, object_name) {
    UseMethod("update_design")
}

#' @importFrom methods slot slot<-
#' @export
update_design.QuadLayout <- function(layout, ..., direction, design,
                                     object_name) {
    slot(layout, direction) <- design
    if (is_horizontal(direction)) {
        if (!is.null(left <- layout@left)) {
            layout@left <- update_design(left,
                design = design, object_name = object_name
            )
        }
        if (!is.null(right <- layout@right)) {
            layout@right <- update_design(right,
                design = design, object_name = object_name,
                from_head = TRUE
            )
        }
    } else {
        if (!is.null(top <- layout@top)) {
            layout@top <- update_design(top,
                design = design, object_name = object_name
            )
        }
        if (!is.null(bottom <- layout@bottom)) {
            layout@bottom <- update_design(bottom,
                design = design, object_name = object_name,
                from_head = TRUE
            )
        }
    }
    layout
}

#' @importFrom methods slot slot<-
#' @export
update_design.StackLayout <- function(layout, ..., design, object_name) {
    layout@design <- design
    layout@plot_list <- lapply(layout@plot_list, function(plot) {
        if (is_craftbox(plot)) return(plot) # styler: off
        update_design(plot,
            direction = layout@direction,
            design = design
        )
    })
    layout
}

#' @export
update_design.CircleLayout <- update_design.StackLayout

#' @importFrom methods slot slot<-
#' @export
update_design.StackCross <- function(layout, ..., design, object_name,
                                     from_head = FALSE) {
    # `design` must be a discrete_design()
    design_list <- c(layout@odesign, list(layout@design))

    # for cross_points, the updating will span it, but only update the panel
    # information
    cross_points <- layout@cross_points

    # the break_points set breaks, updating won't span the break points
    break_points <- layout@break_points

    plot_list <- layout@plot_list
    n <- length(plot_list)
    points <- c(cross_points, n)
    point_index <- seq_along(points)
    if (!from_head) point_index <- rev(point_index)
    for (i in point_index) {
        cross_point <- .subset(points, i)

        # we first update the design in the updated tail
        # it means the first design when `from_head` is `TRUE`
        # the last design when `from_head` is `FALSE`
        if ((from_head && i == 1L) || (!from_head && cross_point == n)) {
            new_design <- design
        } else if (!from_head && any(cross_point == break_points)) {
            break
        } else {
            # for design not in updated tail, we'll only update `panel` and
            # `nobs`, we check the new panel doesn't break the original index
            new_nobs <- .subset2(design, "nobs")
            new_panel <- .subset2(design, "panel")
            new_design <- .subset2(design_list, i)
            # we check the new panel don't disrupt the ordering index
            if (!is.null(new_panel) &&
                !is.null(old_index <- .subset2(new_design, "index"))) {
                # we always prevent from reordering twice.
                new_index <- reorder_index(new_panel, old_index)
                if (!all(old_index == new_index)) {
                    cli_abort(sprintf(
                        "%s disrupt the previously established ordering index of %s (%d)",
                        object_name, object_name(layout), i
                    ))
                }
                new_design["index"] <- list(new_index)
            }
            new_design["nobs"] <- list(new_nobs)
            new_design["panel"] <- list(new_panel)
        }
        design_list[i] <- list(new_design)

        # we then update the design for each plot
        if (i == 1L) {
            subset <- seq_len(cross_point)
        } else {
            subset <- (.subset(points, i - 1L) + 1L):cross_point
        }

        layout@plot_list[subset] <- lapply(
            plot_list[subset], function(plot) {
                if (is_craftbox(plot)) {
                    return(plot)
                }
                update_design(plot,
                    direction = layout@direction,
                    design = new_design
                )
            }
        )
        if (from_head && any(cross_point == break_points)) break
    }
    layout@odesign <- vec_slice(design_list, seq_len(length(design_list) - 1L))
    layout@design <- design_list[[length(design_list)]]
    layout
}

############################################################
melt_discrete_design <- function(old, new, old_name, new_name,
                                 call = caller_call()) {
    old_nobs <- .subset2(old, "nobs")
    new_nobs <- .subset2(new, "nobs")
    if (is.null(new_nobs)) { # no `nobs` provided
        nobs <- old_nobs
    } else if (is.null(old_nobs)) {
        nobs <- new_nobs
    } else if (!identical(new_nobs, old_nobs)) {
        cli_abort(sprintf(
            "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
            new_name, new_nobs, old_name, old_nobs
        ), call = call)
    } else {
        nobs <- new_nobs
    }

    # check panel
    old_panel <- .subset2(old, "panel")
    new_panel <- .subset2(new, "panel")

    if (is.null(new_panel)) { # no panel provided
        panel <- old_panel
    } else if (!is.null(old_panel) && !(new_panel %nest% old_panel)) {
        cli_abort(sprintf(
            "%s disrupt the previously established panel groups of %s",
            new_name, old_name
        ), call = call)
    } else {
        panel <- new_panel
    }

    # check index
    old_index <- .subset2(old, "index")
    new_index <- .subset2(new, "index")
    if (is.null(new_index)) {
        index <- old_index
    } else {
        index <- new_index
    }

    # we always make the index following the panel
    if (!is.null(panel) && !is.null(index)) {
        index <- reorder_index(panel, index)
    }

    # we always prevent from reordering twice.
    if (!is.null(old_index) && !all(old_index == index)) {
        cli_abort(sprintf(
            "%s disrupt the previously established ordering index of %s",
            new_name, old_name
        ), call = call)
    }
    discrete_design(panel, index, nobs)
}

#######################################################################
# ggplot2 add default scales in `compute_aesthetics` process
# then ggplot2 transform all scales
#  layout:
#   in ggplot_build
#    - `setup`:
#       - call `facet$setup_params`
#       - attach `plot_env`
#       - call `facet$setup_data`
#       - call `facet$compute_layout`
#       - call `coord$setup_layout`
#       - call `facet$map_data`
#    - `train_position`: (run twice)
#       - call `facet$init_scales`
#       - call `facet$train_scales`
#    - `setup_panel_params`
#       - call `coord$modify_scales`: we align scales here, since this step
#                                     scales have been trained
#       - call `coord$setup_panel_params`: `view_scales_from_scale()`
#    - `map_position`
#    - `setup_panel_guides`
#       - call `coord$setup_panel_guides`
#       - call `coord$train_panel_guides`
#  in ggplot_gtable
#    - `layout$render`:
#         - call `facet$draw_back`
#         - call `facet$draw_front`
#         - call `coord$draw_panel` for each panel
#         - call `facet$draw_panels`: only once
#           - call `facet$init_gtable`:
#           - call `facet$attach_axes`:
#             - call `coord$render_axis_h`:
#               - call `guide$draw`:
#             - call `coord$render_axis_v`:
#               - call `guide$draw`:
#           - call `facet$attach_strips`:

#' Set `limits`, `breaks`, `labels` for each panel
#'
#' @param x,y design for the layout.
#' @keywords internal
#' @noRd
ggalign_design <- function(x = NULL, y = NULL,
                           xlabels = NULL, ylabels = NULL,
                           xlim = TRUE, ylim = TRUE) {
    structure(
        list(
            x = x, y = y,
            xlabels = xlabels, ylabels = ylabels,
            xlim = xlim, ylim = ylim
        ),
        class = "ggalign_design"
    )
}

setup_discrete_limits <- function(axis, design, n_panels) {
    panel <- .subset2(design, "panel")
    index <- .subset2(design, "index")
    if (n_panels == 1L) {
        list(range(index) + c(-0.5, 0.5))
    } else {
        # For y-axis, ggplot arrange panel from top to bottom,
        # we always choose to reverse the panel order
        if (axis == "y") panel <- fct_rev(panel)
        lapply(split(seq_along(index), panel), function(plot_index) {
            range(plot_index) + c(-0.5, 0.5)
        })
    }
}

#' @importFrom ggplot2 ggplot_add ggproto ggproto_parent
#' @export
ggplot_add.ggalign_design <- function(object, plot, object_name, ...) {
    x_design <- .subset2(object, "x")
    y_design <- .subset2(object, "y")
    if (is.null(x_design) && is.null(y_design)) {
        return(plot)
    }
    ParentCoord <- plot$coordinates
    plot$coordinates <- ggproto(
        NULL, ParentCoord,
        num_of_panels = NULL,
        panel_counter = NULL,
        n_row_panels = NULL, # should be the number of panels in y
        n_column_panels = NULL, # should be the number of panels in x
        setup_layout = function(self, layout, params) {
            # we always initialize the number of panels and a panel counter
            self$num_of_panels <- vec_unique_count(.subset2(layout, "PANEL"))
            self$panel_counter <- 0L
            self$n_column_panels <- vec_unique_count(.subset2(layout, "COL"))
            self$n_row_panels <- vec_unique_count(.subset2(layout, "ROW"))
            if (.subset2(object, "xlim") && !is.null(x_design)) {
                if (is_discrete_design(x_design)) {
                    self$xlim_list <- setup_discrete_limits(
                        "x", x_design, self$n_column_panels
                    )
                } else {
                    self$xlim_list <- x_design
                }
            }
            if (.subset2(object, "ylim") && !is.null(y_design)) {
                if (is_discrete_design(y_design)) {
                    self$ylim_list <- setup_discrete_limits(
                        "y", y_design, self$n_row_panels
                    )
                } else {
                    self$ylim_list <- y_design
                }
            }
            # call the parent method
            ggproto_parent(ParentCoord, self)$setup_layout(layout, params)
        },
        # take the tricks to modify scales in place
        modify_scales = function(self, scales_x, scales_y) {
            # for each scale, we set the `breaks` and `labels`
            if (is_discrete_design(x_design)) {
                align_discrete_scales(
                    "x", scales_x, x_design,
                    labels = .subset2(object, "xlabels"),
                    n_panels = self$n_column_panels,
                    circle_layout = inherits(ParentCoord, "CoordRadial")
                )
            }
            if (is_discrete_design(y_design)) {
                align_discrete_scales(
                    "y", scales_y, y_design,
                    labels = .subset2(object, "ylabels"),
                    n_panels = self$n_row_panels,
                    circle_layout = inherits(ParentCoord, "CoordRadial")
                )
            }
            ggproto_parent(ParentCoord, self)$modify_scales(scales_x, scales_y)
        },
        setup_panel_params = function(self, scale_x, scale_y, params = list()) {
            # `setup_panel_params()` will utilize the `limits`
            # set limits here to ensure each plot will have the same limits
            cur_panel <- self$panel_counter + 1L
            if (!is.null(self$xlim_list)) {
                xlim <- .subset2(
                    self$xlim_list,
                    recycle_whole(cur_panel, self$n_column_panels)
                )
                if (is_discrete_design(x_design) && scale_x$is_discrete() &&
                    !is.null(scale_x$range$range)) {
                    # for discrete scale, the limits starts from zero in each
                    # panel
                    xlim <- xlim - (min(xlim) - 0.5)
                }
                if (inherits(self, "CoordRadial")) {
                    self$limits$theta <- xlim
                } else {
                    self$limits$x <- xlim
                }
            }
            if (!is.null(self$ylim_list)) {
                ylim <- .subset2(
                    self$ylim_list,
                    recycle_each(cur_panel, self$n_column_panels)
                )
                if (is_discrete_design(y_design) && scale_y$is_discrete() &&
                    !is.null(scale_y$range$range)) {
                    # for discrete scale, the limits starts from zero in each
                    # panel
                    ylim <- ylim - (min(ylim) - 0.5)
                }
                if (inherits(self, "CoordRadial")) {
                    self$limits$r <- ylim
                } else {
                    self$limits$y <- ylim
                }
            }
            self$panel_counter <- cur_panel
            ggproto_parent(ParentCoord, self)$setup_panel_params(
                scale_x = scale_x, scale_y = scale_y, params = params
            )
        }
    )
    plot
}

align_discrete_scales <- function(axis, scales, design, labels, n_panels,
                                  circle_layout) {
    panel <- .subset2(design, "panel")
    index <- .subset2(design, "index")

    if (n_panels == 1L) {
        panel <- factor(vec_rep(1L, length(index)))
    } else {
        # For y-axis, ggplot arrange panel from top to bottom,
        # we always choose to reverse the panel order
        if (axis == "y") panel <- fct_rev(panel)
    }
    if (is.null(labels)) {
        data_labels <- NULL
    } else {
        data_labels <- split(labels, panel)
    }
    data_index <- split(index, panel)
    plot_index <- split(seq_along(index), panel)
    default_expand <- ggplot2::expansion()
    for (i in seq_along(scales)) {
        scale <- .subset2(scales, i)
        # we always use the discrete scale to determine labels and breaks
        # https://github.com/tidyverse/ggplot2/blob/7fb4c382f9ea332844d469663a8047355a88dd7a/R/scale-.R#L927
        # setup breaks and labels --------------------
        if (is.null(data_labels) &&
            is.waive(scale$labels) &&
            is.waive(scale$breaks)) {
            # special case for data have no labels
            # By default we also remove the breaks
            scale$breaks <- NULL
            scale$labels <- NULL
        } else {
            dindex <- .subset2(data_index, i)
            pindex <- .subset2(plot_index, i)
            labels <- .subset2(data_labels, i)
            scale$breaks <- get_discrete_breaks(scale, pindex, dindex, labels)
            scale$labels <- get_discrete_labels(
                scale, scale$breaks, pindex, dindex, labels
            )
        }

        # by default we elways remove any expansion
        # we don't allow the set of expansion for discrete variables
        # otherwise, ggmark and `cross_mark` won't work properly
        if (!circle_layout) scale$expand <- default_expand

        # for continuous scale, we don't allow the trans
        # if (!scale$is_discrete() && !identical(scale$trans$name, "identity")) {
        #     cli_warn(sprintf(
        #         "{.arg trans} must be {.field identity} in {.code %s}",
        #         deparse(scale$call)
        #     ))
        #     scale$trans <- scales::as.transform("identity")
        # }
    }
}

#' @importFrom rlang is_empty
get_discrete_breaks <- function(scale, pindex, dindex, labels) {
    if (scale$is_empty()) return(numeric()) # styler: off
    breaks <- scale$breaks
    if (identical(breaks, NA)) {
        cli_abort(c(
            "Invalid {.arg breaks} specification.",
            i = "Use {.code NULL}, not {.code NA}."
        ), call = scale$call)
    }
    if (is.null(breaks)) {
        return(NULL)
    }
    if (is.waive(breaks)) {
        if (scale$is_discrete() &&
            !is.null(labels) &&
            !is.null(scale$range$range) &&
            all(scale$range$range %in% labels)) {
            ans <- labels
        } else {
            ans <- pindex
        }
    } else {
        if (is.null(labels)) {
            limits <- dindex
        } else {
            limits <- labels
        }
        if (is.function(breaks)) {
            breaks <- breaks(limits)
        }

        if (is.factor(breaks) || is.character(breaks)) {
            # we interpreted the character breaks as the names of the original
            # matrix data.
            pos <- match(
                as.character(limits),
                vec_cast(breaks, character(),
                    x_arg = "breaks", call = scale$call
                )
            )
        } else {
            # By default, we interpreted the breaks as the data index
            # If wrapped with `I()`, we interpreted it as the plot index
            if (inherits(breaks, "AsIs")) { # plot index
                pos <- match(pindex, vec_cast(breaks, integer(),
                    x_arg = "breaks", call = scale$call
                ))
            } else { # data index
                pos <- match(dindex, vec_cast(breaks, integer(),
                    x_arg = "breaks", call = scale$call
                ))
            }
        }
        index <- which(!is.na(pos))
        if (is_empty(index)) {
            return(NULL)
        }
        pos <- pos[index]
        if (scale$is_discrete() &&
            !is.null(labels) &&
            !is.null(scale$range$range) &&
            all(scale$range$range %in% labels)) {
            ans <- structure(labels[index], index = index, pos = pos)
        } else {
            ans <- structure(pindex[index], index = index, pos = pos)
        }
    }
    ans
}

#' @importFrom rlang is_empty
get_discrete_labels <- function(scale, breaks, pindex, dindex, labels) {
    scale_labels <- scale$labels
    if (is_empty(breaks) || is.null(scale_labels)) { # if no breaks, no labels
        return(NULL)
    }

    if (identical(scale_labels, NA)) {
        cli_abort(c(
            "Invalid {.arg labels} specification.",
            i = "Use {.code NULL}, not {.code NA}."
        ), call = scale$call)
    }

    # Need to ensure that if breaks were dropped
    if (!is.null(index <- attr(breaks, "index"))) {
        dindex <- dindex[index]
        labels <- labels[index]
    }

    # if layout have no names, use the data index directly
    # re-defined the breaks, the plot use the coordinates index
    # we interpreted user input as the data index
    if (is.null(labels)) {
        user_breaks <- dindex
    } else {
        user_breaks <- labels
    }
    if (is.waive(scale_labels)) { # By default, use the breaks
        user_breaks
    } else if (is.function(scale_labels)) {
        scale_labels(user_breaks)
    } else if (!is.null(names(scale_labels))) {
        # If labels have names, use them to match with breaks
        map <- match(as.character(user_breaks), names(scale_labels))
        user_breaks[map] <- scale_labels[!is.na(map)]
        user_breaks
    } else {
        # Need to ensure that if breaks were dropped, corresponding labels
        # are too
        if (is.null(pos <- attr(breaks, "pos"))) {
            if (inherits(scale_labels, "AsIs")) { # already in the plot index
                # we sort the `pos` so labels ordering won't be changed
                scale_labels <- scale_labels[pindex]
            } else { # in the data index
                scale_labels <- scale_labels[dindex]
            }
        } else {
            if (inherits(scale_labels, "AsIs")) { # already in the plot index
                # we sort the `pos` so labels ordering won't be changed
                scale_labels <- scale_labels[sort(pos)]
            } else { # in the data index
                scale_labels <- scale_labels[pos]
            }
        }
        scale_labels
    }
}

######################################################
# this will remove the old coordinate,
# so always run firstly
gguse_linear_coord <- function(plot, layout_name) {
    coord <- plot$coordinates
    if (!inherits(coord, "CoordTrans") && !coord$is_linear()) {
        cli_warn(c(
            sprintf(
                "{.fn %s} is not supported in %s",
                snake_class(coord), layout_name
            ),
            i = "Will use {.fn coord_cartesian} instead"
        ))
        plot$coordinates <- ggplot2::coord_cartesian()
    }
    plot
}

gguse_circle_coord <- function(plot, coord, ..., layout_name) {
    if (inherits(plot_coord <- plot$coordinates, "CoordRadial")) {
        out <- ggproto(
            NULL, plot_coord,
            theta = coord$theta,
            r = coord$r,
            arc = coord$arc,
            direction = coord$direction,
            r_axis_inside = coord$r_axis_inside,
            expand = coord$expand,
            ...,
            setup_panel_params = circle_panel_params
        )
    } else {
        if (!isTRUE(plot$coordinates$default)) {
            cli_warn(c(
                sprintf(
                    "{.fn %s} is not supported in %s",
                    snake_class(plot_coord), layout_name
                ),
                i = sprintf("Will use {.fn %s} instead", snake_class(coord))
            ))
        }
        if (!inherits(coord, "CoordCircle")) {
            out <- ggproto(NULL, coord, ...,
                setup_panel_params = circle_panel_params
            )
        } else {
            out <- ggproto(NULL, coord, ...)
        }
    }
    out
}

######################################################
#' @importFrom ggplot2 ggproto
ggfacet_modify <- function(plot, ...) {
    ParentFacet <- plot$facet
    plot$facet <- ggproto(NULL, ParentFacet, ...)
    plot
}

gguse_facet <- function(plot, facet) {
    plot$facet <- facet
    plot
}

ggmelt_facet <- function(plot, facet, ...) {
    gguse_facet(plot, melt_facet(facet, plot$facet, ...))
}

#' @param use A template facet object which will be used.
#' @param facet User provided facet object.
#' @noRd
melt_facet <- function(use, facet, ...) UseMethod("melt_facet")

#' @export
melt_facet.NULL <- function(use, facet, ...) {
    facet
}

#' @importFrom ggplot2 ggproto
#' @export
melt_facet.FacetGrid <- function(use, facet, ...,
                                 free_row = FALSE,
                                 free_column = FALSE) {
    if (inherits(facet, "FacetGrid")) {
        # re-dispatch parameters
        params <- facet$params
        if (length(use$params$rows) || !free_row) {
            params$rows <- use$params$rows
        }
        if (length(use$params$cols) || !free_column) {
            params$cols <- use$params$cols
        }
        if (!free_row) { # Don't allow user change the rows
            params$free$y <- use$params$free$y
            params$space_free$y <- use$params$space_free$y
        }
        if (!free_column) { # Don't allow user change the cols
            params$free$x <- use$params$free$x
            params$space_free$x <- use$params$space_free$x
        }

        params$drop <- use$params$drop
        params$as.table <- use$params$as.table

        # if the use is free, it must be free
        ggproto(NULL, facet, params = params)
    } else {
        use
    }
}

#' @importFrom ggplot2 ggproto
#' @export
melt_facet.FacetWrap <- function(use, facet, ...) {
    if (inherits(facet, "FacetWrap")) {
        # re-dispatch parameters
        params <- facet$params

        # we always fix the grid rows and cols
        params$facets <- use$params$facets
        params$nrow <- use$params$nrow
        params$ncol <- use$params$ncol
        params$drop <- use$params$drop
        params$as.table <- use$params$as.table
        ggproto(NULL, facet, params = params)
    } else {
        use
    }
}

#' @export
melt_facet.FacetNull <- function(use, facet, ...) {
    if (inherits(facet, "FacetNull")) {
        facet
    } else {
        use
    }
}

#' @export
melt_facet.FacetStack <- function(use, facet, ...) {
    if (inherits(facet, "FacetGrid")) {
        params <- facet$params
        if (is_horizontal(.subset2(use, "direction"))) {
            # for horizontal stack, we cannot facet by rows
            if (!is.null(params$rows)) {
                cli_warn(sprintf(
                    "Cannot facet by rows in %s",
                    .subset2(use, "object_name")
                ))
                params$rows <- NULL
            }
        } else if (!is.null(params$cols)) {
            # for vertical stack, we cannot facet by cols
            cli_warn(sprintf(
                "Cannot facet by cols in %s",
                .subset2(use, "object_name")
            ))
            params$cols <- NULL
        }
        ggproto(NULL, facet, params = params)
    } else if (inherits(facet, "FacetWrap")) {
        params <- facet$params
        if (is_horizontal(.subset2(use, "direction"))) {
            # for horizontal stack, we cannot facet by rows
            if (is.null(params$nrow)) {
                params$nrow <- 1L
            } else if (params$nrow > 1L) {
                cli_warn(sprintf(
                    "Cannot wrap facet by rows in %s",
                    .subset2(use, "object_name")
                ))
                params$nrow <- 1L
            }
        } else if (!is.null(params$cols)) {
            # for vertical stack, we cannot facet by cols
            if (is.null(params$ncol)) {
                params$ncol <- 1L
            } else if (params$ncol > 1L) {
                cli_warn(sprintf(
                    "Cannot wrap facet by cols in %s",
                    .subset2(use, "object_name")
                ))
                params$ncol <- 1L
            }
        }
    } else if (inherits(facet, "FacetNull")) {
        facet
    } else {
        ggplot2::facet_null()
    }
}

facet_stack <- function(direction, object_name) {
    structure(
        list(direction = direction, object_name = object_name),
        class = "FacetStack"
    )
}

#' @export
melt_facet.FacetQuad <- function(use, facet, ...,
                                 free_row = FALSE,
                                 free_column = FALSE) {
    if (inherits(facet, "FacetGrid")) {
        if (free_row || free_column) {
            params <- facet$params
            if (!free_row && !is.null(params$rows)) {
                cli_warn(sprintf(
                    "Cannot facet by rows in %s",
                    .subset2(use, "layout_name")
                ))
                params$rows <- NULL
                # for horizontal stack, we cannot facet by rows
            }
            if (!free_column && !is.null(params$cols)) {
                cli_warn(sprintf(
                    "Cannot facet by cols in %s",
                    .subset2(use, "layout_name")
                ))
                params$cols <- NULL
            }
            ggproto(NULL, facet, params = params)
        } else {
            ggplot2::facet_null()
        }
    } else if (inherits(facet, "FacetNull")) {
        facet
    } else {
        ggplot2::facet_null()
    }
}

facet_quad <- function(layout_name) {
    structure(list(layout_name = layout_name), class = "FacetQuad")
}

cross <- function(cross = NULL, data = waiver(),
                  data_params = list(), ...,
                  inherit_index = NULL,
                  inherit_panel = NULL,
                  inherit_nobs = NULL,
                  plot = NULL, active = NULL, size = NULL, schemes = NULL,
                  data_arg = caller_arg(data),
                  call = caller_call()) {
    if (override_call(call)) {
        call <- current_call()
    }
    new_craftbox(
        craftsman = cross %||% CraftCross,
        data = allow_lambda(data), data_params = data_params,
        ...,
        inherit_nobs = inherit_nobs,
        inherit_panel = inherit_panel,
        inherit_index = inherit_index,
        plot = plot, active = active, size = size, schemes = schemes,
        data_arg = data_arg, call = call
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @include craftbox-.R
CraftCross <- ggproto(
    "CraftCross", Craftsman,
    free_facet = TRUE,
    free_limits = TRUE,
    data_params = NULL,
    inherit_nobs = NULL,
    inherit_panel = NULL,
    inherit_index = NULL,
    interact_layout = function(self, layout) {
        #  1. check layout is `*_cross()`
        #  2. add `cross_points`
        #  3. add `odesign`
        #  4. define `labels`, we'll rename the `labels` to `labels0`
        layout <- ggproto_parent(CrossGg, self)$interact_layout(layout)

        # will define `labels0`
        self$labels0 <- self$labels

        # check the previous (between two `break_points`) define has been
        # initialized
        if (length(layout@break_points) &&
            is.null(.subset2(layout@design, "nobs"))) {
            cli_abort(sprintf(
                "layout {.field nobs} for %s must be initialized before adding %s",
                self$layout_name, object_name(self)
            ))
        }

        # setup data
        layout_data <- layout@data
        design <- layout@design

        if (is.waive(input_data <- self$data)) { # inherit from the layout
            data <- layout_data
            # `data` is NULL, `inherit_nobs` can be `TRUE` or `FALSE`, we by
            # default regard `inherit_nobs` as `TRUE`
            if (is.null(data) && isFALSE(self$inherit_nobs)) {
                design["nobs"] <- list(NULL)
            }

            # `data` is not `NULL`, the `nobs` will always be the same with
            # previous design, nothing to do
        } else {
            if (is.function(input_data)) {
                if (is.null(layout_data)) {
                    cli_abort(c(
                        sprintf(
                            "{.arg data} in %s cannot be a function",
                            object_name(self)
                        ),
                        i = sprintf("no data was found in %s", self$layout_name)
                    ))
                }
                data <- input_data(layout_data)
            } else {
                data <- input_data
            }
            data <- inject(
                fortify_matrix(
                    data, !!!self$data_params,
                    data_arg = self$data_arg,
                    call = self$call
                )
            ) %|w|% NULL
            if (isTRUE(self$inherit_nobs)) { # we require inherit nobs
                # we check if the data match original data dimention
                if (!is.null(data) &&
                    !is.null(.subset2(design, "nobs")) &&
                    NROW(data) != .subset2(design, "nobs")) {
                    cli_abort(c(
                        sprintf(
                            "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
                            object_name(self), NROW(data), layout_name, layout_nobs
                        ),
                        i = "try to set {.code inherit_nobs = FALSE}"
                    ))
                }
            } else { # for `FALSE` and `NULL`
                if (is.null(data)) {
                    design["nobs"] <- list(NULL)
                } else {
                    if (NROW(data) == 0L) {
                        cli_abort("{.arg data} cannot be empty",
                            call = self$call
                        )
                    }
                    design["nobs"] <- list(NROW(data))
                }
            }
        }

        # we keep the names from the layout data for usage
        self$labels <- vec_names(data)

        # determine if we should inherit panel
        # by default, `inherit_panel = FALSE`
        if (isTRUE(self$inherit_panel)) {
            if (is.null(self$labels0)) {
                cli_abort(c(
                    "Cannot inherit panel from the layout",
                    i = "No labels found in the layout data"
                ))
            }
            if (is.null(self$labels)) {
                cli_abort(c(
                    "Cannot inherit panel from the layout",
                    i = "No labels found in the current {.arg data}"
                ))
            }
            if (!all(self$labels %in% self$labels0)) {
                cli_abort(c(
                    "Cannot inherit panel from the layout",
                    i = "Some labels in the current data are not found in the previous layout data"
                ))
            }
            if (!is.null(panel <- .subset2(design, "panel"))) {
                design["panel"] <- list(
                    droplevels(panel[match(self$labels, self$labels0)])
                )
            }
        } else {
            design["panel"] <- list(NULL)
        }

        # determine if we should inherit panel
        # by default, `inherit_index = FALSE`
        if (isTRUE(self$inherit_index)) {
            if (is.null(self$labels0)) {
                cli_abort(c(
                    "Cannot inherit ordering index from the layout",
                    i = "No labels found in the previous layout data"
                ))
            }

            if (is.null(self$labels)) {
                cli_abort(c(
                    "Cannot inherit ordering index from the layout",
                    i = "No labels found in the current {.arg data}"
                ))
            }

            if (!all(self$labels %in% self$labels0)) {
                cli_abort(c(
                    "Cannot inherit ordering index from the layout",
                    i = "Some labels in the current data are not found in the previous layout data"
                ))
            }

            if (!is.null(index <- .subset2(design, "index"))) {
                new_index <- order(match(
                    self$labels,
                    vec_slice(self$labels0, index)
                ))

                # we always make the index following the panel
                if (!is.null(panel <- .subset2(design, "panel"))) {
                    new_index <- reorder_index(panel, new_index)
                }
                design["index"] <- list(new_index)
            }
        } else {
            design["index"] <- list(NULL)
        }

        # reset layout data
        layout@data <- data # don't restore the attribute

        # update the design
        layout@design <- design

        # udpate break_points
        layout@break_points <- c(layout@break_points, length(layout@plot_list))
        layout
    }
)

# Used by both `circle_layout()` and `stack_layout()`
#' @keywords internal
#' @include layout-.R
methods::setClass(
    "ChainLayout",
    contains = "LayoutProto",
    list(
        data = "ANY",
        name = "character", # used to provide message
        plot_list = "list", # save the list of plots
        design = "ANY" # used to align axis
    )
)

#' Finalize plot modifications from a ChainLayout object.
#'
#' This generic function lets a ChainLayout apply any final transformations
#' to the composed plot before returning it. It does not extract or store
#' the plot, but instead allows the layout to inject custom modifications
#' (e.g., spacing guides, annotations, alignment fixes) at the last step.
#'
#' @param layout A ChainLayout object.
#' @param plot The plot being finalized.
#' @keywords internal
chain_decorate <- function(layout, plot) UseMethod("chain_decorate")

#' @export
chain_decorate.ChainLayout <- function(layout, plot) plot

#' @export
is_layout_discrete.ChainLayout <- function(x, ...) {
    is_discrete_design(x@design)
}

#' @export
is_layout_continuous.ChainLayout <- function(x, ...) {
    is_continuous_design(x@design)
}

#############################################################
# To-DO: Use double dispatch
#' @keywords internal
chain_layout_add <- function(object, layout, object_name) {
    UseMethod("chain_layout_add")
}

#' @export
chain_layout_add.layout_title <- function(object, layout, object_name) {
    layout@titles <- update_non_waive(layout@titles, object)
    layout
}

#' @export
chain_layout_add.list <- function(object, layout, object_name) {
    for (o in object) layout <- chain_layout_add(o, layout, object_name)
    layout
}

#' @export
chain_layout_add.NULL <- function(object, layout, object_name) {
    layout
}

#' @export
chain_layout_add.CraftBox <- function(object, layout, object_name) {
    craftsman <- object@craftsman
    # To-Do: Use S7 and double dispatch
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        # unlock the object
        craftsman$unlock()

        # we lock the `Craftsman` object to prevent user from modifying this
        # object in `$build_plot()` method, we shouldn't do any calculations in
        # `$build_plot()` method
        on.exit(craftsman$lock())

        # initialize the necessary parameters for `Craftsman` object
        if (is_stack_layout(layout)) {
            craftsman$direction <- layout@direction
            craftsman$position <- .subset2(layout@heatmap, "position")
        } else if (is_circle_layout(layout)) {
            # we treat circle layout as a vertical stack layout
            craftsman$direction <- "vertical"
        }
        craftsman$in_linear <- is_linear(layout)
        craftsman$layout_name <- object_name(layout)

        # firstly, we let the object do some changes in the layout
        layout <- craftsman$interact_layout(layout)

        # this step, the object will act with the stack layout
        # group rows into panel or reorder rows, we can also
        # initialize object data
        new_design <- craftsman$setup_design(layout@design)

        # initialize the plot object
        object@plot <- craftsman$setup_plot(object@plot)

        layout <- chain_add_plot(layout, object, object@active, object_name)
    } else { # should be a QuadLayout object
        plot <- quad_layout_add(object, plot, object_name)
        layout@plot_list[[active_index]] <- plot
        new_design <- slot(plot, layout@direction)
    }
    update_design(layout, design = new_design, object_name = object_name)
}

#' @export
chain_layout_add.continuous_limits <- function(object, layout, object_name) {
    if (is_discrete_design(layout@design)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = sprintf(
                "%s cannot align continuous variables",
                object_name(layout)
            )
        ))
    }
    update_design(layout, design = object, object_name = object_name)
}

#' @export
chain_layout_add.ggplot <- function(object, layout, object_name) {
    chain_layout_add(ggfree(data = object), layout, object_name)
}

# Add ggplot2 elements
#' @export
chain_layout_add.default <- function(object, layout, object_name) {
    if (is.null(active_index <- layout@active)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = "No active plot component",
            i = paste(
                "Did you forget to initialize a {.cls ggplot} object",
                "with {.fn ggalign} or {.fn ggfree}?"
            )
        ))
    }
    plot <- .subset2(layout@plot_list, active_index)
    if (is_craftbox(plot)) {
        plot <- chain_plot_add(plot, object, object_name, TRUE)
    } else {
        plot <- quad_layout_add(object, plot, object_name)
    }
    layout@plot_list[[active_index]] <- plot
    layout
}

#' @export
chain_layout_add.layout_theme <- function(object, layout, object_name) {
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        layout@theme <- update_layout_theme(layout@theme, object)
    } else {
        layout@plot_list[[active_index]] <- quad_layout_add(
            object, plot, object_name
        )
    }
    layout
}

chain_plot_add <- function(plot, object, object_name, force) {
    # if `align` has plot, we added the object
    if (force || !is.null(plot@plot)) {
        plot <- craftbox_add(object, plot, object_name)
    }
    plot
}

chain_add_plot <- function(layout, plot, active, object_name) {
    # set up context index
    plot_list <- layout@plot_list
    if (.subset2(active, "use")) {
        active_index <- length(plot_list) + 1L
    } else {
        active_index <- layout@active
    }
    # check the name is unique
    if (!is.na(name <- .subset2(active, "name"))) {
        if (any(names(plot_list) == name)) {
            cli_warn(
                "Adding {.var {object_name}} will replace existing {.field {name}} plot"
            )
        }
        plot_list[[name]] <- plot
    } else {
        plot_list <- c(plot_list, list(plot))
    }

    # add QuadLayout
    layout@plot_list <- plot_list
    layout@active <- active_index
    layout
}

switch_chain_plot <- function(layout, what, call = caller_call()) {
    if (!is.waive(what)) {
        if (!is.null(what)) {
            what <- vec_as_location2(
                what,
                vec_size(layout@plot_list),
                vec_names(layout@plot_list),
                missing = "error",
                arg = "what", call = call
            )
        }
        layout@active <- what
    }
    layout
}

##############################################################
# for `stack_layout()` only
#' @export
chain_layout_add.ggalign_with_quad <- function(object, layout, object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(sprintf(
            "Cannot add {.var {object_name}} to %s",
            object_name(layout)
        ))
    }
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = "Did you forget to add a {.fn quad_layout}?"
        ))
    } else {
        layout@plot_list[[active_index]] <- quad_layout_add(
            object, plot, object_name
        )
    }
    layout
}

#' @export
chain_layout_add.quad_active <- chain_layout_add.ggalign_with_quad

#' @export
chain_layout_add.quad_anno <- chain_layout_add.quad_active

#' @export
chain_layout_add.StackLayout <- chain_layout_add.quad_active

#' @export
chain_layout_add.StackCross <- function(object, layout, object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(sprintf(
            "Cannot add {.var {object_name}} to %s",
            object_name(layout)
        ))
    }

    # preventing from adding `stack_cross` with the same direction in this way,
    # `stack_cross()` cannot be added to the heatmap annotation parallelly with
    # the `stack_layout()`
    if (identical(object@direction, layout@direction)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = "Cannot add {.fn stack_cross} with the same direction as {.fn stack_discrete}."
        ))
    }
    NextMethod() # call StackLayout method
}

#' @export
chain_layout_add.stack_switch <- function(object, layout, object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = "Did you want to add a {.fn circle_switch}?"
        ))
    }
    layout <- switch_chain_plot(
        layout, .subset2(object, "what"),
        quote(stack_switch())
    )
    if (!is.null(sizes <- .subset2(object, "sizes"))) {
        layout@sizes <- sizes
    }
    layout
}

#' @importFrom methods slot
#' @export
chain_layout_add.QuadLayout <- function(object, layout, object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(sprintf(
            "Cannot add {.var {object_name}} to %s",
            object_name(layout)
        ))
    }

    # preventing from adding `stack_cross` with the same direction
    # `cross_link()` cannot be added to the heatmap annotation
    # parallelly with the `stack_cross()`
    if (is_horizontal(direction <- layout@direction)) {
        if (is_cross_layout(object@left) || is_cross_layout(object@right)) {
            cli_abort(c(
                sprintf(
                    "Cannot add {.var {object_name}} to %s",
                    object_name(layout)
                ),
                i = sprintf(
                    "{.field left} or {.field right} annotation contains %s",
                    "{.fn stack_cross}"
                )
            ))
        }
    } else if (is_cross_layout(object@top) || is_cross_layout(object@bottom)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = sprintf(
                "{.field top} or {.field bottom} annotation contains %s",
                "{.fn stack_cross}"
            )
        ))
    }

    # check quad layout is compatible with stack layout
    quad_data <- object@data
    stack_design <- layout@design
    quad_design <- slot(object, direction)
    if (is_continuous_design(quad_design)) {
        if (is_discrete_design(stack_design)) {
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s",
                    object_name(object), object_name(layout)
                ),
                i = sprintf(
                    "%s cannot align continuous variable",
                    object_name(layout)
                )
            ))
        }
        # `quad_layout()` will align continuous variables,
        # `data` can be `NULL`
        extra_design <- slot(object, vec_set_difference(
            c("vertical", "horizontal"), direction
        ))
        allow_null <- is_continuous_design(extra_design)
        if (is.waive(quad_data) || is.function(quad_data)) {
            # check if we should initialize the `quad_layout()` data
            if (is.null(stack_data <- layout@data)) {
                if (allow_null) {
                    quad_data <- NULL
                } else {
                    cli_abort(c(
                        sprintf(
                            "you must provide {.arg data} argument in %s",
                            object_name(object)
                        ),
                        i = sprintf(
                            "no data was found in %s",
                            object_name(layout)
                        )
                    ))
                }
            } else {
                data <- stack_data # should be a data frame
                if (is.waive(quad_data)) { # inherit from the stack layout
                    if (!allow_null) { # we need a matrix
                        cli_abort(c(
                            sprintf(
                                "Cannot add %s to %s",
                                object_name(object), object_name(layout)
                            ),
                            i = sprintf(
                                "{.arg data} in %s is %s, but %s need a {.cls matrix}.",
                                object_name(layout),
                                "{.obj_type_friendly {data}}",
                                object_name(object)
                            ),
                            i = sprintf(
                                "Try provide {.arg data} in %s",
                                object_name(object)
                            )
                        ))
                    }
                } else { # `quad_data` is a function
                    data <- quad_data(data)
                    # check the data format is correct
                    if (allow_null) { # we need a data frame
                        if (!is.data.frame(data)) {
                            cli_abort(sprintf(
                                "{.arg data} in %s must return a {.cls data.frame}",
                                object_name(object)
                            ))
                        }
                    } else if (!is.matrix(data)) { # we need a matrix
                        cli_abort(sprintf(
                            "{.arg data} in %s must return a {.cls matrix}",
                            object_name(object)
                        ))
                    } else {
                        if (NROW(data) == 0L || ncol(data) == 0L) {
                            cli_abort(sprintf(
                                "{.arg data} in %s return an empty matrix",
                                object_name(object)
                            ))
                        }
                    }
                }
                # we initialize the `nobs` of the extra_design for the
                # `quad_layout()`
                if (is_horizontal(direction)) {
                    if (is_discrete_design(slot(object, "vertical"))) {
                        slot(object, "vertical")$nobs <- ncol(data)
                    }
                } else {
                    if (is_discrete_design(slot(object, "horizontal"))) {
                        slot(object, "horizontal")$nobs <- nrow(data)
                    }
                }
            }
            # restore the ggalign attribute
            object@data <- ggalign_data_restore(data, stack_data)
        }
        layout_design <- quad_design
    } else if (is_discrete_design(stack_design)) {
        # both `quad_layout()` and `stack_layout()` will align discrete
        # variables
        if (is.waive(quad_data) || is.function(quad_data)) {
            if (is.null(stack_data <- layout@data)) {
                cli_abort(c(
                    sprintf(
                        "you must provide {.arg data} argument in %s",
                        object_name(object)
                    ),
                    i = sprintf(
                        "no data was found in %s",
                        object_name(layout)
                    )
                ))
            }
            # set `quad_layout()` data
            data <- switch_direction(direction, stack_data, t(stack_data))
            if (is.function(quad_data)) {
                data <- quad_data(data)
                if (!is.matrix(data)) {
                    cli_abort(sprintf(
                        "{.arg data} in %s must return a matrix",
                        object_name(object)
                    ))
                }
                if (NROW(data) == 0L || ncol(data) == 0L) {
                    cli_abort(sprintf(
                        "{.arg data} in %s return an empty matrix",
                        object_name(object)
                    ))
                }
            } else {
                if (NROW(data) == 0L || ncol(data) == 0L) {
                    cli_abort(c(
                        sprintf(
                            "Cannot use data from %s in %s",
                            object_name(layout), object_name(object)
                        ),
                        i = sprintf(
                            "{.arg data} in %s is an empty matrix",
                            object_name(layout)
                        )
                    ))
                }
            }
            # set the `nobs` for `quad_layout()`
            if (is_horizontal(direction)) {
                quad_design$nobs <- nrow(data)
                if (is_discrete_design(slot(object, "vertical"))) {
                    slot(object, "vertical")$nobs <- ncol(data)
                }
            } else {
                quad_design$nobs <- ncol(data)
                if (is_discrete_design(slot(object, "horizontal"))) {
                    slot(object, "horizontal")$nobs <- nrow(data)
                }
            }
            # restore the ggalign attribute
            object@data <- ggalign_data_restore(data, stack_data)
        }
        layout_design <- melt_discrete_design(
            stack_design, quad_design,
            old_name = object_name(layout),
            new_name = object_name
        )
    } else {
        cli_abort(c(
            sprintf(
                "Cannot add %s to %s",
                object_name(object), object_name(layout)
            ),
            i = sprintf(
                "%s cannot align discrete variable",
                object_name(layout)
            )
        ))
    }
    stack <- chain_add_plot(layout, object, object@plot_active, object_name)
    update_design(
        stack,
        design = layout_design,
        object_name = object_name
    )
}

##################################################
#' @export
chain_layout_add.circle_switch <- function(object, layout, object_name) {
    if (!is_circle_layout(layout)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(layout)
            ),
            i = "Did you want to add a {.fn stack_switch}?"
        ))
    }
    if (!is.waive(radial <- .subset2(object, "radial"))) {
        layout@radial <- radial
    }
    if (!is.null(direction <- .subset2(object, "direction"))) {
        layout@direction <- direction
    }
    layout <- switch_chain_plot(
        layout, .subset2(object, "what"),
        quote(circle_switch())
    )
    layout
}

#' Arrange plots in a circular layout
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' If `limits` is provided, a continuous variable will be required and aligned
#' in the direction specified (`circle_continuous`). Otherwise, a discrete
#' variable will be required and aligned (`circle_discrete`).
#'
#' @param radial A [`coord_circle()`]/[`coord_radial()`][ggplot2::coord_radial]
#' object that defines the global parameters for coordinate across all plots
#' in the layout. The parameters `start`, `end`, `direction`, and `expand` will
#' be inherited and applied uniformly to all plots within the layout. The
#' parameters `theta` and `r.axis.inside` will always be ignored and will be set
#' to `"x"` and `TRUE`, respectively, for all plots.
#' @param direction A single string of `r oxford_or(c("inward", "outward"))`,
#' indicating the direction in which the plot is added.
#' - `outward`: The plot is added from the inner to the outer.
#' - `inward`: The plot is added from the outer to the inner.
#' @inheritParams stack_layout
#' @return A `CircleLayout` object.
#' @examples
#' set.seed(123)
#'
#' small_mat <- matrix(rnorm(56), nrow = 7)
#' rownames(small_mat) <- paste0("row", seq_len(nrow(small_mat)))
#' colnames(small_mat) <- paste0("column", seq_len(ncol(small_mat)))
#'
#' # circle_layout
#' # same for circle_discrete()
#' circle_layout(small_mat) +
#'     ggalign() +
#'     geom_tile(aes(y = .column_index, fill = value)) +
#'     scale_fill_viridis_c() +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     scale_color_brewer(palette = "Dark2")
#'
#' # same for circle_continuous()
#' circle_layout(mpg, limits = continuous_limits(c(3, 5))) +
#'     ggalign(mapping = aes(displ, hwy, colour = class)) +
#'     geom_point(size = 2) +
#'     ggalign(mapping = aes(displ, hwy, colour = class)) +
#'     geom_point(size = 2) &
#'     scale_color_brewer(palette = "Dark2") &
#'     theme_bw()
#'
#' @export
circle_layout <- function(data = NULL, ..., radial = NULL,
                          direction = "outward", sector_spacing = NULL,
                          limits = waiver(), theme = NULL,
                          spacing_theta = deprecated()) {
    if (is.waive(limits)) {
        circle_discrete(
            data = data, ..., radial = radial,
            direction = direction, sector_spacing = sector_spacing,
            theme = theme, spacing_theta = spacing_theta
        )
    } else {
        circle_continuous(
            data = data, ..., radial = radial,
            direction = direction, theme = theme, limits = limits,
            spacing_theta = spacing_theta
        )
    }
}

############################################################
#' @inheritParams facet_sector
#' @examples
#' # circle_discrete()
#' # direction outward
#' circle_discrete(small_mat) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     scale_color_brewer(palette = "Dark2") +
#'     ggalign() +
#'     geom_tile(aes(y = .column_index, fill = value)) +
#'     scale_fill_viridis_c()
#'
#' # direction inward
#' circle_discrete(small_mat, direction = "inward") +
#'     ggalign() +
#'     geom_tile(aes(y = .column_index, fill = value)) +
#'     scale_fill_viridis_c() +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     scale_color_brewer(palette = "Dark2")
#'
#' @export
#' @rdname circle_layout
circle_discrete <- function(data = NULL, ..., radial = NULL,
                            direction = "outward", sector_spacing = NULL,
                            theme = NULL, spacing_theta = deprecated()) {
    UseMethod("circle_discrete", data)
}

#' @export
circle_discrete.default <- function(data = NULL, ..., radial = NULL,
                                    direction = "outward",
                                    sector_spacing = NULL,
                                    theme = NULL,
                                    spacing_theta = deprecated()) {
    # the observations are rows, we use matrix to easily
    # reshape it into a long formated data frame for ggplot,
    # and we can easily determine the number of observations
    # from matrix
    data <- data %|w|% NULL
    data <- fortify_matrix(data = data, ...)
    schemes <- default_schemes()
    if (!is.null(data) && !is.function(data)) {
        # if we have provided data, we initialize the `nobs`
        nobs <- vec_size(data)
    } else {
        nobs <- NULL
    }
    new_circle_layout(
        data = data,
        design = discrete_design(nobs = nobs),
        radial = radial, direction = direction, sector_spacing = sector_spacing,
        schemes = schemes, theme = theme, spacing_theta = spacing_theta
    )
}

#' @export
circle_discrete.function <- function(data = NULL, ...) {
    cli_abort(paste0(
        "{.arg data} must be a {.cls matrix}, ",
        "or an object coercible by {.fn fortify_matrix}, or a valid ",
        "{.cls matrix}-like object coercible by {.fn as.matrix}"
    ))
}

#' @export
circle_discrete.formula <- circle_discrete.function

################################################################
#' @examples
#' # circle_continuous()
#' circle_continuous(mpg, limits = continuous_limits(c(3, 5))) +
#'     ggalign(mapping = aes(displ, hwy, colour = class)) +
#'     geom_point(size = 2) +
#'     ggalign(mapping = aes(displ, hwy, colour = class)) +
#'     geom_point(size = 2) &
#'     scale_color_brewer(palette = "Dark2") &
#'     theme_bw()
#' @export
#' @rdname circle_layout
circle_continuous <- function(data = NULL, ..., radial = NULL,
                              direction = "outward", sector_spacing = NULL,
                              limits = NULL, theme = NULL,
                              spacing_theta = deprecated()) {
    UseMethod("circle_continuous", data)
}

#' @export
circle_continuous.default <- function(data = NULL, ..., radial = NULL,
                                      direction = "outward",
                                      sector_spacing = NULL,
                                      limits = NULL, theme = NULL,
                                      spacing_theta = deprecated()) {
    assert_limits(limits)
    data <- data %|w|% NULL
    data <- fortify_data_frame(data = data, ...)
    schemes <- default_schemes()
    new_circle_layout(
        data = data, design = limits,
        radial = radial, direction = direction, sector_spacing = sector_spacing,
        schemes = schemes, theme = theme, spacing_theta = spacing_theta
    )
}

#' @export
circle_continuous.function <- function(data = NULL, ...) {
    cli_abort(paste0(
        "{.arg data} must be a {.cls data.frame}, ",
        "or an object coercible by {.fn fortify_data_frame}, or a valid ",
        "{.cls data.frame}-like object coercible by {.fn as.data.frame}"
    ))
}

#' @export
circle_continuous.formula <- circle_continuous.function

#' @importFrom methods new
new_circle_layout <- function(data, design, radial, direction,
                              sector_spacing = NULL, schemes = NULL,
                              theme = NULL, name = NULL,
                              spacing_theta = deprecated(),
                              call = caller_call()) {
    if (!is.null(theme)) assert_s3_class(theme, "theme", call = call)
    if (!is.null(radial) && !inherits(radial, c("CoordRadial"))) {
        cli_abort("{.arg radial} must be created with {.fn coord_circle}",
            call = call
        )
    }
    if (!is.null(radial) && abs(diff(radial$arc)) < pi / 2L) {
        cli_abort(
            "Cannot create circle of acute angle < 90 in {.arg radial}",
            call = call
        )
    }
    direction <- arg_match0(direction, c("inward", "outward"))
    if (is.null(name)) {
        if (is_continuous_design(design)) {
            name <- "circle_continuous"
        } else {
            name <- "circle_discrete"
        }
    }
    if (lifecycle::is_present(spacing_theta)) {
        lifecycle::deprecate_warn(
            "1.0.2",
            "facet_sector(spacing_theta = )",
            "facet_sector(sector_spacing = )"
        )
        if (is.null(sector_spacing)) sector_spacing <- spacing_theta
    }
    new(
        "CircleLayout",
        name = name, data = data,
        schemes = schemes, # used by the layout
        design = design,
        sector_spacing = sector_spacing,
        theme = theme,
        radial = radial, direction = direction
    )
}

############################################################
# Used to place multiple objects in one axis
#' @importFrom grid unit
#' @importFrom ggplot2 waiver
#' @keywords internal
#' @include layout-chain-.R
methods::setClass("CircleLayout",
    contains = "ChainLayout",
    list(radial = "ANY", sector_spacing = "ANY", direction = "character")
)

# Standalone file: do not edit by hand
# Source: https://github.com/Yunuuuu/standalone/blob/HEAD/R/standalone-obj-type.R
# Generated by: usethis::use_standalone("Yunuuuu/standalone", "obj-type")
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-obj-type.R
# last-updated: 2025-04-11
# license: https://unlicense.org
# imports: rlang (>= 1.1.0)
# ---
#
# ## Changelog
# 2025-04-11:
# - new `allow_what_type`
#
# 2024-11-10:
# - `obj_type_friendly()` gains a `length` argument to control whether to show
#   the length of the vector.
# - `stop_input_type()` gains a `show_length` argument passed to
#   `obj_type_friendly`.
#
# 2024-02-14:
# - `obj_type_friendly()` now works for S7 objects.
#
# 2023-05-01:
# - `obj_type_friendly()` now only displays the first class of S3 objects.
#
# 2023-03-30:
# - `stop_input_type()` now handles `I()` input literally in `arg`.
#
# 2022-10-04:
# - `obj_type_friendly(value = TRUE)` now shows numeric scalars
#   literally.
# - `stop_friendly_type()` now takes `show_value`, passed to
#   `obj_type_friendly()` as the `value` argument.
#
# 2022-10-03:
# - Added `allow_na` and `allow_null` arguments.
# - `NULL` is now backticked.
# - Better friendly type for infinities and `NaN`.
#
# 2022-09-16:
# - Unprefixed usage of rlang functions with `rlang::` to
#   avoid onLoad issues when called from rlang (#1482).
#
# 2022-08-11:
# - Prefixed usage of rlang functions with `rlang::`.
#
# 2022-06-22:
# - `friendly_type_of()` is now `obj_type_friendly()`.
# - Added `obj_type_oo()`.
#
# 2021-12-20:
# - Added support for scalar values and empty vectors.
# - Added `stop_input_type()`
#
# 2021-06-30:
# - Added support for missing arguments.
#
# 2021-04-19:
# - Added support for matrices and arrays (#141).
# - Added documentation.
# - Added changelog.
#
# nocov start
# Following codes were modified from `rlang` package

#' @param x The object type which does not conform to `what`. Its
#'   `obj_type_friendly()` is taken and mentioned in the error message.
#' @param show_value Passed to `value` argument of `obj_type_friendly()`.
#' @param show_length Passed to `length` argument of `obj_type_friendly()`.
#' @param ... Arguments passed to [abort()].
#' @inheritParams args_error_context
#' @importFrom rlang caller_arg caller_env abort
#' @noRd
stop_input_type <- function(x,
                            what,
                            ...,
                            allow_na = FALSE,
                            allow_null = FALSE,
                            show_value = TRUE,
                            show_length = FALSE,
                            arg = caller_arg(x),
                            call = caller_env()) {
    what <- allow_what_type(
        what,
        allow_na = allow_na,
        allow_null = allow_null
    )
    if (inherits(arg, "AsIs")) {
        format_arg <- identity
    } else {
        format_arg <- function(x) sprintf("`%s`", x)
    }
    message <- sprintf(
        "%s must be %s, not %s.",
        format_arg(arg), what,
        obj_type_friendly(x, value = show_value, length = show_length)
    )
    abort(message, ..., call = call, arg = arg)
}

#' @param what The friendly expected type as a string. Can be a
#'   character vector of expected types, in which case the error
#'   message mentions all of them in an "or" enumeration.
#' @noRd
allow_what_type <- function(what, allow_na = FALSE, allow_null = FALSE) {
    if (allow_na) {
        what <- c(what, "`NA`")
    }
    if (allow_null) {
        what <- c(what, "`NULL`")
    }
    if (length(what)) {
        what <- .standalone_oxford_comma(what, final = "or")
    }
    what
}

#' Return English-friendly type
#' @param x Any R object.
#' @param value Whether to describe the value of `x`. Special values
#'   like `NA` or `""` are always described.
#' @param length Whether to mention the length of vectors and lists.
#' @return A string describing the type. Starts with an indefinite
#'   article, e.g. "an integer vector".
#' @importFrom rlang is_missing is_vector
#' @noRd
obj_type_friendly <- function(x, value = TRUE, length = FALSE) {
    if (is_missing(x)) {
        return("absent")
    }

    if (is.object(x)) {
        if (inherits(x, "quosure")) {
            type <- "quosure"
        } else {
            type <- class(x)[[1L]]
        }
        return(sprintf("a <%s> object", type))
    }

    if (!is_vector(x)) {
        return(.rlang_as_friendly_type(typeof(x)))
    }

    n_dim <- length(dim(x))

    if (!n_dim) {
        if (!is.list(x) && length(x) == 1) {
            if (is.na(x)) {
                return(switch(typeof(x),
                    logical = "`NA`",
                    integer = "an integer `NA`",
                    double =
                        if (is.nan(x)) {
                            "`NaN`"
                        } else {
                            "a numeric `NA`"
                        },
                    complex = "a complex `NA`",
                    character = "a character `NA`",
                    .rlang_stop_unexpected_typeof(x)
                ))
            }

            show_infinites <- function(x) {
                if (x > 0) {
                    "`Inf`"
                } else {
                    "`-Inf`"
                }
            }
            str_encode <- function(x, width = 30, ...) {
                if (nchar(x) > width) {
                    x <- substr(x, 1, width - 3)
                    x <- paste0(x, "...")
                }
                encodeString(x, ...)
            }

            if (value) {
                if (is.numeric(x) && is.infinite(x)) {
                    return(show_infinites(x))
                }

                if (is.numeric(x) || is.complex(x)) {
                    number <- as.character(round(x, 2))
                    what <- if (is.complex(x)) {
                        "the complex number"
                    } else {
                        "the number"
                    }
                    return(paste(what, number))
                }

                return(switch(typeof(x),
                    logical = if (x) "`TRUE`" else "`FALSE`",
                    character = {
                        what <- if (nzchar(x)) {
                            "the string"
                        } else {
                            "the empty string"
                        }
                        paste(what, str_encode(x, quote = "\""))
                    },
                    raw = paste("the raw value", as.character(x)),
                    .rlang_stop_unexpected_typeof(x)
                ))
            }

            return(switch(typeof(x),
                logical = "a logical value",
                integer = "an integer",
                double = if (is.infinite(x)) show_infinites(x) else "a number",
                complex = "a complex number",
                character = if (nzchar(x)) "a string" else "\"\"",
                raw = "a raw value",
                .rlang_stop_unexpected_typeof(x)
            ))
        }

        if (length(x) == 0) {
            return(switch(typeof(x),
                logical = "an empty logical vector",
                integer = "an empty integer vector",
                double = "an empty numeric vector",
                complex = "an empty complex vector",
                character = "an empty character vector",
                raw = "an empty raw vector",
                list = "an empty list",
                .rlang_stop_unexpected_typeof(x)
            ))
        }
    }

    vec_type_friendly(x, length = length)
}

#' @importFrom rlang is_vector abort
vec_type_friendly <- function(x, length = FALSE) {
    if (!is_vector(x)) {
        abort("`x` must be a vector.")
    }
    type <- typeof(x)
    n_dim <- length(dim(x))

    add_length <- function(type) {
        if (length && !n_dim) {
            paste0(type, sprintf(" of length %s", length(x)))
        } else {
            type
        }
    }

    if (type == "list") {
        if (n_dim < 2) {
            return(add_length("a list"))
        } else if (is.data.frame(x)) {
            return("a data frame")
        } else if (n_dim == 2) {
            return("a list matrix")
        } else {
            return("a list array")
        }
    }

    type <- switch(type,
        logical = "a logical %s",
        integer = "an integer %s",
        numeric = ,
        double = "a double %s",
        complex = "a complex %s",
        character = "a character %s",
        raw = "a raw %s",
        type = paste0("a ", type, " %s")
    )

    if (n_dim < 2) {
        kind <- "vector"
    } else if (n_dim == 2) {
        kind <- "matrix"
    } else {
        kind <- "array"
    }
    out <- sprintf(type, kind)

    if (n_dim >= 2) {
        out
    } else {
        add_length(out)
    }
}

.rlang_as_friendly_type <- function(type) {
    switch(type,
        list = "a list",
        NULL = "`NULL`",
        environment = "an environment",
        externalptr = "a pointer",
        weakref = "a weak reference",
        S4 = "an S4 object",
        name = ,
        symbol = "a symbol",
        language = "a call",
        pairlist = "a pairlist node",
        expression = "an expression vector",
        char = "an internal string",
        promise = "an internal promise",
        ... = "an internal dots object",
        any = "an internal `any` object",
        bytecode = "an internal bytecode object",
        primitive = ,
        builtin = ,
        special = "a primitive function",
        closure = "a function",
        type
    )
}

#' @importFrom rlang abort caller_env
.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) {
    abort(sprintf("Unexpected type <%s>.", typeof(x)), call = call)
}

#' Return OO type
#' @param x Any R object.
#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`,
#'   `"R6"`, or `"S7"`.
#' @noRd
obj_type_oo <- function(x) {
    if (!is.object(x)) {
        return("bare")
    }

    class <- inherits(x, c("R6", "S7_object"), which = TRUE)

    if (class[[1]]) {
        "R6"
    } else if (class[[2]]) {
        "S7"
    } else if (isS4(x)) {
        "S4"
    } else {
        "S3"
    }
}

.standalone_oxford_comma <- function(x, sep = ", ", final = "and") {
    n <- length(x)

    if (n < 2L) return(x) # styler: off

    head <- x[seq_len(n - 1L)]
    last <- x[n]

    head <- paste(head, collapse = sep)

    # Write a or b. But a, b, or c.
    if (n > 2L) {
        paste0(head, sep, final, " ", last)
    } else {
        paste0(head, " ", final, " ", last)
    }
}

# nocov end

#' @inherit fortify_data_frame.default title description
#'
#' @param data A [`hclust`][stats::hclust] or a
#' [`dendrogram`][stats::as.dendrogram] object.
#' @param center A boolean value. if `TRUE`, nodes are plotted centered with
#' respect to all leaves/tips in the branch. Otherwise (default), plot them in
#' the middle of the direct child nodes.
#' @param type A string indicates the plot type, `"rectangle"` or `"triangle"`.
#' @param leaf_pos The x-coordinates of the leaf node. Must be the same length
#' of the number of observations in `tree`.
#' @param leaf_braches Branches of the leaf node. Must be the same length of the
#' number of observations in `tree`. Usually come from [cutree][stats::cutree].
#' @param reorder_branches A single boolean value, indicates whether reorder the
#' provided `leaf_braches` based on the actual index.
#' @param branch_gap A single numeric value indicates the gap between different
#' branches.
#' @param root A length one string or numeric indicates the root branch.
#' @param priority A string of "left" or "right". if we draw from `right` to
#' `left`, the left will override the right, so we take the `"left"` as the
#' priority. If we draw from `left` to `right`, the right will override the
#' left, so we take the `"right"` as priority. This is used by
#' [`align_dendro()`] to provide support of facet operation in ggplot2.
#' @param double A single logical value indicating whether horizontal lines
#' should be doubled when segments span multiple branches. If `TRUE`, the
#' horizontal lines will be repeated for each branch that the segment spans. If
#' `FALSE`, only one horizontal line will be drawn. This is used by
#' [`align_dendro()`] to provide support of facet operation in ggplot2.
#' @inheritParams fortify_data_frame
#' @return A `data frame` with the node coordinates:
#'   - `.panel`: Similar with `panel` column, but always give the correct
#'              branch for usage of the ggplot facet.
#'   - `.index`: the original index in the tree for the the node
#'   - `label`: node label text
#'   - `x` and `y`: x-axis and y-axis coordinates for the node
#'   - `branch`: which branch the node is. You can use this column to color
#'               different groups.
#'   - `panel`: which panel the node is, if we split the plot into panel
#'              using [facet_grid][ggplot2::facet_grid], this column will show
#'              which panel the node is from. Note: some nodes may
#'              fall outside panel (between two panels), so there are possible
#'              `NA` values in this column.
#'   - `leaf`: A logical value indicates whether the node is a leaf.
#' @section ggalign attributes:
#'  `edge`: A `data frame` for edge coordinates:
#'  - `.panel`: Similar with `panel` column, but always give the correct
#'              branch for usage of the ggplot facet.
#'  - `x` and `y`: x-axis and y-axis coordinates for the start node of the edge.
#'  - `xend` and `yend`: the x-axis and y-axis coordinates of the terminal node
#'                       for edge.
#'  - `branch`: which branch the edge is. You can use this column to color
#'              different groups.
#'  - `panel1` and `panel2`: The panel1 and panel2 columns have the same
#'     functionality as `panel`, but they are specifically for the `edge` data
#'     and correspond to both nodes of each edge.
#' @examples
#' fortify_data_frame(hclust(dist(USArrests), "ave"))
#' @importFrom grid is.unit
#' @importFrom stats order.dendrogram
#' @importFrom rlang arg_match0
#' @family fortify_data_frame
#' @export
fortify_data_frame.dendrogram <- function(data, ...,
                                          priority = "right",
                                          center = FALSE,
                                          type = "rectangle",
                                          leaf_pos = NULL,
                                          leaf_braches = NULL,
                                          reorder_branches = TRUE,
                                          branch_gap = NULL,
                                          root = NULL,
                                          double = TRUE,
                                          data_arg = NULL, call = NULL) {
    call <- call %||% current_call()
    data_arg <- data_arg %||% "data"
    rlang::check_dots_empty(call = call)
    assert_bool(center, call = call)
    assert_bool(reorder_branches, call = call)
    type <- arg_match0(type, c("rectangle", "triangle"), error_call = call)
    priority <- arg_match0(priority, c("left", "right"), error_call = call)
    N <- stats::nobs(data)
    rectangle <- type == "rectangle"
    if (is.null(leaf_pos)) {
        leaf_pos <- seq_len(N)
    } else if (length(leaf_pos) != N) {
        cli_abort(
            "{.arg leaf_pos} must be of the same length of {.arg tree}",
            call = call
        )
    }

    # if no branches provided, all branch will be regarded as the `root`
    if (is.null(leaf_braches)) {
        root <- root %||% "root"
    } else if (anyNA(leaf_braches)) {
        cli_abort("`NA` is not allowed in {.arg leaf_braches}",
            call = call
        )
    } else if (length(leaf_braches) != N) {
        cli_abort(
            "{.arg leaf_braches} must be of the same length of {.arg tree}",
            call = call
        )
    } else if (is.character(leaf_braches)) {
        root <- root %||% "root"
    } else if (is.factor(leaf_braches)) {
        leaf_braches <- as.character(leaf_braches)
        root <- root %||% "root"
    } else if (is.numeric(leaf_braches)) {
        root <- root %||% (min(leaf_braches) - 1L)
    } else {
        cli_abort("{.arg leaf_braches} must be a character or numeric",
            call = call
        )
    }

    if (!is.null(leaf_braches) && reorder_branches) {
        leaf_braches <- .subset(leaf_braches, order.dendrogram(data))
    }

    # check `branch_gap`
    if (is.numeric(branch_gap)) {
        if (!is_scalar(branch_gap)) {
            cli_abort("{.arg branch_gap} must be of length 1",
                call = call
            )
        }
    } else if (is.null(branch_gap)) {
        branch_gap <- 0
    } else {
        cli_abort("{.arg branch_gap} must be numeric value.",
            call = call
        )
    }

    # the root value shouldn't be the same of leaf branches.
    if (!is_scalar(root)) {
        cli_abort("{.arg root} must be of length 1", call = call)
    } else if (anyNA(root)) {
        cli_abort("{.arg root} cannot be `NA`", call = call)
    } else if (any(root == leaf_braches)) {
        cli_abort(
            "{.arg root} cannot contain value in {.arg leaf_braches}",
            call = call
        )
    }

    # initialize values
    i <- 0L # leaf index
    branch_levels <- NULL
    last_branch <- root
    total_gap <- 0
    dendrogram_data <- function(dend, from_root = TRUE) {
        if (stats::is.leaf(dend)) { # base version
            index <- as.integer(dend) # the column index of the original data
            y <- attr(dend, "height") %||% 0
            label <- attr(dend, "label") %||% NA
            i <<- i + 1L
            if (is.null(leaf_braches)) {
                branch <- root
            } else {
                branch <- .subset(leaf_braches, i)
            }

            x <- .subset(leaf_pos, i) + total_gap
            # for every new branch, we saved the branch for later use, in order
            # to order the branch levels, and we add a gap between two branch
            if (branch != last_branch) {
                branch_levels <<- c(branch_levels, branch)
                x <- x + branch_gap
                total_gap <<- total_gap + branch_gap
            }
            last_branch <<- branch

            node <- data_frame0(
                index = index, label = label,
                x = x, y = y, branch = branch,
                leaf = TRUE, panel = branch,
                ggpanel = branch
            )
            list(
                # current node
                node = node, edge = NULL,
                # current node information
                x = x, y = y,
                branch = branch,
                panel = branch,
                ggpanel = branch
            )
        } else if (inherits(dend, "dendrogram")) { # recursive version
            # the parent height  -------------------------------------
            y <- attr(dend, "height")

            # for the children nodes ---------------------------------
            data <- list_transpose(
                lapply(dend, dendrogram_data, from_root = FALSE)
            )

            # node should be the direct children
            node <- vec_rbind(!!!.subset2(data, "node"))
            edge <- vec_rbind(!!!.subset2(data, "edge"))

            # all coordinate for direct children nodes -------------
            # following should be length 2
            direct_leaves_x <- unlist(
                .subset2(data, "x"),
                recursive = FALSE, use.names = FALSE
            )
            direct_leaves_y <- unlist(
                .subset2(data, "y"),
                recursive = FALSE, use.names = FALSE
            )
            direct_leaves_branch <- unlist(
                .subset2(data, "branch"),
                recursive = FALSE, use.names = FALSE
            )
            direct_leaves_panel <- unlist(
                .subset2(data, "panel"),
                recursive = FALSE, use.names = FALSE
            )
            direct_leaves_ggpanel <- unlist(
                .subset2(data, "ggpanel"),
                recursive = FALSE, use.names = FALSE
            )

            # prepare node data ------------------------------------

            # all x coordinate for children nodes --------------------
            # used if center is `TRUE`, we'll calculate the center position
            # among all children nodes
            leaves <- vec_slice(node, .subset2(node, "leaf")) # all leaves

            # we assign the `panel` for current branch node
            ranges <- split(
                .subset2(leaves, "x"),
                .subset2(leaves, "panel")
            )
            ranges <- ranges[
                order(vapply(ranges, min, numeric(1L), USE.NAMES = FALSE))
            ]
            full_panel <- names(ranges)

            # x coordinate for current branch: the midpoint
            if (center) {
                x <- sum(range(.subset2(leaves, "x"))) / 2L
            } else {
                x <- sum(direct_leaves_x) / 2L
            }
            if (is.null(leaf_braches)) { # no branches
                ggpanel <- panel <- branch <- root
            } else {
                # we assign the branch for current branch node
                branch <- unique(direct_leaves_branch)
                # if two children leaves are different, this branch should be
                # `root`, this is often used to color the segments
                if (length(branch) > 1L) branch <- root

                # we assign the `panel` for current branch node
                panel <- NA
                for (i in seq_along(ranges)) {
                    if (x < min(.subset2(ranges, i))) {
                        panel <- NA
                        break
                    } else if (x <= max(.subset2(ranges, i))) {
                        panel <- .subset2(full_panel, i)
                        break
                    }
                }
                # if the node is between two panels, no panel
                # we choose the priority
                if (is.na(ggpanel <- panel)) {
                    # it's not possible for an branch node live outside the
                    # all panels - the left or right most. So `i` won't be 1 or
                    # length(ranges). we don't need to check the argument
                    ggpanel <- switch(priority,
                        left = .subset(full_panel, i - 1L),
                        right = .subset(full_panel, i)
                    )
                }
            }

            # there is no node data in dendrogram root
            if (!from_root) {
                node <- vec_rbind(node, data_frame0(
                    index = NA, label = NA,
                    x = x, y = y, branch = branch, leaf = FALSE,
                    panel = panel, ggpanel = ggpanel
                ))
            }

            # if it's the `rectangle`
            if (rectangle) {
                # 2 vertical lines
                vertical_lines <- data_frame0(
                    x = direct_leaves_x,
                    xend = direct_leaves_x,
                    y = direct_leaves_y,
                    yend = rep_len(y, 2L),
                    branch = direct_leaves_branch,
                    panel1 = direct_leaves_panel,
                    panel2 = direct_leaves_panel,
                    ggpanel = direct_leaves_ggpanel
                )
                # 2 horizontal lines
                # if the horizontal lines spanned multiple panels
                # we double the left line and the right line
                added_edge <- vec_rbind(
                    vertical_lines,
                    # left horizontal line
                    make_horizontal(
                        c(direct_leaves_x[1L], x),
                        panels = c(direct_leaves_panel[1L], panel),
                        ggpanels = c(direct_leaves_ggpanel[1L], ggpanel),
                        y = y,
                        branch = direct_leaves_branch[1L],
                        ranges = ranges,
                        full_panel = full_panel,
                        double = double
                    ),
                    # right horizontal line
                    make_horizontal(
                        c(x, direct_leaves_x[2L]),
                        panels = c(panel, direct_leaves_panel[2L]),
                        ggpanels = c(ggpanel, direct_leaves_ggpanel[2L]),
                        y = y,
                        branch = direct_leaves_branch[2L],
                        ranges = ranges,
                        full_panel = full_panel,
                        double = double
                    )
                )
            } else {
                added_edge <- data_frame0(
                    x = rep_len(x, 2L),
                    xend = direct_leaves_x,
                    y = rep_len(y, 2L),
                    yend = direct_leaves_y,
                    branch = direct_leaves_branch,
                    panel1 = rep_len(panel, 2L),
                    panel2 = direct_leaves_panel,
                    ggpanel = rep_len(ggpanel, 2L)
                )
            }
            if (is.null(edge)) {
                edge <- added_edge
            } else {
                edge <- vec_rbind(edge, added_edge)
            }
            list(
                node = node, edge = edge,
                x = x, y = y, branch = branch,
                panel = panel, ggpanel = ggpanel
            )
        } else {
            cli_abort("Invalid {.cls dendrogram} provided in {.arg {data_arg}}",
                call = call
            )
        }
    }
    ans <- dendrogram_data(data)
    node <- .subset2(ans, "node")
    edge <- .subset2(ans, "edge")

    # set factor levels for branch and panel ---------------
    panel_levels <- branch_levels
    branch_levels <- c(branch_levels, root)
    node$panel <- factor(.subset2(node, "panel"), panel_levels)
    node$branch <- factor(.subset2(node, "branch"), branch_levels)
    node$ggpanel <- factor(.subset2(node, "ggpanel"), panel_levels)
    if (!is.null(edge)) {
        edge$panel1 <- factor(.subset2(edge, "panel1"), panel_levels)
        edge$panel2 <- factor(.subset2(edge, "panel2"), panel_levels)
        edge$branch <- factor(.subset2(edge, "branch"), branch_levels)
        edge$ggpanel <- factor(.subset2(edge, "ggpanel"), panel_levels)
    }
    node <- rename(node, c(ggpanel = ".panel", index = ".index"))
    edge <- rename(edge, c(ggpanel = ".panel"))
    ggalign_data_set(node, edge = edge)
}

#' @param ... Additional arguments passed to `dendrogram` method.
#' @export
#' @rdname fortify_data_frame.dendrogram
fortify_data_frame.hclust <- function(data, ...) {
    fortify_data_frame.dendrogram(stats::as.dendrogram(data), ...)
}

#' @param ggpanels Won't be `NA`
#' @noRd
make_horizontal <- function(x, panels, ggpanels, y, branch,
                            ranges, full_panel = names(ranges),
                            double = TRUE) {
    if (!isTRUE(double) || identical(ggpanels[1L], ggpanels[2L])) {
        # in the same panel
        data_frame0(
            x = x[1L],
            xend = x[2L],
            y = y,
            yend = y,
            branch = branch,
            panel1 = panels[1L],
            panel2 = panels[2L],
            ggpanel = ggpanels[1L]
        )
    } else {
        index <- match(ggpanels, full_panel)
        ending <- index[2L] # right index
        panel0 <- panels[1L]
        ggpanel0 <- ggpanels[1L]
        point0 <- x[1L] # the left point coordinate x
        out <- vector("list", diff(index))
        right_index <- (index[1L] + 1L):ending
        for (i in seq_along(right_index)) {
            i1 <- .subset(right_index, i) # right index
            if (i1 == ending) {
                point1 <- x[2L]
                panel1 <- panels[2L]
                ggpanel1 <- ggpanels[2L]
            } else {
                point1 <- mean(range(.subset2(ranges, i1)))
                ggpanel1 <- panel1 <- .subset(full_panel, i1)
            }
            out[[i]] <- data_frame0(
                x = c(point0, point1),
                xend = c(point1, point0),
                y = y,
                yend = y,
                branch = branch,
                panel1 = c(panel0, panel1),
                panel2 = c(panel1, panel0),
                ggpanel = c(ggpanel0, ggpanel1)
            )
            point0 <- point1
            panel0 <- panel1
            ggpanel0 <- ggpanel1
        }
        vec_rbind(!!!out)
    }
}

#' Reorders layout observations based on specific statistics.
#'
#' @details
#' `r lifecycle::badge('experimental')`
#'
#' The `align_order2()` function differs from `align_order()` in that the
#' `weights` argument in `align_order()` must return atomic weights for each
#' observation. In contrast, the `stat` argument in `align_order2()` can
#' return more complex structures, such as [hclust][stats::hclust] or
#' [dendrogram][stats::as.dendrogram], among others.
#'
#' Typically, you can achieve the functionality of `align_order2()` using
#' `align_order()` by manually extracting the ordering information from
#' the statistic.
#'
#' @param stat A statistical function which accepts a data and returns the
#' statistic, which we'll call [`order2()`] to extract the ordering information.
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' function provided in `stat` argument.
#' @param data A `matrix`, `data frame`, or atomic vector used as the input for
#' the `stat` function. Alternatively, you can specify a `function` (including
#' purrr-like lambda syntax) that will be applied to the layout matrix,
#' transforming it as necessary for statistic calculations. By default, it will
#' inherit from the layout matrix.
#' @inheritParams align_order
#' @inheritSection align Discrete Axis Alignment
#' @examples
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_left() +
#'     align_order2(hclust2)
#' @seealso [order2()]
#' @importFrom ggplot2 waiver
#' @importFrom rlang list2
#' @export
align_order2 <- function(stat, ..., reverse = FALSE,
                         strict = TRUE, data = NULL,
                         active = NULL) {
    stat <- rlang::as_function(stat)
    assert_bool(strict)
    assert_bool(reverse)
    assert_active(active)
    active <- update_active(active, new_active(use = FALSE))
    align(
        align = AlignOrder2,
        stat = stat,
        params = list2(...),
        reverse = reverse,
        strict = strict,
        active = active,
        data = data
    )
}

#' @importFrom ggplot2 ggproto
#' @importFrom rlang inject
AlignOrder2 <- ggproto("AlignOrder2", CraftAlign,
    interact_layout = function(self, layout) {
        layout <- ggproto_parent(CraftAlign, self)$interact_layout(layout)
        layout_data <- layout@data
        if (is.null(input_data <- self$input_data) ||
            is.waive(input_data)) { # inherit from the layout
            if (is.null(data <- layout_data)) {
                cli_abort(c(
                    sprintf(
                        "you must provide {.arg data} in %s",
                        object_name(self)
                    ),
                    i = sprintf("no data was found in %s", self$layout_name)
                ))
            }
        } else if (is.function(input_data)) {
            if (is.null(layout_data)) {
                cli_abort(c(
                    sprintf(
                        "{.arg data} in %s cannot be a function",
                        object_name(self)
                    ),
                    i = sprintf("no data was found in %s", self$layout_name)
                ))
            }
            data <- input_data(layout_data)
        } else {
            data <- input_data
        }

        design <- layout@design
        layout_nobs <- .subset2(design, "nobs")

        # we always regard rows as the observations
        if (is.null(layout_nobs)) {
            layout_nobs <- vec_size(data)
            if (layout_nobs == 0L) {
                cli_abort("{.arg data} cannot be empty", call = self$call)
            }
            design["nobs"] <- list(layout_nobs)
            layout@design <- design
        } else if (vec_size(data) != layout_nobs) {
            cli_abort(sprintf(
                "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
                object_name, vec_size(data), layout_name, layout_nobs
            ))
        }

        # save the labels
        self$labels <- vec_names(data) %||% vec_names(layout_data)
        self$data <- ggalign_data_restore(data, layout_data)
        layout
    },
    compute = function(self, panel, index) {
        inject(self$stat(self$data, !!!self$params))
    },
    align = function(self, panel, index) {
        index <- vec_cast(
            order2(self$statistics), integer(),
            x_arg = "stat", call = self$call
        )
        assert_mismatch_nobs(
            self, vec_size(self$data), vec_size(index),
            arg = "stat"
        )
        if (self$reverse) index <- rev(index)
        assert_reorder(self, panel, index, self$strict)
        list(panel, index)
    },
    summary_align = function(self) c(TRUE, FALSE)
)

#' Ordering Permutation
#'
#' `order2` returns a permutation which rearranges its first argument into
#' ascending order.
#' @param x Any objects can be extracting ordering.
#' @return An integer vector unless any of the inputs has `2^31` or more
#' elements, when it is a double vector.
#' @examples
#' order2(hclust2(matrix(rnorm(100L), nrow = 10L)))
#' @export
order2 <- function(x) UseMethod("order2")

#' @export
#' @rdname order2
order2.hclust <- function(x) x$order

#' @importFrom stats order.dendrogram
#' @export
#' @rdname order2
order2.dendrogram <- function(x) order.dendrogram(x)

#' @export
#' @rdname order2
order2.ser_permutation_vector <- function(x) {
    rlang::check_installed(
        "seriation", "to extract order from `ser_permutation_vector`"
    )
    getExportedValue("seriation", "get_order")(x)
}

#' @export
#' @rdname order2
order2.ser_permutation <- function(x) {
    rlang::check_installed(
        "seriation", "to extract order from `ser_permutation`"
    )
    getExportedValue("seriation", "get_order")(x)
}

#' @export
#' @rdname order2
order2.phylo <- function(x) {
    second <- x$edge[, 2L, drop = TRUE]
    second[second <= length(x$tip.label)]
}

#' Add ggplot to layout without alignment
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' The `ggfree()` function allows you to incorporate a ggplot object into your
#' layout. Unlike `ggalign()`, which aligns every axis value precisely,
#' `ggfree()` focuses on integrating plots into the layout without enforcing
#' strict axis alignment.
#'
#' @inheritParams ggalign
#'
#' @section ggplot2 specification:
#' `ggalign` initializes a ggplot object. The underlying data is created using
#' [`fortify_data_frame()`]. Please refer to this method for more details.
#'
#' When used in `quad_layout()`/`ggheatmap()`, if the data is inherited from the
#' `quad_layout()` and the other direction aligns discrete variables, following
#' columns will be added:
#'
#'  - `.extra_panel`: Provides the panel information for the column (left or
#'    right annotation) or row (top or bottom annotation).
#'  - `.extra_index`: The index information for the column (left or right
#'    annotation) or row (top or bottom annotation).
#'
#' @examples
#' ggheatmap(matrix(rnorm(56), nrow = 7)) +
#'     anno_top() +
#'     align_dendro() +
#'     ggfree(mtcars, aes(wt, mpg)) +
#'     geom_point()
#' @export
ggfree <- function(data = waiver(), ..., size = NULL, active = NULL) {
    UseMethod("ggfree", data)
}

#' @inheritParams ggplot2::ggplot
#' @importFrom ggplot2 ggplot
#' @export
#' @rdname ggfree
ggfree.default <- function(data = waiver(), mapping = aes(), ...,
                           size = NULL, active = NULL) {
    data <- fortify_data_frame(data = data, ...)
    new_free_gg(
        plot = ggplot(data = NULL, mapping = mapping),
        data = data,
        size = size,
        active = active
    )
}

#' @export
ggfree.uneval <- function(data = waiver(), ...) {
    cli_abort(c(
        "{.arg data} cannot be {.obj_type_friendly {data}}",
        "i" = "Have you misspelled the {.arg data} argument in {.fn ggalign}"
    ))
}

#' @export
ggfree.ggplot <- function(data = waiver(), ..., size = NULL, active = NULL) {
    rlang::check_dots_empty()
    plot <- data
    # In ggplot2, `waiver()` was regard to no data
    data <- plot$data %|w|% NULL
    plot <- gguse_data(plot, waiver())
    new_free_gg(plot, data, size = size, active = active)
}

new_free_gg <- function(plot, data, size, active,
                        call = caller_call()) {
    assert_active(active, allow_null = TRUE, call = call)
    active <- update_active(active, new_active(use = TRUE))
    new_craftbox(
        FreeGg,
        # new field for FreeGg
        input_data = data,
        # slots for the plot
        plot = plot,
        size = size,
        active = active,
        schemes = default_schemes(data),
        call = call
    )
}

#' @importFrom ggplot2 ggproto
FreeGg <- ggproto("FreeGg", Craftsman,
    free_facet = TRUE,
    free_limits = TRUE,
    interact_layout = function(self, layout) {
        layout_data <- layout@data
        if (is.waive(input_data <- self$input_data)) { # inherit from the layout
            data <- layout_data
            self$labels <- vec_names(layout_data)

            # for data inherit from the layout, and the design is for discrete
            # variable, we'll integrate the design into the plot data
            self$use_design <- is_stack_layout(layout)

            # if the layout data is from the quad-layout, we use the discrete
            # `design`
            self$use_extra_design <- is_stack_layout(layout) &&
                isTRUE(layout@heatmap$quad_matrix)
        } else if (is.function(input_data)) {
            if (is.null(layout_data)) {
                cli_abort(c(
                    sprintf(
                        "{.arg data} in %s cannot be a function",
                        object_name(self)
                    ),
                    i = sprintf("no data was found in %s", self$layout_name)
                ))
            }
            data <- input_data(layout_data)
        } else {
            data <- input_data
        }
        self$data <- ggalign_data_restore(
            fortify_data_frame(data, call = self$call), layout_data
        )
        layout
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (is.function(data <- self$data)) {
            data <- NULL
        }
        if (is.null(data)) {
            return(gguse_data(plot, data))
        }
        if (isTRUE(self$use_extra_design) &&
            is_discrete_design(extra_design) &&
            !is.null(.subset2(extra_design, "nobs"))) {
            extra_plot_data <- data_frame0(
                .extra_panel = .subset2(extra_design, "panel"),
                .extra_index = .subset2(extra_design, "index")
            )
        } else {
            extra_plot_data <- NULL
        }

        # if inherit from the parent layout
        if (isTRUE(self$use_design) &&
            is_discrete_design(design) &&
            !is.null(.subset2(design, "nobs"))) {
            plot_data <- data_frame0(
                .panel = .subset2(design, "panel"),
                .index = .subset2(design, "index"),
                .names = .subset(self$labels, .subset2(design, "index"))
            )
            if (!is.null(extra_plot_data)) {
                plot_data <- cross_join(plot_data, extra_plot_data)
                data <- full_join(data, plot_data,
                    by.x = c(".column_index", ".row_index"),
                    by.y = c(".extra_index", ".index")
                )
            } else {
                data <- full_join(data, plot_data,
                    by.x = ".row_index", by.y = ".index"
                )
            }
        } else if (!is.null(extra_plot_data)) {
            data <- full_join(data, extra_plot_data,
                by.x = ".column_index", by.y = ".extra_index"
            )
        }
        gguse_data(plot, data)
    },
    summary = function(self, plot) {
        header <- ggproto_parent(Craftsman, self)$summary(plot)
        c(header, "  Add plot without alignment")
    }
)

#' Add ggplot by Aligning discrete or continuous variable
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' `ggalign()` is similar to `ggplot` in that it initializes a `ggplot` data and
#' `mapping`. `ggalign()` allowing you to provide data in various formats,
#' including matrices, data frames, or simple vectors. By default, it will
#' inherit from the layout. If a function, it will apply with the layout matrix.
#' `ggalign()` focuses on integrating plots into a layout by aligning the axes.
#'
#' @param data The following options can be used:
#'   - `NULL`: No data is set.
#'   - [`waiver()`][ggplot2::waiver]: Inherits the data from the layout matrix.
#'   - A `function` (including purrr-like lambda syntax): Applied to the layout
#'     matrix to transform the data before use. To transform the final plot
#'     data, please use [`scheme_data()`].
#'   - A `matrix`, `data.frame`, or atomic vector.
#' @inheritParams ggplot2::ggplot
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' [`fortify_data_frame()`].
#' @param size The relative size of the plot, can be specified as a
#' [`unit()`][grid::unit]. Note that for [`circle_layout()`], all size values
#' will be interpreted as relative sizes, as this layout type adjusts based on
#' the available space in the circular arrangement.
#' @param no_axes `r lifecycle::badge('experimental')` Logical; if `TRUE`,
#'   removes axes elements for the alignment axis using [`theme_no_axes()`]. By
#'   default, will use the option-
#'   `r code_quote(sprintf("%s.align_no_axes", pkg_nm()))`.
#' @param active A [`active()`] object that defines the context settings when
#'   added to a layout.
#' @section ggplot2 specification:
#' `ggalign` initializes a ggplot object. The underlying data is created using
#' [`fortify_data_frame()`]. Please refer to it for more details.
#'
#' When aligning discrete variables, `ggalign()` always applies a default
#' mapping for the axis of the data index in the layout. Specifically:
#'
#'  - `aes(y = .data$.y)` is used for the horizontal `stack_layout()` (including
#'    left and right annotations).
#'  - `aes(x = .data$.x)` is used for the vertical `stack_layout()` (including
#'    top and bottom annotations) and `circle_layout()`.
#'
#' The following columns will be added to the data frame to align discrete
#' variables:
#'
#'  - `.panel`: The panel for the aligned axis. Refers to the `x-axis` for
#'    vertical `stack_layout()` (including top and bottom annotations), and the
#'    `y-axis` for horizontal `stack_layout()` (including left and right
#'    annotations).
#'
#'  - `.names` ([`vec_names()`][vctrs::vec_names]) and `.index`
#'    ([`vec_size()`][vctrs::vec_size()]/[`NROW()`]): Character names (if
#'    available) and the integer index of the original data.
#'
#'  - `.x`/`.y` and `.discrete_x`/`.discrete_y`: Integer indices for `x`/`y`
#'    coordinates, and a factor of the data labels (only applicable when names
#'    exist).
#'
#' It is recommended to use `.x`/`.y`, or `.discrete_x`/`.discrete_y` as the
#' `x`/`y` mapping.
#'
#' If the data inherits from [`quad_layout()`]/[`ggheatmap()`], additional
#' columns will be added:
#'
#'  - `.extra_panel`: Provides the panel information for the column (left or
#'    right annotation) or row (top or bottom annotation).
#'  - `.extra_index`: The index information for the column (left or right
#'    annotation) or row (top or bottom annotation).
#'
#' @inheritSection align Discrete Axis Alignment
#' @examples
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     ggalign() +
#'     geom_point(aes(y = value))
#'
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top(size = 0.5) +
#'     align_dendro(k = 3L) +
#'     ggalign(data = NULL, size = 0.2) +
#'     geom_tile(aes(y = 1L, fill = .panel))
#'
#' @importFrom ggplot2 ggplot aes
#' @importFrom rlang list2
#' @export
ggalign <- function(data = waiver(), mapping = aes(), ..., size = NULL,
                    no_axes = NULL, active = NULL) {
    if (inherits(data, "uneval")) {
        cli_abort(c(
            "{.arg data} cannot be {.obj_type_friendly {data}}",
            "i" = "Have you misspelled the {.arg data} argument in {.fn ggalign}"
        ))
    }
    no_axes <- no_axes %||%
        getOption(sprintf("%s.align_no_axes", pkg_nm()), default = TRUE)
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    new_craftbox(
        AlignGg,
        input_data = allow_lambda(data),
        data_params = list2(...),
        plot = ggplot(mapping = mapping),
        size = size,
        schemes = default_schemes(data, th = theme_no_strip()),
        no_axes = no_axes, active = active
    )
}

#' @importFrom rlang inject
#' @importFrom ggplot2 ggproto ggplot
AlignGg <- ggproto("AlignGg", Craftsman,
    interact_layout = function(self, layout) {
        layout_name <- self$layout_name
        input_data <- self$input_data
        object_name <- object_name(self)
        layout_data <- layout@data

        # inherit data from the layout
        if (is.function(input_data)) {
            if (is.null(layout_data)) {
                cli_abort(c(
                    sprintf(
                        "{.arg data} in %s cannot be a function",
                        object_name
                    ),
                    i = sprintf("no data was found in %s", layout_name)
                ))
            }
            data <- input_data(layout_data)
        } else if (is.waive(input_data)) {
            data <- layout_data %|w|% NULL
            # for data inherit from the layout, and the layout data is from
            # the quad-layout, we'll integrate the `extra_design`
            self$use_extra_design <- is_stack_layout(layout) &&
                isTRUE(layout@heatmap$quad_matrix)
        } else {
            data <- input_data
        }
        plot_data <- inject(
            fortify_data_frame(data, !!!self$data_params, call = self$call)
        )

        # for discrete design, # we need ensure the nobs is the same
        if (is_discrete_design(design <- layout@design)) {
            if (!is.null(data)) {
                if (is.null(layout_nobs <- design$nobs)) {
                    layout_nobs <- NROW(data)
                    if (layout_nobs == 0L) {
                        cli_abort("{.arg data} cannot be empty",
                            call = self$call
                        )
                    }
                } else if (NROW(data) != layout_nobs) {
                    cli_abort(sprintf(
                        "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
                        object_name, NROW(data), layout_name, layout_nobs
                    ))
                }
                design["nobs"] <- list(layout_nobs)

                # we always add `.index` to align the observations
                # For matrix-like object
                if (!is.data.frame(data) &&
                    vec_is(dim(data), integer(), size = 2L)) {
                    plot_data$.index <- vec_rep(seq_len(NROW(data)), NCOL(data))
                } else {
                    plot_data$.index <- seq_len(NROW(data))
                }
                layout@design <- design
                self$labels <- vec_names(data) %||% vec_names(layout_data)
                # always remove names, we'll add it in `build_plot()`
                plot_data$.names <- NULL
            } else {
                self$labels <- vec_names(layout_data)
            }
            self$add_mapping <- TRUE
        }
        self$data <- ggalign_data_restore(plot_data, layout_data)
        layout
    },
    setup_plot = function(self, plot) {
        direction <- self$direction
        ggadd_default(
            plot,
            mapping = if (isTRUE(self$add_mapping)) {
                switch_direction(
                    direction,
                    aes(y = .data$.y),
                    aes(x = .data$.x)
                )
            },
            theme = if (is.null(self$data)) {
                # remove the title and text of axis vertically with the layout
                theme_no_axes(switch_direction(direction, "x", "y"))
            }
        ) + switch_direction(
            direction,
            ggplot2::labs(y = NULL),
            ggplot2::labs(x = NULL)
        )
    },

    #' @importFrom stats reorder
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        data <- self$data

        # if inherit from the parent layout
        if (isTRUE(self$use_extra_design) &&
            is_discrete_design(extra_design) &&
            !is.null(.subset2(extra_design, "nobs"))) {
            # if the data is inherit from the `quad_layout()`
            # the data must be a matrix
            extra_plot_data <- data_frame0(
                .extra_panel = .subset2(extra_design, "panel"),
                .extra_index = .subset2(extra_design, "index")
            )
        } else {
            extra_plot_data <- NULL
        }

        if (is_continuous_design(design)) {
            if (!is.null(data) && !is.null(extra_plot_data)) {
                data <- full_join(data, extra_plot_data,
                    by.x = ".column_index", by.y = ".extra_index"
                )
            }
            return(gguse_data(plot, data))
        } else if (is.null(.subset2(design, "nobs"))) {
            cli_abort(c(
                sprintf(
                    "you must initialize %s before drawing %s",
                    self$layout_name, object_name(self)
                ),
                i = "Or you should use {.fn ggfree}"
            ), call = self$call)
        }
        direction <- self$direction
        axis <- to_coord_axis(direction)
        panel <- .subset2(design, "panel")
        index <- .subset2(design, "index")
        coord_name <- paste0(".", axis)
        plot_data <- data_frame0(
            .panel = panel,
            .index = index,
            # `data_frame0` will omit `NULL`
            .names = .subset(self$labels, index)
        )
        plot_data[[coord_name]] <- seq_along(index)
        if (!is.null(.subset2(plot_data, ".names"))) {
            plot_data[[paste0(".discrete_", axis)]] <- reorder(
                .subset2(plot_data, ".names"),
                .subset2(plot_data, coord_name),
                order = FALSE
            )
        }

        if (!is.null(extra_plot_data)) {
            plot_data <- cross_join(plot_data, extra_plot_data)
            if (!is.null(data)) {
                plot_data <- full_join(data, plot_data,
                    by.x = c(".column_index", ".index"),
                    by.y = c(".extra_index", ".index")
                )
            }
        } else if (!is.null(data)) {
            plot_data <- full_join(data, plot_data, by = ".index")
        }
        gguse_data(plot, ggalign_data_restore(plot_data, data))
    },

    # let Craftsman to add schemes and theme acoordingly
    finish_plot = function(self, plot, schemes, theme) {
        direction <- self$direction
        # remove axis titles, text, ticks used for alignment
        if (isTRUE(self$no_axes)) {
            schemes$scheme_theme <- .subset2(schemes, "scheme_theme") +
                theme_no_axes(switch_direction(direction, "y", "x"))
        }
        plot <- plot_add_schemes(plot, schemes)
        if (is_horizontal(direction)) {
            theme <- theme(
                panel.spacing.y = calc_element("panel.spacing.y", theme)
            )
        } else {
            theme <- theme(
                panel.spacing.x = calc_element("panel.spacing.x", theme)
            )
        }
        plot <- plot + theme
        ggremove_margin(plot, direction) + theme_recycle()
    },
    summary = function(self, plot) {
        header <- ggproto_parent(Craftsman, self)$summary(plot)
        c(header, "  Add plot by Aligning discrete or continuous variable")
    }
)

#' Create ggplot object with layout panel data
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' This function was deprecated because we realised that it's a special case of
#' the [`ggalign()`] function. Please use `ggalign(data = NULL)` instead.
#' @export
#' @keywords internal
align_panel <- function(...) {
    lifecycle::deprecate_stop("0.0.5", "align_panel()", "ggalign(data = NULL)")
}

#' @export
#' @rdname align_panel
ggpanel <- function(...) {
    lifecycle::deprecate_stop("0.0.5", "ggpanel()", "ggalign(data = NULL)")
}

#' Create a New `CraftBox` Object with `CraftAlign` craftsman
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' An `CraftAlign` object interacts with the `Layout` object to reorder or split
#' observations and, in some cases, add plot components to the `Layout`.
#'
#' @param align An `CraftAlign` object.
#' @param ... Additional fields passed to the `align` object.
#' @param plot A ggplot object.
#' @inheritParams ggalign
#' @param schemes Options for `schemes`:
#'  - `NULL`: Used when `align` do not add a plot.
#'  - [`waiver()`][ggplot2::waiver]: Try to infer `schemes` based on `data`.
#' @param call The `call` used to construct the `align` object, for
#'   reporting messages.
#'
#' @section Discrete Axis Alignment:
#' It is important to note that we consider rows as observations, meaning
#' `vec_size(data)`/`NROW(data)` must match the number of observations along the
#' axis used for alignment (x-axis for a vertical stack layout, y-axis for a
#' horizontal stack layout).
#'
#' @return A new `CraftBox` object.
#' @examples
#' align_dendro()
#' @importFrom rlang caller_call current_call
#' @importFrom ggplot2 ggproto
#' @export
#' @keywords internal
align <- function(align, data = NULL, ..., plot = NULL,
                  size = NULL, schemes = NULL, no_axes = NULL,
                  active = NULL, call = caller_call()) {
    if (override_call(call)) {
        call <- current_call()
    }

    # check arguments ---------------------------------------------
    data <- allow_lambda(data)
    no_axes <- no_axes %||%
        getOption(sprintf("%s.align_no_axes", pkg_nm()), default = TRUE)
    schemes <- schemes %|w|% default_schemes(data)

    new_craftbox(
        craftsman = align,

        # additional field for `align` object
        no_axes = no_axes,
        ...,

        # Following fields will be initialzed when added into the layout
        # and will be saved and accessed across the plot rendering process
        direction = NULL,
        position = NULL,
        data = NULL, # Used to save the modified `input_data`
        statistics = NULL, # `$compute` method
        labels = NULL, # the original `vec_names()` of the `input_data`

        # the input data
        input_data = data,

        # object slots
        plot = plot,
        active = active,
        size = size,
        schemes = schemes,

        # call
        call = call
    )
}

#' @details
#' Each of the `Align*` objects is just a [`ggproto()`][ggplot2::ggproto]
#' object, descended from the top-level `CraftAlign`, and each implements
#' various methods and fields.
#'
#' To create a new type of `Align*` object, you typically will want to
#' override one or more of the following:
#'  - `setup_params`: Prepare parameter or check parameters used by this plot.
#'  - `setup_data`: Prepare data used by this plot.
#'  - `compute`: A method used to compute statistics.
#'  - `align`: A method used to group observations into panel or reorder
#'    observations.
#'  - `draw`: A method used to draw the plot. Must return a `ggplot` object.
#' @importFrom ggplot2 ggproto
#' @export
#' @format NULL
#' @usage NULL
#' @rdname align
#' @include craftbox-.R
CraftAlign <- ggproto("CraftAlign", Craftsman,
    interact_layout = function(self, layout) {
        # check plot is compatible with the layout
        if (is_layout_continuous(layout)) {
            layout_name <- self$layout_name
            # `CraftAlign` object is special for discrete variables
            cli_abort(c(
                sprintf("Cannot add %s to %s", object_name(self), layout_name),
                i = sprintf("%s cannot align discrete variables", layout_name)
            ))
        }
        layout
    },
    setup_design = function(self, design) {
        old_panel <- .subset2(design, "panel")
        old_index <- .subset2(design, "index")
        # prepare the data -------------------------------
        # compute statistics ---------------------------------
        self$statistics <- self$compute(panel = old_panel, index = old_index)

        # make the new layout -------------------------------
        panel_and_index <- self$align(panel = old_panel, index = old_index)

        # check panel
        layout_name <- self$layout_name
        nobs <- .subset2(design, "nobs")
        new_panel <- .subset2(panel_and_index, 1L)
        if (!is.null(new_panel)) {
            if (!is.atomic(new_panel)) {
                cli_abort(c(
                    sprintf(
                        "invalid layout panels defined by %s",
                        object_name(self)
                    ),
                    i = "layout panels must be an atomic vector"
                ))
            } else if (anyNA(new_panel)) {
                cli_abort(sprintf(
                    "layout panels defined by %s contain `NA`",
                    object_name(self)
                ))
            } else if (is.null(nobs)) {
                # we have defined panel, but don't define the `nobs`
                cli_abort(sprintf(
                    "%s defined the panels but not define {.field nobs}", object_name(self)
                ))
            } else if (length(new_panel) != nobs) {
                # we have defined panel, but don't define the `nobs`
                cli_abort(sprintf(
                    "layout panels defined by %s (nobs: %d) is not compatible with the nobs: %d",
                    object_name(self), length(new_panel), nobs
                ))
            } else if (!is.null(old_panel) && !(new_panel %nest% old_panel)) {
                cli_abort(sprintf(
                    "%s disrupt the previously established panel groups of %s",
                    object_name(self), layout_name
                ))
            }
        } else if (!is.null(old_panel)) {
            # push developer to reset the panel in the layout
            cli_abort(c(
                sprintf("invalid %s", object_name(self)),
                i = sprintf(
                    "%s reset the {.field panel}, but don't change the {.field panel} of the layout", object_name(self)
                )
            ))
        }
        panel <- new_panel
        if (!is.null(panel) && !is.factor(panel)) panel <- factor(panel)

        # check index
        new_index <- .subset2(panel_and_index, 2L)
        if (!is.null(new_index)) {
            if (!is.integer(new_index)) {
                cli_abort(c(
                    sprintf(
                        "invalid layout ordering index defined by %s", object_name(self)
                    ),
                    i = "layout ordering index must be an integer"
                ))
            } else if (anyNA(new_index)) {
                cli_abort(sprintf(
                    "layout ordering index defined by %s contain `NA`",
                    object_name(self)
                ))
            } else if (is.null(nobs)) {
                # we have defined panel, but don't define the `nobs`
                cli_abort(sprintf(
                    "%s defined the ordering index but not define nobs", object_name(self)
                ))
            } else if (length(new_index) != nobs) {
                # we have defined index, but don't define the `nobs`
                cli_abort(sprintf(
                    "layout ordering index defined by %s (nobs: %d) is not compatible with the nobs (%d)",
                    object_name(self), length(new_index), nobs
                ))
            }
        } else if (!is.null(old_index)) {
            # push developer to reset the `index` in the layout
            cli_abort(c(
                sprintf("invalid %s", object_name(self)),
                i = sprintf(
                    "%s reset the {.field index}, but don't change the {.field index} of the layout",
                    object_name(self)
                )
            ))
        }
        index <- new_index

        # we always make the index following the panel
        if (!is.null(panel) && !is.null(index)) {
            index <- reorder_index(panel, index)
        }

        # we always prevent from reordering twice.
        if (!is.null(old_index) && !all(old_index == index)) {
            cli_abort(sprintf(
                "%s disrupt the previously established ordering index of %s",
                object_name(self), layout_name
            ))
        }
        discrete_design(panel, index, nobs)
    },

    # Following fields should be defined for the new `CraftAlign` object.
    # argument name in these function doesn't matter.
    compute = function(self, panel, index) NULL,

    # Group heamap row/column and reorder, Must return a list of 2:
    #  - the first one should be the groups for heatmap row/column, the factor
    #    levels will determine the panel order, so it should always follow the
    #    index if you don't want the panel levels break the index. See
    #    `AlignDendro` for example.
    #  - the second one should be the heatmap row/column order index, and will
    #    determine the order in each grouped panel.
    #
    # See `$setup_design()` method for details
    # There will have following situations (the input is old index and old
    # panel):
    #
    # 1. old index is NULL and old panel is NULL, there is nothing wrong to
    #    define any new index or panel
    # 2. old index is `NULL` and old panel is not `NULL`, in this way, new
    #    index must follow the old panel.
    #
    #    For new `CraftAlign` object, which can do clustering, we must
    #    abort, if it can not do sub-clustering, if it can do sub-clustering, we
    #    should know if we want to change the order between the groups (panel
    #    levels).
    #
    #    Please check `AlignGroup` object and `CraftAlign` object
    #    For dendrogram, it can do sub-clustering within each group, it also
    #    allows reordering between groups (it provide `reorder_group` argument),
    #    so the new panel levels may be not the same with old panel
    #
    #    For `CraftAlign` object reordering the heatmap rows/columns.
    #    usually we provide a `strict` argument, to allow reorder heatmap within
    #    group only. See `AlignOrder2`.
    #
    # 3. old index is not `NULL`, no matter whether old panel is `NULL` or not,
    #    in this way, we should always ensure the new index won't change the old
    #    index, this will be checked in `$setup_design()` method.
    align = function(self, panel, index) list(panel, index),

    # let Craftsman to add schemes and theme acoordingly
    finish_plot = function(self, plot, schemes, theme) {
        ggproto_parent(AlignGg, self)$finish_plot(plot, schemes, theme)
    },
    summary = function(self, plot) {
        header <- ggproto_parent(Craftsman, self)$summary(plot)
        oo <- self$summary_align()
        nms <- c("plot", "reorder", "split")
        content <- c(
            if (is.null(plot)) "no" else "yes",
            if (isTRUE(oo[1L])) "yes" else "no",
            if (isTRUE(oo[2L])) "yes" else "no"
        )
        nms <- format(nms, justify = "right")
        content <- format(content, justify = "left")
        content <- paste0("  ", nms, ": ", content)
        c(header, content)
    },

    # Summary the action of `Align`
    #
    # @return A logical vector of length 2, indicating:
    # - Whether the object reorders the observations.
    # - Whether the object splits the observations into groups.
    # @keywords internal
    summary_align = function(self) c(FALSE, FALSE)
)

#' Build a Matrix for OncoPrint
#'
#' @description
#' Convert `MAF` object to a matrix:
#'  - `fortify_matrix.MAF`: Extract genomic alterations for genes.
#'  - `fortify_matrix.MAF_pathways`: Extract genomic alterations for pathways.
#'    [`tune.MAF()`] helps convert `MAF` object to a `MAF_pathways` object.
#'
#' @inheritParams rlang::args_dots_empty
#' @param data A [`MAF`][maftools::read.maf] object.
#' @param genes An atomic character defines the genes to draw.
#' @param n_top A single number indicates how many top genes to be drawn.
#' @param remove_empty_genes A single boolean value indicats whether to drop
#' genes without any genomic alterations.
#' @param remove_empty_samples A single boolean value indicats whether to drop
#' samples without any genomic alterations.
#' @param collapse_vars A single boolean value indicating whether to collapse
#' multiple alterations in the same sample and gene into a single value
#' `"Multi_Hit"`. Alternatively, you can provide a single string indicates the
#' collapsed values.
#' @param use_syn A single boolean value indicates whether to include synonymous
#' variants when Classifies SNPs into transitions and transversions.
#' @param missing_genes A string, either `"error"` or `"remove"`, specifying the
#' action for handling missing genes.
#' @inheritParams fortify_matrix
#' @section ggalign attributes:
#'  For `fortify_matrix.MAF`:
#'  - `gene_summary`: A data frame of gene summary informations. See
#'    `maftools::getGeneSummary()` for details.
#'  - `sample_summary`: A data frame of sample summary informations. See
#'    `maftools::getSampleSummary()` for details.
#'  - `sample_anno`: A data frame of sample clinical informations. See
#'    `maftools::getClinicalData()` for details.
#'  - `variant_weights`: A data frame of variant weights. Each gene in a sample
#'    is assigned a total weight of `1`. When multiple variants occur in the
#'    same gene-sample pair, the weight for each variant reflects its proportion
#'    of the total.
#'  - `n_genes`: Total number of genes.
#'  - `n_samples`: Total number of samples.
#'  - `titv`: A list of data frame with Transitions and Transversions
#'    summary. See `maftools::titv()` for details.
#'
#' The levels of `Variant_Classification` will be stored in [`ggalign_lvls()`].
#' If they do not exist, alphabetical ordering will be used.
#'
#' @family fortify_matrix
#' @importFrom utils getFromNamespace
#' @importFrom rlang is_string
#' @export
fortify_matrix.MAF <- function(data, ..., genes = NULL, n_top = NULL,
                               remove_empty_genes = TRUE,
                               remove_empty_samples = TRUE,
                               collapse_vars = TRUE, use_syn = TRUE,
                               missing_genes = "error",
                               data_arg = NULL, call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    rlang::check_installed(
        "maftools", "to make alterations matrix from `MAF` object"
    )
    # prepare arguments
    missing_genes <- arg_match0(
        missing_genes, c("error", "remove"),
        error_call = call
    )
    if (isTRUE(collapse_vars)) {
        collapse_vars <- "Multi_Hit"
    } else if (isFALSE(collapse_vars)) {
        collapse_vars <- NULL
    } else if (is_string(collapse_vars)) {
        if (collapse_vars == "") {
            cli_abort("{.arg collapse_vars} cannot be an empty string",
                call = call
            )
        }
    } else {
        cli_abort(
            paste(
                "{.arg collapse_vars} must be a single boolean value or a string,",
                "but you provide {.obj_type_friendly {collapse_vars}}"
            ),
            call = call
        )
    }

    getSampleSummary <- getExportedValue("maftools", "getSampleSummary")
    getGeneSummary <- getExportedValue("maftools", "getGeneSummary")
    getClinicalData <- getExportedValue("maftools", "getClinicalData")

    # if `maftools` is installed, `data.table` must have been installed
    # No need to check if `data.table` is installed
    dcast <- getExportedValue("data.table", "dcast")
    setDT <- getExportedValue("data.table", "setDT")
    setDF <- getExportedValue("data.table", "setDF")

    sample_summary <- new_data_frame(getSampleSummary(data))
    gene_summary <- new_data_frame(getGeneSummary(data))
    sample_anno <- new_data_frame(getClinicalData(data))

    titv <- getExportedValue("maftools", "titv")
    titv <- titv(data, useSyn = use_syn, plot = FALSE)
    titv <- lapply(titv, new_data_frame)

    # we transform the data into a normal data frame
    data <- new_data_frame(data@data)[
        c("Tumor_Sample_Barcode", "Hugo_Symbol", "Variant_Classification")
    ]
    n_genes <- vec_unique_count(.subset2(data, "Hugo_Symbol"))
    n_samples <- vec_unique_count(.subset2(data, "Tumor_Sample_Barcode"))

    # filter by genes --------------------------------------
    if (!is.null(genes)) {
        # reorder the gene annotation based on the provided genes
        genes <- vec_cast(genes, character())
        if (vec_any_missing(genes)) {
            cli_abort(
                "{.arg genes} cannot contain missing values",
                call = call
            )
        }
        if (vec_duplicate_any(genes)) {
            cli_abort(
                "{.arg genes} cannot contain duplicated values",
                call = call
            )
        }
        if (identical(missing_genes, "remove")) {
            genes <- genes[genes %in% .subset2(gene_summary, "Hugo_Symbol")]
        }
        if (is_empty(genes)) {
            cli_abort(
                "No {.arg genes} remain after removing missing genes",
                call = call
            )
        }
        gene_summary <- vec_slice(
            gene_summary,
            vec_as_location(
                genes,
                n = vec_size(gene_summary),
                names = .subset2(gene_summary, "Hugo_Symbol"),
                missing = "error"
            )
        )
    }
    genes <- .subset2(gene_summary, "Hugo_Symbol")
    if (!is.null(n_top)) {
        n_top <- min(n_top, vec_size(genes))
        index <- vec_slice(
            order(gene_summary$AlteredSamples, decreasing = TRUE),
            seq_len(n_top)
        )
        index <- sort(index) # don't change the order, we do only subset
        genes <- vec_slice(genes, index)
        gene_summary <- vec_slice(gene_summary, index)
    }
    data <- vec_slice(data, .subset2(data, "Hugo_Symbol") %in% genes)

    # Group variants --------------------------------------
    indices <- vec_group_loc(data[c("Tumor_Sample_Barcode", "Hugo_Symbol")])
    vars <- .subset2(data, "Variant_Classification")
    lvls <- levels(vars) %||% sort(vec_unique(vars))
    nlvls <- vec_size(lvls)
    var_list <- vec_chop(as.character(vars), indices = .subset2(indices, "loc"))

    # calcualte the variant weights -----------------------
    variant_weights <- lapply(var_list, function(var) {
        o <- numeric(nlvls)
        names(o) <- lvls
        counts <- vec_count(var)
        o[.subset2(counts, "key")] <- .subset2(counts, "count") /
            sum(.subset2(counts, "count"))
        o
    })
    variant_weights <- inject(rbind(!!!variant_weights))
    gene_indices <- vec_group_loc(
        .subset2(.subset2(indices, "key"), "Hugo_Symbol")
    )
    variant_weights <- lapply(
        vec_chop(variant_weights, indices = .subset2(gene_indices, "loc")),
        colSums
    )
    variant_weights <- vec_cbind(
        Hugo_Symbol = .subset2(gene_indices, "key"),
        vec_rbind(!!!variant_weights)
    )

    # collapse the vars ------------------------------------
    if (is.null(collapse_vars)) {
        vars <- vapply(var_list, function(var) {
            if (length(var) > 1L) {
                paste(var, collapse = ";")
            } else {
                var
            }
        }, character(1L), USE.NAMES = FALSE)
    } else {
        vars <- vapply(var_list, function(var) {
            if (vec_unique_count(var) > 1L) {
                collapse_vars
            } else if (length(var) > 1L) {
                paste(var, collapse = ";")
            } else {
                var
            }
        }, character(1L), USE.NAMES = FALSE)
        if (any(vars == collapse_vars)) lvls <- c(lvls, collapse_vars)
    }
    ans <- vec_cbind(
        .subset2(indices, "key"),
        new_data_frame(list(Variant_Classification = vars))
    )

    # restore all samples, this will introduce `NA` in `Hugo_Symbol`
    ans <- right_join(ans, data_frame0(
        Tumor_Sample_Barcode = vec_unique(sample_summary$Tumor_Sample_Barcode)
    ))
    setDT(ans)
    ans <- dcast(ans, Hugo_Symbol ~ Tumor_Sample_Barcode,
        value.var = "Variant_Classification"
    )
    setDF(ans)
    ans <- vec_slice(ans, !is.na(.subset2(ans, "Hugo_Symbol")))

    # convert data into a matrix
    if (remove_empty_genes) {
        # convert to a matrix
        ans <- as.matrix(column_to_rownames(ans, "Hugo_Symbol"))

        # reorder the rows based on the `genes` specified
        index <- match(genes, rownames(ans))
        ans <- vec_slice(ans, index[!is.na(index)])
    } else {
        # restore all genes
        ans <- right_join(ans, data_frame0(Hugo_Symbol = genes))

        # convert to a matrix
        ans <- as.matrix(column_to_rownames(ans, "Hugo_Symbol"))

        # reorder the rows based on the `genes` specified
        ans <- vec_slice(ans, genes)
    }

    # filter samples when necessary
    if (remove_empty_samples) {
        keep <- colSums(!is.na(ans)) > 0L
        ans <- ans[, keep, drop = FALSE]
    }

    # reorder the rows based on the gene ordering
    gene_summary <- vec_slice(
        gene_summary,
        vec_as_location(
            rownames(ans),
            n = vec_size(gene_summary),
            names = vec_cast(gene_summary$Hugo_Symbol, character())
        )
    )
    variant_weights <- vec_slice(
        variant_weights,
        vec_as_location(
            rownames(ans),
            n = vec_size(variant_weights),
            names = variant_weights$Hugo_Symbol
        )
    )

    # reorder columns based on the sample ordering
    sample_summary <- vec_slice(
        sample_summary,
        vec_as_location(
            colnames(ans),
            n = vec_size(sample_summary),
            names = vec_cast(sample_summary$Tumor_Sample_Barcode, character())
        )
    )
    sample_anno <- vec_slice(
        sample_anno,
        vec_as_location(
            colnames(ans),
            n = vec_size(sample_anno),
            names = sample_anno$Tumor_Sample_Barcode
        )
    )
    titv <- lapply(titv, function(data) {
        data <- left_join(
            data_frame0(Tumor_Sample_Barcode = colnames(ans)),
            data
        )
        vec_slice(data, vec_as_location(
            colnames(ans),
            n = vec_size(data),
            names = vec_cast(data$Tumor_Sample_Barcode, character())
        ))
    })
    ggalign_data_set(ans,
        sample_summary = sample_summary,
        gene_summary = gene_summary,
        sample_anno = sample_anno,
        variant_weights = variant_weights,
        n_samples = n_samples, n_genes = n_genes, titv = titv,
        .lvls = lvls
    )
}

#' Convert the shape of a MAF for fortify method
#'
#' @param data A [`MAF`][maftools::read.maf] object.
#' @param shape Not used currently.
#' @seealso [`fortify_matrix.MAF_pathways()`]
#' @family tune
#' @export
tune.MAF <- function(data, shape = NULL) {
    if (!is.null(shape)) {
        cli_abort("{.arg shape} cannot be used currently for {.cls MAF} object")
    }
    new_tune(data, class = "MAF_pathways")
}

#' @param pathdb A string of `r oxford_or(c("smgbp", "sigpw"))`, or a named list
#' of genes to define the pathways.
#' @param remove_empty_pathways A single boolean value indicats whether to drop
#' pathways without any genomic alterations.
#' @section ggalign attributes:
#'  For `fortify_matrix.MAF_pathways`:
#'  - `gene_list`: the pathway contents.
#'  - `pathway_summary`: pathway summary informations. See
#'    `maftools::pathways()` for details.
#'  - `sample_summary`: sample summary informations. See
#'    `maftools::getSampleSummary()` for details.
#'  - `sample_anno`: sample clinical informations. See
#'    `maftools::getClinicalData()` for details.
#' @export
#' @rdname fortify_matrix.MAF
fortify_matrix.MAF_pathways <- function(data, ..., pathdb = "smgbp",
                                        remove_empty_pathways = TRUE,
                                        remove_empty_samples = TRUE,
                                        data_arg = NULL,
                                        call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    rlang::check_installed(
        "maftools", "to make alterations matrix from `MAF` object"
    )
    get_pw_summary <- getFromNamespace("get_pw_summary", "maftools")
    maf <- tune_data(data)
    if (rlang::is_string(pathdb)) {
        pathdb <- arg_match0(pathdb, c("sigpw", "smgbp"))
        pathway_summary <- get_pw_summary(maf, pathways = pathdb)
    } else if (is.data.frame(pathdb)) {
        cli_abort("{.arg pathdb} cannot be a data frame", call = call)
    } else if (is.list(pathdb)) {
        if (!rlang::is_named(pathdb)) {
            cli_abort(sprintf(
                "{.arg pathdb} must be a named list of a single string of %s",
                oxford_or(c("sigpw", "smgbp"))
            ), call = call)
        }
        pathdb <- data_frame0(
            Pathway = factor(
                vec_rep_each(names(pathdb), lengths(pathdb)),
                names(pathdb)
            ),
            Gene = unlist(pathdb, FALSE, FALSE)
        )
        pathdb <- vec_unique(pathdb)
        pathway_summary <- get_pw_summary(maf, pathways = pathdb)
    }
    getSampleSummary <- getExportedValue("maftools", "getSampleSummary")
    getClinicalData <- getExportedValue("maftools", "getClinicalData")
    sample_summary <- new_data_frame(getSampleSummary(maf))
    sample_anno <- new_data_frame(getClinicalData(maf))

    gene_list <- attr(pathway_summary, "genes") # a list of genes
    ans <- new_data_frame(maf@data)[
        c("Tumor_Sample_Barcode", "Hugo_Symbol", "Variant_Classification")
    ]
    full_genes <- unlist(gene_list, FALSE, FALSE)
    ans$pathways <- vec_slice(
        vec_set_names(
            vec_rep_each(names(gene_list), lengths(gene_list)),
            full_genes
        ),
        if_else(ans$Hugo_Symbol %in% full_genes,
            ans$Hugo_Symbol, NA_character_
        )
    )
    ans$Alt <- if_else(is.na(.subset2(ans, "pathways")), NA_character_, "Alt")
    ans <- vec_unique(ans[c("Tumor_Sample_Barcode", "pathways", "Alt")])

    # if `maftools` is installed, `data.table` must have been installed
    # No need to check if `data.table` is installed
    dcast <- getExportedValue("data.table", "dcast")
    setDT <- getExportedValue("data.table", "setDT")
    setDF <- getExportedValue("data.table", "setDF")
    setDT(ans)
    ans <- dcast(ans, pathways ~ Tumor_Sample_Barcode,
        value.var = "Alt", fill = NA_character_
    )
    setDF(ans)
    ans <- vec_slice(ans, !is.na(.subset2(ans, "pathways")))

    # convert data into a matrix
    if (remove_empty_pathways) {
        # convert to a matrix
        ans <- as.matrix(column_to_rownames(ans, "pathways"))

        # reorder the rows based on the `pathways` specified
        index <- match(names(gene_list), rownames(ans))
        gene_list <- gene_list[!is.na(index)]
        ans <- vec_slice(ans, index[!is.na(index)])
    } else {
        # restore all pathways
        ans <- right_join(ans, data_frame0(pathways = names(gene_list)))

        # convert to a matrix
        ans <- as.matrix(column_to_rownames(ans, "pathways"))

        # reorder the rows based on the `pathways` specified
        ans <- vec_slice(ans, names(gene_list))
    }

    # filter samples when necessary
    if (remove_empty_samples) {
        keep <- colSums(!is.na(ans)) > 0L
        ans <- ans[, keep, drop = FALSE]
    }

    # reorder the rows based on the pathways ordering
    setDF(pathway_summary)
    pathway_summary <- vec_slice(
        pathway_summary,
        vec_as_location(
            rownames(ans),
            n = vec_size(pathway_summary),
            names = vec_cast(pathway_summary$Pathway, character())
        )
    )

    # reorder columns based on the sample ordering
    sample_summary <- vec_slice(
        sample_summary,
        vec_as_location(
            colnames(ans),
            n = vec_size(sample_summary),
            names = vec_cast(sample_summary$Tumor_Sample_Barcode, character())
        )
    )
    sample_anno <- vec_slice(
        sample_anno,
        vec_as_location(
            colnames(ans),
            n = vec_size(sample_anno),
            names = sample_anno$Tumor_Sample_Barcode
        )
    )
    ggalign_data_set(ans,
        gene_list = gene_list,
        pathway_summary = pathway_summary,
        sample_summary = sample_summary,
        sample_anno = sample_anno
    )
}

#' Build a matrix from a maftools object
#'
#' @inheritParams rlang::args_dots_empty
#' @param data A [`GISTIC`][maftools::readGistic] object.
#' @param n_top A single number indicates how many top bands to be drawn.
#' @param bands An atomic character defines the bands to draw.
#' @param ignored_bands An atomic character defines the bands to be ignored.
#' @param sample_anno A data frame of sample clinical features to be added.
#' @param remove_empty_samples A single boolean value indicating whether to drop
#' samples without any genomic alterations.
#' @inheritParams fortify_matrix
#' @section ggalign attributes:
#'  - `sample_anno`: sample clinical informations provided in `sample_anno`.
#'  - `sample_summary`: sample copy number summary informations. See
#'    `data@@cnv.summary` for details.
#'  - `cytoband_summary`: cytoband summary informations. See
#'    `data@@cytoband.summary` for details.
#'  - `gene_summary`: gene summary informations. See
#'    `data@@gene.summary` for details.
#'  - `summary`: A data frame of summary information. See `data@@summary` for
#'    details.
#' @family fortify_matrix
#' @export
fortify_matrix.GISTIC <- function(data, ..., n_top = NULL, bands = NULL,
                                  ignored_bands = NULL, sample_anno = NULL,
                                  remove_empty_samples = TRUE,
                                  data_arg = NULL,
                                  call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    rlang::check_installed(
        "maftools",
        "to make CNV matrix from `GISTIC` object"
    )
    assert_number_whole(n_top,
        allow_null = TRUE,
        call = call
    )
    assert_character(bands,
        allow_null = TRUE,
        call = call
    )
    assert_character(ignored_bands,
        allow_null = TRUE,
        call = call
    )
    assert_s3_class(sample_anno, "data.frame",
        allow_null = TRUE,
        call = call
    )
    assert_bool(remove_empty_samples,
        call = call
    )
    cn_mat <- data@cnMatrix
    if (is.null(bands)) {
        bands <- rownames(cn_mat)
    } else {
        bands <- intersect(bands, rownames(cn_mat))
    }
    if (!is.null(ignored_bands)) {
        bands <- setdiff(bands, ignored_bands)
    }
    if (!is.null(bands)) {
        cn_mat <- vec_slice(cn_mat, rownames(cn_mat) %in% bands)
    }
    if (!is.null(n_top)) {
        cn_mat <- vec_slice(cn_mat, seq_len(min(n_top, nrow(cn_mat))))
    }
    if (remove_empty_samples) {
        keep <- colSums(cn_mat != "") > 0L
        cn_mat <- cn_mat[, keep, drop = FALSE]
    }
    if (!is.null(sample_anno)) {
        loc <- vec_locate_matches(
            colnames(cn_mat),
            .subset2(sample_anno, "Tumor_Sample_Barcode") %||%
                .subset2(sample_anno, 1L),
            relationship = "one-to-one",
            needles_arg = "data",
            haystack_arg = "sample_anno",
            error_call = call
        )
        sample_anno <- vec_slice(sample_anno, .subset2(loc, "haystack"))
    }
    sample_summary <- new_data_frame(data@cnv.summary)
    sample_summary <- vec_slice(
        sample_summary,
        vec_as_location(
            colnames(cn_mat),
            n = vec_size(sample_summary),
            names = vec_cast(sample_summary$Tumor_Sample_Barcode, character())
        )
    )
    gene_summary <- new_data_frame(data@gene.summary)
    cytoband_sumamry <- new_data_frame(data@cytoband.summary)
    cytoband_sumamry <- vec_slice(
        cytoband_sumamry,
        vec_as_location(
            rownames(cn_mat),
            n = vec_size(cytoband_sumamry),
            names = vec_cast(cytoband_sumamry$Unique_Name, character())
        )
    )
    ggalign_data_set(cn_mat,
        sample_anno = sample_anno,
        sample_summary = sample_summary,
        cytoband_sumamry = cytoband_sumamry,
        gene_summary = gene_summary,
        sumamry = data@summary
    )
}

# Use S4 to override the double dispatch problem of ggplot2
# And it's easy to convert a S4 Class to a S7 Class
methods::setClass(
    "CraftBox",
    list(
        plot = "ANY", # To avoid modify in place, we put plot in a slot
        active = "ANY",
        size = "ANY",
        schemes = "ANY",
        craftsman = "ANY" # `Craftsman` object
    )
)

#' Show `CraftBox` information
#' @param object A `CraftBox` object.
#' @return The input invisiblely.
#' @keywords internal
methods::setMethod("show", "CraftBox", function(object) {
    print(object)
})

#' @importFrom methods new
new_craftbox <- function(craftsman = NULL, ...,
                         plot = NULL, active = NULL, size = NULL,
                         schemes = NULL, call = caller_call()) {
    assert_active(active, allow_null = FALSE, call = call)
    if (is.null(size)) {
        size <- unit(NA, "null")
    } else {
        size <- check_size(size, call = call)
    }
    new(
        "CraftBox",
        # `call`: used to provide error message
        craftsman = ggproto(NULL, craftsman %||% Craftsman, ..., call = call),
        schemes = schemes %||% default_schemes(),
        plot = plot, active = active, size = size
    )
}

#' @export
print.CraftBox <- function(x, ...) {
    cat(x@craftsman$summary(x@plot), sep = "\n")
    invisible(x)
}

#' @export
plot.CraftBox <- function(x, ...) {
    cli_abort(sprintf("Cannot plot %s object directly", object_name(x)))
}

#' @importFrom grid grid.draw
#' @exportS3Method
grid.draw.CraftBox <- plot.CraftBox

#' Add custom objects to ggalign plot
#' @keywords internal
methods::setMethod("+", c("CraftBox", "ANY"), function(e1, e2) {
    if (missing(e2)) {
        cli_abort(c(
            "Cannot use {.code {.Generic}} with a single argument.",
            "i" = "Did you accidentally put {.code {.Generic}} on a new line?"
        ))
    }

    if (is.null(e2)) return(e1) # styler: off

    # Get the name of what was passed in as e2, and pass along so that it
    # can be displayed in error messages
    e2name <- paste(deparse(substitute(e2)), collapse = " ")
    switch(.Generic, # nolint
        `+` = craftbox_add(e2, e1, e2name),
        stop_incompatible_op(.Generic, e1, e2)
    )
})

#' @importFrom methods is
is_craftbox <- function(x) is(x, "CraftBox")

is_cross_plot <- function(x) is_craftbox(x) && is_cross(x@craftsman)

is_cross <- function(x) inherits(x, "CraftCross")

#######################################################
#' @importFrom ggplot2 ggproto
Craftsman <- ggproto("Craftsman",
    call = NULL,

    # following fields will be added when added to the layout
    in_linear = NULL,
    layout_name = NULL,
    direction = NULL,
    position = NULL, # for stack_layout() in quad_layout()
    labels = NULL,

    # A single boolean value indicates whether we should set facet and coord
    free_facet = FALSE,
    free_coord = FALSE,
    free_limits = FALSE,

    # we always prevent user from modifying the object in `$build_plot()` and
    # `$finish_plot()` methods
    locked = TRUE,
    lock = function(self) {
        assign("locked", value = TRUE, envir = self)
    },
    unlock = function(self) {
        assign("locked", value = FALSE, envir = self)
    },

    ############################################################
    # when added to the `Layout` object, will call following methods

    # we usually, define the `nobs` in `interact_layout`, since we can
    # act with the layout data in `interact_layout` method
    interact_layout = function(self, layout) layout,

    # we define the `panel` and `index` method in `setup_design` method
    setup_design = function(self, design) design,
    setup_plot = function(self, plot) plot,

    ##############################################################
    # Don't change the facet and coord in following methods
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        plot
    },
    finish_plot = function(self, plot, schemes, theme) {
        plot <- plot_add_schemes(plot, schemes)
        ggremove_margin(plot, self$direction) + theme_recycle()
    },

    # utils method to print the object, should return a character vector
    summary = function(self, plot) {
        cls <- class(self)
        cls <- cls[seq_len(which(cls == "Craftsman"))]
        sprintf("<Class: %s>", paste(cls, collapse = " "))
    }
)

# Used to lock the `Craftsman` object
#' @export
`$<-.Craftsman` <- function(x, name, value) {
    if (x$locked) {
        cli_abort(c(
            sprintf("Cannot modify %s", object_name(x)),
            i = sprintf("%s is locked", object_name(x))
        ), call = x$call)
    }
    NextMethod()
}

#################################################################
craftbox_add <- function(object, craftbox, object_name) {
    if (is.null(craftbox@plot)) {
        cli_abort(c(
            sprintf(
                "Cannot add {.var {object_name}} to %s",
                object_name(craftbox)
            ),
            i = sprintf("no plot found for %s", object_name(craftbox))
        ))
    }
    UseMethod("craftbox_add")
}

#' @importFrom ggplot2 ggplot_add
#' @export
craftbox_add.default <- function(object, craftbox, object_name) {
    craftbox@plot <- ggplot_add(
        object,
        ggfun("plot_clone")(craftbox@plot),
        object_name
    )
    craftbox
}

#' @export
craftbox_add.ggalign_scheme <- function(object, craftbox, object_name) {
    name <- ggalign_scheme_name(object)
    craftbox@schemes[name] <- list(update_scheme(
        object, .subset2(craftbox@schemes, name), object_name
    ))
    craftbox
}

######################################################################
plot_build <- function(align, ..., schemes, theme) {
    plot <- align$build_plot(plot@plot, ...)
    align$finish_plot(plot, schemes, theme)
}

#' Arrange plots horizontally or vertically
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' If `limits` is provided, a continuous variable will be required and aligned
#' in the direction specified (`stack_continuous`). Otherwise, a discrete
#' variable will be required and aligned (`stack_discrete`).
#'
#' Several aliases are provided for convenience:
#' - `stack_vertical`: A special case of `stack_layout` that sets `direction
#'   = "v"`.
#' - `stack_horizontal`: A special case of `stack_layout` that sets `direction
#'   = "h"`.
#' - `stack_discretev`: A special case of `stack_discrete` that sets `direction
#'   = "v"`.
#' - `stack_discreteh`: A special case of `stack_discrete` that sets `direction
#'   = "h"`.
#' - `stack_continuousv()`: A special case of `stack_free` that sets `direction
#'   = "v"`.
#' - `stack_continuoush()`: A special case of `stack_free` that sets `direction
#'   = "h"`.
#'
#' For historical reasons, the following aliases are available:
#' - `stack_align` is an alias for `stack_discrete`.
#' - `stack_alignv` is an alias for `stack_discretev`.
#' - `stack_alignh` is an alias for `stack_discreteh`.
#' - `stack_free` is an alias for `stack_continuous`.
#' - `stack_freev` is an alias for `stack_continuousv`.
#' - `stack_freeh` is an alias for `stack_continuoush`.
#'
#' @param direction A string indicating the direction of the stack layout,
#' either `"h"`(`horizontal`) or `"v"`(`vertical`).
#' @param data `r rd_layout_data()`:
#'  - If `limits` is not provided, [`fortify_matrix()`] will be used to get a
#'    matrix.
#'  - If `limits` is specified, [`fortify_data_frame()`] will be used to get a
#'    data frame.
#'
#' @param ... Additional arguments passed to [`fortify_data_frame()`] or
#' [`fortify_matrix()`].
#' @param theme A [`theme()`][ggplot2::theme] object used to customize various
#' elements of the layout, including `guides`, `title`, `subtitle`, `caption`,
#' `margins`, `panel.border`, and `background`. By default, the theme will
#' inherit from the parent `layout`. It also controls the panel spacing for all
#' plots in the layout.
#'
#' @param sizes A numeric value or a [`unit`][grid::unit] object. When used for
#' the [`quad_layout()`] annotation, it must be of length `1`. When used in the
#' [`stack_layout()`] with a nested [`quad_layout()`], it should be of length
#' `3`, specifying the relative heights (for `direction = "h"`) or widths (for
#' `direction = "v"`) to be applied to the layout.
#' @param limits A [`continuous_limits()`] object specifying the left/lower
#' limit and the right/upper limit of the scale. Used to align the continuous
#' axis.
#' @return A `StackLayout` object.
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 7L)
#'
#' stack_horizontal(small_mat) + align_dendro()
#'
#' # this is the same with:
#' stack_discrete("h", small_mat) + align_dendro()
#'
#' stack_discreteh(small_mat) + align_dendro()
#'
#' # For vertical layout:
#' stack_vertical(small_mat) + align_dendro()
#'
#' @export
stack_layout <- function(direction, data = NULL, ...,
                         theme = NULL, sizes = NA, limits = waiver()) {
    if (is.waive(limits)) {
        stack_discrete(
            data = data, direction = direction, ...,
            theme = theme, sizes = sizes
        )
    } else {
        stack_continuous(
            data = data, direction = direction, ...,
            theme = theme, sizes = sizes, limits = limits
        )
    }
}

#' @export
#' @rdname stack_layout
stack_horizontal <- function(data = NULL, ..., limits = waiver()) {
    stack_layout(data = data, direction = "h", limits = limits, ...)
}

#' @export
#' @rdname stack_layout
stack_vertical <- function(data = NULL, ..., limits = waiver()) {
    stack_layout(data = data, direction = "v", limits = limits, ...)
}

###################################################################
#' @export
#' @rdname stack_layout
stack_discrete <- function(direction, data = NULL, ...,
                           theme = NULL, sizes = NA) {
    UseMethod("stack_discrete", data)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_align <- stack_discrete

#' @export
#' @rdname stack_layout
stack_discretev <- function(data = NULL, ...) {
    stack_discrete(data = data, direction = "v", ...)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_alignv <- stack_discretev

#' @export
#' @rdname stack_layout
stack_discreteh <- function(data = NULL, ...) {
    stack_discrete(data = data, direction = "h", ...)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_alignh <- stack_discreteh

#' @export
stack_discrete.default <- function(direction, data = NULL, ...,
                                   theme = NULL, sizes = NA) {
    direction <- check_direction(direction)
    # the observations are rows, we use matrix to easily
    # reshape it into a long formated data frame for ggplot,
    # and we can easily determine the number of observations
    # from matrix
    data <- data %|w|% NULL
    data <- fortify_matrix(data = data, ...)
    schemes <- default_schemes()
    if (!is.null(data) && !is.function(data)) {
        # if we have provided data, we initialize the `nobs`
        nobs <- vec_size(data)

        # for data has dimention but one dimention is 0
        # as.matrix(data.frame(row.names = letters))
        if (nobs == 0L) {
            cli_abort("empty data is no allowed")
        }
    } else {
        nobs <- NULL
    }
    new_stack_layout(
        name = "stack_discrete",
        data = data, direction = direction,
        design = discrete_design(nobs = nobs),
        schemes = schemes, theme = theme, sizes = sizes
    )
}

#' @export
stack_discrete.function <- function(direction, data = NULL, ...) {
    cli_abort(paste0(
        "{.arg data} must be a {.cls matrix}, ",
        "or an object coercible by {.fn fortify_matrix}, or a valid ",
        "{.cls matrix}-like object coercible by {.fn as.matrix}"
    ))
}

#' @export
stack_discrete.formula <- stack_discrete.function

################################################################
#' @export
#' @rdname stack_layout
stack_continuous <- function(direction, data = NULL, ..., limits = NULL,
                             theme = NULL, sizes = NA) {
    UseMethod("stack_continuous", data)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_free <- stack_continuous

#' @export
#' @rdname stack_layout
stack_continuousv <- function(data = NULL, ...) {
    stack_continuous(data = data, direction = "v", ...)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_freev <- stack_continuousv

#' @export
#' @rdname stack_layout
stack_continuoush <- function(data = NULL, ...) {
    stack_continuous(data = data, direction = "h", ...)
}

#' @usage NULL
#' @export
#' @rdname stack_layout
stack_freeh <- stack_continuoush

#' @export
stack_continuous.default <- function(direction, data = NULL, ...,
                                     limits = NULL, theme = NULL, sizes = NA) {
    assert_limits(limits)
    direction <- check_direction(direction)
    data <- data %|w|% NULL
    data <- fortify_data_frame(data = data, ...)
    schemes <- default_schemes()
    new_stack_layout(
        name = "stack_continuous",
        data = data, direction = direction, design = limits,
        schemes = schemes, theme = theme, sizes = sizes
    )
}

#' @export
stack_continuous.function <- function(direction, data = NULL, ...) {
    cli_abort(paste0(
        "{.arg data} must be a {.cls data.frame}, ",
        "or an object coercible by {.fn fortify_data_frame}, or a valid ",
        "{.cls data.frame}-like object coercible by {.fn as.data.frame}"
    ))
}

#' @export
stack_continuous.formula <- stack_continuous.function

#' @importFrom methods new
new_stack_layout <- function(data, direction, design,
                             schemes = NULL, theme = NULL, sizes = NA,
                             name = NULL, call = caller_call()) {
    sizes <- check_stack_sizes(sizes, call = call)
    if (!is.null(theme)) assert_s3_class(theme, "theme", call = call)
    if (is.null(name)) {
        if (is_continuous_design(design)) {
            name <- "stack_continuous"
        } else {
            name <- "stack_discrete"
        }
    }
    new(
        "StackLayout",
        name = name, data = data,
        direction = direction,
        theme = theme, schemes = schemes, # used by the layout
        sizes = sizes, design = design
    )
}

############################################################
# Used to place multiple objects in one axis
#' @importFrom grid unit
#' @importFrom ggplot2 waiver
#' @keywords internal
#' @include layout-chain-.R
methods::setClass(
    "StackLayout",
    contains = "ChainLayout",
    list(
        direction = "character",
        heatmap = "list", # used by heatmap annotation
        sizes = "ANY" # used by stack layout
    ),
    prototype = list(
        heatmap = list(
            position = NULL,
            free_guides = waiver(),
            # indicate whether or not the data is from the quad-layout matrix
            quad_matrix = FALSE
        )
    )
)

#' @keywords internal
quad_layout_add <- function(object, quad, object_name) {
    UseMethod("quad_layout_add")
}

#############################################################
#' @export
quad_layout_add.layout_title <- function(object, quad, object_name) {
    quad@titles <- update_non_waive(quad@titles, object)
    quad
}

##############################################################
# Preventing from adding following elements
#' @export
quad_layout_add.matrix <- function(object, quad, object_name) {
    cli_abort(sprintf("Can't change data of %s", object_name(quad)))
}

#' @export
quad_layout_add.data.frame <- quad_layout_add.matrix

#############################################################
# Add elements for the main body or the annotation
#' @importFrom methods slot slot<-
#' @export
quad_layout_add.default <- function(object, quad, object_name) {
    if (is.null(position <- quad@active)) {
        quad <- quad_body_add(object, quad, object_name)
    } else if (is.null(stack <- slot(quad, position))) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "the {.field {position}} annotation stack is not initialized",
            i = "Try to use {.code quad_anno(initialize = TRUE)} or you can add a {.code stack_layout()} manually"
        ))
    } else {
        slot(quad, position) <- chain_layout_add(object, stack, object_name)
    }
    quad
}

#' @export
quad_layout_add.list <- function(object, quad, object_name) {
    for (o in object) quad <- quad_layout_add(o, quad, object_name)
    quad
}

#' @export
quad_layout_add.NULL <- function(object, quad, object_name) {
    quad
}

#' @export
quad_layout_add.ggalign_with_quad <- function(object, quad, object_name) {
    old <- quad@active
    contexts <- quad_operated_context(object, old, "+") %||%
        list(NULL) # we wrap `NULL` to a list for `for loop`.
    object <- .subset2(object, "object")
    object_name <- .subset2(object, "object_name")
    for (active in contexts) {
        quad@active <- active
        quad <- quad_layout_add(object, quad, object_name)
    }
    quad@active <- old
    quad
}

##################################################################
#' @export
quad_layout_add.quad_active <- function(object, quad, object_name) {
    if (!is.null(width <- .subset2(object, "width"))) {
        quad@width <- width
    }
    if (!is.null(height <- .subset2(object, "height"))) {
        quad@height <- height
    }
    quad@active <- NULL
    quad
}

#' @importFrom methods slot
#' @export
quad_layout_add.quad_anno <- function(object, quad, object_name) {
    position <- .subset2(object, "position")
    initialize <- .subset2(object, "initialize")
    stack <- slot(quad, position)
    if (is.null(stack) && !isFALSE(initialize)) {
        # try to initialize the annotation stack with the layout data
        direction <- to_direction(position)
        layout_design <- slot(quad, direction)
        # for the annotation stack, we try to take the data from the
        # quad layout
        quad_data <- quad@data
        data <- waiver() # use waiver() to indicate data is not initialized
        quad_matrix <- FALSE # the default value for `quad_matrix` in the stack
        if (is_continuous_design(layout_design)) { # the stack need a data frame
            if (!is.data.frame(quad_data)) {
                if (is.null(initialize)) {
                    cli_warn(paste(
                        "`data` in {.fn {quad@name}} is",
                        "{.obj_type_friendly {quad_data}}, but the",
                        "{.field {position}} annotation stack need a",
                        "{.cls data.frame}, won't initialize",
                        "the {.field {position}} annotation stack"
                    ))
                } else {
                    data <- NULL
                }
            } else {
                data <- quad_data
            }
        } else if (is.matrix(quad_data)) { # the stack need a matrix
            if (is_horizontal(direction)) {
                data <- quad_data
            } else {
                data <- ggalign_data_restore(t(quad_data), quad_data)
            }
            quad_matrix <- TRUE
        } else {
            if (is.null(initialize)) {
                cli_warn(paste(
                    "`data` in {.fn {quad@name}} is",
                    "{.obj_type_friendly {quad_data}}, but the",
                    "{.field {position}} annotation stack need a",
                    "{.cls data.frame}, won't initialize",
                    "the {.field {position}} annotation stack"
                ))
            } else {
                data <- NULL
            }
        }
        if (!is.waive(data)) { # initialize the annotation stack
            stack <- new_stack_layout(
                data = data,
                direction = direction,
                # the layout parameters should be the same with `quad_layout()`
                design = layout_design,
                # we'll inherit the action data function when
                schemes = default_schemes(if (is.null(data)) NULL else waiver())
            )
            stack@heatmap$position <- position
            stack@heatmap$quad_matrix <- quad_matrix
        }
    } else if (!is.null(stack) && isTRUE(initialize)) {
        cli_abort(c(
            "Cannot initialize the {position} annotation stack",
            i = "{position} annotation stack has already been initialized"
        ))
    }

    if (!is.null(stack)) {
        # update parameters
        if (!is.null(size <- .subset2(object, "size"))) {
            stack@sizes <- size
        }
        if (!is.waive(free_guides <- .subset2(object, "free_guides"))) {
            stack@heatmap["free_guides"] <- list(free_guides)
        }
        stack <- switch_chain_plot(
            stack, .subset2(object, "what"), quote(quad_anno())
        )
        slot(quad, position) <- stack
    }
    quad@active <- position
    quad
}

#' @export
quad_layout_add.QuadLayout <- function(object, quad, object_name) {
    cli_abort(c(
        sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
        i = "Did you mean to place multiple {.fn quad_layout} elements inside a {.fn stack_layout}?"
    ))
}

#' @export
quad_layout_add.StackLayout <- function(object, quad, object_name) {
    # we check if there is an active annotation
    if (is.null(position <- quad@active)) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "no active annotation stack",
            i = "try to activate an annotation stack with {.fn anno_*}"
        ))
    }
    # check the annotation stack is not initialized
    if (!is.null(slot(quad, position))) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "{position} annotation stack already exists"
        ))
    }
    # cannot contain nested layout
    if (!all(vapply(object@plot_list, is_craftbox, logical(1L),
                    USE.NAMES = FALSE))) { # styler: off
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "annotation stack cannot contain nested layout"
        ))
    }
    # check quad layout is compatible with stack layout
    if (!identical(direction <- to_direction(position), object@direction)) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "only {.field {direction}} stack is allowed in {position} annotation"
        ))
    }
    if (length(object@sizes) > 1L) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "{.arg sizes} must be of length one to use the stack as an annotation"
        ))
    }
    quad_design <- slot(quad, direction)
    if (is_cross_layout(object) &&
        any(position == c("bottom", "right")) &&
        !is_empty(object@cross_points)) {
        # if there are cross points in bottom or right annotation,
        # use the first design
        stack_design <- .subset2(object@odesign, 1L)
    } else {
        stack_design <- object@design
    }
    # check if we can align in this direction
    # `stack_layout()` is free from aligning obervations in this axis
    if (is_continuous_design(stack_design)) {
        if (!is_continuous_design(quad_design)) {
            cli_abort(c(
                sprintf(
                    "Cannot add {.var {object_name}} to %s",
                    object_name(quad)
                ),
                i = sprintf(
                    "%s cannot align continuous variable in {.field {direction}} direction",
                    object_name(quad)
                )
            ))
        }
        layout_design <- stack_design
    } else if (is_discrete_design(quad_design)) {
        layout_design <- melt_discrete_design(
            quad_design, stack_design,
            old_name = object_name(quad),
            new_name = object_name
        )
    } else {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = sprintf(
                "%s cannot align discrete variable in {.field {direction}} direction",
                object_name(quad)
            )
        ))
    }
    object@heatmap$position <- position
    slot(quad, position) <- object
    update_design(quad,
        direction = direction,
        design = layout_design,
        object_name = object_name
    )
}

#' @importFrom methods slot slot<-
#' @export
quad_layout_add.CraftBox <- function(object, quad, object_name) {
    if (is.null(position <- quad@active)) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "no active annotation stack",
            i = "try to activate an annotation stack with {.fn anno_*}"
        ))
    }
    if (is.null(stack <- slot(quad, position))) {
        cli_abort(c(
            sprintf("Cannot add {.var {object_name}} to %s", object_name(quad)),
            i = "the {.field {position}} annotation stack is not initialized",
            i = "Try to use {.code quad_anno(initialize = TRUE)} or you can add a {.code stack_layout()} manually"
        ))
    }

    # add annotation -----------------------------
    stack <- chain_layout_add(object, stack, object_name)
    slot(quad, position) <- stack

    # if there are cross points in bottom or right annotation, we use
    # the first design
    if (is_cross_layout(stack) &&
        any(position == c("bottom", "right")) &&
        !is_empty(stack@cross_points)) {
        new_design <- .subset2(stack@odesign, 1L)
    } else {
        new_design <- stack@design
    }

    update_design(
        quad,
        direction = to_direction(position),
        design = new_design,
        object_name = object_name
    )
}

#######################################################
# used to add elements for main body
#' @keywords internal
quad_body_add <- function(object, quad, object_name) {
    UseMethod("quad_body_add")
}

#' @importFrom ggplot2 ggplot_add
#' @export
quad_body_add.default <- function(object, quad, object_name) {
    quad@plot <- ggplot_add(object, ggfun("plot_clone")(quad@plot), object_name)
    quad
}

#' @export
quad_body_add.Coord <- function(object, quad, object_name) {
    if (!inherits(object, "CoordCartesian")) {
        cli_warn(c(
            "only {.field cartesian coordinate} is supported",
            i = "will discard {.var {object_name}} directly"
        ))
        return(quad)
    }
    NextMethod() # call default method
}

#' @export
quad_body_add.layout_theme <- function(object, quad, object_name) {
    quad@theme <- update_layout_theme(quad@theme, object)
    quad
}

#' @export
quad_body_add.ggalign_scheme <- function(object, quad, object_name) {
    name <- ggalign_scheme_name(object)
    quad@body_schemes[name] <- list(update_scheme(
        object, .subset2(quad@body_schemes, name), object_name
    ))
    quad
}

#' Arrange plots in the quad-side of a main plot
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' This function arranges plots around the quad-sides of a main plot, aligning
#' both horizontal and vertical axes, and can handle either discrete or
#' continuous variables.
#'
#' - If `xlim` is provided, a continuous variable will be required and aligned
#'   in the vertical direction. Otherwise, a discrete variable will be required
#'   and aligned.
#' - If `ylim` is provided, a continuous variable will be required and aligned
#'   in the horizontal direction. Otherwise, a discrete variable will be
#'   required and aligned.
#'
#' The `quad_discrete` is a special case where both `xlim` and `ylim` are not
#' provided.
#'
#' The `quad_continuous` is a special case where both `xlim` and `ylim` are
#' provided.
#'
#' For historical reasons, the following aliases are available:
#' - `quad_alignh`: Align discrete variables in the horizontal direction and
#'   continuous variables in vertical direction.
#' - `quad_alignv`: Align discrete variables in the vertical direction and
#'   continuous variables in horizontal direction.
#' - `quad_alignb` is an alias for `quad_discrete`.
#' - `quad_free` is an alias for `quad_continuous`.
#'
#' @param data `r rd_layout_data()`. By default, this will attempt
#'   to inherit from the parent layout.
#'
#' If both `xlim` and `ylim` are provided, a `data frame` is required, and
#'   [`fortify_data_frame()`] will be used to convert the data to a data frame.
#'   When inherited by an annotation stack, no transposition will be applied.
#'
#' Otherwise, a `matrix` is required, and [`fortify_matrix()`] will be used to
#'   convert the data to a matrix. When inherited by the column annotation
#'   stack, the data will be transposed.
#' @param mapping Default list of aesthetic mappings to use for main plot in the
#' layout. If not specified, must be supplied in each layer added to the main
#' plot.
#' @param xlim,ylim A [`continuous_limits()`] object specifying the left/lower
#' limit and the right/upper limit of the scale. Used to align the continuous
#' axis.
#' @param width,height The relative width/height of the main plot, can be a
#' [`unit`][grid::unit] object.
#' @inheritParams stack_layout
#' @inheritParams align
#' @return A `QuadLayout` object.
#' @section ggplot2 specification:
#' If either `xlim` or `ylim` is not provided, the data input will be converted
#' to a matrix using [`fortify_matrix()`], and the data in the underlying main
#' plot will contain the following columns:
#'
#'  - `.panel_x` and `.panel_y`: the column and row panel groups.
#'
#'  - `.x` and `.y`: an integer index of `x` and `y` coordinates
#'
#'  - `.discrete_x` and `.discrete_y`: a factor of the data labels (only
#'    applicable when `.row_names` and `.column_names` exists).
#'
#'  - `.row_names` and `.column_names`: A character of the row and column names
#'    of the original matrix (only applicable when names exist).
#'
#'  - `.row_index` and `.column_index`: the row and column index of the original
#'    matrix.
#'
#'  - `value`: the actual matrix value.
#'
#' Otherwise, the data input will be used for the main plot.
#'
#' @export
quad_layout <- function(data = waiver(), mapping = aes(),
                        xlim = waiver(), ylim = waiver(),
                        ...,
                        theme = NULL, active = NULL,
                        width = NA, height = NA) {
    if (is.waive(xlim) && is.waive(ylim)) {
        quad_discrete(
            data = data, mapping = mapping,
            ..., active = active, theme = theme,
            width = width, height = height
        )
    } else if (!is.waive(xlim) && !is.waive(ylim)) {
        quad_continuous(
            data = data, mapping = mapping, xlim = xlim, ylim = ylim,
            ..., active = active, theme = theme,
            width = width, height = height
        )
    } else {
        data <- fortify_matrix(data = data, ...)
        new_quad_layout(
            name = "quad_layout",
            data = data, ylim = ylim, xlim = xlim,
            mapping = mapping, active = active, theme = theme,
            width = width, height = height
        )
    }
}

#' @export
#' @rdname quad_layout
quad_alignh <- function(..., ylim = waiver()) {
    quad_layout(..., xlim = NULL, ylim = ylim)
}

#' @export
#' @rdname quad_layout
quad_alignv <- function(..., xlim = waiver()) {
    quad_layout(..., xlim = xlim, ylim = NULL)
}

##########################################################
#' @export
#' @rdname quad_layout
quad_discrete <- function(data = waiver(), mapping = aes(),
                          ...,
                          theme = NULL, active = NULL,
                          width = NA, height = NA) {
    UseMethod("quad_discrete")
}

#' @export
#' @rdname quad_layout
#' @usage NULL
quad_alignb <- quad_discrete

#' @export
quad_discrete.default <- function(data = waiver(), mapping = aes(),
                                  ...,
                                  theme = NULL, active = NULL,
                                  width = NA, height = NA) {
    data <- fortify_matrix(data = data, ...)
    new_quad_layout(
        name = "quad_discrete", data = data, xlim = waiver(), ylim = waiver(),
        mapping = mapping, active = active, theme = theme,
        width = width, height = height
    )
}

#' @export
quad_discrete.uneval <- function(data, ...) {
    cli_abort(c(
        "{.arg data} cannot be {.obj_type_friendly {data}}",
        "i" = "Have you misspelled the {.arg data} argument in {.fn quad_discrete}"
    ))
}

#############################################################
#' @export
#' @rdname quad_layout
quad_continuous <- function(data = waiver(), mapping = aes(),
                            xlim = NULL, ylim = NULL,
                            ...,
                            theme = NULL, active = NULL,
                            width = NA, height = NA) {
    UseMethod("quad_continuous")
}

#' @usage NULL
#' @export
#' @rdname quad_layout
ggside <- quad_continuous

#' @usage NULL
#' @export
#' @rdname quad_layout
quad_free <- quad_continuous

#' @export
quad_continuous.default <- function(data = waiver(), mapping = aes(),
                                    xlim = NULL, ylim = NULL,
                                    ...,
                                    theme = NULL, active = NULL,
                                    width = NA, height = NA) {
    xlim <- xlim %|w|% NULL
    ylim <- ylim %|w|% NULL
    data <- fortify_data_frame(data = data, ...)
    new_quad_layout(
        name = "quad_continuous",
        data = data, xlim = xlim, ylim = ylim,
        mapping = mapping, active = active, theme = theme,
        width = width, height = height
    )
}

#' @export
quad_continuous.uneval <- function(data, ...) {
    cli_abort(c(
        "{.arg data} cannot be {.obj_type_friendly {data}}",
        "i" = "Have you misspelled the {.arg data} argument in {.fn quad_free}"
    ))
}

#####################################################
#' @importFrom ggplot2 ggplot
#' @importFrom methods new
new_quad_layout <- function(name, data, xlim = waiver(), ylim = waiver(),
                            mapping = aes(), theme = NULL, active = NULL,
                            width = NA, height = NA,
                            class = "QuadLayout",
                            call = caller_call()) {
    if (!is.waive(xlim)) assert_limits(xlim, call = call)
    if (!is.waive(ylim)) assert_limits(ylim, call = call)
    if (is.waive(xlim) || is.waive(ylim)) {
        # If we need align discrete variables, data cannot be `NULL` and
        # must be provided, here, we convert it to waiver() to indicate
        # inherit from the parent layout
        data <- data %||% waiver()
        if (!is.waive(data) && !is.function(data)) {
            nrows <- NROW(data)
            ncols <- ncol(data)

            # for data has dimention but one dimention is 0
            # as.matrix(data.frame(row.names = letters))
            if (nrows == 0L || ncols == 0L) {
                cli_abort("empty data is no allowed")
            }
        } else {
            nrows <- NULL
            ncols <- NULL
        }
    }
    horizontal <- ylim %|w|% discrete_design(nobs = nrows)
    vertical <- xlim %|w|% discrete_design(nobs = ncols)

    # always remove default axis titles
    # https://stackoverflow.com/questions/72402570/why-doesnt-gplot2labs-overwrite-update-the-name-argument-of-scales-function
    # There are multiple ways to set labels in a plot, which take different
    # priorities. Here are the priorities from highest to lowest.
    # 1. The guide title.
    # 2. The scale name.
    # 3. The `labs()` function.
    # 4. The captured expression in aes().
    plot <- ggplot(mapping = mapping) +
        ggplot2::labs(x = NULL, y = NULL)

    if (!is.null(theme)) assert_s3_class(theme, "theme", call = call)
    # for `QuadLayout`, we use `NULL` to inherit data from parent layout
    # since `QuadLayout` must have data, and won't be waiver()
    # if inherit from the parent layout data, we'll inherit
    # the action data function
    schemes <- default_schemes(
        if (is.null(data)) waiver() else NULL,
        th = theme_no_strip()
    )

    # check arguments -----------------------------------
    width <- check_size(width, call = call)
    height <- check_size(height, call = call)
    assert_active(active, call = call)

    # Here we use S4 object to override the double dispatch of `+.gg` method
    new(
        class,
        # used by the layout
        data = data, theme = theme,
        schemes = schemes,
        plot_active = update_active(active, new_active(use = TRUE)),
        name = name,
        # used by the main body
        body_schemes = default_schemes(waiver()),
        # following parameters can be controlled by `quad_switch`
        width = width, height = height,
        # following parameters are used internally
        plot = plot, horizontal = horizontal, vertical = vertical
    )
}

# Used to create the QuadLayout
#' @include layout-.R
methods::setClass(
    "QuadLayout",
    contains = "LayoutProto",
    list(
        data = "ANY", plot = "ANY", body_schemes = "list", name = "character",
        # parameters for main body
        width = "ANY", height = "ANY",
        # Used to align axis
        horizontal = "ANY", vertical = "ANY",
        # top, left, bottom, right must be a StackLayout object.
        top = "ANY", left = "ANY", bottom = "ANY", right = "ANY",
        # If we regard `QuadLayout` as a plot, and put it into the stack
        # layout, we need following arguments to control it's behavour
        plot_active = "ANY"
    ),
    prototype = list(
        # used by QuadLayout
        top = NULL, left = NULL, bottom = NULL, right = NULL
    )
)

#' @export
is_layout_discrete.QuadLayout <- function(x, direction, ...) {
    is_discrete_design(slot(x, direction))
}

#' @export
is_layout_continuous.QuadLayout <- function(x, direction, ...) {
    is_continuous_design(slot(x, direction))
}

#' Define the links to connect the marked observations
#'
#' @description
#' This function allows users to define links between marked observations and
#' plot panel (e.g., for creating visual connections for related data), which
#' could help explain the observations.
#'
#' @param .draw A function used to draw the links. The function must return a
#'   [`grob()`][grid::grob] object. If the function does not return a valid
#'   `grob`, nothing will be drawn. The input data for the function must contain
#'   two arguments: a data frame for the panel side coordinates and a data frame
#'   for the marked observation coordinates.
#' @inheritParams .mark_draw
#' @seealso
#'  - [`mark_line()`]
#'  - [`mark_tetragon()`]
#'  - [`mark_triangle()`]
#'  - [`.mark_draw()`]
#' @importFrom rlang is_empty inject
#' @importFrom grid gTree gList
#' @export
mark_draw <- function(.draw, ...) {
    if (!is.function(draw <- allow_lambda(.draw))) {
        cli_abort("{.arg .draw} must be a function")
    }
    new_draw <- function(data) {
        ans <- lapply(data, function(dd) {
            draw(.subset2(dd, "panel"), .subset2(dd, "link"))
        })
        ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
        if (!is_empty(ans)) {
            gTree(children = inject(gList(!!!ans)))
        }
    }
    .mark_draw(new_draw, ...)
}

#' @inherit mark_draw title
#'
#' @description
#' A base version of [`mark_draw`], designed for performance optimization. This
#' function is used to build other `mark_*` functions that manage the drawing of
#' links between marked observations.
#'
#' @param .draw A function used to draw the links. The function must return a
#'   [`grob()`][grid::grob] object. If the function does not return a valid
#'   `grob`, nothing will be drawn. The input data for the function contains a
#'   list, where each item is a list of two data frames: one for the panel side
#'   coordinates (`"panel"`) and one for the marked observations coordinates
#'   (`"link"`).
#'
#' @inheritParams pair_links
#' @seealso [`mark_draw()`]
#' @export
.mark_draw <- function(.draw, ...) {
    if (override_call(call <- caller_call())) {
        call <- current_call()
    }
    if (!is.function(draw <- allow_lambda(.draw))) {
        cli_abort("{.arg .draw} must be a function", call = call)
    }
    links <- pair_links(...)
    structure(list(draw = draw, links = links), class = "ggalign_mark_draw")
}

#' @export
print.ggalign_mark_draw <- function(x, ...) {
    header <- sprintf("<%s>", vec_ptype_full(x))
    cat(header, sep = "\n")
    obj_print_data(.subset2(x, "links"))
    invisible(x)
}

#' Link the observations and the panel with a line
#'
#' @inheritParams .mark_draw
#' @param .element A [`element_line()`][ggplot2::element_line] object.
#'   Vectorized fields will be recycled to match the total number of groups, or
#'   you can wrap the element with [`I()`] to recycle to match the drawing
#'   groups. The drawing groups typically correspond to the number of
#'   observations, as each observation will be linked with the plot panel.
#' @importFrom ggplot2 element_line
#' @export
mark_line <- function(..., .element = NULL) {
    assert_s3_class(.element, "element_line", allow_null = TRUE)
    default <- calc_element("ggalign.line", complete_theme(theme_get()))
    if (is.null(.element)) {
        .element <- default
    } else {
        .element <- ggplot2::merge_element(.element, default)
    }
    .mark_draw(.draw = function(data) {
        data <- lapply(data, function(d) {
            panel <- .subset2(d, "panel")
            link <- .subset2(d, "link")
            data_frame0(
                # there is only one row for panel, it's safe to use
                # vec_interleave directly
                x = vec_interleave(
                    (panel$x + panel$xend) / 2L,
                    (link$x + link$xend) / 2L
                ),
                y = vec_interleave(
                    (panel$y + panel$yend) / 2L,
                    (link$y + link$yend) / 2L
                )
            )
        })
        if (inherits(.element, "AsIs")) {
            .element <- element_rep_len(.element,
                length.out = sum(list_sizes(data)) / 2L
            )
        } else {
            .element <- element_rep_len(.element, length.out = length(data))
            .element <- element_vec_rep_each(.element,
                times = list_sizes(data) / 2L
            )
        }
        data <- vec_rbind(!!!data)
        element_grob(
            .element,
            x = data$x, y = data$y,
            id.lengths = vec_rep(2L, vec_size(data) / 2L),
            default.units = "native"
        )
    }, ...)
}

#' Link the observations and the panel with a quadrilateral
#'
#' @inheritParams .mark_draw
#' @param .element A [`element_polygon()`] object. Vectorized fields will be
#'   recycled to match the total number of groups, or you can wrap the element
#'   with [`I()`] to recycle to match the drawing groups. The drawing groups
#'   are usually the same as the defined groups, but they will differ when the
#'   defined group of observations is separated and cannot be linked with a
#'   single quadrilateral. In such cases, the number of drawing groups will be
#'   larger than the number of defined groups.
#' @export
mark_tetragon <- function(..., .element = NULL) {
    assert_s3_class(.element, "element_polygon", allow_null = TRUE)
    default <- calc_element("ggalign.polygon", complete_theme(theme_get()))
    if (is.null(.element)) {
        .element <- default
    } else {
        .element <- ggplot2::merge_element(.element, default)
    }
    .mark_draw(.draw = function(data) {
        data <- lapply(data, function(d) {
            panel <- .subset2(d, "panel")
            link <- .subset2(d, "link")

            # find the consecutive groups
            index <- .subset2(link, "link_index")
            oindex <- order(index)
            group <- cumsum(c(0L, diff(index[oindex])) != 1L)

            # restore the order
            group <- group[order(oindex)]

            # split link into groups
            link <- vec_split(link, group)

            # for each group, we draw a quadrilateral
            vec_rbind(!!!lapply(.subset2(link, "val"), function(dd) {
                data_frame0(
                    x = vec_c(panel$x, panel$xend, max(dd$xend), min(dd$x)),
                    y = vec_c(panel$y, panel$yend, max(dd$yend), min(dd$y))
                )
            }))
        })
        if (inherits(.element, "AsIs")) {
            .element <- element_rep_len(.element,
                length.out = sum(list_sizes(data)) / 4L
            )
        } else {
            .element <- element_rep_len(.element, length.out = length(data))
            .element <- element_vec_rep_each(.element,
                times = list_sizes(data) / 4L
            )
        }
        data <- vec_rbind(!!!data)
        if (vec_size(data)) {
            element_grob(
                .element,
                x = data$x, y = data$y,
                id.lengths = vec_rep(4L, nrow(data) / 4L),
                default.units = "native"
            )
        }
    }, ...)
}

#' Link the observations and the panel with a triangle
#'
#' @inheritParams .mark_draw
#' @param orientation A single string, either `"plot"` or `"observation"`,
#'   indicating the base of the triangle.
#' @param .element An [`element_polygon()`] object. Vectorized fields will be
#'   recycled to match the total number of groups, or you can wrap the element
#'   with [`I()`] to recycle to match the drawing groups.
#'   - When `orientation` is `"plot"`, the drawing groups typically correspond
#'     to the number of observations.
#'   - When `orientation` is `"observation"`, the drawing groups usually match
#'     the defined groups, but will differ if the defined group of observations
#'     is separated and cannot be linked with a single triangle. In this case,
#'     the number of drawing groups will be larger than the number of defined
#'     groups.
#' @importFrom rlang arg_match0
#' @export
mark_triangle <- function(..., orientation = "plot", .element = NULL) {
    assert_s3_class(.element, "element_polygon", allow_null = TRUE)
    default <- calc_element("ggalign.polygon", complete_theme(theme_get()))
    if (is.null(.element)) {
        .element <- default
    } else {
        .element <- ggplot2::merge_element(.element, default)
    }
    orientation <- arg_match0(orientation, c("plot", "observation"))
    .mark_draw(.draw = function(data) {
        data <- lapply(data, function(d) {
            panel <- .subset2(d, "panel")
            link <- .subset2(d, "link")
            if (identical(orientation, "plot")) {
                # for each link, we draw a triangle
                triangle_list <- lapply(vec_seq_along(link), function(i) {
                    dd <- vec_slice(link, i)
                    data_frame0(
                        x = vec_c(panel$x, panel$xend, (dd$x + dd$xend) / 2L),
                        y = vec_c(panel$y, panel$yend, (dd$y + dd$yend) / 2L),
                    )
                })
            } else {
                # find the consecutive groups
                index <- .subset2(link, "link_index")
                oindex <- order(index)
                group <- cumsum(c(0L, diff(index[oindex])) != 1L)

                # restore the order
                group <- group[order(oindex)]

                # split link into groups
                link <- vec_split(link, group)

                # for each group, we draw a triangle
                triangle_list <- lapply(.subset2(link, "val"), function(dd) {
                    data_frame0(
                        x = vec_c(
                            (panel$x + panel$xend) / 2L,
                            max(dd$xend), min(dd$x)
                        ),
                        y = vec_c(
                            (panel$y + panel$yend) / 2L,
                            max(dd$yend), min(dd$y)
                        )
                    )
                })
            }
            vec_rbind(!!!triangle_list)
        })
        if (inherits(.element, "AsIs")) {
            .element <- element_rep_len(.element,
                length.out = sum(list_sizes(data)) / 3L
            )
        } else {
            .element <- element_rep_len(.element, length.out = length(data))
            .element <- element_vec_rep_each(.element,
                times = list_sizes(data) / 3L
            )
        }
        data <- vec_rbind(!!!data)
        if (vec_size(data)) {
            element_grob(
                .element,
                x = data$x, y = data$y,
                id.lengths = vec_rep(3L, nrow(data) / 3L),
                default.units = "native"
            )
        }
    }, ...)
}

#####################################################
#' @export
`[.ggalignMarkGtable` <- function(x, i, j) {
    # subset will violate the `ggalignMarkGtable` `shape`
    # we always use the next method
    x <- remove_class(x, "ggalignMarkGtable")
    x$ggalign_link_data <- NULL
    NextMethod()
}

#' @importFrom ggplot2 ggproto
#' @export
alignpatch.ggalign_mark_plot <- function(x) {
    ggproto(NULL, PatchAlignMark, plot = x)
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @include alignpatch-ggplot2.R
PatchAlignMark <- ggproto(
    "PatchAlignMark", PatchGgplot,
    patch_gtable = function(self, theme, guides, plot = self$plot) {
        ans <- ggproto_parent(PatchGgplot, self)$patch_gtable(plot = plot)
        # re-define the draw method, we assign new class
        ans <- add_class(ans, "ggalignMarkGtable")
        ans$ggalign_link_data <- plot$ggalign_link_data
        ans
    },
    add_plot = function(self, gt, plot, t, l, b, r, name, z = 2L) {
        gtable_add_grob(
            gt,
            grobs = plot,
            # t = 8, l = 6, b = 14, r = 12
            # t = t + 7L, l = l + 5L, b = b - 6L, r = r - 5L,
            t = t + TOP_BORDER, l = l + LEFT_BORDER,
            name = name, z = z
        )
    },
    add_background = function(self, gt, bg, t, l, b, r, name, z = 1L) {
        gtable_add_grob(
            gt,
            grobs = bg,
            t = t + TOP_BORDER, l = l + LEFT_BORDER,
            name = name, z = z
        )
    },
    get_sizes = function(self, free = NULL, gt = self$gt) {
        ggproto_parent(PatchGgplot, self)$get_sizes(.tlbr, gt = gt)
    },
    align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                            gt = self$gt) {
        gt # free from alignment
    }
)

# preDraw:
#  - makeContext
#  - pushvpgp
#  - preDrawDetails: by default, do noting
# makeContent:
# drawDetails:
# postDraw:
#  - postDrawDetails: by default, do noting
#  - popgrobvp
#' @importFrom grid makeContent unit convertHeight convertWidth viewport
#' @importFrom stats reorder
#' @export
makeContent.ggalignMarkGtable <- function(x) {
    # Grab viewport information
    width <- convertWidth(unit(1, "npc"), "mm", valueOnly = TRUE)
    height <- convertHeight(unit(1, "npc"), "mm", valueOnly = TRUE)

    # Grab grob metadata
    plot_widths <- compute_null_width(.subset2(x, "widths"),
        valueOnly = TRUE
    )
    plot_widths <- scales::rescale(plot_widths, c(0, 1), from = c(0, width))
    plot_heights <- compute_null_height(.subset2(x, "heights"),
        valueOnly = TRUE
    )
    plot_heights <- scales::rescale(plot_heights, c(0, 1), from = c(0, height))

    panel_loc <- find_panel(x)
    data <- .subset2(x, "ggalign_link_data")
    full_data1 <- .subset2(data, "full_data1")
    full_data2 <- .subset2(data, "full_data2")
    direction <- .subset2(data, "direction")
    link_index_list <- .subset2(data, "link_index")
    data_index_list <- .subset2(data, "data_index")
    obs_size <- .subset2(data, "obs_size")

    # prepare output for current for loop
    coords <- vector("list", 2L)
    names(coords) <- c("hand1", "hand2")
    for (link in names(coords)) {
        link_index <- lapply(link_index_list, .subset2, link)
        data_index <- lapply(data_index_list, .subset2, link)
        # early exit and step into next cycle if no link
        if (all(vapply(link_index, is.null, logical(1L), USE.NAMES = FALSE))) {
            coords[link] <- list(link_index)
            next
        }
        full_breaks <- switch(link,
            hand1 = full_data1,
            hand2 = full_data2
        )

        spacing <- .subset2(data, switch(link,
            hand1 = "spacing1",
            hand2 = "spacing2"
        ))

        # each value represent an `observation`, for panel space, we use `NA`
        # obs arranged from left to top, and from bottom to top
        points <- unlist(vec_interleave(full_breaks, list(NA)), FALSE, FALSE)
        # remove the last panel space, shouldn't exist
        points <- points[-length(points)]
        sizes <- numeric(length(points))
        n_spacing <- length(full_breaks) - 1L

        # then, we define the link grobs
        if (is_horizontal(direction)) { # the link should be in left or right
            spacing <- convertHeight(spacing, "mm", valueOnly = TRUE)
            spacing <- scales::rescale(spacing, c(0, 1), from = c(0, height))
            sizes[is.na(points)] <- spacing
            obs_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
            sizes[!is.na(points)] <- obs_height # nobs
            yend <- cumsum(sizes)
            link_x <- switch(link,
                hand1 = 0,
                hand2 = 1
            )
            # by default, the height for each observation is `1`,
            # if we define obs size, we just re-scale it
            removed <- (1 - obs_size) * obs_height
            link_coord <- data_frame0(
                x = link_x, xend = link_x,
                y = yend - sizes + removed / 2L,
                yend = yend - removed / 2L
            )
            link_coord <- vec_slice(link_coord, !is.na(points))

            # from bottom to the top, following the ordering of the `breaks`
            panel_index <- seq(
                from = .subset2(panel_loc, "b"),
                to = .subset2(panel_loc, "t"),
                length.out = length(link_index)
            )
            l_border <- plot_widths[seq_len(.subset2(panel_loc, "l") - 1L)]
            r_border <- plot_widths[-seq_len(.subset2(panel_loc, "r"))]

            # for a gtable, heights are from top to the bottom,
            # we reverse the heights
            # we have reversed the `plot_cum_heights`, so the ordering index
            # should also be reversed
            panel_index <- nrow(x) - panel_index + 1L
            panel_yend <- cumsum(rev(plot_heights))
            panel_x <- switch(link,
                hand1 = sum(l_border),
                hand2 = 1 - sum(r_border)
            )
            panel_coord <- data_frame0(
                x = panel_x,
                xend = panel_x,
                y = (panel_yend - rev(plot_heights))[panel_index],
                yend = panel_yend[panel_index]
            )
        } else { # the link should be in top or bottom
            spacing <- convertWidth(spacing, "mm", valueOnly = TRUE)
            spacing <- scales::rescale(spacing, c(0, 1), from = c(0, width))
            sizes[is.na(points)] <- spacing
            obs_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
            sizes[!is.na(points)] <- obs_width
            xend <- cumsum(sizes)
            link_y <- switch(link,
                hand1 = 1,
                hand2 = 0
            )
            # by default, the width for each observation is `1`,
            # if we define obs size, we just re-scale it
            removed <- (1 - obs_size) * obs_width
            link_coord <- data_frame0(
                x = xend - sizes + removed / 2L,
                xend = xend - removed / 2L,
                y = link_y, yend = link_y
            )
            link_coord <- vec_slice(link_coord, !is.na(points))

            panel_index <- seq(
                from = .subset2(panel_loc, "l"),
                to = .subset2(panel_loc, "r"),
                length.out = length(link_index)
            )
            t_border <- plot_heights[seq_len(.subset2(panel_loc, "t") - 1L)]
            b_border <- plot_heights[-seq_len(.subset2(panel_loc, "b"))]
            panel_xend <- cumsum(plot_widths)
            panel_y <- switch(link,
                hand1 = 1 - sum(t_border),
                hand2 = sum(b_border)
            )
            panel_coord <- data_frame0(
                x = (panel_xend - plot_widths)[panel_index],
                xend = panel_xend[panel_index],
                y = panel_y, yend = panel_y
            )
        }
        hand <- switch(link,
            hand1 = switch_direction(direction, "left", "top"),
            hand2 = switch_direction(direction, "right", "bottom")
        )
        nms <- names(link_index)
        link_panels <- vec_rep_each(names(full_breaks), list_sizes(full_breaks))
        coords[[link]] <- lapply(seq_along(link_index), function(i) {
            l_index <- .subset2(link_index, i)
            if (is.null(l_index)) return(NULL) # styler: off
            d_index <- .subset2(data_index, i)
            link <- vec_slice(link_coord, l_index)
            link$link_id <- nms[i]
            link$link_panel <- reorder(
                vec_slice(link_panels, l_index), l_index,
                order = FALSE
            )
            link$link_index <- l_index
            link$.hand <- hand
            link$.index <- d_index
            panel <- vec_slice(panel_coord, i)
            list(panel = panel, link = link)
        })
    }
    coords <- vec_interleave(
        .subset2(coords, "hand1"),
        .subset2(coords, "hand2")
    )
    coords <- list_drop_empty(coords)
    draw <- .subset2(data, "draw")
    if (is.gList(grob <- draw(coords))) {
        grob <- gTree(children = grob)
    }

    if (is.grob(grob)) {
        layout <- .subset2(x, "layout")
        panels <- layout[
            grepl("^panel", .subset2(layout, "name")), ,
            drop = FALSE
        ]
        x <- gtable_add_grob(
            x,
            grobs = grob,
            t = 1L, l = 1L, b = -1L, r = -1L,
            # always draw with panel area
            z = min(panels$z)
        )
    }
    NextMethod()
}

#' Build a matrix
#'
#' @param data A matrix object.
#' @inheritParams rlang::args_dots_empty
#' @inheritParams fortify_matrix
#' @section shape:
#'  - `upset`: [`fortify_matrix.matrix_upset()`]
#'  - `oncoplot`: [`fortify_matrix.matrix_oncoplot()`]
#' @family fortify_matrix
#' @export
fortify_matrix.matrix <- fortify_matrix.waiver

#' Convert the shape of a matrix for fortify method
#'
#' @param data A matrix.
#' @param shape A string of `r oxford_or(c("upset", "oncoplot"))`.
#' @seealso
#' - [`fortify_matrix.matrix()`]
#' - [`fortify_matrix.matrix_upset()`]
#' - [`fortify_matrix.matrix_oncoplot()`]
#' @family tune
#' @importFrom rlang arg_match0
#' @export
tune.matrix <- function(data, shape) {
    shape <- arg_match0(shape, c("upset", "oncoplot"))
    if (identical(shape, "oncoplot")) {
        if (!is.character(data)) {
            cli_abort(
                "{.arg data} must be a character matrix to use {shape} shape"
            )
        }
    }
    new_tune(data, class = sprintf("matrix_%s", shape))
}

#' @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
#' @export
fortify_matrix.matrix_upset <- function(data, ..., data_arg = NULL,
                                        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
    )
}

#' Build a Matrix for OncoPrint
#'
#' @description
#' Converts a matrix suitable for creating an OncoPrint. [`tune.matrix()`]
#' helps convert `matrix` object to a `matrix_oncoplot` object.
#'
#' @param data A matrix where each row represents an genes, and each column
#' represents samples. The values in the matrix indicate whether the element is
#' part of the set.
#' @inheritParams fortify_matrix.MAF
#' @section ggalign attributes:
#'  - `gene_summary`: An integer vector of the altered samples for each gene.
#'  - `sample_summary`: An integer vector of the altered genes for each sample.
#'  - `n_genes`: Total number of genes.
#'  - `n_samples`: Total number of samples.
#'
#' @seealso [`tune.matrix()`]
#' @family fortify_matrix
#' @export
fortify_matrix.matrix_oncoplot <- function(data, ...,
                                           genes = NULL, n_top = NULL,
                                           remove_empty_genes = TRUE,
                                           remove_empty_samples = TRUE,
                                           missing_genes = "error",
                                           data_arg = NULL,
                                           call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)

    # check arguments
    missing_genes <- arg_match0(
        missing_genes, c("error", "remove"),
        error_call = call
    )

    data <- tune_data(data)
    alt <- !is.na(data)
    storage.mode(alt) <- "integer"
    gene_summary <- rowSums(alt)
    sample_summary <- colSums(alt)
    n_genes <- nrow(data)
    n_samples <- ncol(data)

    # filter by genes --------------------------------------
    if (!is.null(genes)) {
        genes <- vec_cast(genes, character())
        if (vec_any_missing(genes)) {
            cli_abort(
                "{.arg genes} cannot contain missing values",
                call = call
            )
        }
        if (vec_duplicate_any(genes)) {
            cli_abort(
                "{.arg genes} cannot contain duplicated values",
                call = call
            )
        }
        if (identical(missing_genes, "remove")) {
            genes <- genes[genes %in% rownames(data)]
        }
        if (is_empty(genes)) {
            cli_abort(
                "No {.arg genes} remain after removing missing genes",
                call = call
            )
        }
        index <- vec_as_location(
            genes,
            n = vec_size(data),
            names = rownames(data),
            missing = "error"
        )
        data <- vec_slice(data, index)
        alt <- vec_slice(alt, index)
        gene_summary <- vec_slice(gene_summary, index)
    }

    if (!is.null(n_top)) {
        n_top <- min(n_top, vec_size(alt))
        index <- vec_slice(
            order(rowSums(alt), decreasing = TRUE),
            seq_len(n_top)
        )
        data <- vec_slice(data, index)
        alt <- vec_slice(alt, index)
        gene_summary <- vec_slice(gene_summary, index)
    }

    # filter empty genes
    if (remove_empty_genes) {
        keep <- rowSums(alt) > 0L
        data <- vec_slice(data, keep)
        gene_summary <- vec_slice(gene_summary, keep)
    }

    # filter empty samples
    if (remove_empty_samples) {
        keep <- colSums(alt) > 0L
        data <- data[, keep, drop = FALSE]
        sample_summary <- vec_slice(sample_summary, keep)
    }

    ggalign_data_set(data,
        sample_summary = sample_summary,
        gene_summary = gene_summary,
        n_samples = n_samples,
        n_genes = n_genes
    )
}

#' Order observations based on weights
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Ordering observations based on summary weights or a specified ordering
#' character or integer index.
#'
#' @param weights A summary function which accepts a data and returns the
#' weights for each observations. Alternatively, you can provide an ordering
#' index as either an integer or a character. Since characters have been
#' designated as character indices, if you wish to specify a function name as a
#' string, you must enclose it with [`I()`].
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' function provided in `weights` argument.
#' @param reverse A boolean value. Should the sort order be in reverse?
#' @param strict A boolean value indicates whether the order should be strict.
#' If previous groups has been established, and strict is `FALSE`, this will
#' reorder the observations in each group.
#' @param data A `matrix`, `data frame`, or atomic vector used as the input for
#' the `weights` function. Alternatively, you can specify a `function`
#' (including purrr-like lambda syntax) that will be applied to the layout
#' matrix, transforming it as necessary for weight calculations. By default, it
#' will inherit from the layout matrix.
#' @inheritParams align
#' @inheritSection align Discrete Axis Alignment
#' @examples
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_left() +
#'     align_order(I("rowMeans"))
#' @importFrom ggplot2 waiver
#' @importFrom rlang list2
#' @export
align_order <- function(weights = rowMeans, ...,
                        reverse = FALSE, strict = TRUE, data = NULL,
                        active = NULL) {
    if (is.numeric(weights) ||
        (is.character(weights) && !inherits(weights, "AsIs"))) {
        # vec_duplicate_any is slight faster than `anyDuplicated`
        if (vec_any_missing(weights) || vec_duplicate_any(weights)) {
            cli_abort(paste(
                "{.arg weights} must be an ordering numeric or character",
                "without missing value or ties"
            ))
        } else if (is.numeric(weights)) {
            weights <- vec_cast(weights, integer())
        }
        if (vec_size(weights) == 0L) {
            cli_abort("{.arg weights} cannot be empty")
        }
        if (!is.null(data)) {
            cli_warn(c(
                "{.arg data} won't be used",
                i = "{.arg weights} is not a {.cls function}"
            ))
        }
    } else {
        weights <- rlang::as_function(weights)
        data <- data %||% waiver()
    }
    assert_bool(strict)
    assert_bool(reverse)
    assert_active(active)
    active <- update_active(active, new_active(use = FALSE))
    align(
        align = AlignOrder,
        weights = weights,
        params = list2(...),
        reverse = reverse,
        strict = strict,
        active = active,
        data = data
    )
}

#' @importFrom ggplot2 ggproto
#' @importFrom rlang inject is_atomic
AlignOrder <- ggproto("AlignOrder", CraftAlign,
    interact_layout = function(self, layout) {
        if (is.function(self$weights)) {
            layout <- ggproto_parent(AlignOrder2, self)$interact_layout(layout)
        } else {
            layout <- ggproto_parent(CraftAlign, self)$interact_layout(layout)
            if (is.null(layout_nobs <- .subset2(layout@design, "nobs"))) {
                layout@design["nobs"] <- list(vec_size(self$weights))
            } else {
                assert_mismatch_nobs(
                    self, layout_nobs, vec_size(self$weights),
                    arg = "weights"
                )
            }
            self$labels <- vec_names(layout@data)
        }
        layout
    },
    compute = function(self, panel, index) {
        if (is.function(self$weights)) {
            ans <- inject(self$weights(self$data, !!!self$params))
            if (!is_atomic(ans)) {
                cli_abort(
                    "{.arg weights} must return an atomic weights",
                    call = self$call
                )
            }
            assert_mismatch_nobs(
                self, vec_size(ans), vec_size(ans),
                arg = "weights"
            )
            ans
        }
    },
    align = function(self, panel, index) {
        if (is.function(self$weights)) {
            index <- order(self$statistics)
        } else {
            index <- vec_as_location(
                self$weights,
                n = vec_size(self$weights),
                names = self$labels,
                missing = "error",
                call = self$call
            )
        }
        if (self$reverse) index <- rev(index)
        assert_reorder(self, panel, index, self$strict)
        list(panel, index)
    },
    summary_align = function(self) c(TRUE, FALSE)
)

#' Define the links to connect a pair of observations
#'
#' @description
#' This function allows users to define links between a pair of observations,
#' facilitating the visualization of connections between related data points.
#'
#' @param .draw A function used to draw the links. The function must return a
#'   [`grob()`][grid::grob] object. If the function does not return a valid
#'   `grob`, no drawing will occur. The input data for the function should
#'   include a data frame with the coordinates of the pair of observations to
#'   be linked.
#' @inheritParams .link_draw
#' @seealso
#'  - [`link_line()`]
#'  - [`.link_draw()`]
#' @importFrom rlang is_empty inject
#' @importFrom grid gTree gList
#' @export
link_draw <- function(.draw, ...) {
    if (!is.function(draw <- allow_lambda(.draw))) {
        cli_abort("{.arg .draw} must be a function")
    }
    new_draw <- function(data) {
        ans <- lapply(data, draw)
        ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
        if (!is_empty(ans)) inject(gList(!!!ans))
    }
    .link_draw(new_draw, ...)
}

#' @inherit link_draw title
#'
#' @description
#' A base version of [`link_draw()`], optimized for performance. This function
#' serves as the foundation for building other `link_*` functions that manage
#' the drawing of links between pairs of observations.
#'
#' @param .draw A function used to draw the links. The function must return a
#'   [`grob()`][grid::grob] object. If the function does not return a valid
#'   `grob`, no drawing will occur. The input data for the function should be
#'   a list, where each item is a data frame containing the coordinates of
#'   the pair of observations.
#' @inheritParams pair_links
#' @seealso [`link_draw()`]
#' @export
.link_draw <- function(.draw, ...) {
    if (override_call(call <- caller_call())) {
        call <- current_call()
    }
    if (!is.function(draw <- allow_lambda(.draw))) {
        cli_abort("{.arg .draw} must be a function", call = call)
    }
    links <- pair_links(...)
    structure(list(draw = draw, links = links), class = "ggalign_link_draw")
}

#' @export
print.ggalign_link_draw <- function(x, ...) {
    header <- sprintf("<%s>", vec_ptype_full(x))
    cat(header, sep = "\n")
    obj_print_data(.subset2(x, "links"))
    invisible(x)
}

#' Link the paired observations with a line
#'
#' @inheritParams .link_draw
#' @param .element A [`element_line()`][ggplot2::element_line] object.
#'   Vectorized fields will be recycled to match the total number of groups, or
#'   you can wrap the element with [`I()`] to recycle to match the drawing
#'   groups. The drawing groups typically correspond to the product of the
#'   number of observations from both sides, as each pair of observations will
#'   be linked with a single line.
#' @importFrom ggplot2 element_line
#' @export
link_line <- function(..., .element = NULL) {
    assert_s3_class(.element, "element_line", allow_null = TRUE)
    default <- calc_element("ggalign.line", complete_theme(theme_get()))
    if (is.null(.element)) {
        .element <- default
    } else {
        .element <- ggplot2::merge_element(.element, default)
    }
    ans <- .link_draw(.draw = function(data) {
        data <- lapply(data, function(d) {
            # if the link is only in one side, we do nothing
            if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
                return(NULL)
            }
            both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
            data <- cross_join(.subset2(both, 1L), .subset2(both, 2L))
            data_frame0(
                x = vec_interleave(
                    (data$x.x + data$xend.x) / 2L,
                    (data$x.y + data$xend.y) / 2L
                ),
                y = vec_interleave(
                    (data$y.x + data$yend.x) / 2L,
                    (data$y.y + data$yend.y) / 2L
                )
            )
        })
        if (inherits(.element, "AsIs")) {
            .element <- element_rep_len(.element,
                length.out = sum(list_sizes(data)) / 2L
            )
        } else {
            .element <- element_rep_len(.element, length.out = length(data))
            .element <- element_vec_rep_each(.element,
                times = list_sizes(data) / 2L
            )
        }
        data <- vec_rbind(!!!data)
        if (vec_size(data)) {
            element_grob(
                .element,
                x = data$x, y = data$y,
                id.lengths = vec_rep(2L, vec_size(data) / 2L),
                default.units = "native"
            )
        }
    }, ...)
    add_class(ans, "ggalign_link_line")
}

#' Link the paired observations with a quadrilateral
#'
#' @inheritParams .link_draw
#' @inheritParams mark_tetragon
#' @export
link_tetragon <- function(..., .element = NULL) {
    assert_s3_class(.element, "element_polygon", allow_null = TRUE)
    default <- calc_element("ggalign.polygon", complete_theme(theme_get()))
    if (is.null(.element)) {
        .element <- default
    } else {
        .element <- ggplot2::merge_element(.element, default)
    }
    .link_draw(.draw = function(data) {
        data <- lapply(data, function(d) {
            # if the link is only in one side, we do nothing
            if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
                return(NULL)
            }
            both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
            both <- lapply(both, function(link) {
                # find the consecutive groups
                index <- .subset2(link, "link_index")
                oindex <- order(index)
                group <- cumsum(c(0L, diff(index[oindex])) != 1L)

                # restore the order
                group <- group[order(oindex)]

                # split link into groups
                .subset2(vec_split(link, group), "val")
            })
            both <- vec_expand_grid(
                hand1 = .subset2(both, 1L),
                hand2 = .subset2(both, 2L)
            )
            ans <- .mapply(function(hand1, hand2) {
                data_frame0(
                    x = vec_c(
                        min(hand1$x), max(hand1$xend),
                        max(hand2$xend), min(hand2$x)
                    ),
                    y = vec_c(
                        min(hand1$y), max(hand1$yend),
                        max(hand2$yend), min(hand2$y)
                    )
                )
            }, both, NULL)
            vec_rbind(!!!ans)
        })
        if (inherits(.element, "AsIs")) {
            .element <- element_rep_len(.element,
                length.out = sum(list_sizes(data)) / 4L
            )
        } else {
            .element <- element_rep_len(.element, length.out = length(data))
            .element <- element_vec_rep_each(.element,
                times = list_sizes(data) / 4L
            )
        }
        data <- vec_rbind(!!!data)
        if (vec_size(data)) {
            element_grob(
                .element,
                x = data$x, y = data$y,
                id.lengths = vec_rep(4L, vec_size(data) / 4L),
                default.units = "native"
            )
        }
    }, ...)
}

# preDraw:
#  - makeContext
#  - pushvpgp
#  - preDrawDetails: by default, do noting
# makeContent:
# drawDetails:
# postDraw:
#  - postDrawDetails: by default, do noting
#  - popgrobvp
#' @importFrom grid makeContent convertHeight convertWidth gList setChildren
#' @export
makeContent.ggalignLinkTree <- function(x) {
    # Grab viewport information
    width <- convertWidth(unit(1, "npc"), "mm", valueOnly = TRUE)
    height <- convertHeight(unit(1, "npc"), "mm", valueOnly = TRUE)

    # Grab grob metadata
    full_data1 <- .subset2(x, "full_data1")
    full_data2 <- .subset2(x, "full_data2")
    direction <- .subset2(x, "direction")
    link_index_list <- .subset2(x, "link_index")
    data_index_list <- .subset2(x, "data_index")
    obs_size <- .subset2(x, "obs_size")

    # prepare output for current for loop
    coords <- vector("list", 2L)
    names(coords) <- c("hand1", "hand2")
    for (link in names(coords)) {
        link_index <- lapply(link_index_list, .subset2, link)
        data_index <- lapply(data_index_list, .subset2, link)
        # early exit and step into next cycle if no link
        if (all(vapply(link_index, is.null, logical(1L), USE.NAMES = FALSE))) {
            coords[link] <- list(link_index)
            next
        }
        full_breaks <- switch(link,
            hand1 = full_data1,
            hand2 = full_data2
        )

        spacing <- .subset2(x, switch(link,
            hand1 = "spacing1",
            hand2 = "spacing2"
        ))

        # each value represent an `observation`, for panel space, we use `NA`
        # obs arranged from left to top, and from bottom to top
        points <- unlist(vec_interleave(full_breaks, list(NA)), FALSE, FALSE)
        # remove the last panel space, shouldn't exist
        points <- points[-length(points)]
        sizes <- numeric(length(points))
        n_spacing <- length(full_breaks) - 1L

        # then, we define the link grobs
        if (is_horizontal(direction)) { # the link should be in left or right
            spacing <- convertHeight(spacing, "mm", valueOnly = TRUE)
            spacing <- scales::rescale(spacing, c(0, 1), from = c(0, height))
            sizes[is.na(points)] <- spacing
            obs_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
            sizes[!is.na(points)] <- obs_height # nobs
            yend <- cumsum(sizes)
            link_x <- switch(link,
                hand1 = 0,
                hand2 = 1
            )
            # by default, the height for each observation is `1`,
            # if we define obs size, we just re-scale it
            removed <- (1 - obs_size) * obs_height
            link_coord <- data_frame0(
                x = link_x, xend = link_x,
                y = yend - sizes + removed / 2L,
                yend = yend - removed / 2L
            )
            link_coord <- vec_slice(link_coord, !is.na(points))
        } else { # the link should be in top or bottom
            spacing <- convertWidth(spacing, "mm", valueOnly = TRUE)
            spacing <- scales::rescale(spacing, c(0, 1), from = c(0, width))
            sizes[is.na(points)] <- spacing
            obs_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
            sizes[!is.na(points)] <- obs_width
            xend <- cumsum(sizes)
            link_y <- switch(link,
                hand1 = 1,
                hand2 = 0
            )
            # by default, the width for each observation is `1`,
            # if we define obs size, we just re-scale it
            removed <- (1 - obs_size) * obs_width
            link_coord <- data_frame0(
                x = xend - sizes + removed / 2L,
                xend = xend - removed / 2L,
                y = link_y, yend = link_y
            )
            link_coord <- vec_slice(link_coord, !is.na(points))
        }
        hand <- switch(link,
            hand1 = switch_direction(direction, "left", "top"),
            hand2 = switch_direction(direction, "right", "bottom")
        )
        nms <- names(link_index)
        link_panels <- vec_rep_each(names(full_breaks), list_sizes(full_breaks))
        coords[[link]] <- lapply(seq_along(link_index), function(i) {
            l_index <- .subset2(link_index, i)
            if (is.null(l_index)) return(NULL) # styler: off
            d_index <- .subset2(data_index, i)
            link <- vec_slice(link_coord, l_index)
            link$link_id <- nms[i]
            link$link_panel <- reorder(
                vec_slice(link_panels, l_index), l_index,
                order = FALSE
            )
            link$link_index <- l_index
            link$.hand <- hand
            link$.index <- d_index
            link
        })
    }

    # hand1 - hand2
    data <- .mapply(vec_rbind, coords, NULL)
    draw <- .subset2(x, "draw")
    if (is.grob(grob <- draw(data))) { # wrap single grob to a gList
        grob <- gList(grob)
    }
    if (is.gList(grob)) {
        setChildren(x, grob)
    } else {
        x
    }
}

#' Determine the Active Context of Quad-Layout
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' - `quad_active`: Sets the active context to the `r rd_quad()` itself.
#' - `quad_anno`: Sets the active context to the specified annotation stack
#'   based on the `position` argument.
#' - `anno_top`: A special case of `quad_anno` with `position = "top"`.
#' - `anno_left`: A special case of `quad_anno` with `position = "left"`.
#' - `anno_bottom`: A special case of `quad_anno` with `position = "bottom"`.
#' - `anno_right`: A special case of `quad_anno` with `position = "right"`.
#'
#' @inheritParams quad_layout
#' @return An object that can be added to `r rd_quad()`.
#' @export
#' @rdname quad_active
quad_active <- function(width = NULL, height = NULL) {
    if (!is.null(width)) width <- check_size(width)
    if (!is.null(height)) height <- check_size(height)
    structure(
        list(width = width, height = height),
        class = c("quad_active", "quad_switch")
    )
}

#' @details
#' By default, `quad_anno()` attempts to initialize the annotation stack layout
#' using data from `r rd_quad()`. However, in situations where you want to use
#' different data for the annotation stack, you can set `initialize = FALSE`
#' and then provide a custom `stack_layout()`.
#'
#' @param position `r rd_quad_position("activated")`.
#' @param size A numeric value or an [`unit`][grid::unit] object to set the
#' total `height`/`width` of the annotation stack.
#'  - If `position` is `"top"` or `"bottom"`, `size` sets the total height of
#' the annotation.
#'  - If `position` is `"left"` or `"right"`, `size` sets the total width of the
#' annotation.
#' @param free_guides Override the `guides` collection behavior specified in the
#' `r rd_quad()` for the annotation stack.
#' @param initialize A boolean indicating whether the annotation stack should be
#' initialized if it is not already. By default, the annotation stack layout
#' will attempt to initialize when the data is compatible. If set to `TRUE`, and
#' the data in `r rd_quad()` is incompatible with the annotation stack, no
#' data will be used in the stack.
#' @param what What should get activated in the annotation stack?
#' `r rd_chain_what()`.
#' @seealso [`quad_switch()`]
#' @export
#' @rdname quad_active
quad_anno <- function(position, size = NULL, free_guides = waiver(),
                      initialize = NULL, what = waiver()) {
    if (is.null(position)) {
        cli_abort(c(
            paste(
                "{.arg position} must be a single string of",
                "{oxford_or(.TLBR)}, not `NULL`"
            ),
            i = "Do you want to set the active context to the `quad_layout()` with {.fn quad_active}?"
        ))
    }
    position <- match.arg(position, .TLBR)
    quad_switch_anno(
        size = size, free_guides = free_guides,
        initialize = initialize, what = what,
        position = position
    )
}

#' @export
#' @rdname quad_active
anno_top <- function(size = NULL, free_guides = waiver(), initialize = NULL,
                     what = waiver()) {
    quad_switch_anno(
        size = size, free_guides = free_guides,
        initialize = initialize, what = what,
        position = "top"
    )
}

#' @export
#' @rdname quad_active
anno_left <- function(size = NULL, free_guides = waiver(), initialize = NULL,
                      what = waiver()) {
    quad_switch_anno(
        size = size, free_guides = free_guides,
        initialize = initialize, what = what,
        position = "left"
    )
}

#' @export
#' @rdname quad_active
anno_bottom <- function(size = NULL, free_guides = waiver(), initialize = NULL,
                        what = waiver()) {
    quad_switch_anno(
        size = size, free_guides = free_guides,
        initialize = initialize, what = what,
        position = "bottom"
    )
}

#' @export
#' @rdname quad_active
anno_right <- function(size = NULL, free_guides = waiver(), initialize = NULL,
                       what = waiver()) {
    quad_switch_anno(
        size = size, free_guides = free_guides,
        initialize = initialize, what = what,
        position = "right"
    )
}

quad_switch_anno <- function(position, size, free_guides, initialize, what,
                             call = caller_call()) {
    if (!is.null(size)) size <- check_size(size, call = call)
    assert_layout_position(free_guides, call = call)
    if (!is.waive(what)) what <- check_stack_context(what, call = call)
    assert_bool(initialize, allow_null = TRUE)
    structure(
        list(
            position = position, size = size,
            free_guides = free_guides, what = what,
            initialize = initialize
        ),
        class = c("quad_anno", "quad_switch")
    )
}

#' Initialize Quad-Layout Annotation
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' This function was deprecated, you can add `stack_layout()` directly.
#'
#' @export
#' @keywords internal
quad_init <- function(position, data = waiver(), ...) {
    lifecycle::deprecate_stop("0.0.6", "quad_init()", "stack_layout()")
}

#' @inherit quad_active title return
#' @description
#' `r lifecycle::badge('stable')`
#'
#' `quad_switch()` integrates [`quad_active()`] and [`quad_anno()`] into one
#' function for ease of use. This function allows you to quickly change the
#' active context of the [`quad_layout()`] and its annotations.
#'
#' `hmanno` is an alias for `quad_switch`, with additional arguments for
#' backward compatibility
#'
#' @param position `r rd_quad_position("activated")`. If `NULL`, it sets the
#'  active context to the `r rd_quad()` itself.
#' @inheritParams rlang::args_dots_empty
#' @inheritParams quad_active
#' @examples
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     align_dendro()
#' @importFrom ggplot2 waiver
#' @seealso [`quad_active()`]/[`quad_anno()`]
#' @export
quad_switch <- function(position = NULL, size = NULL,
                        width = NULL, height = NULL, free_guides = waiver(),
                        initialize = NULL, what = waiver()) {
    if (is.null(position)) {
        quad_active(width = width, height = height)
    } else {
        position <- match.arg(position, .TLBR)
        quad_switch_anno(
            size = size,
            free_guides = free_guides, what = what,
            initialize = initialize,
            position = position
        )
    }
}

#' @inheritParams heatmap_layout
#' @export
#' @rdname quad_switch
hmanno <- quad_switch

#' Arrange multiple plots into a grid
#'
#' @param ... <[dyn-dots][rlang::dyn-dots]> A list of plots, ususally the
#' ggplot object. Use `NULL` to indicate an empty spacer.
#' @param ncol,nrow The dimensions of the grid to create - if both are `NULL` it
#' will use the same logic as [`facet_wrap()`][ggplot2::facet_wrap] to set the
#' dimensions
#' @param byrow If `FALSE` the plots will be filled in in column-major order.
#' @param widths,heights The relative widths and heights of each column and row
#' in the grid. Will get repeated to match the dimensions of the grid. The
#' special value of `NA` will behave as `1null` unit unless a fixed aspect plot
#' is inserted in which case it will allow the dimension to expand or contract
#' to match the aspect ratio of the content.
#' @param area Specification of the location of areas in the layout. Can
#' either be specified as a text string or by concatenating calls to
#' [`area()`] together.
#' @param guides A string with one or more of `r oxford_and(c(.tlbr, "i"))`
#' indicating which side of guide legends should be collected. Defaults to
#' [`waiver()`][ggplot2::waiver()], which inherits from the parent layout. If
#' there is no parent layout, or if `NULL` is provided, no guides will be
#' collected.
#' @param theme A [`theme()`][ggplot2::theme] object used to customize various
#' elements of the layout. By default, the theme will inherit from the parent
#' `layout`.
#' @param design An alias for `area`, retained for backward compatibility.
#' @return An `AlignPatches` object.
#' @seealso
#'  - [layout_design()]
#'  - [layout_title()]
#'  - [layout_theme()]
#' @examples
#' # directly copied from patchwork
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) +
#'     geom_bar(aes(gear)) +
#'     facet_wrap(~cyl)
#' p4 <- ggplot(mtcars) +
#'     geom_bar(aes(carb))
#' p5 <- ggplot(mtcars) +
#'     geom_violin(aes(cyl, mpg, group = cyl))
#'
#' # Either add the plots as single arguments
#' align_plots(p1, p2, p3, p4, p5)
#'
#' # Or use bang-bang-bang to add a list
#' align_plots(!!!list(p1, p2, p3), p4, p5)
#'
#' # Match plots to areas by name
#' area <- "#BB
#'           AA#"
#' align_plots(B = p1, A = p2, area = area)
#'
#' # Compare to not using named plot arguments
#' align_plots(p1, p2, area = area)
#' @export
align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
                        widths = NA, heights = NA, area = NULL,
                        guides = waiver(), theme = NULL, design = NULL) {
    plots <- rlang::dots_list(..., .ignore_empty = "all", .named = NULL)
    nms <- names(plots)
    area <- area %||% design
    if (!is.null(nms) && is.character(area)) {
        area_names <- unique(trimws(.subset2(strsplit(area, ""), 1L)))
        area_names <- sort(vec_set_difference(area_names, c("", "#")))
        if (all(nms %in% area_names)) {
            plot_list <- vector("list", length(area_names))
            names(plot_list) <- area_names
            plot_list[nms] <- plots
            plots <- plot_list
        }
    }

    for (plot in plots) {
        if (!has_method(plot, "alignpatch", default = FALSE)) {
            cli_abort("Cannot align {.obj_type_friendly {plot}}")
        }
    }

    # setup layout parameters
    layout <- layout_design(
        ncol = ncol, nrow = nrow, byrow = byrow,
        widths = widths, heights = heights, area = area,
        guides = guides
    )
    AlignPatches(plots = plots, layout = layout, theme = theme)
}

#' @importFrom ggplot2 is_theme
#' @importFrom S7 new_object S7_object prop prop<-
AlignPatches <- S7::new_class("AlignPatches",
    properties = list(
        plots = S7::new_property(
            S7::class_list,
            setter = function(self, value) {
                if (!is.null(prop(self, "plots"))) {
                    cli_abort("'@plots' is read-only")
                }
                prop(self, "plots", check = FALSE) <- value
                self
            }
        ),
        layout = S7::new_property(
            S7::class_list,
            setter = function(self, value) {
                if (!inherits(value, "layout_design")) {
                    cli_abort("'@layout' must be a {.fn layout_design} object")
                }
                old <- prop(self, "layout") %||% list(
                    ncol = NULL, nrow = NULL, byrow = TRUE,
                    widths = NA, heights = NA, area = NULL,
                    guides = waiver()
                )
                guides <- .subset2(value, "guides")
                value$guides <- NULL # guides need special consideration
                old <- update_non_waive(old, value)
                if (is.null(guides) || is.waive(guides)) {
                    old["guides"] <- list(guides)
                } else if (!identical(guides, NA)) {
                    old["guides"] <- list(setup_guides(guides))
                }
                prop(self, "layout", check = FALSE) <- old
                self
            }
        ),
        titles = S7::new_property(
            S7::class_list,
            setter = function(self, value) {
                if (!inherits(value, "layout_title")) {
                    cli_abort("'@titles' must be a {.fn layout_title} object'")
                }
                old <- prop(self, "titles") %||%
                    list(title = NULL, subtitle = NULL, caption = NULL)
                prop(self, "titles", check = FALSE) <- update_non_waive(
                    old, value
                )
                self
            }
        ),
        theme = S7::new_property(
            S7::class_any,
            setter = function(self, value) {
                if (!is.null(value) && !is_theme(value)) {
                    cli_abort("'@theme' must be a {.cls theme} object'")
                }
                if (is.null(prop(self, "theme")) || is.null(value)) {
                    prop(self, "theme", check = FALSE) <- value
                } else {
                    prop(self, "theme", check = FALSE) <- prop(self, "theme") +
                        value
                }
                self
            },
            default = NULL
        )
    ),
    constructor = function(plots = list(), layout = NULL,
                           titles = NULL, theme = NULL) {
        out <- new_object(
            S7_object(),
            plots = plots,
            layout = layout %||% layout_design(),
            titles = titles %||% layout_title(),
            theme = theme
        )
        # for backward compatibility
        add_class(out, "alignpatches")
    }
)

#' @importFrom rlang caller_env
local(
    S7::method(`+`, list(AlignPatches, S7::class_any)) <-
        function(e1, e2) {
            # Get the name of what was passed in as e2, and pass along so that
            # it can be displayed in error messages
            if (missing(e2)) {
                cli_abort(c(
                    "Cannot use {.code +} with a single argument.",
                    "i" = "Did you accidentally put {.code +} on a new line?"
                ))
            }
            e2name <- deparse(substitute(e2, env = caller_env(2)))
            alignpatches_add(e2, e1, e2name)
        }
)

#' @importFrom S7 S7_dispatch
alignpatches_add <- S7::new_generic(
    "alignpatches_add", "object",
    function(object, patches, objectname) S7_dispatch()
)

S7::method(alignpatches_add, S7::class_any) <-
    function(object, patches, objectname) {
        if (is.null(object)) return(patches) # styler: off
        cli_abort(c(
            "Cannot add {objectname}",
            "x" = "Only other layout elements or compatible objects can be added."
        ))
    }

#############################################################
#' Define the grid to compose plots in
#'
#' To control how different plots are laid out, you need to add a layout design
#' specification. If you are nesting grids, the layout is scoped to the current
#' nesting level.
#' @inheritParams align_plots
#' @return A `layout_design` object.
#' @examples
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) +
#'     geom_bar(aes(gear)) +
#'     facet_wrap(~cyl)
#' align_plots(p1, p2, p3) +
#'     layout_design(nrow = 1L)
#' align_plots(p1, p2, p3) +
#'     layout_design(ncol = 1L)
#' @importFrom ggplot2 waiver
#' @export
layout_design <- function(ncol = waiver(), nrow = waiver(), byrow = waiver(),
                          widths = waiver(), heights = waiver(),
                          area = waiver(), guides = NA, design = waiver()) {
    if (!is.waive(ncol)) {
        assert_number_whole(ncol, min = 1, allow_na = TRUE, allow_null = TRUE)
    }
    if (!is.waive(nrow)) {
        assert_number_whole(nrow, min = 1, allow_na = TRUE, allow_null = TRUE)
    }
    if (!is.waive(byrow)) assert_bool(byrow)
    area <- area %|w|% design
    if (!is.waive(area)) area <- as_areas(area)
    if (!identical(guides, NA) && !is.waive(guides) && !is.null(guides)) {
        assert_guides(guides)
    }
    structure(
        list(
            ncol = ncol,
            nrow = nrow,
            byrow = byrow,
            widths = widths,
            heights = heights,
            area = area,
            guides = guides
        ),
        class = c("layout_design", "plot_layout")
    )
}

S3_layout_design <- S7::new_S3_class("layout_design")

S7::method(alignpatches_add, S3_layout_design) <-
    function(object, patches, objectname) {
        patches@layout <- object
        patches
    }

S7::method(alignpatches_add, S7::new_S3_class("plot_layout")) <-
    function(object, patches, objectname) {
        object$area <- object$design # pathwork use `design`
        object <- .subset(object, names(layout_design()))
        if (is.waive(object$guides)) {
            object$guides <- NA
        } else if (identical(object$guides, "auto")) {
            object$guides <- waiver()
        } else if (identical(object$guides, "collect")) {
            object$guides <- "tlbr"
        } else if (identical(object$guides, "keep")) {
            object["guides"] <- list(NULL)
        }
        alignpatches_add(add_class(object, "layout_design"), patches)
    }

##############################################################
#' Annotate the whole layout
#'
#' @inheritParams ggplot2::labs
#' @return A `layout_title` object.
#' @examples
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) +
#'     geom_bar(aes(gear)) +
#'     facet_wrap(~cyl)
#' align_plots(p1, p2, p3) +
#'     layout_title(title = "I'm title")
#' @importFrom ggplot2 waiver
#' @export
layout_title <- function(title = waiver(), subtitle = waiver(),
                         caption = waiver()) {
    if (!is.waive(title)) assert_string(title, allow_null = TRUE)
    if (!is.waive(subtitle)) assert_string(subtitle, allow_null = TRUE)
    if (!is.waive(caption)) assert_string(caption, allow_null = TRUE)
    structure(
        list(title = title, subtitle = subtitle, caption = caption),
        class = c("layout_title", "plot_annotation")
    )
}

S3_layout_title <- S7::new_S3_class("layout_title")

S7::method(alignpatches_add, S3_layout_title) <-
    function(object, patches, objectname) {
        patches@titles <- object
        patches
    }

##############################################################
#' Modify theme of the layout
#'
#' @inherit ggplot2::theme
#' @param ... A [`theme()`][ggplot2::theme] object or additional element
#' specifications not part of base ggplot2. In general, these should also be
#' defined in the `element tree` argument. [`Splicing`][rlang::splice] a list
#' is also supported.
#'
#' @details
#' A [`theme()`][ggplot2::theme] object used to customize various elements of
#' the layout, including `guides`, `title`, `subtitle`, `caption`, `margins`,
#' `panel.border`, and `background`. By default, the theme will inherit from the
#' parent `layout`.
#'
#' - `guides`, `panel.border`, and `background` will always be used even for the
#' nested `alignpatches` object.
#'
#' - `title`, `subtitle`, `caption`, and `margins` will be added for the
#' top-level `alignpatches` object only.
#'
#' @examples
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) +
#'     geom_bar(aes(gear)) +
#'     facet_wrap(~cyl)
#' align_plots(
#'     p1 + theme(plot.background = element_blank()),
#'     p2 + theme(plot.background = element_blank()),
#'     p3 + theme(plot.background = element_blank())
#' ) +
#'     layout_theme(plot.background = element_rect(fill = "red"))
#' @importFrom ggplot2 theme
#' @export
layout_theme <- rlang::new_function(
    # We utilize editor completion by listing all `theme()` arguments here.
    # By placing `...` at the beginning, we can check if the first
    # following argument is a `theme()` object rather than individual theme
    # elements.
    c(
        rlang::exprs(... = ),
        .subset(
            rlang::fn_fmls(theme),
            vec_set_difference(names(rlang::fn_fmls(theme)), "...")
        )
    ),
    quote({
        elements <- ggfun("find_args")(..., complete = NULL, validate = NULL)
        ans <- theme(!!!elements)
        th <- NULL
        for (i in seq_len(...length())) {
            if (inherits(t <- ...elt(i), "theme")) {
                th <- ggfun("add_theme")(th, t)
            }
        }
        add_class(ggfun("add_theme")(th, ans), "layout_theme")
    })
)

S3_layout_theme <- S7::new_S3_class("layout_theme")

S7::method(alignpatches_add, S3_layout_theme) <-
    function(object, patches, objectname) {
        patches@theme <- object
        patches
    }

S7::method(alignpatches_add, S7::new_S3_class("plot_annotation")) <-
    function(object, patches, objectname) {
        patches@titles <- .subset(object, names(layout_title()))
        patches@theme <- .subset2(object, "theme")
        patches
    }

update_layout_theme <- function(old, new) {
    if (is.null(old) || is.null(new)) return(new) # styler: off
    old + new
}

#' Add layout annotation (internal use)
#'
#' This function is a placeholder for future extensions.
#' If you're trying to apply a theme, use [layout_theme()] instead.
#'
#' @param ... Currently unused. May accept a theme in the future.
#' @param theme A theme object. If not `waiver()`, an error will be raised.
#'
#' @return None. This function is used for input validation.
#' @importFrom ggplot2 is_theme
#' @export
#' @keywords internal
layout_annotation <- function(..., theme = waiver()) {
    if (is_theme(...elt(1)) || !is.waive(theme)) {
        cli_abort("Please use {.fn layout_theme} instead; {.fn layout_annotation} is reserved for future extensions.")
    }
}

#' Add a plot to annotate selected observations
#'
#' @param mark A [`mark_draw()`] object to define how to draw the links. Like
#' [`mark_line()`], [`mark_tetragon()`]. Note the names of the pair links will
#' be used to define the panel names so must be unique.
#' @inheritParams ggalign
#' @param group1,group2 A single boolean value indicating whether to use the
#'   panel group information from the layout as the paired groups. By default,
#'   if no specific observations are selected in `mark`, `ggmark()` will
#'   automatically connect all observations and group them according to the
#'   layout's defined groups.
#' @param obs_size A single numeric value that indicates the size of a single
#'   observation, ranging from `(0, 1]`.
#' @section ggplot2 specification:
#' `ggmark` initializes a ggplot object. The underlying data is created using
#' [`fortify_data_frame()`]. Please refer to it for more details.
#'
#' In addition, the following columns will be added to the data frame:
#'
#'  - `.panel`: the panel for the aligned axis. It means `x-axis` for vertical
#'    stack layout (including top and bottom annotation), `y-axis` for
#'    horizontal stack layout (including left and right annotation).
#'
#'  - `.names` ([`vec_names()`][vctrs::vec_names]) and `.index`
#'    ([`vec_size()`][vctrs::vec_size()]/[`NROW()`]): a character names (only
#'    applicable when names exists) and an integer of index of the original
#'    data.
#'
#'  - `.hand`: A factor with levels `c("left", "right")` for horizontal stack
#'    layouts, or `c("top", "bottom")` for vertical stack layouts, indicating
#'    the position of the linked observations.
#'
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 7)
#' rownames(small_mat) <- paste0("row", seq_len(nrow(small_mat)))
#' colnames(small_mat) <- paste0("column", seq_len(ncol(small_mat)))
#'
#' # mark_line
#' ggheatmap(small_mat) +
#'     theme(axis.text.x = element_text(hjust = 0, angle = -60)) +
#'     anno_right() +
#'     align_kmeans(3L) +
#'     ggmark(mark_line(I(1:3) ~ NULL)) +
#'     geom_boxplot(aes(.names, value)) +
#'     theme(plot.margin = margin(l = 0.1, t = 0.1, unit = "npc"))
#'
#' # mark_tetragon
#' ggheatmap(small_mat) +
#'     theme(axis.text.x = element_text(hjust = 0, angle = -60)) +
#'     anno_right() +
#'     align_kmeans(3L) +
#'     ggmark(mark_tetragon(I(1:3) ~ NULL)) +
#'     geom_boxplot(aes(.names, value)) +
#'     theme(plot.margin = margin(l = 0.1, t = 0.1, unit = "npc"))
#' @importFrom rlang list2
#' @export
ggmark <- function(mark, data = waiver(), mapping = aes(), ...,
                   group1 = NULL, group2 = NULL,
                   obs_size = 1, size = NULL, active = NULL) {
    if (!inherits(mark, "ggalign_mark_draw")) {
        cli_abort("{.arg mark} must be a {.fn mark_draw} object")
    }
    assert_obs_size(obs_size)
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    assert_bool(group1, allow_null = TRUE)
    assert_bool(group2, allow_null = TRUE)
    new_craftbox(
        MarkGg,
        # fields added to `MarkGg`
        input_data = allow_lambda(data), # used by AlignGg
        params = list2(...), # used by AlignGg
        mark = mark, # used by MarkGg
        group1 = group1, group2 = group2,
        obs_size = obs_size,

        # slot
        plot = ggplot(mapping = mapping),
        size = size,
        schemes = default_schemes(data, th = theme_panel_border()),
        active = active
    )
}

#' @importFrom ggplot2 ggproto ggplot margin element_rect
MarkGg <- ggproto("MarkGg", Craftsman,
    free_facet = TRUE,
    free_limits = TRUE,
    interact_layout = function(self, layout) {
        layout_name <- self$layout_name
        if (!self$in_linear) { # only used for linear coordinate
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s",
                    object_name(self), layout_name
                ),
                i = sprintf(
                    "%s can only be used in linear layout",
                    object_name(self)
                )
            ))
        }
        if (is_layout_continuous(layout)) { # only used for discrete variable
            # ggmark special for discrete variables
            cli_abort(c(
                sprintf("Cannot add %s to %s", object_name(self), layout_name),
                i = sprintf("%s cannot align discrete variables", layout_name)
            ))
        }
        ans <- ggproto_parent(AlignGg, self)$interact_layout(layout)
        self$labels0 <- self$labels # CrossMark uses `labels0`
        ans
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (is.null(.subset2(design, "nobs"))) {
            cli_abort(sprintf(
                "you must initialize %s before drawing %s",
                self$layout_name, object_name(self)
            ), call = self$call)
        }
        mark <- self$mark

        # parse links --------------------------------------------
        links <- .subset2(mark, "links")
        group1 <- self$group1
        group2 <- self$group2
        position <- self$position
        if (is_empty(links) && is.null(group1) && is.null(group2)) {
            # guess group1 and group2 from position
            if (is.null(position)) { # a normal stack layout
                group1 <- TRUE
            } else if (any(position == c("top", "left"))) {
                group2 <- TRUE
            } else {
                group1 <- TRUE
            }
        }
        full_data <- split(
            seq_len(.subset2(design, "nobs")),
            .subset2(design, "panel")
        )
        if (isTRUE(group1) && isTRUE(group2)) {
            extra_links <- mapply(function(l1, l2) {
                new_pair_link(I(l1), I(l2))
            }, full_data, full_data, SIMPLIFY = FALSE)
        } else if (isTRUE(group1)) {
            extra_links <- lapply(full_data, function(l) {
                new_pair_link(hand1 = I(l))
            })
        } else if (isTRUE(group2)) {
            extra_links <- lapply(full_data, function(l) {
                new_pair_link(hand2 = I(l))
            })
        } else {
            extra_links <- NULL
        }

        # unlock the object
        self$unlock()
        self$mark$links <- vec_c(extra_links, links)
        on.exit(self$mark <- mark, add = TRUE) # restore the original `mark`
        on.exit(self$lock(), add = TRUE)

        # setup the plot
        plot <- ggproto_parent(CrossMark, self)$build_plot(
            plot,
            design,
            extra_design,
            previous_design %||% design
        )
        plot_data <- plot$data

        # prepare data for the plot ------------------------------
        if (!is.null(data <- self$data)) {
            plot_data <- inner_join(plot_data, data, by = ".index")
        }
        gguse_data(plot, ggalign_data_restore(plot_data, data))
    },
    finish_plot = function(self, plot, schemes, theme) {
        ggproto_parent(CrossMark, self)$finish_plot(plot, schemes, theme)
    },
    summary = function(self, plot) {
        header <- ggproto_parent(Craftsman, self)$summary(plot)
        c(header, "  Add plot to annotate observations")
    }
)

#' Plot dendrogram tree
#'
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' [`geom_segment()`][ggplot2::geom_segment].
#' @param plot_dendrogram A boolean value indicates whether plot the dendrogram
#' tree.
#' @param plot_cut_height A boolean value indicates whether plot the cut height.
#' @section ggplot2 specification:
#' `align_dendro` initializes a ggplot `data` and `mapping`.
#'
#' The internal `ggplot` object will always use a default mapping of
#' `aes(x = .data$x, y = .data$y)`.
#'
#' The default ggplot data is the `node` coordinates with `edge` data attached
#' in [`ggalign`][ggalign_attr()] attribute, in addition, a
#' [`geom_segment`][ggplot2::geom_segment] layer with a data frame of the `edge`
#' coordinates will be added when `plot_dendrogram = TRUE`.
#'
#' See [`fortify_data_frame.dendrogram()`] for details.
#' @param merge_dendrogram A single boolean value, indicates whether we should
#' merge multiple dendrograms, only used when previous groups have been
#' established. Default: `FALSE`.
#' @inheritParams align_hclust
#' @inheritParams fortify_data_frame.dendrogram
#' @inheritParams ggalign
#' @inheritSection align Discrete Axis Alignment
#' @examples
#' # align_dendro will always add a plot area
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     align_dendro()
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     align_dendro(k = 3L)
#'
#' @importFrom ggplot2 aes
#' @importFrom rlang list2
#' @export
align_dendro <- function(mapping = aes(), ...,
                         distance = "euclidean",
                         method = "complete",
                         use_missing = "pairwise.complete.obs",
                         reorder_dendrogram = FALSE,
                         merge_dendrogram = FALSE,
                         reorder_group = FALSE,
                         k = NULL, h = NULL, cutree = NULL,
                         plot_dendrogram = TRUE,
                         plot_cut_height = NULL, root = NULL,
                         center = FALSE, type = "rectangle",
                         size = NULL, data = NULL,
                         no_axes = NULL, active = NULL) {
    assert_bool(plot_cut_height, allow_null = TRUE)
    assert_bool(merge_dendrogram)

    # setup the default value for `plot_cut_height`
    plot_cut_height <- plot_cut_height %||% (
        # we by default don't draw the height of the user-provided cutree
        # since function like `dynamicTreeCut` will merge tree
        (!is.null(k) || !is.null(h)) && is.null(cutree)
    )
    plot <- ggplot(mapping = mapping)
    if (plot_dendrogram) {
        plot <- plot + ggplot2::geom_segment(
            mapping = aes(
                x = .data$x, y = .data$y,
                xend = .data$xend, yend = .data$yend
            ),
            ...,
            stat = "identity",
            data = function(data) ggalign_attr(data, "edge")
        )
    }
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    .align_hclust(
        align = AlignDendro,
        distance = distance,
        method = method,
        use_missing = use_missing,
        merge_dendro = merge_dendrogram,
        plot_cut_height = plot_cut_height,
        type = type, root = root, center = center,
        reorder_dendrogram = reorder_dendrogram,
        reorder_group = reorder_group,
        schemes = default_schemes(th = theme_no_strip()),
        k = k, h = h, cutree = cutree, data = data, active = active,
        size = size, no_axes = no_axes, plot = plot
    )
}

#' @importFrom ggplot2 aes ggplot
#' @importFrom rlang inject
#' @include craft-align-hclust.R
AlignDendro <- ggproto("AlignDendro", AlignHclust,
    setup_plot = function(self, plot) {
        ggadd_default(plot, aes(x = .data$x, y = .data$y)) + switch_direction(
            self$direction,
            ggplot2::labs(x = "height"),
            ggplot2::labs(y = "height")
        )
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        plot_cut_height <- self$plot_cut_height
        center <- self$center
        type <- self$type
        root <- self$root
        panel <- .subset2(design, "panel")
        index <- .subset2(design, "index")

        statistics <- .subset2(self, "statistics")
        direction <- self$direction
        priority <- switch_direction(direction, "left", "right")
        dendrogram_panel <- self$panel[index]
        if (!is.null(dendrogram_panel) &&
            # we allow to change the panel level name, but we prevent
            # from changing the underlying factor level (the underlying
            # ordering)
            !all(as.integer(dendrogram_panel) == as.integer(panel))) {
            cli_abort("you cannot do sub-splitting in dendrogram groups")
        }

        if (self$multiple_tree) {
            branches <- levels(panel)
            data <- vector("list", length(statistics))
            start <- 0L
            for (i in seq_along(data)) {
                tree <- .subset2(statistics, i)
                n <- stats::nobs(tree)
                end <- start + n
                data[[i]] <- fortify_data_frame(
                    tree,
                    priority = priority,
                    center = center,
                    type = type,
                    leaf_pos = seq(start + 1L, end),
                    leaf_braches = rep_len(.subset(branches, i), n),
                    reorder_branches = FALSE,
                    root = root,
                    double = TRUE,
                    call = self$call
                )
                start <- end
            }
            data <- lapply(
                list(
                    node = data,
                    edge = lapply(data, ggalign_attr, "edge")
                ),
                function(dat) {
                    ans <- vec_rbind(!!!dat, .names_to = "parent")
                    ans$.panel <- factor(.subset2(ans, ".panel"), branches)
                    ans
                }
            )
            edge <- .subset2(data, "edge")
            node <- .subset2(data, "node")
        } else {
            if (nlevels(panel) > 1L && type == "triangle" && self$in_linear) {
                cli_warn(c(paste(
                    "{.arg type} of {.arg triangle}",
                    "is not well support for facet dendrogram"
                ), i = "will use {.filed rectangle} dendrogram instead"))
                type <- "rectangle"
            }
            data <- fortify_data_frame(
                statistics,
                priority = priority,
                center = center,
                type = type,
                leaf_braches = as.character(panel),
                # panel has been reordered by the dendrogram index
                reorder_branches = FALSE,
                root = root,
                double = TRUE,
                call = self$call
            )
            edge <- ggalign_attr(data, "edge")
            node <- data
        }

        # add names
        if (!is.null(self$labels)) {
            node$.names <- .subset(self$labels, .subset2(node, ".index"))
        }
        if (is_horizontal(direction)) {
            edge <- rename(
                edge,
                c(x = "y", xend = "yend", y = "x", yend = "xend")
            )
            node <- rename(node, c(x = "y", y = "x"))
        }

        # we do some tricks, since ggplot2 won't remove the attributes
        # we attach the `edge` data
        plot <- gguse_data(plot, ggalign_data_set(node, edge = edge))

        if (plot_cut_height && !is.null(height <- .subset2(self, "height"))) {
            plot <- plot +
                switch_direction(
                    direction,
                    ggplot2::geom_vline(
                        xintercept = height, linetype = "dashed"
                    ),
                    ggplot2::geom_hline(
                        yintercept = height, linetype = "dashed"
                    )
                )
        }
        position <- .subset2(self, "position")
        if (!self$in_linear || # for circular layout
            # for bottom annotation, reverse y-axis
            (!is.null(position) && position == "bottom")) {
            plot <- reverse_continuous_axis(plot, "y")
        } else if (!is.null(position) && position == "left") {
            # for left annotation, reverse x-axis
            plot <- reverse_continuous_axis(plot, "x")
        }

        # always turn off clip, this is what dendrogram dependends on
        old_coord <- plot$coordinates
        if (!identical(old_coord$clip, "off")) {
            # to prevent from changing the input of user.
            plot$coordinates <- ggproto(NULL, old_coord, clip = "off")
        }
        plot
    }
)

tree_one_node <- function(index, label) {
    structure(
        index,
        class = "dendrogram",
        leaf = TRUE,
        height = 0,
        label = label,
        members = 1L
    )
}

# this function won't set the right `midpoint`, but `dendrogram_data` function
# won't use it, so, it has no hurt to use.
merge_dendrogram <- function(parent, children) {
    if (is.null(parent)) { # if no parent, call the merge function from `stats`
        return(Reduce(function(x, y) {
            merge(x, y, adjust = "none")
        }, children))
    }
    children_heights <- vapply(
        children, attr, numeric(1L), "height",
        USE.NAMES = FALSE
    )
    parent_branch_heights <- tree_branch_heights(parent)
    cutoff_height <- max(children_heights) + min(parent_branch_heights) * 0.5
    .merge_dendrogram <- function(dend) {
        if (stats::is.leaf(dend)) { # base version, leaf should be the index
            .subset2(children, dend)
        } else { # for a branch, we should update the members, height
            attrs <- attributes(dend)
            # we recursively run for each node of current branch
            dend <- lapply(dend, .merge_dendrogram)
            heights <- vapply(dend, attr, numeric(1L), "height",
                USE.NAMES = FALSE
            )
            n_members <- vapply(dend, attr, integer(1L), "members",
                USE.NAMES = FALSE
            )
            # we update height and members
            attrs$height <- .subset2(attrs, "height") + max(heights)
            attrs$members <- sum(n_members)
            attributes(dend) <- attrs
            dend
        }
    }
    ans <- .merge_dendrogram(parent)
    attr(ans, "cutoff_height") <- cutoff_height
    ans
}

#' @importFrom stats reorder
reorder_dendrogram <- function(dend, wts) {
    if (inherits(dend, "hclust")) dend <- stats::as.dendrogram(dend)
    reorder(x = dend, wts = wts, agglo.FUN = mean)
}

tree_branch_heights <- function(dend) {
    if (stats::is.leaf(dend)) {
        return(NULL)
    } else {
        c(
            attr(dend, "height"),
            unlist(lapply(dend, tree_branch_heights), FALSE, FALSE)
        )
    }
}

#' Create a ggplot inset
#'
#' @inheritParams ggwrap
#' @return A `patch_inset` object, which can be added in ggplot.
#' @inherit patch seealso
#' @examples
#' library(grid)
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p1 + inset(p2, vp = viewport(0.6, 0.6,
#'     just = c(0, 0), width = 0.4, height = 0.4
#' ))
#' @export
inset <- function(
    plot,
    ...,
    align = "panel",
    on_top = TRUE,
    clip = TRUE,
    vp = NULL) {
    make_inset(
        plot = plot,
        ...,
        align = align,
        on_top = on_top,
        clip = clip,
        vp = vp
    )
}

#' @importFrom grid editGrob
#' @importFrom rlang arg_match0
make_inset <- function(
    plot,
    ...,
    align,
    on_top,
    clip,
    vp,
    call = caller_call()) {
    assert_bool(on_top, call = call)
    align <- arg_match0(align, c("panel", "plot", "full"), error_call = call)
    assert_bool(clip, call = call)
    assert_s3_class(vp, "viewport", allow_null = TRUE, call = call)
    if (!is.grob(grob <- patch(x = plot, ...))) {
        cli_abort("{.fn patch} must return a {.cls grob}", call = call)
    }
    if (!is.null(vp)) grob <- editGrob(grob, vp = vp)
    structure(
        list(
            grob = grob,
            align = align,
            clip = if (clip) "on" else "off",
            on_top = on_top
        ),
        class = "patch_inset"
    )
}

#' @importFrom grid grid.draw
#' @export
grid.draw.patch_inset <- function(x, recording = TRUE) {
    grid.draw(.subset2(x, "grob"))
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.patch_inset <- function(object, plot, object_name, ...) {
    make_wrap(plot, object)
}

#' @importFrom grid unit.c
#' @export
ggalign_build.QuadLayout <- function(x) {
    x <- default_layout(x)
    patches <- quad_build(x)
    plots <- .subset2(patches, "plots")
    sizes <- .subset2(patches, "sizes")
    design <- list(
        top = area(1, 2),
        left = area(2, 1),
        main = area(2, 2),
        bottom = area(3, 2),
        right = area(2, 3)
    )
    sizes <- imap(list(
        height = c("top", "main", "bottom"),
        width = c("left", "main", "right")
    ), function(x, name) {
        out <- .subset(sizes, x)
        out$main <- .subset2(.subset2(out, "main"), name)
        out <- .subset(
            out,
            !vapply(.subset(plots, x), is.null, logical(1L), USE.NAMES = FALSE)
        )
        do.call(unit.c, out)
    })
    keep <- !vapply(plots, is.null, logical(1L), USE.NAMES = FALSE)
    design <- trim_area(vec_c(!!!vec_set_names(vec_slice(design, keep), NULL)))
    titles <- x@titles
    align_plots(
        !!!.subset(plots, keep),
        design = design,
        heights = .subset2(sizes, "height"),
        widths = .subset2(sizes, "width"),
        guides = .subset2(.subset2(x@schemes, "scheme_align"), "guides"),
        theme = x@theme
    ) + layout_title(
        title = .subset2(titles, "title"),
        subtitle = .subset2(titles, "subtitle"),
        caption = .subset2(titles, "caption")
    )
}

quad_build <- function(quad, schemes = NULL, theme = NULL,
                       direction = NULL) {
    UseMethod("quad_build")
}

#######################################################################
#' @param schemes,theme Parameters from parent layout
#' @importFrom ggplot2 aes
#' @importFrom rlang is_empty
#' @importFrom grid unit is.unit unit.c
#' @export
#' @noRd
quad_build.QuadLayout <- function(quad, schemes = NULL, theme = NULL,
                                  direction = NULL) {
    data <- quad@data
    row_design <- setup_design(quad@horizontal)
    column_design <- setup_design(quad@vertical)
    if (is.function(data)) {
        cli_abort(c(
            "{.arg data} cannot be a {.cls function}",
            i = sprintf(
                "Did you want to add %s to a {.fn stack_layout}?",
                object_name(quad)
            )
        ))
    }
    if (is_discrete_design(row_design) &&
        is.null(.subset2(row_design, "nobs"))) {
        cli_abort(sprintf(
            "you must initialize %s before drawing the main plot",
            object_name(quad),
        ))
    }
    if (is_discrete_design(column_design) &&
        is.null(.subset2(column_design, "nobs"))) {
        cli_abort(sprintf(
            "you must initialize %s before drawing the main plot",
            object_name(quad),
        ))
    }
    schemes <- inherit_parent_layout_schemes(quad, schemes)
    if (is.null(direction)) {
        spacing <- NULL
    } else if (is_horizontal(direction)) {
        spacing <- "y"
    } else {
        spacing <- "x"
    }
    theme <- inherit_parent_layout_theme(quad, theme, spacing = spacing)

    # prepare action for vertical and horizontal stack layout
    vertical_align <- horizontal_align <- the_align <-
        .subset2(schemes, "scheme_align")
    if (!is.null(layout_labs <- .subset2(the_align, "free_labs")) &&
        !is.waive(layout_labs)) {
        # prepare labs for child stack layout
        horizontal_align$free_labs <- gsub("[lr]", "", layout_labs)
        vertical_align$free_labs <- gsub("[tb]", "", layout_labs)
        if (!nzchar(horizontal_align$free_labs)) {
            horizontal_align["free_labs"] <- list(NULL)
        }
        if (!nzchar(vertical_align$free_labs)) {
            vertical_align["free_labs"] <- list(NULL)
        }
    }

    # inherit from the parent stack layout
    if (!is.null(layout_spaces <- .subset2(the_align, "free_spaces")) &&
        !is.waive(layout_spaces)) {
        horizontal_align$free_spaces <- gsub("[lr]", "", layout_spaces)
        vertical_align$free_spaces <- gsub("[tb]", "", layout_spaces)
        if (!nzchar(horizontal_align$free_spaces)) {
            horizontal_align["free_spaces"] <- list(NULL)
        }
        if (!nzchar(vertical_align$free_spaces)) {
            vertical_align["free_spaces"] <- list(NULL)
        }
    }

    # plot annotations ----------------------------
    stack_list <- lapply(.TLBR, function(position) {
        if (is_empty(stack <- slot(quad, position))) {
            return(list(plot = NULL, size = NULL))
        }
        pschemes <- schemes
        # inherit from horizontal align or vertical align
        if (is_horizontal(to_direction(position))) {
            extra_design <- column_design
            pschemes$scheme_align <- horizontal_align
        } else {
            extra_design <- row_design
            pschemes$scheme_align <- vertical_align
        }
        plot <- stack_build(
            stack,
            schemes = pschemes,
            theme = theme,
            extra_design = extra_design
        )
        if (is.null(plot)) {
            size <- NULL
        } else {
            size <- stack@sizes
        }
        list(plot = plot, size = size)
    })
    names(stack_list) <- .TLBR
    stack_list <- list_transpose(stack_list)
    plots <- .subset2(stack_list, 1L) # the annotation plot itself
    sizes <- .subset2(stack_list, 2L) # annotation size

    # read the plot ---------------------------------------
    p <- quad@plot

    # setup the facet -----------------------------------
    do_row_facet <- is_discrete_design(row_design) &&
        nlevels(.subset2(row_design, "panel")) > 1L
    do_column_facet <- is_discrete_design(column_design) &&
        nlevels(.subset2(column_design, "panel")) > 1L

    if (do_row_facet && do_column_facet) {
        default_facet <- ggplot2::facet_grid(
            rows = ggplot2::vars(.data$.panel_y),
            cols = ggplot2::vars(.data$.panel_x),
            scales = "free", space = "free",
            drop = FALSE, as.table = FALSE
        )
        free_row <- FALSE
        free_column <- FALSE
    } else if (do_row_facet) {
        default_facet <- ggplot2::facet_grid(
            rows = ggplot2::vars(.data$.panel_y),
            scales = "free_y", space = "free",
            drop = FALSE, as.table = FALSE
        )
        free_row <- FALSE
        free_column <- is_continuous_design(column_design)
    } else if (do_column_facet) {
        default_facet <- ggplot2::facet_grid(
            cols = ggplot2::vars(.data$.panel_x),
            scales = "free_x", space = "free",
            drop = FALSE, as.table = FALSE
        )
        free_row <- is_continuous_design(row_design)
        free_column <- FALSE
    } else {
        default_facet <- facet_quad(object_name(quad))
        free_row <- is_continuous_design(row_design)
        free_column <- is_continuous_design(column_design)
    }

    # set the facets and coord ---------------------------
    # we don't align observations for `quad_free()`
    # add default data ----------------------------------
    p <- gguse_data(p, quad_build_data(data, row_design, column_design))
    p <- gguse_linear_coord(p, object_name(quad))
    p <- ggmelt_facet(p, default_facet,
        free_row = free_row, free_column = free_column
    )
    p <- p +
        ggalign_design(
            x = column_design, y = row_design,
            xlabels = .subset(
                colnames(data),
                .subset2(column_design, "index")
            ),
            ylabels = .subset(
                vec_names(data),
                .subset2(row_design, "index")
            )
        )

    # add action ----------------------------------------
    p <- plot_add_schemes(p, inherit_schemes(quad@body_schemes, schemes))
    if (do_row_facet) {
        p <- p + theme(panel.spacing.y = calc_element("panel.spacing.y", theme))
    }
    if (do_column_facet) {
        p <- p + theme(panel.spacing.x = calc_element("panel.spacing.x", theme))
    }
    p <- p + theme_recycle()

    # collect all plots and sizes ----------------------
    plots <- append(plots, list(main = p), 2L)
    sizes <- append(
        sizes,
        list(main = list(width = quad@width, height = quad@height)),
        3L
    )
    list(plots = plots, sizes = sizes)
}

#' @importFrom stats reorder
quad_build_data <- function(data, row_design, column_design) {
    if (is.null(data) ||
        (is_continuous_design(row_design) &&
            is_continuous_design(column_design))) {
        return(data)
    }
    if (is_discrete_design(row_design)) {
        row_panel <- .subset2(row_design, "panel")
        row_index <- .subset2(row_design, "index")
        row_data <- data_frame0(
            .panel_y = row_panel,
            .index_y = row_index,
            .y = seq_along(row_index)
        )
    }
    if (is_discrete_design(column_design)) {
        column_panel <- .subset2(column_design, "panel")
        column_index <- .subset2(column_design, "index")
        column_data <- data_frame0(
            .panel_x = column_panel,
            .index_x = column_index,
            .x = seq_along(column_index)
        )
    }
    if (is_discrete_design(row_design) && is_discrete_design(column_design)) {
        panel_data <- cross_join(row_data, column_data)
        by.x <- c(".column_index", ".row_index")
        by.y <- c(".index_x", ".index_y")
    } else if (is_discrete_design(column_design)) {
        panel_data <- column_data
        by.x <- ".column_index"
        by.y <- ".index_x"
    } else {
        panel_data <- row_data
        by.x <- ".row_index"
        by.y <- ".index_y"
    }
    ans <- fortify_data_frame.matrix(data)
    ans <- full_join(ans, panel_data, by.x = by.x, by.y = by.y)
    if (!is.null(.subset2(ans, ".row_names")) &&
        is_discrete_design(row_design)) {
        ans$.discrete_y <- reorder(
            .subset2(ans, ".row_names"),
            .subset2(ans, ".y"),
            order = FALSE
        )
    }
    if (!is.null(.subset2(ans, ".column_names")) &&
        is_discrete_design(column_design)) {
        ans$.discrete_x <- reorder(
            .subset2(ans, ".column_names"),
            .subset2(ans, ".x"),
            order = FALSE
        )
    }
    ggalign_data_restore(ans, data)
}

# `vec_rep`
recycle_whole <- function(x, len) {
    out <- x %% len
    if (out == 0L) len else out
}

# `vec_rep_each`
recycle_each <- function(x, len) {
    (x - 1L) %/% len + 1L
}

#' @importFrom utils modifyList
update_non_waive <- function(old, new, keep_null = TRUE) {
    modifyList(old,
        new[!vapply(new, is.waive, logical(1L), USE.NAMES = FALSE)],
        keep.null = keep_null
    )
}

is_s3 <- function(x) is.object(x) && !isS4(x) && !inherits(x, "R6")

#' @importFrom rlang names2
names_or_index <- function(x) {
    nms <- names2(x)
    empty <- nms == ""
    nms[empty] <- seq_along(x)[empty]
    nms
}

#################################################################
#' Read Example Data
#'
#' This function reads example data from the file. If no file is specified, it
#' returns a list of available example files.
#'
#' @param file A string representing the name of the example file to be read. If
#' `NULL`, the function will return a list of available example file names.
#' @return If `file` is `NULL`, returns a character vector of available example
#' file names. Otherwise, returns the contents of the specified example file,
#' read as an R object.
#' @examples
#' read_example()
#' @export
read_example <- function(file = NULL) {
    if (is.null(file)) {
        dir(pkg_extdata())
    } else {
        readRDS(pkg_extdata(file, mustWork = TRUE))
    }
}

with_options <- function(code, ...) {
    opts <- options(...)
    on.exit(options(opts))
    force(code)
}

#' @param ans Whether to assign the final results into the 'ans' variable.
#' @noRd
fn_body_append <- function(fn, ..., ans = FALSE) {
    args <- rlang::fn_fmls(fn)
    body <- rlang::fn_body(fn)
    body <- as.list(body)
    if (ans) body[[length(body)]] <- rlang::expr(ans <- !!body[[length(body)]])
    body <- as.call(c(body, rlang::enexprs(...)))
    rlang::new_function(args, body)
}

# This will work with most things but be aware that it might fail with some
# complex objects. For example, according to `?S3Methods`, calling foo on
# matrix(1:4, 2, 2) would try `foo.matrix`, then `foo.numeric`, then
# `foo.default`; whereas this code will just look for `foo.matrix` and
# `foo.default`.
#' @importFrom utils getS3method
#' @importFrom methods extends
has_method <- function(x, f, inherit = TRUE, default = inherit) {
    x_class <- class(x)
    if (inherit) {
        if (isS4(x)) x_class <- extends(x_class)
        if (default) x_class <- c(x_class, "default")
    } else {
        x_class <- .subset(x_class, 1L)
    }
    for (cls in x_class) {
        if (!is.null(getS3method(f, cls, optional = TRUE))) {
            return(TRUE)
        }
    }
    return(FALSE)
}

#' For functions with a `call` argument, we check if the call originates from
#' the current package. If it does, we use the caller's call; if not, we use the
#' current call directly. Used by `align()` and `free()`
#' @noRd
#' @importFrom utils packageName
override_call <- function(call = NULL) {
    # if no caller call
    if (is.null(call) || is.function(f <- .subset2(call, 1L))) {
        return(TRUE)
    }
    # if call from the current package
    !identical(
        packageName(environment(eval(f))),
        pkg_nm()
    )
}

# library(data.table)
# library(vctrs)
# `%nest_unique%` <- function(x, y) {
#     ans <- new_data_frame(list(x = x, y = y))
#     ans <- unique(ans)
#     !anyDuplicated(ans$x)
# }
# `%nest_vctrs%` <- function(x, y) {
#     ans <- new_data_frame(list(x = x, y = y))
#     ans <- vec_unique(ans)
#     !vec_duplicate_any(.subset2(ans, "x"))
# }
# `%nest_vctrs_loc%` <- function(x, y) {
#     # we don't check the inputs for performance
#     loc <- vec_unique_loc(new_data_frame(list(x = x, y = y)))
#     !vec_duplicate_any(vec_slice(x, loc))
# }
# `%nest_data_table%` <- function(x, y) {
#     ans <- data.table(x = x, y = y)
#     ans <- unique(ans)
#     !anyDuplicated(.subset2(ans, "x"))
# }
# `%nest_split%` <- function(x, y) {
#     all(lengths(lapply(split(y, x), unique)) == 1L)
# }
# `%nest_table%` <- function(x, y) {
#     all(rowSums(table(x, y) > 0L) == 1L)
# }
# foo <- rep(seq(10^4L / 2L), each = 4)
# bar <- rep(seq(10^4L), each = 2)
# bench::mark(
#     nest_unique = bar %nest_unique% foo,
#     nest_vctrs = bar %nest_vctrs% foo,
#     nest_vctrs_loc = bar %nest_vctrs_loc% foo,
#     nest_data_table = bar %nest_data_table% foo,
#     nest_split = bar %nest_split% foo,
#     nest_table = bar %nest_table% foo,
# )
#> Warning: Some expressions had a GC in every iteration; so filtering is
#> disabled.
#> # A tibble: 6 x 6
#>   expression           min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>      <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 nest_unique       5.37ms   7.49ms    134.      1.33MB    69.2
#> 2 nest_vctrs       200.3us 214.57us   3591.     754.7KB     6.00
#> 3 nest_vctrs_loc  193.99us 207.29us   4490.    706.95KB     6.00
#> 4 nest_data_table 402.71us 459.55us   1918.    985.25KB     4.00
#> 5 nest_split       11.87ms  14.08ms     69.8     1.15MB    54.3
#> 6 nest_table      183.52ms 189.87ms      5.20  576.35MB     8.67
`%nest%` <- function(x, y) {
    # we don't check the inputs for performance
    loc <- vec_unique_loc(new_data_frame(list(x = x, y = y)))
    !vec_duplicate_any(vec_slice(x, loc))
}

save_png <- function(code, width = 400L, height = 400L) {
    path <- tempfile(fileext = ".png")
    grDevices::png(path, width = width, height = height)
    on.exit(grDevices::dev.off())
    print(code)
    path
}

add_class <- function(x, ...) {
    if (is.null(x)) return(x) # styler: off
    class(x) <- vec_unique(c(..., class(x)))
    x
}

remove_class <- function(x, ...) {
    oldClass(x) <- vec_set_difference(oldClass(x), c(...))
    x
}

###########################################################
switch_position <- function(position, x, y) {
    switch(position,
        top = ,
        bottom = x,
        left = ,
        right = y
    )
}

to_direction <- function(position) {
    switch_position(position, "vertical", "horizontal")
}

is_vertical <- function(direction) direction == "vertical"

is_horizontal <- function(direction) direction == "horizontal"

switch_direction <- function(direction, h, v) {
    if (is_horizontal(direction)) {
        h
    } else {
        v
    }
}

to_coord_axis <- function(direction) {
    switch_direction(direction, "y", "x")
}

to_matrix_axis <- function(direction) {
    switch_direction(direction, "row", "column")
}

##########################################################
data_frame0 <- function(...) data_frame(..., .name_repair = "minimal")

as_data_frame0 <- function(data, ...) {
    as.data.frame(
        x = data, ...,
        make.names = FALSE,
        stringsAsFactors = FALSE,
        fix.empty.names = FALSE
    )
}

quickdf <- function(x) {
    class(x) <- "data.frame"
    attr(x, "row.names") <- .set_row_names(length(.subset2(x, 1L)))
    x
}

fct_rev <- function(x) {
    ans <- as.factor(x)
    factor(ans, levels = rev(levels(ans)))
}

reverse_trans <- function(x) sum(range(x, na.rm = TRUE)) - x

fclass <- function(x) .subset(class(x), 1L)

is_scalar <- function(x) length(x) == 1L

is_scalar_numeric <- function(x) length(x) == 1L && is.numeric(x)

#' @export
ggalign_build.CircleLayout <- function(x) {
    x <- default_layout(x)
    circle_build(x)
}

#' @importFrom utils packageVersion
#' @importFrom ggplot2 find_panel calc_element ggproto ggplotGrob theme
#' @importFrom gtable gtable_add_grob gtable_add_padding is.gtable
#' @importFrom grid unit viewport editGrob
#' @importFrom rlang is_empty arg_match0
circle_build <- function(circle, schemes = NULL, theme = NULL) {
    schemes <- inherit_parent_layout_schemes(circle, schemes)
    theme <- inherit_parent_layout_theme(circle, theme)
    # for empty plot
    base <- ggplot() +
        theme +
        ggplot2::labs(
            title = .subset2(circle@titles, "title"),
            subtitle = .subset2(circle@titles, "subtitle"),
            caption = .subset2(circle@titles, "caption")
        )
    if (is_empty(plot_list <- circle@plot_list)) {
        return(ggplotGrob(base))
    }

    # we remove the plot without actual plot area
    keep <- vapply(plot_list, function(plot) {
        !is.null(plot@plot)
    }, logical(1L), USE.NAMES = FALSE)
    plot_list <- .subset(plot_list, keep)
    if (is_empty(plot_list)) return(ggplotGrob(base)) # styler: off

    # we reorder the plots based on the `order` slot
    plot_order <- vapply(plot_list, function(plot) {
        .subset2(plot@active, "order")
    }, integer(1L), USE.NAMES = FALSE)
    plot_list <- .subset(plot_list, make_order(plot_order))

    # plot coordinate
    if (is.null(input_radial <- circle@radial)) {
        radial <- coord_circle(theta = "x", r.axis.inside = TRUE)
    } else {
        radial <- ggproto(NULL, input_radial, theta = "x", r_axis_inside = TRUE)
    }

    sizes <- vapply(plot_list, function(plot) {
        # for circular layout, we only support relative size
        if (is.na(size <- as.numeric(plot@size))) {
            size <- 1
        }
        size
    }, numeric(1L), USE.NAMES = FALSE)

    # For each plot track, relative to the total radius (1):
    # 1. total radius: 1
    # 2. total radius for the plot area (for each plot track): 1 - inner_radius
    if (inherits(radial, "CoordCircle")) {
        inner_radius <- radial$inner_radius[1L] / 0.5
        outer_radius <- radial$inner_radius[2L] / 0.5
    } else {
        # For `CoordRadial`
        # `0.4` is coord_radial used for scale size in ggplot2 to add extra
        # spaces for axis labels
        # https://github.com/tidyverse/ggplot2/issues/6284
        inner_radius <- radial$inner_radius[1L] / 0.4
        outer_radius <- radial$inner_radius[2L] / 0.4
    }
    plot_track <- sizes / sum(sizes) * (outer_radius - inner_radius)

    # For each plot, the plot size is calculated by adding the space for the
    # inner radius of each track.
    N <- length(plot_list)
    index <- seq_len(N)
    direction <- circle@direction
    if (identical(direction, "outward")) {
        plot_sizes <- inner_radius + cumsum(plot_track)
    } else {
        plot_sizes <- outer_radius -
            cumsum(c(0, utils::head(plot_track, -1L)))
        # The plots are always build outward, so the order is reversed.
        index <- rev(index)
    }

    # For each plot, the inner radius is calculated as the difference between
    # the plot size and its track size.
    plot_inner <- plot_sizes - plot_track
    guides <- vector("list", N)
    plot_table <- NULL
    design <- setup_design(circle@design)
    for (i in index) {
        plot_size <- plot_sizes[[i]]
        plot <- .subset2(plot_list, i)
        craftsman <- plot@craftsman # `Craftsman` object
        plot_schemes <- inherit_schemes(plot@schemes, schemes)
        # the actual plot
        plot <- plot@plot

        # we always use `null` facet
        # we won't respect `free_facet` and `free_coord`
        plot_coord <- gguse_circle_coord(
            plot,
            coord = radial,
            # https://github.com/tidyverse/ggplot2/issues/6284
            # Use `0.5` to remove the extra spaces for axis label
            inner_radius = c(
                plot_inner[[i]] / plot_size,
                # for the outmost plot, we respect the outer radius defined by
                # the users, for others, we alway use 1 to remove any spacing
                # between two tracks
                if (i == N) outer_radius else 1
            ) * 0.5,
            layout_name = craftsman$layout_name
        )
        if (!craftsman$free_facet) {
            if (is_discrete_design(design)) {
                if (nlevels(.subset2(design, "panel")) > 1L) {
                    plot <- plot + facet_sector(
                        ggplot2::vars(.data$.panel),
                        sector_spacing = circle@sector_spacing %||% (pi / 180),
                        drop = FALSE
                    )
                } else {
                    plot <- ggmelt_facet(plot, ggplot2::facet_null())
                }
            } else {
                if (inherits(plot$facet, "FacetSector")) {
                    plot <- ggfacet_modify(plot,
                        sector_spacing = circle@sector_spacing %||% (pi / 180),
                        drop = FALSE
                    )
                } else {
                    plot <- ggmelt_facet(plot, ggplot2::facet_null())
                }
            }
        }
        plot$coordinates <- plot_coord

        # set limits and default scales
        if (!craftsman$free_limits) {
            plot <- plot + ggalign_design(
                x = design,
                xlabels = .subset(craftsman$labels, .subset2(design, "index"))
            )
        }

        # let `Craftsman` add other components
        plot <- craftsman$build_plot(plot, design = design)
        plot <- craftsman$finish_plot(
            plot,
            schemes = plot_schemes, theme = theme
        )
        plot <- plot + ggplot2::labs(x = NULL, y = NULL) +
            theme(panel.border = element_blank())
        plot <- chain_decorate(circle, plot)

        # copied from `ggplot2:::ggplot_gtable`
        data <- ggplot2::ggplot_build(plot)
        plot <- data$plot
        plot_layout <- data$layout
        data <- data$data
        plot_theme <- complete_theme(plot$theme)

        geom_grobs <- ggfun("by_layer")(
            function(l, d) l$draw_geom(d, plot_layout),
            plot$layers, data,
            "converting geom to grob"
        )
        gt <- plot_layout$render(geom_grobs, data, plot_theme, plot$labels)

        # for each inner gtable, we insert it to the panel area of the
        # outter gtable
        #
        # For bbox, `ggplot2::polar_bbox` always take (0.5, 0.5) as origin
        bbox <- ggfun("polar_bbox")(
            plot_layout$coord$arc, margin = c(0, 0, 0, 0),
            inner_radius = plot_layout$coord$inner_radius
        )
        origin <- c(
            scales::rescale(0.5, from = bbox$x),
            scales::rescale(0.5, from = bbox$y)
        )
        spacing <- calc_element("panel.spacing.r", plot_theme)

        if (is.null(plot_table)) {
            plot_table <- gt
        } else {
            # define the panel size of the inner track
            rescale_factor <- last_plot_size / plot_size

            # the spacer between two plots
            if (identical(direction, "outward")) {
                spacer <- last_spacing
            } else {
                spacer <- spacing
            }
            if (inherits(spacer, "element_blank") || is.null(spacer)) {
                spacer <- unit(0, "mm")
            }
            plot_table <- editGrob(plot_table, vp = viewport(
                width = unit(rescale_factor, "npc") - spacer,
                height = unit(rescale_factor, "npc") - spacer,
                x = origin[1L], y = origin[2L], just = just,
                default.units = "native", clip = "off"
            ))

            # add the inner track to the panel area of the outter track
            panel_loc <- find_panel(gt)
            plot_table <- gtable_add_grob(
                gt, plot_table,
                t = .subset2(panel_loc, "t"),
                l = .subset2(panel_loc, "l"),
                b = .subset2(panel_loc, "b"),
                r = .subset2(panel_loc, "r"),
                name = "inner-track"
            )
        }

        # build legends
        guides[i] <- list(plot$guides$assemble(plot_theme))

        # assign value for next loop
        just <- origin
        last_plot_size <- plot_size # the last plot panel size
        last_spacing <- spacing
    }

    # attach the guide legends
    guides <- collect_guides_list(guides, zeroGrob())
    theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines")
    theme$legend.spacing.y <- calc_element("legend.spacing.y", theme)
    theme$legend.spacing.x <- calc_element("legend.spacing.x", theme)
    theme$legend.box.spacing <- calc_element(
        "legend.box.spacing", theme
    ) %||% unit(0.2, "cm")
    legend_box <- .mapply(
        function(guides, guide_pos) assemble_guides(guides, guide_pos, theme),
        list(guides = guides, guide_pos = names(guides)),
        NULL
    )
    names(legend_box) <- names(guides)
    plot_table <- ggfun("table_add_legends")(plot_table, legend_box, theme)

    # Title
    title <- element_render(
        theme, "plot.title", .subset2(circle@titles, "title"),
        margin_y = TRUE, margin_x = TRUE
    )
    title_height <- grobHeight(title)

    # Subtitle
    subtitle <- element_render(
        theme, "plot.subtitle", .subset2(circle@titles, "subtitle"),
        margin_y = TRUE, margin_x = TRUE
    )
    subtitle_height <- grobHeight(subtitle)

    # whole plot annotation
    caption <- element_render(
        theme, "plot.caption", .subset2(circle@titles, "caption"),
        margin_y = TRUE, margin_x = TRUE
    )
    caption_height <- grobHeight(caption)

    # positioning of title and subtitle is governed by plot.title.position
    # positioning of caption is governed by plot.caption.position
    #   "panel" means align to the panel(s)
    #   "plot" means align to the entire plot (except margins and tag)
    title_pos <- arg_match0(
        theme$plot.title.position %||% "panel",
        c("panel", "plot"),
        arg_nm = "plot.title.position",
        error_call = quote(theme())
    )

    caption_pos <- arg_match0(
        theme$plot.caption.position %||% "panel",
        values = c("panel", "plot"),
        arg_nm = "plot.caption.position",
        error_call = quote(theme())
    )

    pans <- plot_table$layout[
        grepl("^panel", plot_table$layout$name), ,
        drop = FALSE
    ]
    if (title_pos == "panel") {
        title_l <- min(pans$l)
        title_r <- max(pans$r)
    } else {
        title_l <- 1
        title_r <- ncol(plot_table)
    }
    if (caption_pos == "panel") {
        caption_l <- min(pans$l)
        caption_r <- max(pans$r)
    } else {
        caption_l <- 1
        caption_r <- ncol(plot_table)
    }

    plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0)
    plot_table <- gtable_add_grob(plot_table, subtitle,
        name = "subtitle",
        t = 1, b = 1, l = title_l, r = title_r, clip = "off"
    )

    plot_table <- gtable_add_rows(plot_table, title_height, pos = 0)
    plot_table <- gtable_add_grob(plot_table, title,
        name = "title",
        t = 1, b = 1, l = title_l, r = title_r, clip = "off"
    )

    plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1)
    plot_table <- gtable_add_grob(plot_table, caption,
        name = "caption",
        t = -1, b = -1, l = caption_l, r = caption_r, clip = "off"
    )
    plot_table <- ggfun("table_add_tag")(plot_table, NULL, theme)

    # Margins
    plot_margin <- calc_element("plot.margin", theme) %||% margin()
    plot_table <- gtable_add_padding(plot_table, plot_margin)

    if (inherits(theme$plot.background, "element")) {
        plot_table <- gtable_add_grob(plot_table,
            element_render(theme, "plot.background"),
            t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf
        )
        plot_table$layout <- plot_table$layout[
            c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),
        ]
        plot_table$grobs <- plot_table$grobs[
            c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))
        ]
    }

    # add alt-text as attribute
    # attr(plot_table, "alt-label") <- plot$labels$alt
    strip_pos <- find_strip_pos(plot_table)

    # always add strips columns and/or rows
    plot_table <- add_strips(plot_table, strip_pos)
    setup_patch_titles(plot_table, patch_titles = list(
        top = NULL, left = NULL, bottom = NULL, right = NULL
    ), theme = theme)
}

#' 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
#' @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")
}

#' 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
#' @aliases fortify_matrix.list
#' @export
fortify_matrix.list_upset <- function(data, mode = "distinct", ...,
                                      data_arg = NULL, 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)
    if (length(data) == 0L) {
        cli::cli_abort(
            "No valid data: All input lists are either empty or contain only missing values.",
            call = call
        )
    }

    # 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
    )
}

#' Add a plot to annotate observations
#'
#' @inheritParams cross_none
#' @inheritParams ggmark
#'
#' @section ggplot2 Specification:
#' The `cross_mark` function initializes a `ggplot` object. The underlying data
#' contains following columns:
#'
#'  - `.panel`: the panel for the aligned axis. It means `x-axis` for vertical
#'    stack layout (including top and bottom annotation), `y-axis` for
#'    horizontal stack layout (including left and right annotation).
#'
#'  - `.names` ([`vec_names()`][vctrs::vec_names]) and `.index`
#'    ([`vec_size()`][vctrs::vec_size()]/[`NROW()`]): a character names (only
#'    applicable when names exists) and an integer of index of the original
#'    data.
#'
#'  - `.hand`: A factor with levels `c("left", "right")` for horizontal stack
#'    layouts, or `c("top", "bottom")` for vertical stack layouts, indicating
#'    the position of the linked observations.
#'
#' You can use [`scheme_data()`] to modify the internal data if needed.
#'
#' @export
cross_mark <- function(mark, data = waiver(), ...,
                       obs_size = 1, inherit_index = NULL, inherit_panel = NULL,
                       inherit_nobs = NULL,
                       size = NULL, active = NULL) {
    if (!inherits(mark, "ggalign_mark_draw")) {
        cli_abort("{.arg mark} must be a {.fn mark_draw} object")
    }
    assert_obs_size(obs_size)
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    cross(CrossMark,
        data = data, data_params = list2(...),
        mark = mark, obs_size = obs_size,
        plot = ggplot(), size = size,
        schemes = default_schemes(th = theme_panel_border()),
        active = active,
        inherit_nobs = inherit_nobs,
        inherit_panel = inherit_panel,
        inherit_index = inherit_index
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @include craft-cross-.R
CrossMark <- ggproto("CrossMark", CraftCross,
    interact_layout = function(self, layout) {
        if (!self$in_linear) { # only used for linear coordinate
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s",
                    object_name(self), layout_name
                ),
                i = sprintf(
                    "%s can only be used in linear layout",
                    object_name(self)
                )
            ))
        }
        ggproto_parent(CraftCross, self)$interact_layout(layout)
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (is.null(.subset2(previous_design, "nobs"))) {
            cli_abort(
                sprintf(
                    "layout {.field nobs} for %s before %s is not initialized ",
                    self$layout_name, object_name(self)
                )
            )
        }
        if (is.null(.subset2(design, "nobs"))) {
            cli_abort(
                sprintf(
                    "layout {.field nobs} for %s after %s is not initialized ",
                    self$layout_name, object_name(self)
                )
            )
        }
        direction <- self$direction

        # parse links --------------------------------------------
        mark <- self$mark
        design1 <- previous_design
        design2 <- design
        full_data1 <- split(
            seq_len(.subset2(design1, "nobs")),
            .subset2(design1, "panel")
        )
        full_data2 <- split(
            seq_len(.subset2(design2, "nobs")),
            .subset2(design2, "panel")
        )
        link_index <- make_links_data(
            .subset2(mark, "links"),
            design1 = design1, design2 = design2,
            labels1 = self$labels0, labels2 = self$labels
        )
        if (vec_duplicate_any(nms <- names(link_index))) { # nolint
            cli_abort(
                c(
                    "panel names must be unique in {.arg mark}",
                    i = "duplicated names: {.val {nms[vec_duplicate_detect(nms)]}}"
                ),
                call = self$call
            )
        }
        data_index <- lapply(link_index, function(link) {
            if (is.null(link)) {
                return(NULL)
            }
            hand1 <- .subset2(link, "hand1")
            hand2 <- .subset2(link, "hand2")
            list(
                hand1 = .subset2(design1, "index")[hand1],
                hand2 = .subset2(design2, "index")[hand2]
            )
        })

        # prepare data for the plot
        plot_data <- lapply(data_index, function(index) {
            if (is.null(index)) {
                return(NULL)
            }
            hand1 <- .subset2(index, "hand1")
            hand2 <- .subset2(index, "hand2")
            hand <- switch_direction(
                direction,
                c("left", "right"),
                c("top", "bottom")
            )
            data_frame0(
                .hand = vec_rep_each(hand, c(length(hand1), length(hand2))),
                .names = vec_c(self$labels0[hand1], self$labels[hand2]),
                .index = vec_c(hand1, hand2)
            )
        })
        plot_data <- vec_rbind(!!!plot_data, .names_to = ".panel")
        plot_data$.panel <- factor(plot_data$.panel, names(data_index))
        plot_data$.hand <- factor(plot_data$.hand, switch_direction(
            direction, c("left", "right"), c("bottom", "top")
        ))

        # prepare data for the plot ------------------------------
        plot <- gguse_data(plot, plot_data)

        # set up facets
        if (nlevels(plot_data$.panel) > 1L) {
            if (inherits(plot$facet, "FacetGrid")) {
                facet <- switch_direction(
                    direction,
                    ggplot2::facet_grid(
                        rows = ggplot2::vars(.data$.panel),
                        scales = "free_y", space = "free",
                        drop = FALSE, as.table = FALSE
                    ),
                    ggplot2::facet_grid(
                        cols = ggplot2::vars(.data$.panel),
                        scales = "free_x", space = "free",
                        drop = FALSE, as.table = FALSE
                    )
                )
            } else {
                facet <- switch_direction(
                    direction,
                    ggplot2::facet_wrap(
                        facets = ggplot2::vars(.data$.panel),
                        ncol = 1L, as.table = FALSE
                    ),
                    ggplot2::facet_wrap(
                        facets = ggplot2::vars(.data$.panel),
                        nrow = 1L, as.table = FALSE
                    )
                )
            }
        } else {
            facet <- facet_stack(direction, object_name(self))
        }
        # `free_row` and `free_column` have nothing with `facet_stack`
        # it's safe to use it directly
        plot <- ggmelt_facet(plot, facet, free_row = TRUE, free_column = TRUE)
        plot$ggalign_link_data <- list(
            full_data1 = full_data1,
            full_data2 = full_data2,
            link_index = link_index,
            data_index = data_index,
            direction = direction,
            draw = .subset2(mark, "draw"),
            obs_size = self$obs_size
        )
        add_class(plot, "ggalign_mark_plot", "patch_ggplot")
    },
    finish_plot = function(self, plot, schemes, theme) {
        plot <- plot_add_schemes(plot, schemes)

        # save spacing for usage
        spacing <- calc_element(
            switch_direction(
                self$direction,
                "panel.spacing.y",
                "panel.spacing.x"
            ),
            theme
        ) %||% unit(0, "mm")

        # save spacing for usage
        plot$ggalign_link_data$spacing1 <-
            plot$ggalign_link_data$spacing2 <- spacing

        plot + theme_recycle()
    },
    summary = function(self, plot) {
        header <- ggproto_parent(CraftCross, self)$summary(plot)
        c(header, "  Add plot to annotate observations")
    }
)

mark_use_facet <- function(plot, facet) {

}

#' @importFrom ggplot2 ggproto
#' @export
alignpatch.alignpatches <- function(x) {
    ggproto(NULL, PatchAlignpatches, plot = x)
}

#' @noRd
PatchAlignpatches <- ggproto("PatchAlignpatches", Patch,
    set_guides = function(self, guides) guides,
    #' @importFrom gtable gtable gtable_add_grob
    #' @importFrom grid unit
    #' @importFrom ggplot2 wrap_dims calc_element zeroGrob theme_get
    #' @importFrom S7 prop
    patch_gtable = function(self, theme = theme_get(), guides = NULL,
                            top_level = FALSE, plot = self$plot) {
        patches <- lapply(prop(plot, "plots"), alignpatch)
        layout <- prop(plot, "layout")

        # get the design areas and dims ------------------
        panel_widths <- .subset2(layout, "widths")
        panel_heights <- .subset2(layout, "heights")
        if (is.null(area <- .subset2(layout, "area"))) {
            if (is.null(layout$ncol) && length(panel_widths) > 1L) {
                layout$ncol <- length(panel_widths)
            }
            if (is.null(layout$nrow) && length(panel_heights) > 1L) {
                layout$nrow <- length(panel_heights)
            }
            dims <- wrap_dims(
                length(patches),
                .subset2(layout, "nrow"),
                .subset2(layout, "ncol")
            )
            area <- create_area(
                dims[2L], dims[1L],
                .subset2(layout, "byrow")
            )
        } else {
            dims <- c(max(field(area, "b")), max(field(area, "r")))
        }

        # filter `plots` based on the design areas --------------------
        if (vec_size(area) < vec_size(patches)) {
            cli_warn(
                "Too few patch areas to hold all plots. Dropping plots"
            )
            plots <- vec_slice(patches, vec_seq_along(area))
        } else {
            area <- vec_slice(area, seq_along(patches))
        }

        # remove NULL patch -----------------------------------
        keep <- !vapply(patches, is.null, logical(1L), USE.NAMES = FALSE)
        patches <- vec_slice(patches, keep)

        # if no plots, we return empty gtable -----------------
        if (is_empty(patches)) return(make_patch_table()) # styler: off
        self$patches <- patches

        # add borders to patch --------------------------------
        area <- vec_slice(area, keep)
        for (i in seq_along(patches)) {
            patches[[i]]$borders <- c(
                if (field(area, "t")[i] == 1L) "top" else NULL,
                if (field(area, "l")[i] == 1L) "left" else NULL,
                if (field(area, "b")[i] == .subset(dims, 1L)) {
                    "bottom"
                } else {
                    NULL
                },
                if (field(area, "r")[i] == .subset(dims, 2L)) {
                    "right"
                } else {
                    NULL
                }
            )
        }

        # we inherit parameters from the parent --------------------
        # by default, we won't collect any guide legends
        parent_guides <- guides
        guides <- .subset2(layout, "guides") %|w|% parent_guides

        # by default, we use ggplot2 default theme
        if (!is.null(prop(plot, "theme"))) theme <- theme + prop(plot, "theme")
        self$theme <- theme

        #######################################################
        # 1. patch_gtable: create the gtable for the patch, will set internal
        #    `gt`
        # 2. `collect_guides`, can change the internal `gt`
        # 3. set_sizes:
        #     - (To-Do) align_panel_spaces: can change the internal `gt`
        #     - align_panel_sizes, can change the internal `gt`
        #     - get_sizes, the widths and heights for the internal `gt`
        # 4. set_grobs: will call `align_border` and `split_gt`, return the
        #    final gtable
        # setup gtable list ----------------------------------
        # Let each patch to determine whether to collect guides
        collected <- lapply(patches, function(patch) patch$set_guides(guides))
        collected_guides <- vector("list", length(patches))

        # Always ensure that plots placed in a border collect their guides, if
        # any guides are to be collected in that border. This prevents overlap,
        # unless the guides will be collected by the parent layout.
        border_with_guides <- unique(unlist(collected, FALSE, FALSE))
        border_with_guides <- setdiff(border_with_guides, parent_guides)
        for (i in seq_along(patches)) {
            patch <- .subset2(patches, i)
            g <- union(
                .subset2(collected, i),
                intersect(border_with_guides, patch$borders)
            )
            patch$gt <- patch$patch_gtable(theme = theme, guides = g)
            collected_guides[i] <- list(patch$collect_guides(g))
        }

        # collect guides  ---------------------------------------
        self$collected_guides <- collect_guides_list(collected_guides)

        # prepare the output ----------------------------------
        gt <- gtable(
            unit(rep(0L, TABLE_COLS * dims[2L]), "null"),
            unit(rep(0L, TABLE_ROWS * dims[1L]), "null")
        )

        # setup sizes for each row/column -----------------------
        gt <- self$set_sizes(
            area, dims, panel_widths, panel_heights,
            patches = patches, gt = gt
        )

        # add the panel position --------------------------------
        panel_pos <- list(
            t = TOP_BORDER + 1L,
            l = LEFT_BORDER + 1L,
            b = TABLE_ROWS * dims[1L] - BOTTOM_BORDER,
            r = TABLE_COLS * dims[2L] - RIGHT_BORDER
        )

        # add guides into the final gtable ----------------------
        if (top_level) {
            gt <- self$attach_guide_list(
                guide_list = self$collected_guides,
                theme = theme,
                panel_pos = panel_pos,
                gt = gt
            )
        }

        # setup grobs -------------------------------------------
        # For z in the gtable layout
        # 0L: layout background
        # 1L: background of the plot
        # 2L: plot table
        # 3L: foreground of the panel area
        # 4L: legends
        gt <- self$set_grobs(area, patches = patches, gt = gt)

        # add panel area ---------------------------------------
        gt <- gtable_add_grob(
            gt, list(zeroGrob()),
            t = .subset2(panel_pos, "t"),
            l = .subset2(panel_pos, "l"),
            b = .subset2(panel_pos, "b"),
            r = .subset2(panel_pos, "r"),
            z = 0L,
            name = "panel-area"
        )
        gt <- gtable_add_grob(
            gt,
            # foreground
            list(element_render(theme, "panel.border", fill = NA)),
            t = .subset2(panel_pos, "t"),
            l = .subset2(panel_pos, "l"),
            b = .subset2(panel_pos, "b"),
            r = .subset2(panel_pos, "r"),
            z = 3L,
            name = "panel-foreground"
        )

        # add background -----------------------------------
        if (!top_level && inherits(theme$plot.background, "element")) {
            gt <- gtable_add_grob(gt,
                element_render(theme, "plot.background"),
                t = 1L, l = 1L, b = -1L, r = -1L,
                name = "background", z = 0L
            )
        }

        # arrange the grobs
        idx <- order(.subset2(.subset2(gt, "layout"), "z"))
        gt$layout <- vec_slice(.subset2(gt, "layout"), idx)
        gt$grobs <- .subset(.subset2(gt, "grobs"), idx)
        gt
    },
    align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                            gt = self$gt, patches = self$patches) {
        if (is.null(t) && is.null(l) && is.null(b) && is.null(r)) {
            return(gt)
        }
        gt <- Patch$align_border(t = t, l = l, b = b, r = r, gt = gt)
        self$recurse_lapply(function(patch, grob, t, l, b, r) {
            # For each plot grob, we reuse it's method to set the border
            # sizes we only set the border sizes for plot in the border
            patch$align_border(t = t, l = l, b = b, r = r, gt = grob)
        }, t = t, l = l, b = b, r = r, gt = gt, patches = patches)
    },
    collect_guides = function(self, guides, gt = self$gt) {
        collected_guides <- self$collected_guides
        # for guides not collected by the top-level alignpatches, we attach the
        # guides
        self$gt <- self$attach_guide_list(
            collected_guides[
                vec_set_difference(names(collected_guides), guides)
            ],
            gt = gt
        )
        # return guides to be collected
        .subset(collected_guides, guides)
    },
    #' @importFrom grid is.unit unit
    set_sizes = function(self, area, dims,
                         panel_widths, panel_heights,
                         patches, gt = self$gt) {
        panel_widths <- rep(panel_widths, length.out = dims[2L])
        panel_heights <- rep(panel_heights, length.out = dims[1L])
        if (!is.unit(panel_widths)) panel_widths <- unit(panel_widths, "null")
        if (!is.unit(panel_heights)) {
            panel_heights <- unit(panel_heights, "null")
        }

        # For gtable with fixed aspect ratio -------------
        # if it cannot be fixed and aligned, the strip, axis and labs will be
        # attached into the panel
        # the plot to be fixed must in only one square of the area
        need_fix <- field(area, "l") == field(area, "r") &
            field(area, "t") == field(area, "b") &
            vapply(
                patches,
                function(patch) patch$respect(),
                logical(1L),
                USE.NAMES = FALSE
            )

        # here we respect the aspect ratio when necessary -----
        # if the width or height is NA, we will guess the panel widths or
        # heights based on the fixed aspect ratio
        guess_widths <- which(is.na(as.numeric(panel_widths)))
        guess_heights <- which(is.na(as.numeric(panel_heights)))
        cols <- field(area, "l")
        rows <- field(area, "t")
        patch_index <- order(
            # we first set the widths for the fixed plot with heights set by
            # user
            cols %in% guess_widths & !rows %in% guess_heights,
            # we then set the heights for the fixed plot with widths set by user
            !cols %in% guess_widths & rows %in% guess_heights,
            # we set widths and heights for remaning plots
            # based on the number of plots in each row/column in the descending
            # order
            c(table(rows[need_fix]))[as.character(rows)],
            c(table(cols[need_fix]))[as.character(cols)],
            decreasing = TRUE
        )
        respect_dims <- vector("list", length(patches))

        # For plot cannot be fixed, we always attach strips, axes and labels
        # into the panel area
        for (i in patch_index) {
            row <- .subset(rows, i)
            col <- .subset(cols, i)
            # we always build a standard gtable layout from the gtable
            panel_sizes <- .subset2(patches, i)$align_panel_sizes(
                panel_width = panel_widths[col],
                panel_height = panel_heights[row]
            )
            panel_widths[col] <- .subset2(panel_sizes, "width")
            panel_heights[row] <- .subset2(panel_sizes, "height")
            if (.subset2(panel_sizes, "respect")) {
                respect_dims[[i]] <- matrix(c(
                    (row - 1L) * TABLE_ROWS + TOP_BORDER + 1L,
                    (col - 1L) * TABLE_COLS + LEFT_BORDER + 1L
                ), nrow = 1L)
            }
        }
        if (!is.null(respect_dims <- do.call(base::rbind, respect_dims))) {
            respect <- matrix(
                0L, TABLE_ROWS * dims[1L],
                TABLE_COLS * dims[2L]
            )
            respect[respect_dims] <- 1L
            gt$respect <- respect
        }

        # we set the widths/heights with no fixed plots to be 1 null
        if (any(guess_widths <- is.na(as.numeric(panel_widths)))) {
            panel_widths[guess_widths] <- unit(1L, "null")
        }
        if (any(guess_heights <- is.na(as.numeric(panel_heights)))) {
            panel_heights[guess_heights] <- unit(1L, "null")
        }

        # setup sizes for non-panel rows/columns --------------
        sizes <- table_sizes(
            lapply(patches, function(patch) patch$get_sizes()),
            area, dims[2L], dims[1L]
        )
        widths <- .subset2(sizes, "widths")
        heights <- .subset2(sizes, "heights")

        # restore the panel sizes ----------------------------
        width_ind <- seq(LEFT_BORDER + 1L,
            by = TABLE_COLS, length.out = dims[2L]
        )
        height_ind <- seq(TOP_BORDER + 1L,
            by = TABLE_ROWS, length.out = dims[1L]
        )
        widths[width_ind] <- panel_widths
        heights[height_ind] <- panel_heights

        # setup the widths and heights -----------------------
        gt$widths <- widths
        gt$heights <- heights
        gt
    },

    #' @importFrom gtable gtable_add_grob
    set_grobs = function(self, area, patches, gt = self$gt) {
        widths <- .subset2(gt, "widths")
        heights <- .subset2(gt, "heights")
        for (i in seq_along(patches)) {
            loc <- vec_slice(area, i)
            # We must align the borders for the gtable grob with the
            # final plot area sizes
            l <- (field(loc, "l") - 1L) * TABLE_COLS + 1L
            l_widths <- widths[seq(l, l + LEFT_BORDER - 1L)]
            r <- field(loc, "r") * TABLE_COLS
            r_widths <- widths[seq(r - RIGHT_BORDER + 1L, r)]
            t <- (field(loc, "t") - 1L) * TABLE_ROWS + 1L
            t_heights <- heights[seq(t, t + TOP_BORDER - 1L)]
            b <- field(loc, "b") * TABLE_ROWS
            b_heights <- heights[seq(b - BOTTOM_BORDER + 1L, b)]
            patch <- .subset2(patches, i)

            grobs <- patch$split_gt(patch$align_border(
                t = t_heights, l = l_widths,
                b = b_heights, r = r_widths
            ))

            # then we add the plot ---------------------------------
            gt <- patch$add_plot(
                gt, .subset2(grobs, "plot"), t, l, b, r,
                name = paste("plot", i, sep = "-")
            )

            # add background grob ----------------------------------
            if (!is.null(bg <- .subset2(grobs, "bg"))) {
                # we always add background in the beginning --------
                gt <- patch$add_background(
                    gt, bg, t, l, b, r,
                    name = paste("plot", i, "background", sep = "-")
                )
            }

            # remove the grob from the patch, we wont' use it anymore
            patch$gt <- NULL
        }
        gt
    },
    attach_guide_list = function(self, guide_list, theme = self$theme,
                                 panel_pos = find_panel(gt),
                                 gt = self$gt) {
        if (length(guide_list)) {
            # https://github.com/tidyverse/ggplot2/blob/57ba97fa04dadc6fd73db1904e39a09d57a4fcbe/R/guides-.R#L512
            theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines")
            theme$legend.spacing.y <- calc_element("legend.spacing.y", theme)
            theme$legend.spacing.x <- calc_element("legend.spacing.x", theme)
            theme$legend.box.spacing <- calc_element(
                "legend.box.spacing", theme
            ) %||% unit(0.2, "cm")
            for (guide_pos in names(guide_list)) {
                gt <- self$attach_guides(
                    guide_pos = guide_pos,
                    guides = .subset2(guide_list, guide_pos),
                    theme = theme, panel_pos = panel_pos,
                    clip = "off", z = 4L, gt = gt
                )
            }
        }
        gt
    },
    #' @importFrom gtable gtable_width gtable_height
    #' @importFrom grid unit.c grobWidth grobHeight
    #' @importFrom ggplot2 find_panel zeroGrob
    attach_guides = function(self, guide_pos, guides, theme,
                             panel_pos = find_panel(gt), ...,
                             gt = self$gt) {
        guide_box <- assemble_guides(guides, guide_pos, theme = theme)
        name <- sprintf("guide-box-collected-%s", guide_pos)
        if (guide_pos == "inside") {
            gt <- gtable_add_grob(
                x = gt,
                grobs = guide_box,
                t = panel_pos$t,
                l = panel_pos$l,
                b = panel_pos$b,
                r = panel_pos$r,
                name = name,
                ...
            )
            return(gt)
        }
        spacing <- .subset2(theme, "legend.box.spacing")
        if (guide_pos == "left") {
            if (is.gtable(guide_box)) {
                legend_width <- gtable_width(guide_box)
                widths <- unit.c(spacing, legend_width)
            } else {
                legend_width <- grobWidth(guide_box)
                widths <- unit(c(0, 0), "mm")
            }
            gt <- gtable_add_grob(
                x = gt,
                grobs = guide_box,
                t = panel_pos$t,
                l = panel_pos$l - 6L,
                b = panel_pos$b,
                name = name,
                ...
            )
            gt$widths[.subset2(panel_pos, "l") - 5:6] <- widths
        } else if (guide_pos == "right") {
            if (is.gtable(guide_box)) {
                legend_width <- gtable_width(guide_box)
                widths <- unit.c(spacing, legend_width)
            } else {
                legend_width <- grobWidth(guide_box)
                widths <- unit(c(0, 0), "mm")
            }
            gt <- gtable_add_grob(
                x = gt,
                grobs = guide_box,
                t = panel_pos$t,
                l = panel_pos$r + 6L,
                b = panel_pos$b,
                name = name,
                ...
            )
            gt$widths[.subset2(panel_pos, "r") + 5:6] <- widths
        } else if (guide_pos == "bottom") {
            location <- .subset2(theme, "legend.location") %||% "panel"
            place <- switch(location,
                panel = panel_pos,
                list(l = 1L, r = ncol(gt))
            )
            if (is.gtable(guide_box)) {
                legend_height <- gtable_height(guide_box)
                heights <- unit.c(spacing, legend_height)
            } else {
                legend_height <- grobHeight(guide_box)
                heights <- unit(c(0, 0), "mm")
            }
            gt <- gtable_add_grob(
                x = gt,
                grobs = guide_box,
                t = panel_pos$b + 6L,
                l = place$l,
                r = place$r,
                name = name,
                ...
            )
            gt$heights[.subset2(panel_pos, "b") + 5:6] <- heights
        } else if (guide_pos == "top") {
            location <- .subset2(theme, "legend.location") %||% "panel"
            place <- switch(location,
                panel = panel_pos,
                list(l = 1L, r = ncol(gt))
            )
            if (is.gtable(guide_box)) {
                legend_height <- gtable_height(guide_box)
                heights <- unit.c(spacing, legend_height)
            } else {
                legend_height <- grobHeight(guide_box)
                heights <- unit(c(0, 0), "mm")
            }
            gt <- gtable_add_grob(
                x = gt,
                grobs = guide_box,
                t = panel_pos$t - 6L,
                l = place$l,
                r = place$r,
                name = name,
                ...
            )
            gt$heights[.subset2(panel_pos, "t") - 5:6] <- heights
        }
        gt
    },

    #' @importFrom rlang is_empty
    free_border = function(self, borders, gt = self$gt,
                           patches = self$patches) {
        gt <- self$recurse_lapply(
            function(patch, grob, t, l, b, r) {
                borders <- intersect(borders, c(t, l, b, r))
                if (is_empty(borders)) return(grob) # styler: off
                patch$free_border(borders = borders, gt = grob)
            },
            t = "top", l = "left", b = "bottom", r = "right",
            gt = gt, patches = patches
        )
        # for the collected guides, we should also liberate them
        guide_index <- sprintf("guide-box-collected-%s", borders) %in%
            .subset2(.subset2(gt, "layout"), "name")
        if (any(guide_index)) {
            gt <- PatchGgplot$free_border(
                borders = borders[guide_index], gt = gt
            )
        }
        gt
    },
    align_free_border = function(self, borders,
                                 t = NULL, l = NULL, b = NULL, r = NULL,
                                 gt = self$gt, patches = self$patches) {
        gt <- self$recurse_lapply(
            function(patch, grob, t, l, b, r) {
                patch$align_free_border(
                    borders = borders,
                    t = t, l = l, b = b, r = r, gt = grob
                )
            },
            t = t, l = l, b = b, r = r,
            gt = gt, patches = patches
        )
        PatchGgplot$align_free_border(
            borders = borders,
            t = t, l = l, b = b, r = r, gt = gt
        )
    },

    #' @importFrom rlang is_empty
    free_lab = function(self, labs, gt = self$gt, patches = self$patches) {
        self$recurse_lapply(
            function(patch, grob, t, l, b, r) {
                labs <- intersect(labs, c(t, l, b, r))
                if (is_empty(labs)) return(grob) # styler: off
                patch$free_lab(labs = labs, gt = grob)
            },
            t = "top", l = "left", b = "bottom", r = "right",
            gt = gt, patches = patches
        )
    },
    # we apply function in each plot gtable in `gt`.
    #' @importFrom rlang is_empty
    recurse_lapply = function(self, .fn, t, l, b, r,
                              gt = self$gt, patches = self$patches) {
        # if no plot provided, we'll do nothing
        if (is_empty(patches)) return(gt) # styler: off
        patch_index <- seq_along(patches)
        grobs <- .subset2(gt, "grobs")
        layout_index <- match(
            paste0("plot-", patch_index),
            .subset2(.subset2(gt, "layout"), "name")
        )
        # For each grob, we reuse the method from the patch
        gt$grobs[layout_index] <- .mapply(function(layout_idx, patch_idx) {
            patch <- .subset2(patches, patch_idx)
            borders <- .subset2(patch, "borders")
            .fn(
                patch = patch,
                grob = .subset2(grobs, layout_idx),
                t = if (any(borders == "top")) t else NULL,
                l = if (any(borders == "left")) l else NULL,
                b = if (any(borders == "bottom")) b else NULL,
                r = if (any(borders == "right")) r else NULL
            )
        }, list(layout_idx = layout_index, patch_idx = patch_index), NULL)
        gt
    }
)

#' @importFrom grid convertHeight convertWidth unit
table_sizes <- function(sizes, area, ncol, nrow) {
    # `null` unit of the panel area will be converted into 0
    # we'll set the panel width and height afterward
    widths <- lapply(sizes, function(size) {
        convertWidth(.subset2(size, "widths"), "mm", valueOnly = TRUE)
    })
    widths <- vapply(seq_len(ncol * TABLE_COLS), function(i) {
        area_col <- (i - 1L) %/% TABLE_COLS + 1L
        col_loc <- i %% TABLE_COLS
        if (col_loc == 0L) col_loc <- TABLE_COLS
        area_side <- if (col_loc <= LEFT_BORDER + 1L) "l" else "r"
        idx <- field(area, area_side) == area_col
        if (any(idx)) {
            max(
                vapply(.subset(widths, idx), .subset, numeric(1L), col_loc),
                0L
            )
        } else {
            0L
        }
    }, numeric(1L), USE.NAMES = FALSE)
    heights <- lapply(sizes, function(size) {
        convertHeight(.subset2(size, "heights"), "mm", valueOnly = TRUE)
    })
    heights <- vapply(seq_len(nrow * TABLE_ROWS), function(i) {
        area_row <- recycle_each(i, TABLE_ROWS)
        row_loc <- recycle_whole(i, TABLE_ROWS)
        area_side <- if (row_loc <= TOP_BORDER + 1L) "t" else "b"
        idx <- field(area, area_side) == area_row
        if (any(idx)) {
            max(
                vapply(
                    .subset(heights, idx), .subset, numeric(1L),
                    row_loc,
                    USE.NAMES = FALSE
                ),
                0L
            )
        } else {
            0L
        }
    }, numeric(1L), USE.NAMES = FALSE)
    list(widths = unit(widths, "mm"), heights = unit(heights, "mm"))
}

#' Add patch titles to plot borders
#'
#' This function extends ggplot2's title functionality, allowing you to add
#' titles to each border of the plot: top, left, bottom, and right.
#'
#' @details
#'
#' The appearance and alignment of these patch titles can be customized using
#' [theme()][ggplot2::theme]:
#' - `plot.patch_title`/`plot.patch_title.*`: Controls the text appearance of
#'   patch titles. By default, `plot.patch_title` inherit from `plot.title`, and
#'   settings for each border will inherit from `plot.patch_title`, with the
#'   exception of the `angle` property, which is not inherited.
#' - `plot.patch_title.position`/`plot.patch_title.position.*`: Determines the
#'   alignment of the patch titles. By default, `plot.patch_title.position`
#'   inherit from `plot.title.position`, and settings for each border will
#'   inherit from `plot.patch_title`. The value `"panel"` aligns the patch
#'   titles with the plot panels. Setting this to `"plot"` aligns the patch
#'   title with the entire plot (excluding margins and plot tags).
#'
#' @param top,left,bottom,right A string specifying the title to be added to the
#' top, left, bottom, and right border of the plot.
#' @return A [`labels`][ggplot2::labs] object to be added to ggplot.
#' @examples
#' ggplot(mtcars) +
#'     geom_point(aes(mpg, disp)) +
#'     patch_titles(
#'         top = "I'm top patch title",
#'         left = "I'm left patch title",
#'         bottom = "I'm bottom patch title",
#'         right = "I'm right patch title"
#'     )
#' @export
#' @importFrom ggplot2 waiver
patch_titles <- function(top = waiver(), left = waiver(), bottom = waiver(),
                         right = waiver()) {
    structure(
        list(top = top, left = left, bottom = bottom, right = right),
        class = "ggalign_patch_labels"
    )
}

#' @importFrom ggplot2 find_panel calc_element zeroGrob element_grob merge_element
#' @importFrom rlang arg_match0
#' @importFrom grid grobName
setup_patch_titles <- function(table, patch_titles, theme) {
    # complete_theme() will ensure `plot_title` exists
    old_text <- calc_element("plot.title", theme)
    # always justification by center for patch title
    old_text$hjust <- 0.5
    if (is.null(text <- .subset2(theme, "plot.patch_title"))) {
        text <- old_text
    } else if (inherits(text, "element_text")) {
        text <- merge_element(text, old_text)
    } else {
        cli_abort(paste(
            "Theme element {.var plot.patch_title} must be a",
            "{.cls element_text}."
        ), call = quote(theme()))
    }
    # inherit from plot.title.position, default use "panel"
    position <- .subset2(theme, "plot.patch_title.position") %||%
        .subset2(theme, "plot.title.position") %||% "panel"
    for (border in .TLBR) {
        panel_pos <- find_panel(table)
        patch_title <- .subset2(patch_titles, border)
        name <- paste("plot.patch_title", border, sep = ".")
        if (is.null(patch_title)) {
            title <- zeroGrob()
        } else {
            # set the default angle
            text$angle <- switch(border,
                top = 0L,
                left = 90L,
                bottom = 0L,
                right = -90L
            )
            # we merge the element with `plot.patch_title`
            if (is.null(el <- .subset2(theme, name))) {
                el <- text
            } else if (inherits(el, "element_text")) {
                el <- merge_element(el, text)
            } else {
                cli_abort(paste(
                    "Theme element {.var {name}} must have",
                    "class {.cls element_text}."
                ), call = quote(theme()))
            }
            # render the patch title grob
            title <- element_grob(el, patch_title,
                margin_y = TRUE, margin_x = TRUE
            )
            title$name <- grobName(title, name)
        }

        name <- paste("plot.patch_title.position", border, sep = ".")
        pos <- arg_match0(
            .subset2(theme, name) %||% position,
            c("panel", "plot"),
            arg_nm = name,
            error_call = quote(theme())
        )
        if (border == "top") {
            height <- grobHeight(title)
            if (pos == "panel") {
                l <- panel_pos$l
                r <- panel_pos$r
            } else {
                l <- 1L
                r <- ncol(table)
            }
            h <- .subset2(panel_pos, "t") - 4L # above original xlab
            table <- gtable_add_rows(table, height, pos = h)
            table <- gtable_add_grob(table, title,
                name = "patch-title-top",
                t = h + 1L, b = h + 1L, l = l, r = r,
                clip = "off"
            )
        } else if (border == "left") {
            width <- grobWidth(title)
            if (pos == "panel") {
                t <- panel_pos$t
                b <- panel_pos$b
            } else {
                t <- 1L
                b <- nrow(table)
            }
            v <- .subset2(panel_pos, "l") - 4L # left of the ylab
            table <- gtable_add_cols(table, width, pos = v)
            table <- gtable_add_grob(table, title,
                name = "patch-title-left",
                t = t, b = b, l = v + 1L, r = v + 1L,
                clip = "off"
            )
        } else if (border == "bottom") {
            height <- grobHeight(title)
            if (pos == "panel") {
                l <- panel_pos$l
                r <- panel_pos$r
            } else {
                l <- 1L
                r <- ncol(table)
            }
            h <- .subset2(panel_pos, "b") + 3L # below original xlab
            table <- gtable_add_rows(table, height, pos = h)
            table <- gtable_add_grob(table, title,
                name = "patch-title-bottom",
                t = h + 1L, b = h + 1L, l = l, r = r,
                clip = "off"
            )
        } else if (border == "right") {
            width <- grobWidth(title)
            if (pos == "panel") {
                t <- panel_pos$t
                b <- panel_pos$b
            } else {
                t <- 1L
                b <- nrow(table)
            }
            v <- .subset2(panel_pos, "r") + 3L # right of the ylab
            table <- gtable_add_cols(table, width, pos = v)
            table <- gtable_add_grob(table, title,
                name = "patch-title-right",
                t = t, b = b, l = v + 1L, r = v + 1L,
                clip = "off"
            )
        }
    }
    table
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.ggalign_patch_labels <- function(object, plot, object_name, ...) {
    plot$ggalign_patch_labels <- update_non_waive(
        plot$ggalign_patch_labels %||% list(), object
    )
    if (!inherits(plot, "patch_ggplot")) {
        plot <- add_class(plot, "patch_ggplot")
    }
    plot
}

# Exported function for ggplot2
# Usually a quick shortcuts to define something
#
#' Remove axis elements
#'
#' @param axes Which axes elements should be removed? A string containing
#' one or more of `r oxford_and(c(.tlbr, "x", "y"))`.
#' @param text If `TRUE`, will remove the axis labels.
#' @param ticks If `TRUE`, will remove the axis ticks.
#' @param title If `TRUE`, will remove the axis title.
#' @param line If `TRUE`, will remove the axis line.
#' @return A [`theme()`][ggplot2::theme] object.
#' @examples
#' p <- ggplot() +
#'     geom_point(aes(x = wt, y = qsec), data = mtcars)
#' p + theme_no_axes()
#' p + theme_no_axes("b")
#' p + theme_no_axes("l")
#' @importFrom rlang inject
#' @importFrom ggplot2 theme element_blank
#' @export
theme_no_axes <- function(axes = "xy", text = TRUE, ticks = TRUE,
                          title = TRUE, line = FALSE) {
    assert_string(axes, empty_ok = FALSE)
    if (grepl("[^tlbrxy]", axes)) {
        cli_abort(sprintf(
            "{.arg axes} can only contain the %s characters",
            oxford_and(c(.tlbr, "x", "y"))
        ))
    }
    axes <- split_position(axes)
    el <- list(text = text, ticks = ticks, title = title, line = line)
    el <- names(el)[vapply(el, isTRUE, logical(1L), USE.NAMES = FALSE)]
    el_axis <- el_pos <- NULL
    if (length(positions <- vec_set_intersect(axes, .tlbr))) {
        positions <- .subset(
            c(t = "top", l = "left", b = "bottom", r = "right"),
            positions
        )
        el_pos <- vec_expand_grid(pos = positions, el = el)
        el_pos <- paste("axis",
            .subset2(el_pos, "el"),
            if_else(.subset2(el_pos, "pos") %in% c("top", "bottom"), "x", "y"),
            .subset2(el_pos, "pos"),
            sep = "."
        )
    }
    if (length(axes <- vec_set_intersect(axes, c("x", "y")))) {
        el_axis <- vec_expand_grid(axes = axes, el = el)
        el_axis <- paste("axis",
            .subset2(el_axis, "el"), .subset2(el_axis, "axes"),
            sep = "."
        )
    }
    el <- c(el_axis, el_pos)
    el <- vec_set_names(vec_rep(list(element_blank()), length(el)), el)
    inject(theme(!!!el, validate = FALSE))
}

##########################################################################
#' Theme Polygon elements
#'
#' Draw polygon.
#'
#' @inheritParams ggplot2::element_rect
#' @inheritParams geom_rect3d
#' @inheritParams ggplot2::fill_alpha
#' @param linewidth Line size in `mm`.
#' @param linetype Line type for lines. An integer (0:8), a name (blank, solid,
#' dashed, dotted, dotdash, longdash, twodash), or a string with an even number
#' (up to eight) of hexadecimal digits which give the lengths in consecutive
#' positions in the string.
#' @seealso [`element_rect`][ggplot2::element_rect]
#' @return A `element_polygon` object
#' @export
element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL,
                            linetype = NULL, alpha = NULL, lineend = NULL,
                            linejoin = NULL, linemitre = NULL, color = NULL,
                            inherit.blank = FALSE) {
    if (!is.null(color)) colour <- color
    structure(
        list(
            fill = fill, colour = colour, alpha = alpha,
            linewidth = linewidth, linetype = linetype,
            lineend = lineend, linejoin = linejoin, linemitre = linemitre,
            inherit.blank = inherit.blank
        ),
        class = c("ggalign_element_polygon", "element_polygon", "element")
    )
}

#' @importFrom utils packageVersion
#' @importFrom grid gpar
#' @importFrom ggplot2 element_grob fill_alpha
#' @export
element_grob.ggalign_element_polygon <- function(element,
                                                 x = c(0, 0.5, 1, 0.5),
                                                 y = c(0.5, 1, 0.5, 0),
                                                 fill = NULL,
                                                 colour = NULL,
                                                 linewidth = NULL,
                                                 linetype = NULL, ...) {
    if (packageVersion("ggplot2") > "3.5.2") {
        gp <- ggfun("gg_par")(
            lwd = linewidth, col = colour, fill = fill, lty = linetype
        )
        element_gp <- ggfun("gg_par")(
            lwd = element$linewidth,
            col = element$colour,
            fill = fill_alpha(element$fill, element$alpha %||% NA),
            lty = element$linetype,
            lineend = element$lineend,
            linejoin = element$linejoin,
            linemitre = element$linemitre
        )
    } else {
        gp <- gpar(
            lwd = ggfun("len0_null")(linewidth * .pt),
            col = colour,
            fill = fill,
            lty = linetype
        )
        element_gp <- gpar(
            lwd = ggfun("len0_null")(element$linewidth * .pt),
            col = element$colour,
            fill = fill_alpha(element$fill, element$alpha %||% NA),
            lty = element$linetype,
            lineend = element$lineend,
            linejoin = element$linejoin,
            linemitre = element$linemitre
        )
    }
    grid::polygonGrob(
        x = x, y = y,
        gp = ggfun("modify_list")(element_gp, gp), ...
    )
}

#' Theme curve elements
#'
#' Draw curve.
#'
#' @inheritParams element_polygon
#' @inheritParams grid::curveGrob
#' @param arrow.fill Fill colour for arrows.
#' @return A `element_curve` object
#' @export
element_curve <- function(colour = NULL, linewidth = NULL, linetype = NULL,
                          lineend = NULL, color = NULL, curvature = NULL,
                          angle = NULL, ncp = NULL, shape = NULL,
                          arrow = NULL, arrow.fill = NULL,
                          inherit.blank = FALSE) {
    colour <- color %||% colour
    arrow.fill <- arrow.fill %||% colour
    arrow <- arrow %||% FALSE
    structure(
        list(
            colour = colour, linewidth = linewidth, linetype = linetype,
            lineend = lineend, curvature = curvature, angle = angle,
            ncp = ncp, shape = shape, arrow = arrow, arrow.fill = arrow.fill,
            inherit.blank = inherit.blank
        ),
        class = c("ggalign_element_curve", "element_curve", "element")
    )
}

#' @importFrom grid gpar gTree gList
#' @importFrom ggplot2 element_grob
#' @export
element_grob.ggalign_element_curve <- function(element, x = 0:1, y = 0:1,
                                               colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL,
                                               arrow.fill = NULL,
                                               default.units = "npc",
                                               id = NULL,
                                               id.lengths = NULL, ...) {
    arrow <- if (is.logical(element$arrow) && !element$arrow) {
        NULL
    } else {
        element$arrow
    }
    if (is.null(arrow)) {
        arrow.fill <- colour
        element$arrow.fill <- element$colour
    }
    # The gp settings can override element_gp
    gp <- gpar(
        col = colour,
        fill = arrow.fill %||% colour,
        lwd = ggfun("len0_null")(linewidth * .pt),
        lty = linetype,
        lineend = lineend
    )
    element_gp <- gpar(
        col = element$colour,
        fill = element$arrow.fill %||% element$colour,
        lwd = ggfun("len0_null")(element$linewidth * .pt),
        lty = element$linetype,
        lineend = element$lineend
    )
    gp <- ggfun("modify_list")(element_gp, gp)
    if (is.null(id)) {
        if (is.null(id.lengths)) {
            id <- vec_rep(1L, length(x))
        } else {
            id <- vec_rep_each(seq_along(id.lengths), id.lengths)
        }
    }
    index_list <- .subset2(vec_split(seq_along(x), id), "val")
    ans <- lapply(index_list, function(index) {
        grid::curveGrob(
            vec_slice(x, index),
            vec_slice(y, index),
            default.units = default.units,
            gp = gp[index],
            curvature = element$curvature,
            angle = element$angle,
            ncp = element$ncp,
            shape = element$shape,
            arrow = arrow,
            square = FALSE, squareShape = 1,
            inflect = FALSE, open = TRUE,
            ...
        )
    })
    gTree(children = inject(gList(!!!ans)))
}

##########################################################################
element_lengths <- function(.el, .fn, ...) {
    fields <- element_vec_fields(.el)
    if (is.null(fields)) 0L
    lengths(.el[fields])
}

#' Apply a function to the fields of an element object
#'
#' @description
#' For an [`element`][ggplot2::element_blank] object, some fields are
#' vectorized, while others are not. This function allows you to apply a
#' function to the vectorized fields.
#'
#' The following helper functions are available:
#'
#'  - `element_rep`: Applies [`rep()`].
#'  - `element_rep_len`: Applies [`rep_len()`].
#'  - `element_vec_recycle`: Applies [`vec_recycle()`][vctrs::vec_recycle].
#'  - `element_vec_rep`: Applies [`vec_rep()`][vctrs::vec_rep].
#'  - `element_vec_rep_each`: Applies [`vec_rep_each()`][vctrs::vec_rep_each].
#'  - `element_vec_slice`: Applies [`vec_slice()`][vctrs::vec_slice].
#'
#' @param .el An [`element`][ggplot2::element_blank] object.
#' @param .fn The function to be applied to the vectorized fields of the element
#' object.
#' @param ... Additional arguments passed on to `fn`.
#' @export
element_vec <- function(.el, .fn, ...) {
    fields <- element_vec_fields(.el)
    if (is.null(fields)) {
        return(.el)
    }
    .el[fields] <- lapply(.el[fields], function(value) {
        if (!is.null(value)) value <- .fn(value, ...)
        value
    })
    .el
}

#' @export
#' @rdname element_vec
element_rep <- function(.el, ...) element_vec(.el, rep, ...)

#' @param length.out Non-negative integer. The desired length of the output
#' vector. Other inputs will be coerced to a double vector and the first element
#' taken. Ignored if `NA` or invalid.
#' @export
#' @rdname element_vec
element_rep_len <- function(.el, length.out, ...) {
    element_vec(.el, rep_len, ..., length.out = length.out)
}

#' @inheritParams vctrs::vec_recycle
#' @export
#' @rdname element_vec
element_vec_recycle <- function(.el, size, ...) {
    element_vec(.el, vec_recycle, size = size, ...)
}

#' @inheritParams vctrs::vec_rep
#' @export
#' @rdname element_vec
element_vec_rep <- function(.el, times, ...) {
    element_vec(.el, vec_rep, times = times, ...)
}

#' @export
#' @rdname element_vec
element_vec_rep_each <- function(.el, times, ...) {
    element_vec(.el, vec_rep_each, times = times, ...)
}

#' @inheritParams vctrs::vec_slice
#' @importFrom grid is.unit
#' @export
#' @rdname element_vec
element_vec_slice <- function(.el, i, ...) {
    element_vec(.el, function(x) {
        if (is.unit(x)) x[i, ...] else vec_slice(x, i, ...)
    })
}

element_vec_fields <- function(el) UseMethod("element_vec_fields")

#' @export
element_vec_fields.ggalign_element_polygon <- function(el) {
    c(
        "fill", "colour", "linewidth", "linetype",
        "lineend", "linejoin", "linemitre", "alpha"
    )
}

#' @export
element_vec_fields.element_blank <- function(el) NULL

#' @export
element_vec_fields.element_polygon <- function(el) {
    c("fill", "colour", "linewidth", "linetype")
}

#' @export
element_vec_fields.element_point <- function(el) {
    c("colour", "shape", "size", "fill", "stroke")
}

#' @export
element_vec_fields.element_rect <- function(el) {
    c("fill", "colour", "linewidth", "linetype")
}

#' @export
element_vec_fields.element_line <- function(el) {
    c("colour", "linewidth", "linetype", "lineend")
}

#' @export
element_vec_fields.element_text <- function(el) {
    c(
        "family", "face", "colour", "size", "hjust", "vjust",
        "angle", "lineheight"
    )
}

#' @export
element_vec_fields.default <- function(el) stop_input_type(el, "an element")

######################################################
#' Remove scale expansion
#'
#' @param borders Which border should be removed? A string containing
#' one or more of `r oxford_and(c(.tlbr, "x", "y"))`.
#' @return An object which can be added to ggplot.
#' @export
no_expansion <- function(borders = "tlbr") {
    assert_string(borders, empty_ok = FALSE)
    if (grepl("[^tlbrxy]", borders)) {
        cli_abort(sprintf(
            "{.arg borders} can only contain the %s characters",
            oxford_and(c(.tlbr, "x", "y"))
        ))
    }
    borders <- .subset(list(
        t = "top", l = "left", b = "bottom", r = "right",
        x = c("left", "right"), y = c("bottom", "top")
    ), split_position(borders))
    borders <- vec_unique(unlist(borders, recursive = FALSE, use.names = FALSE))
    # expansion in x-axis
    structure(list(borders = borders), class = c("ggalign_no_expansion"))
}

#' @importFrom ggplot2 ggplot_add ggproto ggproto_parent
#' @export
ggplot_add.ggalign_no_expansion <- function(object, plot, object_name, ...) {
    borders <- .subset2(object, "borders")
    ParentLayout <- plot$layout

    # tricks to ensure remove `coord` won't remove `no_expansion()`
    plot$layout <- ggproto(NULL, ParentLayout,
        setup_panel_params = function(self) {
            ParentCoord <- self$coord
            self$coord <- ggproto(NULL, ParentCoord,
                setup_panel_params = function(self, scale_x, scale_y,
                                              params = list()) {
                    if (!is.null(scale_x)) {
                        expansion <- scale_x$expand %|w|%
                            if (packageVersion("ggplot2") > "3.5.2") {
                                ggfun("default_expansion")(
                                    scale_y,
                                    # for ggplot2 > 3.5.2, expand was passed by
                                    # params
                                    expand = params$expand[c(4, 2)]
                                )
                            } else {
                                ggfun("default_expansion")(
                                    scale_y,
                                    # for ggplot2 > 3.5.2, expand was passed by
                                    # params
                                    expand = self$expand
                                )
                            }
                        if (any(borders == "left")) {
                            expansion[1:2] <- 0
                        }
                        if (any(borders == "right")) {
                            expansion[3:4] <- 0
                        }
                        scale_x$expand <- expansion
                    }
                    if (!is.null(scale_y)) {
                        expansion <- scale_y$expand %|w|%
                            if (packageVersion("ggplot2") > "3.5.2") {
                                ggfun("default_expansion")(
                                    scale_y,
                                    # for ggplot2 > 3.5.2, expand was passed by
                                    # params
                                    expand = params$expand[c(3, 1)]
                                )
                            } else {
                                ggfun("default_expansion")(
                                    scale_y,
                                    # for ggplot2 > 3.5.2, expand was passed by
                                    # params
                                    expand = self$expand
                                )
                            }
                        if (any(borders == "bottom")) {
                            expansion[1:2] <- 0
                        }
                        if (any(borders == "top")) {
                            expansion[3:4] <- 0
                        }
                        scale_y$expand <- expansion
                    }
                    ggproto_parent(ParentCoord, self)$setup_panel_params(
                        scale_x = scale_x, scale_y = scale_y, params = params
                    )
                }
            )
            ggproto_parent(ParentLayout, self)$setup_panel_params()
        }
    )
    plot
}

#' Create an OncoPrint
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' The `ggoncoplot()` function generates `oncoPrint` visualizations that display
#' genetic alterations in a matrix format. This function is especially useful
#' for visualizing complex genomic data, such as mutations, copy number
#' variations, and other genomic alterations in cancer research.
#'
#' @details
#' `ggoncoplot()` is a wrapper around the [`ggheatmap()`] function, designed to
#' simplify the creation of `OncoPrint`-style visualizations. The function
#' automatically processes the input character matrix by splitting the encoded
#' alterations (delimited by `r oxford_or(c(";", ":", ",", "|"))`) into
#' individual genomic events and unnesting the columns for visualization.
#'
#' @param data A character matrix which encodes the alterations, you can use
#' `r oxford_or(c(";", ":", ",", "|"))` to separate multiple alterations.
#' @inheritParams heatmap_layout
#' @param map_width,map_height A named numeric value defines the width/height of
#' each alterations.
#'
#' @param reorder_row A boolean value indicating whether to reorder the rows
#' based on the frequency of alterations. You can set this to `FALSE`, then add
#' `align_order(~rowSums(!is.na(.x)), reverse = TRUE)` to achieve the same
#' result. You may also need to set `strit = FALSE` in [`align_order()`] if
#' there are already groups.
#'
#' @param reorder_column A boolean value indicating whether to reorder the
#' columns based on the characteristics of the alterations. You can set this to
#' `FALSE`, then add `align_order2(memo_order)` to achieve the same result. You
#' may also need to set `strit = FALSE` in [`align_order2()`] if there are
#' already groups.
#'
#' @param remove_duplicates A logical value indicating whether to remove
#' duplicated variants within the same cell.
#'
#' @param filling Same as [`ggheatmap()`], but only `"tile"` can be used.
#' @examples
#' # A simple example from `ComplexHeatmap`
#' mat <- read.table(textConnection(
#'     "s1,s2,s3
#' g1,snv;indel,snv,indel
#' g2,,snv;indel,snv
#' g3,snv,,indel;snv"
#' ), row.names = 1, header = TRUE, sep = ",", stringsAsFactors = FALSE)
#'
#' ggoncoplot(mat, map_width = c(snv = 0.5), map_height = c(indel = 0.9)) +
#'     guides(fill = "none") +
#'     anno_top(size = 0.5) +
#'     ggalign() +
#'     geom_bar(aes(fill = value), data = function(x) {
#'         subset(x, !is.na(value))
#'     }) +
#'     anno_right(size = 0.5) +
#'     ggalign() +
#'     geom_bar(aes(fill = value), orientation = "y", data = function(x) {
#'         subset(x, !is.na(value))
#'     }) &
#'     scale_fill_brewer(palette = "Dark2", na.translate = FALSE)
#' @inherit heatmap_layout return
#' @importFrom ggplot2 aes
#' @export
ggoncoplot <- function(data = NULL, mapping = aes(), ...,
                       map_width = NULL, map_height = NULL,
                       reorder_row = reorder_column,
                       reorder_column = TRUE,
                       remove_duplicates = FALSE,
                       width = NA, height = NA, filling = waiver(),
                       theme = NULL, active = NULL) {
    UseMethod("ggoncoplot")
}

#' @export
ggoncoplot.NULL <- function(data = NULL, mapping = aes(), ...) {
    cli_abort("{.fn ggoncoplot} only accept a valid character matrix")
}

#' @export
ggoncoplot.functon <- ggoncoplot.NULL

#' @export
ggoncoplot.formula <- ggoncoplot.functon

#' @importFrom ggplot2 aes
#' @importFrom rlang arg_match0
#' @export
#' @rdname ggoncoplot
ggoncoplot.default <- function(data = NULL, mapping = aes(), ...,
                               map_width = NULL, map_height = NULL,
                               reorder_row = reorder_column,
                               reorder_column = TRUE,
                               remove_duplicates = FALSE,
                               width = NA, height = NA, filling = waiver(),
                               theme = NULL, active = NULL) {
    # prepare the matrix
    data <- fortify_matrix(data = data, ...)
    if (!is.character(data)) {
        cli_abort("{.arg data} must be a character matrix")
    }

    assert_bool(reorder_column)
    assert_bool(reorder_row)
    assert_bool(remove_duplicates)

    # convert empty string into NA
    data <- trimws(data, whitespace = "[\\h\\v]")
    data[data == ""] <- NA_character_

    # check filling
    if (isTRUE(filling) || is.waive(filling)) {
        filling <- "tile"
    } else if (isFALSE(filling)) {
        filling <- NULL
    } else if (!is.null(filling)) {
        filling <- arg_match0(filling, c("tile", "raster"))
        if (filling == "raster") {
            cli_warn("Cannot use {.fn geom_raster} in oncoplot")
            filling <- "tile"
        }
    }

    # prepare the plot data action
    pdata <- function(data) {
        vars <- strsplit(data$value, split = "\\s*[;:,|]\\s*", perl = TRUE)
        if (remove_duplicates) vars <- lapply(vars, vec_unique)
        lvls <- ggalign_lvls_get(data)
        data <- vec_rep_each(data, list_sizes(vars))
        value <- unlist(vars, recursive = FALSE, use.names = FALSE)
        if (!is.null(lvls)) value <- factor(value, levels = lvls)
        data$value <- value
        data
    }

    # draw the oncoplot
    ans <- heatmap_layout(
        data = data, mapping = mapping,
        width = width, height = height,
        theme = theme, active = active, filling = NULL
    ) -
        # set the default `scheme_data()`
        scheme_data(data = pdata)

    # prepare counts matrix to reorder the column or rows
    if (reorder_column || reorder_row) {
        counts <- !is.na(data)
        storage.mode(counts) <- "integer"
        weights <- rowSums(counts)
        row_index <- order(weights, decreasing = TRUE)
    }

    if (reorder_row) {
        ans <- ans + anno_left() + align_order(row_index, reverse = TRUE)
    }
    if (reorder_column) {
        column_scores <- .memo_order(vec_slice(counts, row_index))
        ans <- ans +
            anno_top() +
            align_order(order(column_scores, decreasing = TRUE))
    }

    # reset the active context
    ans <- ans + quad_active()
    if (!is.null(filling)) {
        # we always make sure heatmap body has such action data
        ans <- ans + scheme_data(data = pdata)

        # set mapping for width and height
        tile_mapping <- aes(
            .data$.x, .data$.y,
            fill = .data$value,
            width = replace_na(map_width[.data$value], 1),
            height = replace_na(map_height[.data$value], 1)
        )
        if (!is.null(map_width)) {
            if (!rlang::is_named(map_width) || !is.numeric(map_width)) {
                cli_abort("{.arg map_width} must be a named numeric")
            }
        } else {
            tile_mapping$width <- NULL
        }
        if (!is.null(map_height)) {
            if (!rlang::is_named(map_height) || !is.numeric(map_height)) {
                cli_abort("{.arg map_height} must be a named numeric")
            }
        } else {
            tile_mapping$height <- NULL
        }
        # check if user has provided and manual fill mapping
        if (!is.null(.subset2(ans@plot$mapping, "fill"))) {
            tile_mapping$fill <- NULL
        }
        ans <- ans + ggplot2::geom_tile(tile_mapping)
    }
    ans
}

#' Sort matrix for better visualization
#'
#' Helper function used to order the Oncoplot samples. Typically, you would use
#' this in combination with [`align_order2()`], e.g.,
#' `align_order2(memo_order)`.
#'
#' @param x A matrix, where `NA` values will be treated as empty.
#' @return A vector of ordering weights.
#' @export
memo_order <- function(x) {
    # For `align_order2()`, rows are considered as the observations
    # `.memo_order` will regard the columns as the observations
    .memo_order(t(x), counts = FALSE, reorder_rows = TRUE)
}

# Following code is modified from
# <https://gist.github.com/armish/564a65ab874a770e2c26>
.memo_order <- function(x, counts = TRUE, reorder_rows = FALSE) {
    if (!isTRUE(counts)) {
        x <- !is.na(x)
        storage.mode(x) <- "integer"
    }
    if (isTRUE(reorder_rows)) {
        row_index <- order(rowSums(x), decreasing = TRUE)
        x <- vec_slice(x, row_index)
    }
    structure(
        apply(x, 2L, function(x) {
            score <- 2^(length(x) - seq_along(x))
            score[x == 0L] <- 0
            sum(score)
        }),
        class = "memo_weights"
    )
}

#' @export
#' @rdname order2
order2.memo_weights <- function(x) order(x, decreasing = TRUE)

# We are removing the patchwork dependency by defining our own version of
# patchwork::area, as some desired features won't be merged (see this
# https://github.com/thomasp85/patchwork/issues/379). Therefore, ggalign will
# retain `alignpatch-*` scripts.

#' Define the plotting areas in `align_plots`
#'
#' @inherit patchwork::area
#' @details
#' The grid that the areas are specified in reference to enumerate rows from top
#' to bottom, and coloumns from left to right. This means that `t` and `l`
#' should always be less or equal to `b` and `r` respectively. Instead of
#' specifying area placement with a combination of `area()` calls, it is
#' possible to instead pass in a single string
#'
#' ```
#' areas <- c(area(1, 1, 2, 1),
#'            area(2, 3, 3, 3))
#' ```
#'
#' is equivalent to
#'
#' ```
#' areas < -"A##
#'           A#B
#'           ##B"
#' ```
#' @return A `ggalign_area` object.
#' @examples
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) +
#'     geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) +
#'     geom_bar(aes(gear)) +
#'     facet_wrap(~cyl)
#'
#' layout <- c(
#'     area(1, 1),
#'     area(1, 3, 3),
#'     area(3, 1, 3, 2)
#' )
#'
#' # Show the layout to make sure it looks as it should
#' plot(layout)
#'
#' # Apply it to a alignpatches
#' align_plots(p1, p2, p3, design = layout)
#' @export
area <- function(t, l, b = t, r = l) {
    if (missing(t) || missing(l)) {
        one_area <- list(
            t = integer(0L),
            l = integer(0L),
            b = integer(0L),
            r = integer(0L)
        )
    } else {
        one_area <- df_list(
            t = vec_cast(t, integer()),
            l = vec_cast(l, integer()),
            b = vec_cast(b, integer()),
            r = vec_cast(r, integer())
        )
        if (any(.subset2(one_area, "t") > .subset2(one_area, "b"))) {
            cli_abort("{.arg t} must be less than {.arg b}")
        }
        if (any(.subset2(one_area, "l") > .subset2(one_area, "r"))) {
            cli_abort("{.arg l} must be less than {.arg r}")
        }
    }
    new_areas(one_area)
}

# Define a custom S3 class `ggalign_area`, without using S7 directly
# Patchwork expects traditional S3 classes, and S7 classes are not fully
# interoperable with patchwork layouts.
S3_area <- S7::new_S3_class("ggalign_area")

new_areas <- function(x) new_rcrd(x, class = c("ggalign_area", "patch_area"))

create_area <- function(ncol, nrow, byrow) {
    mat <- matrix(seq_len(ncol * nrow),
        nrow = nrow, ncol = ncol, byrow = byrow
    )
    ind <- as.vector(mat)
    ind <- match(seq_along(ind), ind)
    area(t = row(mat)[ind], l = col(mat)[ind])
}

#' @export
obj_print_data.ggalign_area <- function(x, ...) {
    x <- vec_data(x)
    if (vec_size(x) > 0) {
        x <- vec_set_names(x, paste0(vec_seq_along(x), ": "))
        print(x = x, ..., quote = FALSE)
    } else {
        cat("   ", names(x), "\n", sep = " ")
    }
}

#' @export
obj_print_footer.ggalign_area <- function(x, ...) {
    if (vec_size(x) == 0) {
        ncols <- 0
        nrows <- 0
    } else {
        ncols <- max(field(x, "r"))
        nrows <- max(field(x, "b"))
    }
    cat("\n<Spanning", ncols, "columns and", nrows, "rows>\n")
}

#' @export
vec_ptype_abbr.ggalign_area <- function(x, ...) "areas"

trim_area <- function(area) {
    area <- vec_data(area)
    w <- min(.subset2(area, "l"), .subset2(area, "r"))
    h <- min(.subset2(area, "t"), .subset2(area, "b"))
    area$l <- .subset2(area, "l") - w + 1L
    area$r <- .subset2(area, "r") - w + 1L
    area$t <- .subset2(area, "t") - h + 1L
    area$b <- .subset2(area, "b") - h + 1L
    new_areas(area)
}

as_areas <- function(x) UseMethod("as_areas")

#' @export
as_areas.default <- function(x) {
    cli_abort("Cannot convert {.obj_type_friendly {x}} into a design area")
}

#' @export
as_areas.NULL <- function(x) NULL

#' @export
as_areas.ggalign_area <- function(x) x

#' @export
as_areas.character <- function(x) {
    call <- current_call() # used for message only
    # split into rows
    x <- .subset2(strsplit(x, split = "\n"), 1L)
    x <- lapply(x, trimws)
    if (identical(x[[1L]], "")) x[[1L]] <- NULL
    if (identical(x[[length(x)]], "")) x[[length(x)]] <- NULL
    x <- lapply(x, function(x) .subset2(strsplit(x, split = ""), 1L))
    ncols <- list_sizes(x)
    ncol <- .subset(ncols, 1L)
    if (any(ncols != ncol)) {
        cli_abort("character layout must be rectangular", call = call)
    }
    row <- rep(seq_along(x), each = ncol)
    col <- rep(seq_len(ncol), length(x))
    x <- unlist(x, use.names = FALSE)
    # here, area will be reordered by the levels of `x`
    area_list <- imap(split(seq_along(x), x), function(i, name) {
        if (identical(name, "#")) {
            return(area())
        }
        area_rows <- range(row[i])
        area_cols <- range(col[i])
        t <- .subset(area_rows, 1L)
        l <- .subset(area_cols, 1L)
        b <- .subset(area_rows, 2L)
        r <- .subset(area_cols, 2L)
        if (!all(x[row >= t & row <= b & col >= l & col <= r] ==
            x[.subset(i, 1L)])) {
            cli_abort("Patch areas must be rectangular", call = call)
        }
        new_areas(list(t = t, l = l, b = b, r = r))
    })
    vec_c(!!!vec_set_names(area_list, NULL))
}

# For area from patchwork
#' @export
as_areas.patch_area <- function(x) add_class(x, "ggalign_area")

#' @importFrom grid unit
#' @importFrom ggplot2 aes margin theme ggplot
#' @importFrom utils packageVersion
#' @export
plot.ggalign_area <- function(x, ...) {
    data <- vec_data(x)
    data$l <- data$l - 0.45
    data$r <- data$r + 0.45
    data$t <- data$t - 0.45
    data$b <- data$b + 0.45
    data$name <- as.factor(vec_seq_along(x))
    b_fun <- function(lim) {
        if (lim[1] < lim[2]) {
            lim <- seq(floor(lim[1]), ceiling(lim[2]), by = 1)
        } else {
            lim <- seq(ceiling(lim[1]), floor(lim[2]), by = -1)
        }
        lim[-c(1, length(lim))]
    }
    ggplot(data) +
        ggplot2::geom_rect(aes(
            xmin = .data$l, xmax = .data$r,
            ymin = .data$t, ymax = .data$b, fill = .data$name
        ), alpha = 0.3) +
        ggplot2::scale_y_reverse(breaks = b_fun, expand = c(0, 0.04)) +
        ggplot2::scale_x_continuous(
            breaks = b_fun, expand = c(0, 0.04), position = "top"
        ) +
        ggplot2::labs(fill = "Patch") +
        ggplot2::theme_void() +
        theme(
            panel.grid.minor = if (packageVersion("ggplot2") >= "3.4.0") {
                ggplot2::element_line(linewidth = 0.5, colour = "grey")
            } else {
                ggplot2::element_line(size = 0.5, colour = "grey")
            },
            axis.text = ggplot2::element_text(),
            axis.ticks.length = unit(3, "mm"),
            plot.margin = margin(10, 10, 10, 10)
        )
}

#' Build a Matrix
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' 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.
#' @param data_arg The argument name for `data`. Developers can use it to
#' improve messages. Not used by the user.
#' @param call The execution environment where `data` and other arguments for
#' the method are collected. Developers can use it to improve messages. Not
#' used by the user.
#' @return A matrix.
#' @eval
#' rd_collect_family("fortify_matrix", "`fortify_matrix` method collections")
#' @export
fortify_matrix <- function(data, ..., data_arg = NULL,
                           call = NULL) {
    UseMethod("fortify_matrix")
}

#' @inheritParams rlang::args_dots_empty
#' @inherit fortify_matrix title return
#' @description
#' By default, it calls [`as.matrix()`] to build a matrix.
#' @inheritParams fortify_matrix
#' @family fortify_matrix
#' @importFrom rlang try_fetch
#' @export
fortify_matrix.default <- function(data, ..., data_arg = NULL,
                                   call = NULL) {
    call <- call %||% current_call()
    data_arg <- data_arg %||% "data"
    rlang::check_dots_empty(call = call)
    try_fetch(
        as.matrix(data),
        error = function(cnd) {
            cli_abort(
                paste0(
                    "{.arg {data_arg}} must be a {.cls matrix}, ",
                    "or an object coercible by {.fn fortify_matrix}, or a valid ",
                    "{.cls matrix}-like object coercible by {.fn as.matrix}"
                ),
                call = call
            )
        }
    )
}

#' @export
fortify_matrix.waiver <- function(data, ..., data_arg = NULL,
                                  call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    data
}

#' @export
fortify_matrix.NULL <- fortify_matrix.waiver

#' @export
fortify_matrix.function <- fortify_matrix.waiver

#' @export
fortify_matrix.formula <- function(data, ..., data_arg = NULL,
                                   call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    rlang::as_function(data)
}

#' Calculate inter-region distances for genomic rainfall plots
#'
#' This function computes distances between adjacent genomic regions, grouped by
#' chromosome. Useful for visualizing clustering or dispersion of genomic
#' features.
#'
#' @param region A data frame with at least 3 columns: chromosome, start, and
#' end.
#' @param mode How to assign distance for intermediate regions: one of `"min"`,
#'   `"max"`, `"mean"`, `"left"`, or `"right"`.
#' @details
#' The distance between two adjacent regions is calculated as the number of
#' bases between the **end position of the upstream region** and the
#' **start position of the downstream region**. If two regions overlap or are
#' adjacent (≤1 bp apart), the distance is set to `0`. The resulting distance is
#' assigned to each region according to the selected `mode`:
#'
#' - `"left"`: assign the distance to the upstream region
#' - `"right"`: assign to the downstream region
#' - `"min"` / `"max"` / `"mean"`: for intermediate regions, calculate the
#'   minimum, maximum, or average of the distances to neighboring regions
#'
#' @return A data frame with an additional `dist` column.
#' @export
genomic_dist <- function(region, mode = NULL) {
    # Check input validity
    if (is.null(mode)) {
        mode <- "min"
    } else {
        mode <- arg_match0(mode, c("min", "max", "mean", "left", "right"))
    }
    if (!is.data.frame(region) || ncol(region) < 3L) {
        cli_abort("{.arg region} must have at least 3 columns: chromosome, start, and end")
    }
    if (anyNA(region[[1L]]) || anyNA(region[[2L]]) || anyNA(region[[3L]])) {
        cli_abort("Columns 1, 2, and 3 of {.arg region} must not contain missing values")
    }
    if (!is.numeric(region[[2L]]) || !is.numeric(region[[3L]])) {
        cli_abort("Columns 2 and 3 of {.arg region} must be numeric (start and end positions)")
    }
    if (any(region[[2L]] > region[[3L]])) {
        cli_abort("Column 2 (start) must not be greater than column 3 (end) in any row of {.arg region}")
    }

    # Split the region data frame by chromosome (first column)
    groups <- vec_split(region, .subset2(region, 1L))
    dist_list <- lapply(.subset2(groups, "val"), function(d) {
        n <- nrow(d)
        if (n < 2L) {
            d$dist <- NA_real_
            return(d)
        }

        # Sort regions by start, then end positions
        ordering <- order(.subset2(d, 2L), .subset2(d, 3L))

        # Compute distances between adjacent regions
        dists <- vapply(seq_len(n - 1L), function(i) {
            first <- vec_slice(d, ordering[i])
            second <- vec_slice(d, ordering[i + 1])
            out <- .subset2(second, 2L) - .subset2(first, 3L)
            # If overlapping or adjacent (≤1 bp), treat distance as 0
            if (out <= 1L) out <- 0L else out <- as.integer(out)
            out
        }, integer(1L), USE.NAMES = FALSE)

        # If only two regions, just repeat the distance
        if (n == 2L) {
            d$dist <- rep_len(dists, n)
            return(d)
        }

        # For intermediate regions (not first or last), choose how to assign
        # distance
        d1 <- dists[seq_len(n - 2L)]
        d2 <- dists[2:(n - 1L)]
        if (mode == "min") {
            body_dists <- pmin(d1, d2)
        } else if (mode == "max") {
            body_dists <- pmax(d1, d2)
        } else if (mode == "mean") {
            body_dists <- (d1 + d2) / 2L
        } else if (mode == "left") {
            body_dists <- d1
        } else if (mode == "right") {
            body_dists <- d2
        }

        # Combine distances: head, body, and tail
        d$dist <- c(dists[1L], body_dists, dists[n - 1L])[order(ordering)]
        d
    })
    vec_rbind(!!!dist_list)
}

#' Calculate Genomic Region Density
#'
#' Computes the density or count of genomic regions in sliding or fixed windows
#' across the genome. The density can be reported as the percentage of uncovered
#' bases or the number of overlapping regions within each window.
#'
#' This function splits the input by chromosome and tiles the genomic space
#' into windows, optionally overlapping. For each window, it calculates:
#'
#' - the number of regions that overlap it (if `mode = "count"`), or
#' - the fraction of bases covered by any region (if `mode = "percent"`).
#'
#' @param region A data frame with at least 3 columns: chromosome, start, and
#' end.
#'   - Column 1: character or factor, chromosome name.
#'   - Column 2: numeric, start position (must be ≤ end).
#'   - Column 3: numeric, end position.
#' @param window_size Numeric, the width of each window (default is `1e+07`).
#'   Ignored if `n_window` is specified.
#' @param n_window Integer, the number of windows per chromosome. If provided,
#'   overrides `window_size` and evenly splits the chromosome into `n_window`
#'   (non-overlapping) or `2*n_window - 1` (overlapping) windows.
#' @param overlap Logical, whether to use overlapping windows (default `TRUE`).
#'   Overlapping windows are spaced by half the window size.
#' @param mode Character, either `"coverage"` or `"count"`:
#'   - `"count"`: reports the number of regions overlapping each window.
#'   - `"coverage"`: reports the fraction of each window covered by regions.
#' @param seqlengths Optional named vector of chromosome lengths. If missing,
#'   the maximum `end` value in the input is used as the chromosome length.
#'
#' @return A data frame with columns:
#'   - `seqnames`: The sequence (e.g., chromosome) names.
#'   - `start`: start of each window
#'   - `end`: end of each window
#'   - `density`: the region count or covered percent, depending on `mode`
#'
#' @examples
#' region <- data.frame(
#'     chr = rep("chr1", 3),
#'     start = c(100, 5000000, 15000000),
#'     end = c(2000000, 7000000, 17000000)
#' )
#' genomic_density(region, window_size = 1e7, mode = "count")
#' genomic_density(region, n_window = 3, overlap = FALSE, mode = "coverage")
#'
#' @export
genomic_density <- function(region, window_size = 1e+07, n_window = NULL,
                            overlap = TRUE, mode = c("coverage", "count"),
                            seqlengths = NULL) {
    # Check input validity
    assert_number_whole(window_size, allow_null = TRUE, min = 1)
    assert_number_whole(n_window, allow_null = TRUE, min = 1)
    if (is.null(window_size) && is.null(n_window)) {
        cli_abort(c(
            "Both {.arg window_size} and {.arg n_window} are {.val NULL}.",
            "i" = "You must supply at least one of these arguments to define the binning strategy."
        ))
    }
    assert_bool(overlap)
    if (is.null(mode)) {
        mode <- "coverage"
    } else {
        mode <- arg_match0(mode, c("coverage", "count"))
    }
    if (!is.data.frame(region) || ncol(region) < 3L) {
        cli_abort("{.arg region} must have at least 3 columns: chromosome, start, and end")
    }
    if (anyNA(region[[1L]]) || anyNA(region[[2L]]) || anyNA(region[[3L]])) {
        cli_abort("Columns 1, 2, and 3 of {.arg region} must not contain missing values")
    }
    if (!is.numeric(region[[2L]]) || !is.numeric(region[[3L]])) {
        cli_abort("Columns 2 and 3 of {.arg region} must be numeric (start and end positions)")
    }
    if (any(region[[2L]] > region[[3L]])) {
        cli_abort("Column 2 (start) must not be greater than column 3 (end) in any row of {.arg region}")
    }

    # Split the region data frame by chromosome (first column)
    groups <- vec_split(region, .subset2(region, 1L))
    density_list <- lapply(.subset2(groups, "val"), function(d) {
        chr <- .subset2(d, 1L)[1L]
        if (is.null(seqlengths)) {
            max_pos <- max(.subset2(region, 3L))
        } else {
            max_pos <- seqlengths[chr]
            if (is.na(max_pos)) {
                cli_abort("Chromosome {.val {chr}} is not found in {.arg seqlengths}. Please check that all chromosomes in {.arg region} have corresponding sequence lengths.")
            }
        }
        if (overlap) {
            if (is.null(n_window)) {
                # Half-step sliding windows: start at 1, step = half window size
                b <- seq(0L, max_pos, by = window_size %/% 2L)
                s <- b[-length(b)]
                s <- s[-length(s)] + 1L
                e <- s + window_size - 1L
            } else {
                b <- seq(0L, max_pos, length.out = 2L * n_window + 1L)
                s <- b[-length(b)]
                s <- s[-length(s)] + 1L
                e <- s + b[3L] - b[1L] - 1L
            }
        } else {
            if (is.null(n_window)) {
                b <- seq(0L, max_pos, by = window_size)
                s <- b[-length(b)] + 1L
                e <- s + window_size - 1L
            } else {
                b <- seq(0, max_pos, length.out = n_window + 1L)
                s <- b[-length(b)] + 1L
                e <- s + b[2L] - b[1L]
            }
        }
        s <- as.integer(s)
        e <- as.integer(e)
        region_s <- .subset2(d, 2L)
        region_e <- .subset2(d, 3L)
        if (mode == "count") {
            # For each window, count how many regions overlap with it
            density <- vapply(seq_along(s), function(i) {
                si <- s[i]
                ei <- e[i]
                sum(!(region_s > ei | region_e < si))
            }, integer(1L), USE.NAMES = FALSE)
        } else {
            region_s <- as.integer(ceiling(region_s))
            region_e <- as.integer(floor(region_e))
            # For each window, calculate the proportion of bases covered by
            # regions
            density <- vapply(seq_along(s), function(i) {
                si <- s[i]
                ei <- e[i]
                # Keep regions that overlap with current window
                keep <- !(region_s > ei | region_e < si)

                # Clip regions to fit within the current window
                region_s_used <- pmax(region_s[keep], si)
                region_e_used <- pmin(region_e[keep], ei)

                # If no overlapping region, coverage is zero
                if (length(region_s_used) == 0L) {
                    return(0)
                }

                # Sort intervals by start, then end
                ordering <- order(region_s_used, region_e_used)
                region_s_used <- region_s_used[ordering]
                region_e_used <- region_e_used[ordering]

                # Initialize with the first interval
                start <- region_s_used[1L]
                end <- region_e_used[1L]

                # If there's only one interval, just compute its coverage
                if (length(region_s_used) == 1L) {
                    cov <- end - start + 1L
                    return(cov / (ei - si + 1L))
                }
                # Merge overlapping/adjacent intervals and compute total
                # coverage
                cov <- 0L
                for (j in 2:length(region_s_used)) {
                    if (region_s_used[j] - end <= 1L) {
                        end <- max(end, region_e_used[j])
                    } else {
                        cov <- cov + (end - start + 1L)
                        start <- region_s_used[j]
                        end <- region_e_used[j]
                    }
                }
                cov <- cov + (end - start + 1L)
                cov / (ei - si + 1L)
            }, numeric(1L), USE.NAMES = FALSE)
        }
        data_frame0(seqnames = chr, start = s, end = e, density = density)
    })
    vec_rbind(!!!density_list)
}

#' Polar Coordinates with Enhanced Controls
#'
#' An extended version of [`coord_radial()`][ggplot2::coord_radial], providing
#' additional customization options.
#'
#' @inheritParams ggplot2::coord_radial
#' @param thetalim,rlim Limits for the `theta` and `r` axes.
#' @param inner.radius A numeric in `[0, 1)` indicates the inner radius.
#' @param outer.radius A numeric in `(0, 1]` indicates the outer radius.
#' [`coord_radial()`][ggplot2::coord_radial] by default uses `0.8`.
#' @examples
#' ggplot(mtcars, aes(disp, mpg)) +
#'     geom_point() +
#'     coord_circle(
#'         start = -0.4 * pi, end = 0.4 * pi,
#'         inner.radius = 0.3, outer.radius = 1
#'     )
#' ggplot(mtcars, aes(disp, mpg)) +
#'     geom_point() +
#'     coord_circle(
#'         start = -0.4 * pi, end = 0.4 * pi,
#'         inner.radius = 0.3, outer.radius = 0.5
#'     )
#' @importFrom ggplot2 ggproto
#' @importFrom rlang arg_match0
#' @export
coord_circle <- function(theta = "x", start = 0, end = NULL,
                         thetalim = NULL, rlim = NULL, expand = FALSE,
                         direction = 1, clip = "off",
                         r.axis.inside = NULL, rotate.angle = FALSE,
                         inner.radius = 0, outer.radius = 0.95) {
    theta <- arg_match0(theta, c("x", "y"))
    assert_number_decimal(start, allow_infinite = FALSE)
    assert_number_decimal(end, allow_infinite = FALSE, allow_null = TRUE)
    if (packageVersion("ggplot2") <= "3.5.2") {
        assert_bool(expand)
    }
    clip <- arg_match0(clip, c("off", "on"))

    valid_inside_axis <- .rlang_check_bool(r.axis.inside,
        allow_null = TRUE
    ) ||
        .rlang_check_number(r.axis.inside,
            allow_decimal = TRUE, allow_infinite = FALSE
        ) == 0L
    if (!valid_inside_axis) {
        cli_abort(
            "{.arg r.axis.inside} must be a single boolean value or a number"
        )
    }

    assert_bool(rotate.angle)
    assert_number_decimal(inner.radius,
        min = 0, max = 1,
        allow_infinite = FALSE
    )
    assert_number_decimal(outer.radius,
        min = 0, max = 1,
        allow_infinite = FALSE
    )
    if (inner.radius >= outer.radius) {
        cli_abort(
            "{.arg outer.radius} must be larger than {.arg inner.radius}"
        )
    }
    r <- if (theta == "x") "y" else "x"

    arc <- c(start, end %||% (start + 2 * pi))
    if (arc[1] > arc[2]) {
        n_rotate <- ((arc[1] - arc[2]) %/% (2 * pi)) + 1
        arc[1] <- arc[1] - n_rotate * 2 * pi
    }
    r.axis.inside <- r.axis.inside %||% !(abs(arc[2] - arc[1]) >= 1.999 * pi)
    inner_radius <- c(inner.radius, outer.radius) / 2

    ggproto(NULL, CoordCircle,
        limits = list(theta = thetalim, r = rlim),
        theta = theta,
        r = r,
        arc = arc,
        expand = expand,
        direction = sign(direction),
        r_axis_inside = r.axis.inside,
        rotate_angle = rotate.angle,
        inner_radius = inner_radius,
        clip = clip
    )
}

#' @importFrom ggplot2 ggproto_parent
circle_panel_params <- function(self, scale_x, scale_y, params = list()) {
    out <- ggproto_parent(ggplot2::CoordRadial, self)$setup_panel_params(
        scale_x, scale_y, params
    )
    if (packageVersion("ggplot2") <= "3.5.2") {
        if (self$theta == "x") {
            xlimits <- self$limits$theta
            ylimits <- self$limits$r
        } else {
            xlimits <- self$limits$r
            ylimits <- self$limits$theta
        }
        new <- c(
            view_scales_polar(
                scale_x, self$theta, xlimits,
                expand = params$expand[c(4, 2)] %||% self$expand
            ),
            view_scales_polar(
                scale_y, self$theta, ylimits,
                expand = params$expand[c(3, 1)] %||% self$expand
            )
        )
        out[names(new)] <- new
    }
    out$bbox <- ggfun("polar_bbox")(
        self$arc, margin = c(0, 0, 0, 0),
        inner_radius = self$inner_radius
    )
    out
}

view_scales_polar <- function(scale, theta, coord_limits, expand = TRUE) {
    aesthetic <- scale$aesthetics[1]
    is_theta <- theta == aesthetic
    name <- if (is_theta) "theta" else "r"
    expansion <- ggfun("default_expansion")(scale, expand = expand)
    limits <- scale$get_limits()
    continuous_range <- ggfun("expand_limits_scale")(
        scale, expansion, limits, coord_limits = coord_limits
    )
    primary <- ggfun("view_scale_primary")(scale, limits, continuous_range)
    view_scales <- list(
        primary,
        sec = ggfun("view_scale_secondary")(scale, limits, continuous_range),
        major = primary$map(primary$get_breaks()),
        minor = primary$map(primary$get_breaks_minor()),
        range = continuous_range
    )
    names(view_scales) <- c(name, paste0(name, ".", names(view_scales)[-1]))
    view_scales
}

#' @importFrom ggplot2 ggproto
CoordCircle <- ggproto(
    "CoordCircle", ggplot2::CoordRadial,
    setup_panel_params = circle_panel_params
)

# here is copied from patchwork
# we modified the `patchwork` package for following reasons:
# 1. collect guides for each side (should be merged into patchwork, not allowed
#    to be merged: https://github.com/thomasp85/patchwork/issues/379).
# 2. `free_*()` functions: see https://github.com/thomasp85/patchwork/issues/379
#     - `free_align()`: added
#     - `free_border()`: not added
#     - `free_lab()`: added
#     - `free_space()`: added
#     - `free_vp()`: not added
# 3. Added titles around the plot top, left, bottom, and right
#    (`patch_titles()`)
TABLE_ROWS <- 18L + 2L
TABLE_COLS <- 15L + 2L

TOP_BORDER <- 9L + 1L
LEFT_BORDER <- 7L + 1L
BOTTOM_BORDER <- 8L + 1L
RIGHT_BORDER <- 7L + 1L

# top-bottom
# 1: margin
# 2: tag
# 3: title
# 4: subtitle
# 5: guide-box-top
# 6: legend.box.spacing
# feature: insert patch title
# 7: xlab-t
# strip.placement = "inside"/"outside"
# 8: axis-t/strip-t
# 9: strip-t/axis-t
# 10: panel
# 11: strip-b
# 12: axis-b
# 13: xlab-b
# feature: insert patch title
# 14: legend.box.spacing
# 15: guide-box-bottom
# 16: caption
# 17: tag
# 18: margin

# left-right
#
# 1: margin
# 2: tag
# 3: guide-box-left
# 4: legend.box.spacing
# feature: insert patch title
# 5: ylab-l
# 6: axis-l
# 8: panel
# 10: axis-r
# 11: ylab-r
# feature: insert patch title
# 12: legend.box.spacing
# 13: guide-box-right
# 14: tag
# 15: margin

.TLBR <- c("top", "left", "bottom", "right")
.tlbr <- c("t", "l", "b", "r")

# position is a single string contains `.tlbr`
setdiff_position <- function(x, y) gsub(sprintf("[%s]", y), "", x)
union_position <- function(x, y) paste0(x, gsub(sprintf("[%s]", x), "", y))
split_position <- function(x) {
    vec_unique(.subset2(strsplit(x, "", fixed = TRUE), 1L))
}

# pos is an atomic character
setup_pos <- function(x) unname(complete_pos(split_position(x)))

setup_guides <- function(x) {
    .subset(
        c(t = "top", l = "left", b = "bottom", r = "right", i = "inside"),
        split_position(x)
    )
}

complete_pos <- function(x) {
    .subset(c(t = "top", l = "left", b = "bottom", r = "right"), x)
}

opposite_pos <- function(pos) {
    switch(pos,
        top = "bottom",
        bottom = "top",
        left = "right",
        right = "left"
    )
}

#' @importFrom ggplot2 zeroGrob
#' @importFrom gtable gtable gtable_add_grob
#' @importFrom grid unit
make_patch_table <- function() {
    widths <- unit(rep(0L, TABLE_COLS), "mm")
    widths[LEFT_BORDER + 1L] <- unit(1L, "null")
    heights <- unit(rep(0L, TABLE_ROWS), "mm")
    heights[TOP_BORDER + 1L] <- unit(1L, "null")
    ans <- gtable(widths, heights)
    gtable_add_grob(ans,
        list(zeroGrob()), TOP_BORDER + 1L, LEFT_BORDER + 1L,
        z = -Inf, name = "panel-area"
    )
}

#' Generate a plot grob.
#'
#' @param x An object to be converted into a [grob][grid::grob].
#' @return A [`grob()`][grid::grob] object.
#' @examples
#' ggalignGrob(ggplot())
#' @export
ggalignGrob <- function(x) {
    ggalign_gtable(ggalign_build(x))
}

# Now, we only define `ggalign_gtable` method for `alignpatches` and `ggplot`
# `ggalign_build` must return these objects
ggalign_build <- function(x) UseMethod("ggalign_build")

ggalign_gtable <- function(x) UseMethod("ggalign_gtable")

#' @export
ggalign_gtable.gtable <- function(x) x

#' Prepare plots to be aligned with `align_plots`
#'
#' @param x A plot object to be prepared for alignment.
#' @details
#' `ggalign` has implement `alignpatch` method for following objects:
#'   - [`ggplot`][ggplot2::ggplot]
#'   - [`alignpatches`][align_plots]
#'   - [`wrapped_plot`][ggwrap]
#'   - [`patch`][patchwork::patchGrob]
#'   - [`wrapped_patch`][patchwork::wrap_elements]
#'   - [`spacer`][patchwork::plot_spacer]
#'
#' @return A `Patch` object.
#' @examples
#' alignpatch(ggplot())
#' @seealso [`align_plots()`]
#' @export
#' @keywords internal
alignpatch <- function(x) UseMethod("alignpatch")

#' @export
alignpatch.default <- function(x) {
    cli_abort("Cannot align {.obj_type_friendly {x}}")
}

#' @export
alignpatch.NULL <- function(x) NULL

patch_no_method <- function(plot, method) {
    cli_abort("no {.fn {method}} method for {.obj_type_friendly {plot}}")
}

#' @importFrom ggplot2 ggproto
#' @importFrom grid unit.c
Patch <- ggproto(
    "Patch", NULL,
    # following fields will be added by `alignpatch()`
    plot = NULL,
    # following fields will be added in `alignpatches$patch_gtable()`
    # borders = NULL, gt = NULL,

    #' @param guides `guides` argument from the parent alignpatches
    #' @return Which side of guide legends should be collected by the parent
    #' `alignpatches` object?
    #' @noRd
    set_guides = function(self, guides) {
        patch_no_method(self$plot, "set_guides")
    },
    patch_gtable = function(self, theme, guides, plot = self$plot) {
        patch_no_method(self$plot, "patch_gtable")
    },
    collect_guides = function(self, guides, gt = self$gt) {
        if (is.null(guides)) return(list()) # styler: off
        layout <- .subset2(gt, "layout")
        grobs <- .subset2(gt, "grobs")
        guides_ind <- grep("guide-box", .subset2(layout, "name"))
        guides_loc <- vec_slice(layout, guides_ind)
        collected_guides <- vector("list", length(guides))
        names(collected_guides) <- guides
        panel_loc <- find_panel(gt)
        remove_grobs <- NULL
        for (guide_pos in guides) {
            guide_ind <- switch(guide_pos,
                top = .subset2(guides_loc, "b") < .subset2(panel_loc, "t"),
                left = .subset2(guides_loc, "r") < .subset2(panel_loc, "l"),
                bottom = .subset2(guides_loc, "t") > .subset2(panel_loc, "b"),
                right = .subset2(guides_loc, "l") > .subset2(panel_loc, "r"),
                inside = .subset2(guides_loc, "t") >= .subset2(panel_loc, "t") &
                    .subset2(guides_loc, "b") <= .subset2(panel_loc, "b") &
                    .subset2(guides_loc, "l") >= .subset2(panel_loc, "l") &
                    .subset2(guides_loc, "r") <= .subset2(panel_loc, "r")
            )
            if (!any(guide_ind)) next
            guide_loc <- vec_slice(guides_loc, guide_ind)
            guide_ind <- .subset(guides_ind, guide_ind)
            remove_grobs <- c(guide_ind, remove_grobs)
            collected_guides[[guide_pos]] <- .subset2(grobs, guide_ind)

            # remove the guide spaces from the original gtable
            # for inside guide, no need to remove the spaces
            if (guide_pos == "inside") next

            space_pos <- switch(guide_pos,
                top = ,
                left = 1L,
                bottom = ,
                right = -1L
            )
            if (guide_pos %in% c("right", "left")) {
                gt$widths[c(guide_loc$l, guide_loc$l + space_pos)] <- unit(
                    c(0L, 0L), "mm"
                )
            } else if (guide_pos %in% c("bottom", "top")) {
                gt$heights[c(guide_loc$t, guide_loc$t + space_pos)] <- unit(
                    c(0L, 0L), "mm"
                )
            }
        }
        if (length(remove_grobs)) {
            gt <- subset_gt(gt, -remove_grobs, trim = FALSE)
        }
        self$gt <- gt
        collected_guides
    },
    respect = function(self, gt = self$gt) isTRUE(.subset2(gt, "respect")),
    align_panel_sizes = function(self, panel_width, panel_height,
                                 gt = self$gt) {
        list(width = panel_width, height = panel_height, respect = FALSE)
    },
    get_sizes = function(self, free = NULL, gt = self$gt) {
        ans <- .subset2(gt, "heights")
        if (any(free == "t")) {
            top <- unit(rep_len(0, TOP_BORDER), "mm")
        } else {
            top <- ans[seq_len(TOP_BORDER)]
        }
        if (any(free == "b")) {
            bottom <- unit(rep_len(0, BOTTOM_BORDER), "mm")
        } else {
            bottom <- ans[seq(length(ans) - BOTTOM_BORDER + 1L, length(ans))]
        }
        ans <- .subset2(gt, "widths")
        if (any(free == "l")) {
            left <- unit(rep_len(0, LEFT_BORDER), "mm")
        } else {
            left <- ans[seq_len(LEFT_BORDER)]
        }
        if (any(free == "r")) {
            right <- unit(rep_len(0, RIGHT_BORDER), "mm")
        } else {
            right <- ans[seq(length(ans) - RIGHT_BORDER + 1L, length(ans))]
        }
        list(
            widths = unit.c(left, unit(0, "mm"), right),
            heights = unit.c(top, unit(0, "mm"), bottom)
        )
    },
    align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                            gt = self$gt) {
        if (!is.null(t)) gt$heights[seq_along(t)] <- t
        if (!is.null(l)) gt$widths[seq_along(l)] <- l
        if (!is.null(b)) {
            n_row <- nrow(gt)
            gt$heights[seq(n_row - length(b) + 1L, n_row)] <- b
        }
        if (!is.null(r)) {
            n_col <- ncol(gt)
            gt$widths[seq(n_col - length(r) + 1L, n_col)] <- r
        }
        gt
    },
    split_gt = function(self, gt = self$gt) {
        isbg <- .subset2(.subset2(gt, "layout"), "name") == "background"
        if (any(isbg)) {
            bg <- .subset(.subset2(gt, "grobs"), isbg) # a list of background
            plot <- subset_gt(gt, !isbg, trim = FALSE)
        } else {
            bg <- NULL
            plot <- gt
        }
        list(bg = bg, plot = plot)
    },
    add_plot = function(self, gt, plot, t, l, b, r, name, z = 2L) {
        gtable_add_grob(
            gt,
            grobs = plot,
            t = t, l = l, b = b, r = r,
            name = name, z = z
        )
    },
    add_background = function(self, gt, bg, t, l, b, r, name, z = 1L) {
        gtable_add_grob(
            gt,
            grobs = bg,
            t = t, l = l, b = b, r = r,
            name = name, z = z
        )
    },
    free_border = function(self, borders, gt = self$gt) {
        patch_no_method(self$plot, "free_border")
    },
    align_free_border = function(self, borders,
                                 t = NULL, l = NULL, b = NULL, r = NULL,
                                 gt = self$gt) {
        patch_no_method(self$plot, "align_free_border")
    },
    free_lab = function(self, labs, gt = self$gt) {
        patch_no_method(self$plot, "free_lab")
    }
)

#' Build a data frame
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' This function converts various objects to a data frame.
#'
#' @param data An object to be converted to a data frame.
#' @param ... Arguments passed to methods.
#' @inheritParams fortify_matrix
#' @return A data frame.
#' @eval
#' rd_collect_family("fortify_data_frame",
#'     "`fortify_data_frame` method collections"
#' )
#' @export
fortify_data_frame <- function(data, ..., data_arg = NULL, call = NULL) {
    UseMethod("fortify_data_frame")
}

#' @inherit fortify_data_frame title description
#' @param ... Additional arguments passed to [`fortify()`][ggplot2::fortify].
#' @inheritParams fortify_data_frame
#' @details
#' By default, it calls [`fortify()`][ggplot2::fortify] to build the
#' data frame.
#' @family fortify_data_frame
#' @export
fortify_data_frame.default <- function(data, ..., data_arg = NULL,
                                       call = NULL) {
    ggplot2::fortify(model = data, ...)
}

#' @inherit fortify_data_frame.default title description
#' @param data An object to be converted to a data frame.
#' @inheritParams rlang::args_dots_empty
#' @inheritParams fortify_data_frame
#' @return A data frame with following columns:
#'
#'  - `.names`: the names for the vector (only applicable if names exist).
#'  - `value`: the actual value of the vector.
#'
#' @family fortify_data_frame
#' @export
fortify_data_frame.character <- function(data, ..., data_arg = NULL,
                                         call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    ans <- list(.names = vec_names(data), value = data)
    if (is.null(.subset2(ans, ".names"))) ans$.names <- NULL
    new_data_frame(ans)
}

#' @rdname fortify_data_frame.character
#' @export
fortify_data_frame.numeric <- fortify_data_frame.character

#' @rdname fortify_data_frame.character
#' @export
fortify_data_frame.logical <- fortify_data_frame.character

#' @rdname fortify_data_frame.character
#' @export
fortify_data_frame.complex <- fortify_data_frame.character

#' @export
fortify_data_frame.waiver <- function(data, ..., data_arg = NULL,
                                      call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    data
}

#' @export
fortify_data_frame.NULL <- fortify_data_frame.waiver

#' @inherit fortify_data_frame.default title description
#' @param data An object to be converted to a data frame.
#' @inheritParams fortify_data_frame
#' @return A data frame with at least following columns:
#'
#'   - `seqnames`: The sequence (e.g., chromosome) names.
#'   - `start`: The start positions of the ranges.
#'   - `end`: The end positions of the ranges.
#'   - `width`: The width of each range.
#'
#' @family fortify_data_frame
#' @export
fortify_data_frame.GRanges <- function(data, ..., data_arg = NULL,
                                       call = NULL) {
    as.data.frame(data, ...)
}

#' @inherit fortify_data_frame.default title description
#' @param data A matrix-like object.
#' @param lvls A logical value indicating whether to restore factor levels using
#' those stored in [`ggalign_lvls()`], or a character vector specifying custom
#' levels for the `value` column. If levels are provided or restored, the
#' `value` column will be returned as a factor.
#' @inheritParams rlang::args_dots_empty
#' @inheritParams fortify_data_frame
#' @return
#' Matrix will be transformed into a long-form data frame, where each row
#' represents a unique combination of matrix indices and their corresponding
#' values. The resulting data frame will contain the following columns:
#'
#'  - `.row_names` and `.row_index`: the row names (only applicable when names
#'  exist) and an integer representing the row index of the original matrix.
#'
#'  - `.column_names` and `.column_index`: the column names (only applicable
#'  when names exist) and column index of the original matrix.
#'
#'  - `value`: the matrix value, returned as a factor if levels are specified or
#'  restored.
#'
#' @family fortify_data_frame
#' @export
fortify_data_frame.matrix <- function(data, lvls = NULL, ...,
                                      data_arg = NULL, call = NULL) {
    call <- call %||% current_call()
    rlang::check_dots_empty(call = call)
    row_nms <- vec_names(data)
    col_nms <- colnames(data)
    if (isFALSE(lvls)) {
        lvls <- NULL
    } else if (isTRUE(lvls)) {
        lvls <- ggalign_lvls_get(lvls)
    } else if (!is.null(lvls) && !is.character(lvls)) {
        cli_abort(
            "{.arg lvls} must be a single boolean value or a character",
            call = call
        )
    }
    data <- new_data_frame(list(
        .row_index = vec_rep(seq_len(nrow(data)), ncol(data)),
        .column_index = vec_rep_each(seq_len(ncol(data)), nrow(data)),
        value = c(data)
    ))
    if (!is.null(row_nms)) data$.row_names <- row_nms[data$.row_index]
    if (!is.null(col_nms)) data$.column_names <- col_nms[data$.column_index]
    if (!is.null(lvls)) data$value <- factor(data$value, levels = lvls)
    data
}

#' @export
#' @rdname fortify_data_frame.matrix
fortify_data_frame.DelayedMatrix <- function(data, ...) {
    fortify_data_frame(as.matrix(data), ...)
}

#' @export
#' @rdname fortify_data_frame.matrix
fortify_data_frame.Matrix <- function(data, ...) {
    fortify_data_frame(as.matrix(data), ...)
}

#' @export
ggalign_build.StackLayout <- function(x) {
    x <- default_layout(x)
    (stack_build(x) %||% align_plots(theme = x@theme)) +
        layout_title(
            title = .subset2(x@titles, "title"),
            subtitle = .subset2(x@titles, "subtitle"),
            caption = .subset2(x@titles, "caption")
        )
}

#' @param schemes,theme Parameters from parent layout
#' @param extra_design layout parameters of the axis vertically with the stack.
#' @noRd
stack_build <- function(stack, schemes = NULL, theme = NULL,
                        extra_design = NULL) {
    if (is_empty(stack@plot_list)) {
        return(NULL)
    }
    direction <- stack@direction
    position <- .subset2(stack@heatmap, "position")
    schemes <- inherit_parent_layout_schemes(stack, schemes)

    if (is_horizontal(direction)) {
        spacing <- "y"
        # for horizontal stack, we by default remove top and bottom spaces
        # if (!is.null(position)) {
        #     schemes$scheme_align["free_spaces"] <- list(
        #         .subset2(schemes$scheme_align, "free_spaces") %|w|% "tb"
        #     )
        # }
    } else {
        spacing <- "x"
        # for vertical stack, we by default remove left and right spaces
        # if (!is.null(position)) {
        #     schemes$scheme_align["free_spaces"] <- list(
        #         .subset2(schemes$scheme_align, "free_spaces") %|w|% "lr"
        #     )
        # }
    }
    theme <- inherit_parent_layout_theme(stack, theme, spacing = spacing)
    composer <- resolve_stack_layout(stack, schemes, theme, extra_design)
    if (is_empty(plots <- .subset2(composer, "plots"))) {
        return(NULL)
    }

    # arrange plots
    if (is.null(position)) { # for stack layout
        # sizes should be of length 3
        sizes <- stack@sizes
        # recycle the sizes when necessary
        if (length(sizes) == 1L) sizes <- rep(sizes, length.out = 3L)
        sizes <- sizes[
            c(
                .subset2(composer, "left_or_top"),
                TRUE,
                .subset2(composer, "right_or_bottom")
            )
        ]
    } else { # for the heatmap annotation
        sizes <- NA
    }
    plot <- align_plots(
        !!!plots,
        design = area(
            .subset2(composer, "t"),
            .subset2(composer, "l"),
            .subset2(composer, "b"),
            .subset2(composer, "r")
        ),
        widths = switch_direction(
            direction,
            do.call(unit.c, .subset2(composer, "sizes")),
            sizes
        ),
        heights = switch_direction(
            direction,
            sizes,
            do.call(unit.c, .subset2(composer, "sizes"))
        ),
        guides = .subset2(.subset2(schemes, "scheme_align"), "guides"),
        theme = stack@theme
    )

    # for annotation, we should always make it next to the main body
    if (is.null(position)) {
        return(plot)
    }
    plot <- free_vp(
        plot,
        x = switch(position,
            left = 1L,
            right = 0L,
            0.5
        ),
        y = switch(position,
            top = 0L,
            bottom = 1L,
            0.5
        ),
        just = switch(position,
            top = "bottom",
            left = "right",
            bottom = "top",
            right = "left"
        )
    )

    # whether we should override the `guides` collection for the whole
    # annotation stack
    free_guides <- .subset2(stack@heatmap, "free_guides")
    if (!is.waive(free_guides)) plot <- free_guide(plot, free_guides)
    # we also apply the `free_spaces` for the whole annotation stack
    free_spaces <- .subset2(
        .subset2(schemes, "scheme_align"), "free_spaces"
    ) %|w|% NULL
    if (!is.null(free_spaces)) {
        plot <- free_space(free_border(plot, free_spaces), free_spaces)
    }
    plot
}

#' @param schemes,theme Parameters for current stack, which have inherited
#' parameters from the parent.
#' @noRd
resolve_stack_layout <- function(stack, schemes, theme, extra_design) {
    UseMethod("resolve_stack_layout")
}

#' @export
resolve_stack_layout.StackLayout <- function(stack, schemes, theme,
                                             extra_design) {
    plot_list <- stack@plot_list
    direction <- stack@direction
    position <- .subset2(stack@heatmap, "position")

    # we remove the plot without actual plot area
    keep <- vapply(plot_list, function(plot) {
        # we remove objects without plot area
        # Now, only `CraftBox` will contain `NULL`
        !is_craftbox(plot) || !is.null(plot@plot)
    }, logical(1L), USE.NAMES = FALSE)
    plot_list <- .subset(plot_list, keep)
    if (is_empty(plot_list)) return(NULL) # styler: off

    # we reorder the plots based on the `order` slot
    plot_order <- vapply(plot_list, function(plot) {
        if (is_layout(plot)) {
            .subset2(plot@plot_active, "order")
        } else {
            .subset2(plot@active, "order")
        }
    }, integer(1L), USE.NAMES = FALSE)
    plot_list <- .subset(plot_list, make_order(plot_order))

    # build the stack
    composer <- stack_composer(direction)

    # for `free_spaces`, if we have applied it in the whole stack layout
    # we shouln't use it for a single plot. Otherwise, the guide legends
    # collected by the layout will overlap with the axis of the plot in the
    # layout.
    #
    # this occurs in the annotation stack (`position` is not `NULL`).
    #
    # here is the example:
    # p1 <- ggplot(mtcars) +
    #     geom_point(aes(mpg, disp))
    # p2 <- ggplot(mtcars) +
    #     geom_boxplot(aes(gear, disp, group = gear, fill = gear))
    # p3 <- ggplot(mtcars) +
    #     geom_bar(aes(gear)) +
    #     facet_wrap(~cyl)
    # align_plots(
    #     free_space(free_border(
    #         align_plots(
    #             # we shouldn't add free_space for the internal plot
    #             free_space(
    #                 free_border(
    #                     p1 + scale_y_continuous(
    #                         expand = expansion(),
    #                         labels = ~ paste("very very long labels", .x)
    #                     ),
    #                     "l"
    #                 ),
    #                 "l"
    #             ),
    #             p2 + theme(legend.position = "left"),
    #             guides = "l"
    #         ),
    #         "l"
    #     ), "l"),
    #     p3 + theme(plot.margin = margin(l = 5, unit = "cm")),
    #     ncol = 1
    # )
    stack_spaces <- .subset2(.subset2(schemes, "scheme_align"), "free_spaces")
    if (is_string(stack_spaces) && !is.null(position)) {
        released_spaces <- stack_spaces
    } else {
        released_spaces <- NULL
    }

    design <- setup_design(stack@design)
    stack_composer_add(
        plot_list,
        stack = stack,
        composer,
        schemes = schemes,
        theme = theme,
        design = design,
        extra_design = extra_design,
        direction = direction,
        position = position,
        released_spaces = released_spaces,
        previous_design = NULL
    )
}

make_order <- function(order) {
    l <- length(order)
    index <- seq_len(l)

    # for order not set by user, we use heuristic algorithm to define the order
    need_action <- is.na(order)
    if (all(need_action)) { # shorthand for the usual way, we don't set any
        return(index)
    } else if (all(!need_action)) { # we won't need do something special
        return(order(order))
    }

    # 1. for outliers, we always put them in the two tail
    # 2. for order has been set and is not the outliers,
    #    we always follow the order
    # 3. non-outliers were always regarded as the integer index
    used <- as.integer(order[!need_action & order >= 1L & order <= l])

    # we flatten user index to continuous integer sequence
    sequence <- vec_unrep(used) # key is the sequence start
    start <- .subset2(sequence, "key")
    end <- pmin(
        start + .subset2(sequence, "times") - 1L,
        vec_c(start[-1L] - 1L, l) # the next start - 1L
    )
    used <- .mapply(function(s, e) s:e, list(s = start, e = end), NULL)

    # following index can be used
    unused <- vec_set_difference(index, unlist(used, FALSE, FALSE))

    # we assign the candidate index to the order user not set.
    order[need_action] <- unused[seq_len(sum(need_action))]

    # make_order(c(NA, 1, NA)): c(2, 1, 3)
    # make_order(c(NA, 1, 3)): c(2, 1, 3)
    # make_order(c(NA, 1, 3, 1)): c(2, 4, 3, 1)
    order(order)
}

#' @importFrom grid grid.draw
#' @importFrom rlang try_fetch cnd_signal
#' @export
print.alignpatches <- function(x, newpage = is.null(vp), vp = NULL, ...) {
    ggplot2::set_last_plot(x)
    if (newpage) {
        grid::grid.newpage()
        if (is.character(vp)) {
            cli_abort(c(
                "{.arg vp} cannot be a character string when {.arg newpage} is TRUE.",
                i = "Please provide a viewport object or set {.arg newpage} to FALSE."
            ))
        }
    }
    if (!is.null(vp)) {
        if (is.character(vp)) {
            cur <- grid::current.viewport()$name
            grid::seekViewport(vp)
            if (!identical(cur, "ROOT")) on.exit(grid::seekViewport(cur))
        } else {
            grid::pushViewport(vp)
            on.exit(grid::upViewport())
        }
    }

    # render the plot
    try_fetch(
        grid.draw(x, ...),
        error = function(e) {
            if (inherits(e, "simpleError") &&
                deparse(conditionCall(e)[[1L]]) == "grid.Call") {
                error_name <- obj_type_friendly(x)
                if (Sys.getenv("RSTUDIO") == "1") {
                    cli_abort(c(paste(
                        "The RStudio {.field Plots} window may be",
                        "too small to show", error_name
                    ), i = "Please make the window larger."), parent = e)
                } else {
                    cli_abort(c(
                        "The viewport may be too small to show {error_name}.",
                        i = "Please make the window larger."
                    ), parent = e)
                }
            }
            cnd_signal(e)
        }
    )
    invisible(x)
}

#' @importFrom grid grid.draw
#' @exportS3Method
grid.draw.alignpatches <- function(x, recording = TRUE) {
    grid.draw(ggalignGrob(x), recording = recording)
}

#' @export
ggalign_build.alignpatches <- function(x) x

#' @importFrom ggplot2 find_panel element_render theme theme_get
#' @importFrom gtable gtable_add_grob gtable_add_rows gtable_add_cols
#' @importFrom rlang arg_match0
#' @importFrom S7 prop
#' @export
ggalign_gtable.alignpatches <- function(x) {
    titles <- prop(x, "titles")

    # ensure theme has no missing value
    theme <- prop(x, "theme") %||% theme_get()

    # `TO-DO`: use `complete_theme()` from ggplot2 release
    theme <- complete_theme(theme)
    attr(x, "theme") <- theme # bypass the setter function
    table <- alignpatch(x)$patch_gtable(top_level = TRUE)

    fix_respect <- is.matrix(.subset2(table, "respect"))

    # Add title, subtitle, and caption -------------------
    # https://github.com/tidyverse/ggplot2/blob/2e08bba0910c11a46b6de9e375fade78b75d10dc/R/plot-build.R#L219C3-L219C9
    title <- element_render(
        theme = theme, "plot.title", .subset2(titles, "title"),
        margin_y = TRUE, margin_x = TRUE
    )
    title_height <- grobHeight(title)

    # Subtitle
    subtitle <- element_render(
        theme, "plot.subtitle", .subset2(titles, "subtitle"),
        margin_y = TRUE, margin_x = TRUE
    )
    subtitle_height <- grobHeight(subtitle)

    # caption
    caption <- element_render(
        theme, "plot.caption", .subset2(titles, "caption"),
        margin_y = TRUE, margin_x = TRUE
    )
    caption_height <- grobHeight(caption)

    # positioning of title and subtitle is governed by plot.title.position
    # positioning of caption is governed by plot.caption.position
    #   "panel" means align to the panel(s)
    #   "plot" means align to the entire plot (except margins and tag)
    panel_pos <- find_panel(table)
    title_pos <- arg_match0(
        theme$plot.title.position %||% "panel",
        c("panel", "plot"),
        arg_nm = "plot.title.position",
        error_call = quote(theme())
    )

    caption_pos <- arg_match0(
        theme$plot.caption.position %||% "panel",
        values = c("panel", "plot"),
        arg_nm = "plot.caption.position",
        error_call = quote(theme())
    )
    if (title_pos == "panel") {
        title_l <- panel_pos$l
        title_r <- panel_pos$r
    } else {
        title_l <- 1L
        title_r <- ncol(table)
    }
    if (caption_pos == "panel") {
        caption_l <- panel_pos$l
        caption_r <- panel_pos$r
    } else {
        caption_l <- 1L
        caption_r <- ncol(table)
    }

    table <- gtable_add_rows(table, subtitle_height, pos = 0)
    table <- gtable_add_grob(table, subtitle,
        name = "subtitle",
        t = 1, b = 1, l = title_l, r = title_r, clip = "off"
    )

    table <- gtable_add_rows(table, title_height, pos = 0)
    table <- gtable_add_grob(table, title,
        name = "title",
        t = 1, b = 1, l = title_l, r = title_r, clip = "off"
    )

    table <- gtable_add_rows(table, caption_height, pos = -1)
    table <- gtable_add_grob(table, caption,
        name = "caption",
        t = -1, b = -1, l = caption_l, r = caption_r, clip = "off"
    )
    if (fix_respect) {
        table$respect <- rbind(0L, 0L, table$respect, 0L)
    }

    # add margins --------------------------------------
    plot_margin <- calc_element("plot.margin", theme)

    table <- gtable_add_rows(table, plot_margin[1L], 0L)
    table <- gtable_add_rows(table, plot_margin[3L])
    if (fix_respect) table$respect <- rbind(0L, table$respect, 0L)
    table <- gtable_add_cols(table, plot_margin[2L], 0L)
    table <- gtable_add_cols(table, plot_margin[4L])
    if (fix_respect) table$respect <- cbind(0L, table$respect, 0L)

    # add background -----------------------------------
    if (inherits(theme$plot.background, "element")) {
        table <- gtable_add_grob(table,
            element_render(theme, "plot.background"),
            t = 1L, l = 1L, b = -1L, r = -1L, name = "background", z = -Inf
        )
        table$layout <- table$layout[
            c(nrow(table$layout), 1:(nrow(table$layout) - 1L)),
        ]
        table$grobs <- table$grobs[
            c(nrow(table$layout), 1:(nrow(table$layout) - 1L))
        ]
    }
    table
}

#' Create a Grob That Spans Multiple Viewports
#'
#' This function initializes a communication channel to share location signals
#' across different viewports. It returns a `channelSenderGrob` object, which
#' can transmit multiple signals using its `$signal` method (see the "Signal"
#' section below for details). When drawn, all collected signals are passed to
#' the `make_content` function to generate the final [`grob`][grid::grob].
#'
#' @param make_content A function that accepts the list of signal locations and
#' returns a [`grob`][grid::grob].
#' @param ... Additional arguments passed to `make_content`.
#' @inheritParams grid::grob
#'
#' @section Signal:
#' A `channelSenderGrob` can emit multiple location signals using the `$signal`
#' method. This method accepts the following arguments:
#'
#'   - `x`: X-coordinate.
#'   - `y`: Y-coordinate.
#'   - `default.units`: The default units for `x` and `y`.
#'   - `tag`: A character string used to identify the location.
#'   - `name`: A name for the returned grob.
#'   - `vp`: A [`viewport`][grid::viewport] for the returned grob.
#'
#' The `$signal` method returns a `channelSignalGrob`.
#'
#' @return A `channelSenderGrob` object.
#' @examples
#' # we create a new channel, we will emit two singals
#' # here: we just add a line between the two signals
#' channel <- channelGrob(function(locations) {
#'     # you can also use `tag` to identify the locations
#'     loc1 <- .subset2(locations, 1L)
#'     loc2 <- .subset2(locations, 2L)
#'     grid::segmentsGrob(loc1$x, loc1$y, loc2$x, loc2$y)
#' })
#'
#' gt <- gtable::gtable(unit(1:2, c("cm")), unit(5, "cm"))
#' gt <- gtable::gtable_add_grob(
#'     gt,
#'     list(
#'         grid::rectGrob(gp = gpar(color = "black", fill = NA)),
#'         channel$signal(0.5, 0.5, "npc")
#'     ),
#'     t = 1, l = 1, name = c("rect1", "signal1")
#' )
#' gt <- gtable::gtable_add_grob(
#'     gt,
#'     list(
#'         grid::rectGrob(gp = gpar(color = "red", fill = NA)),
#'         channel$signal(0.5, 0.5, "npc")
#'     ),
#'     t = 1, l = 2, name = c("rect2", "signal2")
#' )
#' grid::grid.newpage()
#' grid::grid.draw(gt)
#' @importFrom grid unit is.unit grob
#' @importFrom rlang list2
#' @export
channelGrob <- function(make_content, ..., name = NULL, vp = NULL) {
    make_content <- allow_lambda(make_content)
    if (!is.function(make_content)) {
        cli_abort("{.arg make_content} must be a function")
    }
    # Used to communicate between different signals
    channel <- new.env(parent = emptyenv())
    channel$make_content <- make_content
    channel$dots <- list2(...)
    channel$n <- 0L # total number of signals
    grob(
        channel = channel,
        name = name,
        vp = vp,

        # method used to release signal and retutn a new grob
        signal = function(self, x, y, default.units = "native",
                          tag = NULL, name = NULL, vp = NULL) {
            if (!is.unit(x)) x <- unit(x, default.units)
            if (!is.unit(y)) y <- unit(y, default.units)
            if (length(x) != length(y)) {
                cli_abort("{.arg x} and {.arg y} must have the same length")
            }
            assert_string(tag, allow_empty = FALSE, allow_null = TRUE)
            signal <- list(list(x = x, y = y))
            if (!is.null(tag)) names(signal) <- tag
            channel <- .subset2(self, "channel")
            channel$signals <- c(channel$signals, signal)
            i <- channel$n <- channel$n + 1L
            grob(
                channel = channel,
                i = i,
                name = name,
                vp = vp,
                cl = c("channelSignalGrob", "channelGrob")
            )
        },
        # Grob used to send signals
        cl = c("channelSenderGrob", "channelGrob")
    )
}

#' @export
`$.channelGrob` <- function(self, name) {
    field <- .subset2(self, name)
    if (!is.function(field)) {
        return(field)
    }
    args <- formals(field)
    # is.null is a fast path for a common case; the %in% check is slower but
    # also catches the case where there's a `self = NULL` argument.
    has_self <- !is.null(args[["self"]]) || "self" %in% names(args)

    # We assign the method with its correct name and construct a call to it to
    # make errors reported as coming from the method name rather than `field()`
    assign(name, field, envir = environment())
    args <- list(quote(...))
    if (has_self) {
        args$self <- quote(self)
    }
    rlang::new_function(alist(... = ), rlang::call2(name, !!!args))
}

#' @export
`[[.channelGrob` <- `$.channelGrob`

# https://www.stat.auckland.ac.nz/~paul/Reports/CustomGrobs/custom-grob.html
# preDraw:
#  - makeContext
#  - pushvpgp
#  - preDrawDetails: by default, do noting
# makeContent:
# drawDetails:
# postDraw:
#  - postDrawDetails: by default, do noting
#  - popgrobvp
#' @importFrom grid makeContent drawDetails viewport is.grob gTree grob
#' @export
makeContent.channelGrob <- function(x) {
    channel <- .subset2(x, "channel")
    # If no signals, do nothing
    if (channel$n == 0L) return(x) # styler: off

    if (inherits(x, "channelSenderGrob")) {
        # we use the viewport from the signals sender
        channel$vp <- grid::current.viewport()
    } else if (inherits(x, "channelSignalGrob")) {
        if (is.null(channel$locations)) {
            channel$locations <- vector("list", channel$n)
            names(channel$locations) <- names(channel$signals)
        }

        # convert the viewport coordinates to the device coordinates
        i <- .subset2(x, "i")
        signal <- .subset2(channel$signals, i)
        channel$locations[[i]] <- grid::deviceLoc(signal$x, signal$y)
        if (all(!vapply(channel$locations, is.null, logical(1L), # styler: off
                        USE.NAMES = FALSE))) {                   # styler: off
            # When all locations have been prepared
            # we output the grob with all device locations
            x <- grob(
                channel = channel,
                vp = .subset2(x, "vp"), # Don't change the viewport
                cl = c("channelReceiverGrob", "channelGrob")
            )
        }
    }
    x
}

#' @export
drawDetails.channelGrob <- function(x, recording) {
}

#' @importFrom grid grid.draw viewport gTree is.grob
#' @export
drawDetails.channelReceiverGrob <- function(x, recording) {
    # we always reset the locations after drawing
    old <- grid::current.viewport()$name
    on.exit(grid::seekViewport(old), add = TRUE)
    channel <- .subset2(x, "channel")
    locations <- channel$locations
    on.exit(channel$locations <- NULL, add = TRUE)
    if (!is.null(vp <- channel$vp)) {
        grid::seekViewport(vp$name)
        # convert the device cooridnates into the drawing viewport coordinates
        trans <- solve(grid::current.transform())
        locations <- lapply(locations, grid_solve_loc, trans = trans)
    } else { # If no viewport, we use the `ROOT` viewport
        grid::upViewport(0)
        grid::pushViewport(viewport())
    }
    grob <- rlang::inject(channel$make_content(locations, !!!channel$dots))
    if (is.gList(grob)) grob <- gTree(children = grob)
    if (is.grob(grob)) grid.draw(grob, recording = recording)
}

#' @importFrom grid gpar
#' @export
grid::gpar

#' @importFrom grid unit
#' @export
grid::unit

is.gList <- function(x) inherits(x, "gList")

is.gTree <- function(x) inherits(x, "gTree")

#' @importFrom grid unitType absolute.size
is_absolute_unit <- function(x) unitType(absolute.size(x)) != "null"

#' @importFrom grid unitType
is_null_unit <- function(x) unitType(x) == "null"

is_null_grob <- function(x) inherits(x, c("zeroGrob", "null"))

#' @importFrom grid is.grob nullGrob
ensure_grob <- function(x, default = nullGrob()) {
    if (is.gList(x)) x <- gTree(children = x)
    if (is.grob(x)) x else default
}

# `current.transform()` transforms from *inches* within the current viewport to
# *inches* on the overall device.
grid_solve_loc <- function(loc, trans, valueOnly = FALSE) {
    x <- grid::convertX(loc$x, "inches", valueOnly = TRUE)
    y <- grid::convertY(loc$y, "inches", valueOnly = TRUE)
    out <- matrix(c(x, y, rep_len(1, length(x))), ncol = 3L) %*%
        trans
    out <- list(x = out[, 1L, drop = TRUE], y = out[, 2L, drop = TRUE])
    if (!valueOnly) out <- lapply(out, unit, "inches")
    out
}

loc_device2vp <- function(x, y, valueOnly = FALSE) {
    assert_s3_class(x, "unit")
    assert_s3_class(y, "unit")
    if (length(x) != length(y)) {
        cli_abort("{.arg x} and {.arg y} must have the same length")
    }
    assert_bool(valueOnly)
    grid_solve_loc(
        list(x = x, y = y),
        solve(grid::current.transform()),
        valueOnly = valueOnly
    )
}

loc_vp2device <- function(x, y, valueOnly = FALSE) {
    assert_s3_class(x, "unit")
    assert_s3_class(y, "unit")
    if (length(x) != length(y)) {
        cli_abort("{.arg x} and {.arg y} must have the same length")
    }
    assert_bool(valueOnly)
    grid::deviceLoc(x, y, valueOnly = valueOnly)
}

# # allow the missing value in the unit for `str` method
# ggalign_unit <- function(x, ...) UseMethod("ggalign_unit")
# #' @export
# ggalign_unit.default <- function(x, ...) ggalign_unit(as.numeric(x), ...)
# #' @export
# ggalign_unit.numeric <- function(x, units = "null", data = NULL, ...) {
#     add_class(unit(x, units, data = data), "ggalign_unit")
# }
# #' @export
# ggalign_unit.unit <- function(x, ...) add_class(x, "ggalign_unit")
# is_ggalign_unit <- function(x) inherits(x, "ggalign_unit")

# # allow the missing value in the unit for `str` method
#' @importFrom utils str
#' @export
str.unit <- function(object, ...) obj_str(object, ...)

#' @export
vec_ptype_abbr.unit <- function(x, ...) fclass(x)

#' @importFrom utils str
#' @export
obj_str_footer.unit <- function(x, ..., indent.str = " ", nest.lev = 0,
                                give.attr = TRUE) {
    if (!isTRUE(give.attr)) {
        return(invisible(x))
    }
    attr <- attributes(x)
    attr[["class"]] <- NULL
    attr[["names"]] <- NULL
    if (length(attr) == 0) {
        return(invisible(x))
    }
    indent.str <- paste0(" ", indent.str)
    for (nm in names(attr)) {
        cat(indent.str, paste0("- attr(*, \"", nm, "\"):"), sep = "")
        str(
            attr[[nm]],
            no.list = TRUE, ...,
            nest.lev = nest.lev + 1L,
            indent.str = indent.str
        )
    }
    invisible(x)
}

#' @importFrom gtable gtable_trim
subset_gt <- function(gt, index, trim = TRUE) {
    gt$layout <- vec_slice(.subset2(gt, "layout"), index)
    gt$grobs <- .subset(.subset2(gt, "grobs"), index)
    if (trim) gtable_trim(gt) else gt
}

gtable_trim_widths <- function(gt) {
    layout <- .subset2(gt, "layout")
    w <- range(.subset2(layout, "l"), .subset2(layout, "r"))
    gt$widths <- .subset2(gt, "widths")[seq.int(w[1L], w[2L])]
    if (is.matrix(respect <- .subset2(gt, "respect"))) {
        respect <- respect[, seq.int(w[1L], w[2L]), drop = FALSE]
        if (all(respect == 0L)) respect <- FALSE
        gt$respect <- respect
    }
    layout$l <- .subset2(layout, "l") - w[1L] + 1L
    layout$r <- .subset2(layout, "r") - w[1L] + 1L
    gt$layout <- layout
    gt
}

gtable_trim_heights <- function(gt) {
    layout <- .subset2(gt, "layout")
    h <- range(.subset2(layout, "t"), .subset2(layout, "b"))
    gt$heights <- .subset2(gt, "heights")[seq.int(h[1L], h[2L])]
    if (is.matrix(respect <- .subset2(gt, "respect"))) {
        respect <- respect[seq.int(h[1L], h[2L]), , drop = FALSE]
        if (all(respect == 0L)) respect <- FALSE
        gt$respect <- respect
    }
    layout$t <- .subset2(layout, "t") - h[1L] + 1L
    layout$b <- .subset2(layout, "b") - h[1L] + 1L
    gt$layout <- layout
    gt
}

liberate_area <- function(gt, top, left, bottom, right,
                          clip = "inherit", name = NULL, vp = NULL) {
    if (any(remove <- grob_in_area(gt, top, right, bottom, left))) {
        liberated <- gt[top:bottom, left:right]
        if (is.function(vp <- allow_lambda(vp))) {
            liberated$vp <- vp(liberated)
        } else if (inherits(vp, "viewport")) {
            liberated$vp <- vp
        }
        liberated$respect <- FALSE
        name <- name %||%
            paste(
                .subset2(.subset2(liberated, "layout"), "name"),
                collapse = "; "
            )
        gt <- subset_gt(gt, !remove, trim = FALSE)
        gt <- gtable_add_grob(
            gt,
            list(liberated),
            top,
            left,
            bottom,
            right,
            z = max(.subset2(.subset2(liberated, "layout"), "z")),
            clip = clip,
            name = name
        )
    }
    gt
}

grob_in_area <- function(gt, top, right, bottom, left) {
    .subset2(.subset2(gt, "layout"), "l") >= left &
        .subset2(.subset2(gt, "layout"), "t") >= top &
        .subset2(.subset2(gt, "layout"), "r") <= right &
        .subset2(.subset2(gt, "layout"), "b") <= bottom
}

compute_null_width <- function(x, unitTo = "mm", valueOnly = FALSE) {
    compute_null_unit(x, "width", unitTo = unitTo, valueOnly = valueOnly)
}

compute_null_height <- function(x, unitTo = "mm", valueOnly = FALSE) {
    compute_null_unit(x, "height", unitTo = unitTo, valueOnly = valueOnly)
}

#' @importFrom grid unit convertHeight convertWidth
compute_null_unit <- function(x, type = c("width", "height"), unitTo = "mm",
                              valueOnly = FALSE) {
    null <- is_null_unit(x) # null unit
    if (type == "width") {
        ans <- convertWidth(x, unitTo, valueOnly = TRUE)
        total <- convertWidth(unit(1, "npc"), unitTo = unitTo, valueOnly = TRUE)
    } else {
        ans <- convertHeight(x, unitTo, valueOnly = TRUE)
        total <- convertHeight(
            unit(1, "npc"),
            unitTo = unitTo,
            valueOnly = TRUE
        )
    }
    if (any(null)) {
        null_size <- total - sum(ans[!null])
        # other units in the same row/ column also have unit null
        coef <- as.numeric(x[null])
        ans[null] <- (null_size / sum(coef)) * coef
    }
    if (!valueOnly) ans <- unit(ans, unitTo)
    ans
}

#' Connect two layout crosswise
#'
#' @description
#' `ggcross` resets the layout ordering index of a [`stack_cross()`]. This
#' allows you to add other `align_*` objects to define a new layout ordering
#' index. Any objects added after `ggcross` will use this updated layout
#' ordering index. This feature is particularly useful for creating `tanglegram`
#' visualizations. `ggcross()` is an alias of `ggcross()`.
#'
#' @inheritParams ggalign
#' @section ggplot2 specification:
#' `ggcross()` initializes a ggplot `data` and `mapping`.
#'
#' `ggcross()` always applies a default mapping for the axis of the data index
#' in the layout. This mapping is `aes(y = .data$.y)` for horizontal stack
#' layout (including left and right annotation) and `aes(x = .data$.x)` for
#' vertical stack layout (including top and bottom annotation).
#'
#' The data in the underlying `ggplot` object will contain following columns:
#'
#'  - `.panel`: The panel for the aligned axis. Refers to the `x-axis` for
#'    vertical `stack_layout()` (including top and bottom annotations), and the
#'    `y-axis` for horizontal `stack_layout()` (including left and right
#'    annotations).
#'
#'  - `.names` ([`vec_names()`][vctrs::vec_names]) and `.index`
#'    ([`vec_size()`][vctrs::vec_size()]/[`NROW()`]): Character names (if
#'    available) and the integer index of the original data.
#'
#'  - `.hand`: a factor indicates the index groups.
#'
#'  - `.x`/`.y` and `.discrete_x`/`.discrete_y`: Integer indices for `x`/`y`
#'    coordinates, and a factor of the data labels (only applicable when names
#'    exist).
#'
#' It is recommended to use `.x`/`.y`, or `.discrete_x`/`.discrete_y` as the
#' `x`/`y` mapping.
#'
#' @importFrom ggplot2 ggplot aes
#' @export
ggcross <- function(mapping = aes(), size = NULL,
                    no_axes = NULL, active = NULL) {
    active <- update_active(active, new_active(use = TRUE))
    no_axes <- no_axes %||%
        getOption(sprintf("%s.align_no_axes", pkg_nm()), default = TRUE)
    cross(
        CrossGg,
        plot = ggplot(mapping = mapping),
        schemes = default_schemes(th = theme_no_strip()),
        size = size, no_axes = no_axes, active = active
    )
}

#' @importFrom ggplot2 ggproto
CrossGg <- ggproto("CrossGg",
    CraftCross,
    interact_layout = function(self, layout) {
        if (!is_cross_layout(layout)) {
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s",
                    object_name(self), self$layout_name
                ),
                i = sprintf(
                    "%s can only be used in {.fn stack_cross}",
                    object_name(self)
                )
            ))
        }

        # udpate cross_points
        layout@cross_points <- c(layout@cross_points, length(layout@plot_list))

        # update old design list
        layout@odesign <- c(layout@odesign, list(layout@design))

        # we keep the names from the layout data for usage
        self$labels <- vec_names(layout@data)
        layout
    },
    setup_design = function(self, design) {
        design["index"] <- list(NULL) # always reset the index
        design
    },
    setup_plot = function(self, plot) {
        ggadd_default(plot, mapping = switch_direction(
            self$direction, aes(y = .data$.y), aes(x = .data$.x)
        ))
    },
    #' @importFrom stats reorder
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (is.null(.subset2(design, "nobs"))) {
            cli_abort(sprintf(
                "you must initialize %s before drawing %s",
                self$layout_name, object_name(self)
            ), call = self$call)
        }
        direction <- self$direction
        index <- vec_c(
            .subset2(previous_design, "index"),
            .subset2(design, "index")
        )
        data <- data_frame0(
            .panel = vec_c(
                .subset2(previous_design, "panel"),
                .subset2(design, "panel")
            ),
            .index = index,
            # ggcross() only reset ordering index, labels should be the same
            .names = .subset(self$labels, index),
            .hand = if (is_horizontal(direction)) {
                factor(
                    vec_rep_each(
                        c("left", "right"),
                        c(
                            .subset2(previous_design, "nobs"),
                            .subset2(design, "nobs")
                        )
                    ),
                    c("left", "right")
                )
            } else {
                factor(
                    vec_rep_each(
                        c("top", "bottom"),
                        c(
                            .subset2(previous_design, "nobs"),
                            .subset2(design, "nobs")
                        )
                    ),
                    c("bottom", "top")
                )
            }
        )
        axis <- to_coord_axis(direction)
        coord_name <- paste0(".", axis)
        data[[coord_name]] <- vec_c(
            seq_len(.subset2(previous_design, "nobs")),
            seq_len(.subset2(design, "nobs"))
        )
        if (!is.null(.subset2(data, ".names"))) {
            data[[paste0(".discrete_", axis)]] <- reorder(
                .subset2(data, ".names"),
                .subset2(data, coord_name),
                order = FALSE
            )
        }
        plot <- gguse_data(plot, data)
        plot + switch_direction(
            direction,
            default_expansion(x = expansion()),
            default_expansion(y = expansion())
        )
    },
    finish_plot = function(self, plot, schemes, theme) {
        direction <- self$direction
        # remove axis titles, text, ticks used for alignment
        if (isTRUE(self$no_axes)) {
            schemes$scheme_theme <- .subset2(schemes, "scheme_theme") +
                theme_no_axes(switch_direction(direction, "y", "x"))
        }
        plot <- plot_add_schemes(plot, schemes)
        if (is_horizontal(direction)) {
            theme <- theme(
                panel.spacing.y = calc_element("panel.spacing.y", theme)
            )
        } else {
            theme <- theme(
                panel.spacing.x = calc_element("panel.spacing.x", theme)
            )
        }
        plot <- plot + theme
        ggremove_margin(plot, direction) + theme_recycle()
    },
    summary = function(self, plot) {
        header <- ggproto_parent(Craftsman, self)$summary(plot)
        c(header, "  Reset the ordering index and Add plot")
    }
)

#' Layout operator
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#'  - `+`: Adds elements to the active plot in the active layout.
#'  - `&`: Applies elements to all plots in the layout.
#'  - `-`: Adds elements to multiple plots in the layout.
#'
#' @details
#' The `+` operator is straightforward and should be used as needed.
#'
#' In order to reduce code repetition `ggalign` provides two operators for
#' adding ggplot elements (geoms, themes, facets, etc.) to multiple/all plots in
#' `r rd_layout()`: `-` and `&`.
#'
#' @param e1 A `r rd_layout()`.
#' @param e2 An object to be added to the plot.
#' @return A modified `Layout` object.
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 7)
#' ggheatmap(small_mat) +
#'     anno_top() +
#'     ggalign() +
#'     geom_point(aes(y = value))
#'
#' # `&` operator apply it to all plots
#' ggheatmap(small_mat) +
#'     anno_top() +
#'     align_dendro() &
#'     theme(panel.border = element_rect(
#'         colour = "red", fill = NA, linewidth = unit(2, "mm")
#'     ))
#'
#' # If the active layout is the annotation stack, the `-` operator will only
#' # add the elements to all plots in the active annotation stack:
#' ggheatmap(small_mat) +
#'     anno_left(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     align_dendro(aes(color = branch), k = 3L) -
#'     # Modify the the color scales of all plots in the left annotation
#'     scale_color_brewer(palette = "Dark2")
#'
#' # If the active layout is the `stack_layout()` itself, `-`
#' # applies the elements to all plots in the layout except the nested
#' # `ggheatmap()`/`quad_layout()`.
#' stack_alignv(small_mat) +
#'     align_dendro() +
#'     ggtitle("I'm from the parent stack") +
#'     ggheatmap() +
#'     # remove any active context
#'     stack_active() +
#'     align_dendro() +
#'     ggtitle("I'm from the parent stack") -
#'     # Modify the the color scales of all plots in the stack layout except the
#'     # heatmap layout
#'     scale_color_brewer(palette = "Dark2") -
#'     # set the background of all plots in the stack layout except the heatmap
#'     # layout
#'     theme(plot.background = element_rect(fill = "red"))
#'
#' @name layout-operator
NULL

utils::globalVariables(".Generic")

methods::setMethod("Ops", c("LayoutProto", "ANY"), function(e1, e2) {
    if (missing(e2)) {
        cli_abort(c(
            "Cannot use {.code {.Generic}} with a single argument.",
            "i" = "Did you accidentally put {.code {.Generic}} on a new line?"
        ))
    }

    if (is.null(e2)) return(e1) # styler: off

    # Get the name of what was passed in as e2, and pass along so that it
    # can be displayed in error messages
    e2name <- deparse(substitute(e2))
    switch(.Generic, # nolint
        `+` = layout_add(e1, e2, e2name),
        `-` = layout_subtract(e1, e2, e2name),
        `&` = layout_and_add(e1, e2, e2name),
        stop_incompatible_op(.Generic, e1, e2)
    )
})

#################################################################
layout_add <- function(layout, object, object_name) {
    UseMethod("layout_add")
}

#' @export
layout_add.QuadLayout <- function(layout, object, object_name) {
    quad_layout_add(object, layout, object_name)
}

#' @export
layout_add.ChainLayout <- function(layout, object, object_name) {
    chain_layout_add(object, layout, object_name)
}

#################################################################
layout_subtract <- function(layout, object, object_name) {
    UseMethod("layout_subtract")
}

#' @export
layout_subtract.QuadLayout <- function(layout, object, object_name) {
    quad_layout_subtract(object, layout, object_name)
}

#' @export
layout_subtract.ChainLayout <- function(layout, object, object_name) {
    chain_layout_subtract(object, layout, object_name)
}

#################################################################
# we use and_add suffix here, since `and` is very similar with `add`.
layout_and_add <- function(layout, object, object_name) {
    UseMethod("layout_and_add")
}

#' @export
layout_and_add.QuadLayout <- function(layout, object, object_name) {
    quad_layout_and_add(object, layout, object_name)
}

#' @export
layout_and_add.ChainLayout <- function(layout, object, object_name) {
    chain_layout_and_add(object, layout, object_name)
}

# For objects cannot be used with `-` or `&`
#' @include layout-quad-operator.R
#' @include layout-chain-operator.R
lapply(
    c(
        "quad_layout_subtract", "chain_layout_subtract",
        "quad_layout_and_add", "chain_layout_and_add"
    ),
    function(genname) {
        params <- .subset2(strsplit(genname, "_"), 1L)

        # function argument list
        pairlist <- rlang::pairlist2(object = , layout = , object_name = )
        names(pairlist) <- c("object", .subset(params, 1L), "object_name")
        operator <- switch(.subset(params, 3L),
            subtract = "-",
            and = "&"
        )
        # styler: off
        for (class in c("ggplot", "quad_active", "quad_anno", "layout_title",
                        "layout_theme", "CraftBox", "ChainLayout",
                        "QuadLayout", "continuous_limits")) {
            # styler: on
            registerS3method(
                genname, class,
                rlang::new_function(pairlist, substitute(
                    {
                        cli_abort(c(
                            sprintf(
                                "Cannot add %s with {.code %s}",
                                name, operator
                            ),
                            i = "Try to use {.code +} instead"
                        ))
                    },
                    list(
                        name = switch(class,
                            CraftBox = ,
                            ChainLayout = ,
                            QuadLayout = quote(object_name(object)),
                            # for all others
                            "{.var {object_name}}"
                        ),
                        operator = operator
                    )
                ))
            )
        }
    }
)

#' Modify operated Context in `quad_layout()`
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' The `with_quad()` function modifies the application context of elements in
#' `ggheatmap()`/`quad_layout()`. It controls how objects like themes, scales,
#' or other plot modifications apply to specific annotation stacks or the main
#' plot without altering the currently active layout or plot.
#'
#' @param x An object which can be added to the ggplot, including
#' **schemes**. See [`scheme_align()`], [`scheme_data()`], and
#' [`scheme_theme()`]
#' @param position A string specifying one or more positions-
#' `r oxford_and(.tlbr)`- to indicate the annotation stack context for `x`. If
#' `NULL`, will change the operated context to the `quad_layout()` itself. For
#' default behaivours, see `details` section.
#' @param main A single boolean value indicating whether `x` should apply to the
#' main plot, used only when `position` is not `NULL`. By default, if `position`
#' is `waiver()` and the active context of `quad_layout()` is an annotation
#' stack or the active context of `stack_layout()` is itself, `main` will be set
#' to `TRUE`; otherwise, it defaults to `FALSE`.
#' @return The original object with an added attribute that sets the specified
#' context.
#' @details
#' Default Behavior when adding object wrapped with `with_quad()`:
#'
#' For `quad_layout()` object:
#'
#'  - When `ggheatmap()`/`quad_layout()` has no active annotation stack, objects
#'  added via `+` or `-` operate normally without `with_quad()`.
#'  - When the active annotation stack is set, `with_quad()` ensures the applied
#'  object also modifies:
#'    * The main plot (by default).
#'    * Opposite annotation stacks when using `-`.
#'
#' For `stack_layout()` object:
#'
#'   - When the active layout is the `stack_layout()` itself:
#'     * `-` operator will apply changes to all plots along the
#'         `stack_layout()`, which means if the stack layout is in `horizontal`,
#'         `-` operator will also add the element to the `left` and `right`
#'         annotation, if the stack layout is in `vertical`, `-` operator will
#'         also add element to the `top` and `bottom` annotation.
#'     * `+` operator won't do anything special.
#'   - When the active layout is the nested `ggheatmap()`/`quad_layout()`, the
#'   `+`/`-` operator applies the elements to this nested layout, following the
#'   same principles as for `ggheatmap()`/`quad_layout()`.
#'
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 7)
#'
#' # By wrapping object with `with_quad()`, the `+` operator will apply the
#' # object not only to the active plot in the annotation stack, but also to
#' # the main plot unless specified by `main` argument otherwise.
#' ggheatmap(small_mat) +
#'     # initialize the left annotation
#'     anno_left(size = 0.2) +
#'     align_dendro() +
#'     # apply the object not only to the active plot in the annotation stack,
#'     # but also to the main plot
#'     with_quad(theme(plot.background = element_rect(fill = "red")))
#'
#' # the `-` operator will apply changes not only to the active annotation
#' # stack but also to the opposite one (i.e., bottom if top is active, and
#' # vice versa). The same principle applies to the left and right annotation.
#' ggheatmap(small_mat) +
#'     anno_left(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     # Change the active layout to the left annotation
#'     anno_top(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     anno_bottom(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) -
#'     # Modify the color scale of all plots in the bottom and the opposite
#'     # annotation, in this way, the `main` argument by default would be `TRUE`
#'     with_quad(scale_color_brewer(palette = "Dark2", name = "Top and bottom"))
#'
#' # When the `position` argument is manually set, the
#' # default value of the `main` argument will be `FALSE`.
#' ggheatmap(small_mat) +
#'     anno_left(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     anno_top(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     anno_bottom(size = 0.2) +
#'     align_dendro(aes(color = branch), k = 3L) -
#'     # Modify the background of all plots in the left and top annotation
#'     with_quad(theme(plot.background = element_rect(fill = "red")), "tl")
#' @export
with_quad <- function(x, position = waiver(), main = NULL) {
    UseMethod("with_quad")
}

#' @export
with_quad.default <- function(x, position = waiver(), main = NULL) {
    assert_layout_position(position)
    assert_bool(main, allow_null = TRUE)
    structure(
        list(
            object = x,
            object_name = paste(deparse(substitute(x)), collapse = " "),
            position = position, main = main
        ),
        class = "ggalign_with_quad"
    )
}

#' @export
print.ggalign_with_quad <- function(x, ...) {
    print(.subset2(x, "object"))
    invisible(x)
}

#' @export
with_quad.CraftBox <- function(x, position = waiver(), main = NULL) {
    cli_abort(sprintf("Cannot used with %s", object_name(x)))
}

#' @export
with_quad.layout_title <- function(x, position = waiver(), main = NULL) {
    cli_abort("Cannot used with {.obj_type_friendly {x}}")
}

#' @export
with_quad.layout_theme <- with_quad.layout_title

#' @export
with_quad.layout_annotation <- with_quad.layout_title

#' @export
with_quad.quad_active <- with_quad.layout_title

#' @export
with_quad.quad_anno <- with_quad.layout_title

#' @export
with_quad.stack_switch <- with_quad.layout_title

quad_operated_context <- function(with, active, operator) {
    if (is.waive(ans <- .subset2(with, "position"))) {
        if (operator == "-") {
            # if wrap with `with_quad`
            # we determine the `context` from current actual active position
            if (is.null(active)) {
                ans <- NULL
            } else {
                ans <- c(active, opposite_pos(active))
                if (is.null(main <- .subset2(with, "main")) || main) {
                    ans <- c(ans, list(NULL))
                }
            }
        } else if (operator == "+") {
            ans <- active
            if (!is.null(ans)) {
                if (is.null(main <- .subset2(with, "main")) || main) {
                    ans <- c(ans, list(NULL))
                }
            }
        } else {
            cli_abort("Not implement for {operator}")
        }
    } else if (!is.null(ans)) { # if set manually
        ans <- setup_pos(ans)
        if (!is.null(main <- .subset2(with, "main")) && main) {
            ans <- c(ans, list(NULL))
        }
    }
    ans
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.ggalign_with_quad <- function(object, plot, object_name, ...) {
    object <- .subset2(object, "object")
    object_name <- .subset2(object, "object_name")
    ggplot_add(object, plot, object_name)
}

#' Returns a list of guide boxes collected from all plots.
#' Each element in the list corresponds to a specific position, containing a
#' sub-list of guide boxes, where each guide box represents a single plot.
#' @noRd
collect_guides_list <- function(guides_list, empty = NULL) {
    ans <- lapply(c(.TLBR, "inside"), function(guide_pos) {
        guides <- lapply(guides_list, function(guides) {
            # IF no guide-box, a single `zeroGrob()` will be given
            # here, we regard each position is a `zeroGrob()`
            if (is_null_grob(guides)) return(list(guides)) # styler: off
            o <- .subset2(guides, guide_pos)
            # A guide-box should be a `zeroGrob()` or a `gtable` object
            if (maybe_guide_box(o)) {
                return(list(o))
            }
            # For other grobs, we just removed them silently
            if (is.grob(o)) {
                list(NULL)
            } else if (is.list(o)) {
                o[
                    vapply(o, maybe_guide_box,              # styler: off
                        logical(1L), USE.NAMES = FALSE      # styler: off
                    )
                ]
            } else {
                list(NULL)
            }
        })
        guides <- unlist(guides, FALSE, FALSE)
        guides <- guides[
            !vapply(guides, is.null, logical(1L), USE.NAMES = FALSE)
        ]
        if (is_empty(guides)) empty else guides
    })
    names(ans) <- c(.TLBR, "inside")
    ans[!vapply(ans, is.null, logical(1L), USE.NAMES = FALSE)]
}

#' @param guides A list of guide-box
#' @importFrom ggplot2 zeroGrob
#' @importFrom gtable gtable gtable_add_grob
#' @noRd
assemble_guides <- function(guides, guide_pos, theme) {
    if (guide_pos == "inside") {
        # for `zeroGrob()`, it doesn't record the `viewport` information
        # used to identify the inside guide groups, we just removed them
        guides <- guides[
            !vapply(guides, is_null_grob, logical(1L), USE.NAMES = FALSE)
        ]
        if (is_empty(guides)) {
            guide_box <- zeroGrob()
        } else {
            positions <- justs <- vector("list", length(guides))
            for (i in seq_along(guides)) {
                guide <- .subset2(guides, i)
                # for inside guides, it may contain multiple guide-box
                is_box <- grepl("guide-box-inside", guide$layout$name)
                if (any(is_box)) {
                    guides[[i]] <- guide$grobs[is_box]
                } else {
                    guides[[i]] <- list(guide)
                }
                positions[[i]] <- lapply(guides[[i]], function(guide_box) {
                    unit.c(guide_box$vp$x, guide_box$vp$y)
                })
                justs[[i]] <- lapply(guides[[i]], function(guide_box) {
                    guide_box$vp$justification
                })
            }
            guides <- unlist(guides, FALSE, FALSE)
            groups <- data_frame0(
                positions = unlist(positions, FALSE, FALSE),
                justs = unlist(justs, FALSE, FALSE)
            )
            groups <- vec_group_loc(groups)
            index <- vec_seq_along(groups)

            # pakcage each group into a guide-box
            box_list <- vector("list", vec_size(index))
            for (i in index) {
                box_list[[i]] <- assemble_box(
                    guides[groups$loc[[i]]], guide_pos,
                    theme = theme + theme(
                        legend.position.inside = groups$key$positions[[i]],
                        legend.justification.inside = groups$key$justs[[i]]
                    )
                )
            }
            if (vec_size(box_list) > 1L) {
                guide_box <- gtable(unit(1L, "npc"), unit(1L, "npc"))
                guide_box <- gtable_add_grob(
                    guide_box, box_list,
                    t = 1L, l = 1L, clip = "off",
                    name = paste("guide-box-collected-inside", index, sep = "-")
                )
            } else {
                guide_box <- box_list[[1L]]
            }
        }
    } else {
        guide_box <- assemble_box(guides, guide_pos, theme = theme)
    }
    guide_box
}

#' @param guides A list of guide-box
#' @importFrom rlang try_fetch
#' @importFrom ggplot2 zeroGrob
#' @noRd
assemble_box <- function(guides, guide_pos, theme) {
    guides <- guides[
        !vapply(guides, is_null_grob, logical(1L), USE.NAMES = FALSE)
    ]
    if (is_empty(guides)) {
        zeroGrob()
    } else {
        # Remove the guide box background
        grobs <- lapply(guides, function(box) {
            box$grobs[grepl("guides", box$layout$name)]
        })
        grobs <- unlist(grobs, FALSE, FALSE)

        # remove duplicated guides
        grobs <- collapse_guides(grobs)
        if (is_empty(grobs)) return(zeroGrob()) # styler: off
        # for every position, collect all individual guides and arrange them
        # into a guide box which will be inserted into the main gtable
        package_box <- try_fetch(
            .subset2(ggfun("Guides"), "package_box"),
            error = function(cnd) package_box
        )
        package_box(grobs, guide_pos, theme)
    }
}

# The following code was used in earlier versions of ggplot2;
# coverage is not calculated here.
# nocov start
#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @importFrom ggplot2 calc_element
#' @importFrom grid valid.just editGrob viewport
package_box <- function(guides, guide_pos, theme) {
    theme <- complete_guide_theme(guide_pos, theme)
    guides <- guides_build(guides, theme)

    # Set the justification of the legend box
    # First value is xjust, second value is yjust
    just <- valid.just(calc_element("legend.justification", theme))
    xjust <- just[1L]
    yjust <- just[2L]
    guides <- editGrob(guides,
        vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust))
    )
    guides <- gtable_add_rows(guides, unit(yjust, "null"))
    guides <- gtable_add_rows(guides, unit(1L - yjust, "null"), 0L)
    guides <- gtable_add_cols(guides, unit(xjust, "null"), 0L)
    guides <- gtable_add_cols(guides, unit(1L - xjust, "null"))
    guides
}

#' @importFrom gtable gtable_width gtable_height gtable gtable_add_grob
#' @importFrom grid editGrob heightDetails widthDetails valid.just unit.c unit
#' @importFrom ggplot2 margin element_grob element_blank calc_element element_render
guides_build <- function(guides, theme) {
    legend.spacing.y <- .subset2(theme, "legend.spacing.y")
    legend.spacing.x <- .subset2(theme, "legend.spacing.x")
    legend.box.margin <- calc_element("legend.box.margin", theme) %||%
        margin()
    widths <- do.call(`unit.c`, lapply(guides, gtable_width))
    heights <- do.call(`unit.c`, lapply(guides, gtable_height))

    just <- valid.just(.subset2(theme, "legend.box.just"))
    xjust <- just[1]
    yjust <- just[2]
    vert <- identical(.subset2(theme, "legend.box"), "horizontal")
    guides <- lapply(guides, function(g) {
        editGrob(g, vp = viewport(
            x = xjust, y = yjust, just = c(xjust, yjust),
            height = if (vert) heightDetails(g) else 1,
            width = if (!vert) widthDetails(g) else 1
        ))
    })
    guide_ind <- seq(by = 2, length.out = length(guides))
    sep_ind <- seq(2, by = 2, length.out = length(guides) - 1)
    if (vert) {
        heights <- max(heights)
        if (length(widths) != 1) {
            w <- unit(rep_len(0, length(widths) * 2 - 1), "mm")
            w[guide_ind] <- widths
            w[sep_ind] <- legend.spacing.x
            widths <- w
        }
    } else {
        widths <- max(widths)
        if (length(heights) != 1) {
            h <- unit(rep_len(0, length(heights) * 2 - 1), "mm")
            h[guide_ind] <- heights
            h[sep_ind] <- legend.spacing.y
            heights <- h
        }
    }
    widths <- unit.c(legend.box.margin[4], widths, legend.box.margin[2])
    heights <- unit.c(legend.box.margin[1], heights, legend.box.margin[3])
    guides <- gtable_add_grob(
        gtable(widths, heights, name = "guide-box"),
        guides,
        t = 1 + if (!vert) guide_ind else 1,
        l = 1 + if (vert) guide_ind else 1,
        name = "guides"
    )
    gtable_add_grob(
        guides,
        element_render(theme, "legend.box.background"),
        t = 1, l = 1, b = -1, r = -1,
        z = -Inf, clip = "off", name = "legend.box.background"
    )
}

#' @importFrom ggplot2 calc_element
complete_guide_theme <- function(guide_pos, theme) {
    if (guide_pos %in% c("top", "bottom")) {
        theme$legend.box <- calc_element("legend.box", theme) %||% "horizontal"
        theme$legend.direction <- calc_element("legend.direction", theme) %||%
            "horizontal"
        theme$legend.box.just <- calc_element("legend.box.just", theme) %||%
            c("center", "top")
    } else {
        theme$legend.box <- calc_element("legend.box", theme) %||% "vertical"
        theme$legend.direction <- calc_element("legend.direction", theme) %||%
            "vertical"
        theme$legend.box.just <- calc_element("legend.box.just", theme) %||%
            c("left", "top")
    }
    theme
}
# nocov end

################################################################ 3
# Copied from patchwork
collapse_guides <- function(guides) {
    unnamed <- lapply(guides, unname_grob)
    for (i in rev(seq_along(unnamed)[-1])) {
        for (j in seq_len(i - 1)) {
            if (isTRUE(all.equal(unnamed[[i]], unnamed[[j]],
                check.names = FALSE, check.attributes = FALSE
            ))) {
                guides[i] <- NULL
                break
            }
        }
    }
    guides
}

#' @importFrom grid is.unit absolute.size
unname_vp <- function(x) {
    if (inherits(x, "vpTree")) {
        x$parent <- unname_vp(x$parent)
        x$children <- lapply(x$children, unname_vp)
    } else if (inherits(x, "viewport")) {
        x$name <- ""
        if (!is.null(x$layout$widths)) {
            x$layout$widths <- absolute.size(x$layout$widths)
        }
        if (!is.null(x$layout$heights)) {
            x$layout$heights <- absolute.size(x$layout$heights)
        }
    }
    unit_elements <- vapply(x, is.unit, logical(1), USE.NAMES = FALSE)
    x[unit_elements] <- lapply(.subset(x, unit_elements), absolute.size)
    x
}

#' @importFrom grid is.grob is.unit absolute.size
#' @importFrom gtable is.gtable
unname_grob <- function(x) {
    if (is.gtable(x)) {
        x$name <- ""
        x$rownames <- NULL
        x$vp <- unname_vp(x$vp)
        names(x$grobs) <- NULL
        x$grobs <- lapply(x$grobs, unname_grob)
    } else if (is.grob(x)) {
        x$name <- ""
        x$vp <- unname_vp(x$vp)
        x$children <- unname(lapply(x$children, unname_grob))
        x$childrenOrder <- rep_len("", length(x$childrenOrder))
    }
    unit_elements <- vapply(x, is.unit, logical(1), USE.NAMES = FALSE)
    x[unit_elements] <- lapply(.subset(x, unit_elements), absolute.size)
    x
}

#' Rasterize the ggplot layers
#'
#' The function rasterizes input graphical objects (e.g., grob, layer, ggplot)
#' and optionally processes the resulting raster using magick, a powerful image
#' manipulation library. This allows for advanced graphical transformations
#' directly within the plotting pipeline.
#'
#' @param x An object to rasterize, can be a [`grob()`][grid::grob],
#' [`layer()`][ggplot2::layer], [`ggplot()`][ggplot2::ggplot], or a list of such
#' objects.
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams magickGrob
#' @examples
#' # Currently, `magick` package require R >= 4.1.0
#' if (requireNamespace("magick")) {
#'     # data generated code was copied from `ComplexHeatmap`
#'     set.seed(123)
#'     small_mat <- matrix(rnorm(56), nrow = 7)
#'     rownames(small_mat) <- paste0("row", seq_len(nrow(small_mat)))
#'     colnames(small_mat) <- paste0("column", seq_len(ncol(small_mat)))
#'     ggheatmap(small_mat, aes(.x, .y), filling = NULL) +
#'         raster_magick(geom_tile(aes(fill = value)), res = 20)
#'
#'     ggheatmap(small_mat, aes(.x, .y), filling = NULL) +
#'         # Use `magick::filter_types()` to check available `filter` arguments
#'         raster_magick(
#'             geom_tile(aes(fill = value)),
#'             magick = function(image) {
#'                 magick::image_resize(image,
#'                     geometry = "50%x", filter = "Lanczos"
#'                 )
#'             }
#'         )
#' }
#' @return An object with the same class of the input.
#' @seealso [`magickGrob()`]
#' @export
raster_magick <- function(x, magick = NULL, ...,
                          res = NULL, interpolate = FALSE,
                          vp = NULL) {
    rlang::check_installed("magick", "to use `raster_magick()`")
    if (!is.null(magick) && !is.function(magick <- allow_lambda(magick))) {
        cli_abort("{.arg magick} must be a function")
    }
    assert_number_whole(res, min = 1, allow_null = TRUE)
    assert_bool(interpolate)
    raster_magick0(
        x = x, ..., magick = magick,
        res = res, interpolate = interpolate,
        vp = vp
    )
}

# Used to do the actual process, but won't check the arguments
#' @keywords internal
raster_magick0 <- function(x, ...) {
    UseMethod("raster_magick0")
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
raster_magick0.Layer <- function(x, ...) {
    ggproto(
        NULL, x,
        draw_geom = function(self, data, layout) {
            grobs <- ggproto_parent(x, self)$draw_geom(data, layout)
            if (!inherits(layout$coord, "CoordCartesian")) {
                cli_warn(
                    "{.fn raster_magick} only works with {.fn coord_cartesian}."
                )
                return(grobs)
            }
            raster_magick0(grobs, ...)
        }
    )
}

#' @export
raster_magick0.ggplot <- function(x, ...) {
    x$layers <- lapply(x$layers, raster_magick0, ...)
    x
}

#' @export
raster_magick0.list <- function(x, ...) lapply(x, raster_magick0, ...)

#' @export
raster_magick0.grob <- function(x, magick = NULL, ...,
                                res = NULL, interpolate = FALSE,
                                vp = NULL) {
    rlang::check_dots_empty()
    magickGrob0(
        grob = x, magick = magick,
        res = res, interpolate = interpolate, vp = vp
    )
}

#' @export
raster_magick0.gList <- raster_magick0.grob

#' @export
raster_magick0.default <- function(x, ...) {
    cli_abort("Cannot rasterize {.obj_type_friendly {x}}")
}

#' Create a Circular Layout for Genomic Data
#'
#' `circle_genomic()` constructs a circular layout specifically for genomic
#' data. It is a specialized variant of `circle_continuous()` that applies
#' default axis limits and coerces the first column of each plot’s data to use
#' chromosome (`seqname`) identifiers—matching those in the layout data—as
#' factor levels.
#'
#' @param data The input data, which can be:
#'   - A `character` string ("hg19" or "hg38") to load a predefined cytoband
#'     reference.
#'   - A `data.frame` with at least three columns: `chromosome`, `start`, and
#'     `end` positions.
#'   - A genomic object convertible via `fortify_data_frame()`.
#' @param ... Additional arguments passed to specific methods or
#' `fortify_data_frame()`.
#' @inheritParams circle_continuous
#' @return A `circle_layout` object representing the genomic layout.
#' @export
circle_genomic <- function(data, ..., radial = NULL,
                           direction = "outward",
                           sector_spacing = NULL,
                           theme = NULL) {
    UseMethod("circle_genomic")
}

#' @export
circle_genomic.NULL <- function(data, ...) {
    cli_abort("{.arg data} must be provided to initialize `circle_genomic()`")
}

#' @export
circle_genomic.waiver <- circle_genomic.NULL

#' @export
circle_genomic.character <- function(data, ...) {
    data <- arg_match0(data, c("hg19", "hg38"))
    data <- readRDS(
        pkg_extdata(
            switch(data,
                hg19 = "ref_cytoband_hg19.rds",
                hg38 = "ref_cytoband_hg38.rds"
            ),
            mustWork = TRUE
        )
    )
    circle_genomic(data, ...)
}

#' @export
#' @keywords internal
circle_genomic.data.frame <- function(data, ..., radial = NULL,
                                      direction = "outward",
                                      sector_spacing = NULL,
                                      theme = NULL) {
    rlang::check_dots_empty()
    if (ncol(data) < 3L) {
        cli_abort("{.arg data} must have at least 3 columns: chromosome, start, and end")
    }
    if (anyNA(data[[1L]]) || anyNA(data[[2L]]) || anyNA(data[[3L]])) {
        cli_abort("Columns 1, 2, and 3 of {.arg data} must not contain missing values")
    }
    if (!is.numeric(data[[2L]]) || !is.numeric(data[[3L]])) {
        cli_abort("Columns 2 and 3 of {.arg data} must be numeric (start and end positions)")
    }
    if (any(data[[2L]] > data[[3L]])) {
        cli_abort("Column 2 (start) must not be greater than column 3 (end) in any row of {.arg data}")
    }
    data[[1L]] <- as.factor(data[[1L]])
    # seqnames, start, end
    # Special considerations for `data.table`, we cannot use `data[1:2]`
    groups <- vec_split(
        data.frame(start = data[[2L]], end = data[[3L]]),
        data[[1L]]
    )
    ranges <- lapply(
        .subset2(groups, "val"),
        function(d) genomic_range(.subset2(d, 1L), .subset2(d, 2L))
    )
    lvls <- levels(data[[1L]])
    names(ranges) <- .subset2(groups, "key")
    ranges <- ranges[lvls]
    limits <- continuous_limits(!!!ranges)
    ranges <- vec_rbind(!!!ranges, .names_to = "seqnames")
    ranges$seqnames <- factor(ranges$seqnames, levels = lvls)
    new_circle_layout(
        data = ggalign_data_set(data, seqnames = lvls, ranges = ranges),
        design = limits,
        radial = radial, direction = direction,
        sector_spacing = sector_spacing,
        schemes = default_schemes(data), theme = theme,
        name = "circle_genomic"
    )
}

#' @export
circle_genomic.default <- function(data, ..., radial = NULL,
                                   direction = "outward",
                                   sector_spacing = NULL,
                                   theme = NULL) {
    data <- fortify_data_frame(data = data, ...)
    circle_genomic(data,
        radial = radial, direction = direction,
        sector_spacing = sector_spacing, theme = theme
    )
}

genomic_range <- function(start, end) {
    if (length(start) == 1) return(c(start = start, end = end)) # styler: off
    ordering <- order(start)
    s <- start[ordering[1L]]
    e <- end[ordering[1L]]
    for (i in ordering[-1L]) {
        if (start[ordering[i]] - e > 1) {
            cli_abort("Input genomic ranges cannot contain intervals")
        }
        e <- end[ordering[i]]
    }
    c(start = s, end = e)
}

#' @export
chain_decorate.CircleLayout <- function(layout, plot) {
    if (!identical(layout@name, "circle_genomic")) {
        return(plot)
    }
    if (is.data.frame(data <- plot$data)) {
        data[[1L]] <- factor(
            data[[1L]],
            levels = ggalign_attr(layout@data, "seqnames")
        )
        missing <- is.na(data[[1L]])
        if (any(missing)) {
            cli_warn("Removing {.val {sum(missing)}} rows contain missing {.field seqnames}")
            data <- vec_slice(data, !missing)
        }
        plot$data <- data
    }
    plot
}

#' Polar coordinates with Facet support
#'
#' Draw each panel in a sector of the polar coordinate system. If
#' `facet_sector()` is used in a ggplot, the coordinate system must be created
#' with [`coord_circle()`] or [`coord_radial()`][ggplot2::coord_radial].
#'
#' @inheritParams ggplot2::facet_wrap
#' @param sector_spacing The size of spacing between different panel. A numeric
#' of the radians or a [`rel()`][ggplot2::rel] object.
#' @param radial `r lifecycle::badge("deprecated")` Please add the coordinate
#' system directly to the ggplot instead.
#' @param spacing_theta `r lifecycle::badge("deprecated")` Please use
#' `sector_spacing` instead.
#' @examples
#' ggplot(mtcars, aes(disp, mpg)) +
#'     geom_point() +
#'     facet_sector(vars(cyl)) +
#'     coord_circle(
#'         start = -0.4 * pi, end = 0.4 * pi, inner.radius = 0.3,
#'         outer.radius = 0.8, expand = TRUE
#'     )
#' @importFrom ggplot2 ggproto
#' @export
facet_sector <- function(facets, sector_spacing = pi / 180, drop = TRUE,
                         radial = deprecated(), spacing_theta = deprecated()) {
    if (packageVersion("ggplot2") > "3.5.2") {
        facets <- ggfun("compact_facets")(facets)
    } else {
        facets <- ggfun("wrap_as_facets_list")(facets)
    }
    if (inherits(sector_spacing, "CoordRadial") ||
        lifecycle::is_present(radial)) {
        lifecycle::deprecate_stop(
            "1.0.2",
            "facet_sector(radial = )",
            details = "Please add the coordinate to the ggplot instead"
        )
    }
    if (lifecycle::is_present(spacing_theta)) {
        lifecycle::deprecate_warn(
            "1.0.2",
            "facet_sector(spacing_theta = )",
            "facet_sector(sector_spacing = )"
        )
        sector_spacing <- spacing_theta
    }

    # @param strip.position By default, the labels are displayed on the
    # `"outer"` of the plot. Allowed values are `r oxford_or(c("outer",
    # "inner"))`
    # strip.position <- arg_match0(strip.position, c("outer", "inner"))
    # strip.position <- switch(strip.position,
    #     outer = "top",
    #     inner = "bottom"
    # )
    # labeller <- ggfun("fix_labeller")(labeller)
    assert_bool(drop)

    # TO-DO: remove this line and update to
    # the next version of ggplot2 (> 3.5.2)
    if (packageVersion("ggplot2") > "3.5.2") {
        dir <- "lt"
    } else {
        dir <- "h"
    }
    ggproto(
        NULL,
        FacetSector,
        sector_spacing = sector_spacing,
        params = list(
            facets = facets,
            free = list(x = TRUE, y = FALSE),
            strip.position = "top",
            drop = drop, ncol = NULL, nrow = 1L,
            space_free = list(x = TRUE, y = FALSE),
            labeller = ggplot2::label_value, dir = dir,
            draw_axes = list(x = TRUE, y = FALSE),
            axis_labels = list(x = TRUE, y = FALSE),
            as.table = TRUE
        )
    )
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.FacetSector <- function(object, plot, object_name, ...) {
    plot <- NextMethod()
    if (!inherits(plot, "ggalign_facet_sector_plot")) {
        plot <- add_class(plot, "ggalign_facet_sector_plot")
    }
    plot
}

#' @importFrom ggplot2 ggplot_build ggproto ggproto_parent
#' @export
ggplot_build.ggalign_facet_sector_plot <- function(plot, ...) {
    if (inherits(plot$facet, "FacetSector")) {
        if (!inherits(plot$coordinates, "CoordRadial")) {
            if (!isTRUE(plot$coordinates$default)) {
                cli_abort(c(
                    paste(
                        "Cannot use {.fn {snake_class(plot$coordinates)}}",
                        "coordinate with {.fn facet_sector}"
                    ),
                    i = "Please use {.fn coord_circle}/{.fn coord_radial} instead"
                ))
            }
            plot$coordinates <- coord_circle()
        }
        ParentLayout <- plot$layout
        plot$layout <- ggproto(
            "FacetSectorLayout", ParentLayout,
            setup_panel_params = function(self) {
                ggproto_parent(ParentLayout, self)$setup_panel_params()
                if (is.null(ggplot2::Facet$setup_panel_params) &&
                    !is.null(self$facet$setup_panel_params)) {
                    self$panel_params <- self$facet$setup_panel_params(
                        self$panel_params, self$coord
                    )
                }
                invisible()
            }
        )
    }
    NextMethod()
}

#' @importFrom rlang inject
#' @importFrom grid gTree editGrob viewport
#' @importFrom ggplot2 ggproto ggproto_parent
FacetSector <- ggproto(
    "FacetSector", ggplot2::FacetWrap,
    setup_panel_params = function(self, panel_params, coord, ...) {
        # total theta for panel area and panel spacing
        arc_theta <- abs(diff(coord$arc))
        sector_spacing <- self$sector_spacing
        if (inherits(sector_spacing, "rel")) {
            sector_spacing <- sector_spacing * arc_theta
        }
        panel_weights <- vapply(panel_params, function(panel_param) {
            abs(diff(.subset2(panel_param, "theta.range")))
        }, numeric(1L), USE.NAMES = FALSE)

        # total theta for panel area
        panel_theta <- arc_theta -
            # substract the number of spacing between panels
            sector_spacing *
                # for the whole circle, arc_theta == 2 * pi
                # there should be as many panels as the number of panel spacing
                if (abs(arc_theta - 2 * pi) < .Machine$double.eps^0.5) {
                    length(panel_weights)
                } else {
                    length(panel_weights) - 1L
                }
        if (panel_theta <= 0L) {
            cli_abort("No panel area, try to reduce {.arg sector_spacing}")
        }

        # re-distribute the arc for each panel
        panel_point <- vec_interleave(
            panel_theta * panel_weights / sum(panel_weights),
            rep_len(sector_spacing, length(panel_weights))
        )
        panel_point <- cumsum(c(coord$arc[1L], utils::head(panel_point, -1L)))
        for (i in seq_along(panel_params)) {
            panel_param <- .subset2(panel_params, i)
            panel_param$arc <- panel_point[i * 2L - 1:0]
            panel_param$bbox <- ggfun("polar_bbox")(
                panel_param$arc, margin = c(0, 0, 0, 0),
                inner_radius = coord$inner_radius
            )
            panel_params[[i]] <- panel_param
        }
        panel_params
    },
    draw_panels = function(self, panels, layout, x_scales, y_scales, ranges,
                           coord, data, theme, params) {
        # merge different sector into one panel
        bbox <- ggfun("polar_bbox")(
            coord$arc, margin = c(0, 0, 0, 0),
            inner_radius = coord$inner_radius
        )
        for (i in seq_along(panels)) {
            panel_param <- .subset2(ranges, i)
            vp <- list(
                x = scales::rescale(panel_param$bbox$x, from = bbox$x),
                y = scales::rescale(panel_param$bbox$y, from = bbox$y)
            )
            panels[[i]] <- editGrob(
                .subset2(panels, i),
                vp = viewport(
                    x = vp$x[1L], y = vp$y[1L],
                    width = abs(diff(vp$x)),
                    height = abs(diff(vp$y)),
                    just = c(0, 0),
                    clip = "off",
                    default.units = "native"
                )
            )
        }
        panels <- gTree(children = inject(gList(!!!panels)))
        ranges <- lapply(ranges, function(panel_param) {
            panel_param$arc <- coord$arc
            panel_param$bbox <- bbox
            panel_param
        })
        ggplot2::FacetNull$draw_panels(
            panels = list(panels),
            layout = layout, x_scales = x_scales, y_scales = y_scales,
            ranges = ranges, coord = coord, data = data,
            theme = theme, params = params
        )
    }
)

#' Add a plot to connect selected observations
#'
#' @param link A [`link_draw()`] object that defines how to draw the links,
#'   such as [`link_line()`].
#' @param on_top A boolean value indicating whether to draw the link on top of
#'   the plot panel (`TRUE`) or below (`FALSE`).
#' @inheritParams cross_none
#' @inheritParams ggmark
#'
#' @section ggplot2 Specification:
#' The `cross_link` function initializes a `ggplot` object but does not
#' initialize any data. Using [`scheme_data()`] to change the internal data if
#' needed.
#'
#' @export
cross_link <- function(link, data = waiver(), ...,
                       on_top = TRUE, obs_size = 1,
                       inherit_index = NULL, inherit_panel = NULL,
                       inherit_nobs = NULL,
                       size = NULL, active = NULL) {
    if (!inherits(link, "ggalign_link_draw")) {
        cli_abort("{.arg link} must be a {.fn link_draw} object")
    }
    assert_obs_size(obs_size)
    assert_active(active)
    active <- update_active(active, new_active(use = TRUE))
    cross(CrossLink,
        data = data, data_params = list2(...),
        link = link, obs_size = obs_size,
        plot = ggplot(), size = size,
        schemes = default_schemes(),
        active = active,
        on_top = on_top,
        inherit_nobs = inherit_nobs,
        inherit_panel = inherit_panel,
        inherit_index = inherit_index
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @importFrom grid gTree
#' @include craft-cross-.R
CrossLink <- ggproto("CrossLink", CraftCross,
    interact_layout = function(self, layout) {
        if (!self$in_linear) { # only used for linear coordinate
            cli_abort(c(
                sprintf(
                    "Cannot add %s to %s",
                    object_name(self), layout_name
                ),
                i = sprintf(
                    "%s can only be used in linear layout",
                    object_name(self)
                )
            ))
        }
        ggproto_parent(CraftCross, self)$interact_layout(layout)
    },
    build_plot = function(self, plot, design, extra_design = NULL,
                          previous_design = NULL) {
        if (is.null(.subset2(previous_design, "nobs"))) {
            cli_abort(
                sprintf(
                    "layout {.field nobs} for %s before %s is not initialized ",
                    self$layout_name, object_name(self)
                )
            )
        }
        if (is.null(.subset2(design, "nobs"))) {
            cli_abort(
                sprintf(
                    "layout {.field nobs} for %s after %s is not initialized ",
                    self$layout_name, object_name(self)
                )
            )
        }

        direction <- self$direction
        position <- self$position

        # parse links --------------------------------------------
        link <- self$link
        design1 <- previous_design
        design2 <- design
        full_data1 <- split(
            seq_len(.subset2(design1, "nobs")),
            .subset2(design1, "panel")
        )
        full_data2 <- split(
            seq_len(.subset2(design2, "nobs")),
            .subset2(design2, "panel")
        )
        links <- .subset2(link, "links")
        # set default links for link_line()
        if (is_empty(links) &&
            inherits(link, "ggalign_link_line") &&
            identical(.subset2(design1, "nobs"), .subset2(design2, "nobs"))) {
            links <- lapply(seq_len(.subset2(design1, "nobs")), function(i) {
                rlang::new_formula(i, i)
            })
            links <- pair_links(!!!links)
        }
        link_index <- make_links_data(
            links,
            design1 = design1, design2 = design2,
            labels1 = self$labels0, labels2 = self$labels
        )
        data_index <- lapply(link_index, function(index) {
            if (is.null(index)) {
                return(NULL)
            }
            hand1 <- .subset2(index, "hand1")
            hand2 <- .subset2(index, "hand2")
            list(
                hand1 = .subset2(design1, "index")[hand1],
                hand2 = .subset2(design2, "index")[hand2]
            )
        })
        plot$ggalign_link_data <- list(
            full_data1 = full_data1,
            full_data2 = full_data2,
            link_index = link_index,
            data_index = data_index,
            direction = direction,
            draw = .subset2(link, "draw"),
            obs_size = self$obs_size
        )
        plot
    },
    finish_plot = function(self, plot, schemes, theme) {
        plot <- plot_add_schemes(plot, schemes)

        # save spacing for usage
        spacing <- calc_element(
            switch_direction(
                self$direction,
                "panel.spacing.y",
                "panel.spacing.x"
            ),
            theme
        ) %||% unit(0, "mm")

        # setup the grob
        grob <- inject(gTree(
            !!!plot$ggalign_link_data,
            spacing1 = spacing,
            spacing2 = spacing,
            cl = "ggalignLinkTree"
        ))
        plot$ggalign_link_data <- NULL

        # insert the grob
        plot <- plot + inset(grob, on_top = self$on_top)
        ggremove_margin(plot, self$direction) + theme_recycle()
    },
    summary = function(self, plot) {
        header <- ggproto_parent(CraftCross, self)$summary(plot)
        c(header, "  Add plot to connect selected observations")
    }
)

# Standalone file: do not edit by hand
# Source: https://github.com/Yunuuuu/standalone/blob/HEAD/R/standalone-pkg.R
# Generated by: usethis::use_standalone("Yunuuuu/standalone", "pkg")
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-pkg.R
# last-updated: 2025-04-10
# license: https://unlicense.org
# imports: [utils]
# ---

# This file contains various helper utilities, including common functions
# used across multiple packages I have developed. Some functions depend on
# other packages that are not listed in Imports, so use them with caution.

# ## Changelog
# 2025-04-10
# - simplify `from_namespace`
#
# 2025-03-30
# - Add `use_github_release`
#
# 2025-03-12
# - Add `from_namespace`
#
# 2025-03-10:
# - Add `on_exit`
#
# 2025-03-08:
# - Add `pkg_extdata`
# - Add `defer`
#
# 2025-03-04:
# - Add `%||%`
#
# 2025-03-03:
# - Add `rd_collect_family`
# - Add `oxford_and`
# - Add `oxford_or`
# - Add `code_quote`
# - Add `oxford_comma`
#
# 2025-02-26:
# - Add `is_installed`
# - Add `install_pkgs`
# - Add `pkg_nm`
# - Add `pkg_namespace`
#
# nocov start

`%||%` <- function(x, y) if (is.null(x)) y else x

is_installed <- local({
    cache <- new.env(parent = emptyenv())
    function(pkg, version = NULL) {
        id <- if (is.null(version)) pkg else paste(pkg, version, sep = ":")
        out <- cache[[id]]
        if (is.null(out)) {
            if (is.null(version)) {
                out <- requireNamespace(pkg, quietly = TRUE)
            } else {
                out <- requireNamespace(pkg, quietly = TRUE) &&
                    utils::packageVersion(pkg) >= version
            }
            assign(id, out, envir = cache, inherits = FALSE)
        }
        out
    }
})

install_pkgs <- function(pkgs) {
    if (is_installed("pak")) {
        getExportedValue("pak", "pkg_install")(pkgs, ask = FALSE)
    } else {
        utils::install.packages(pkgs)
    }
}

pkg_nm <- function() utils::packageName(environment())

pkg_namespace <- function() topenv(environment())

pkg_extdata <- function(..., mustWork = TRUE) {
    system.file("extdata", ..., package = pkg_nm(), mustWork = mustWork)
}

############################################################
# I’m having trouble connecting to GitHub, and it seems that `gert` does not
# respect the proxy settings in my Git config. To work around this, I modified
# `usethis::use_github_release()` to skip the check that relies on the `gert`
# package.
use_github_release <- function(publish = TRUE) {
    usethis_ns <- getNamespace("usethis")
    usethis <- function(fun, ...) {
        get(x = fun, envir = usethis_ns, inherits = FALSE, ...)
    }
    usethis("check_is_package")("use_github_release()")
    tr <- usethis("target_repo")(
        github_get = TRUE,
        ok_configs = c("ours", "fork")
    )
    usethis("check_can_push")(tr = tr, "to create a release")
    dat <- usethis("get_release_data")(tr)
    release_name <- paste(dat$Package, dat$Version)
    tag_name <- sprintf("v%s", dat$Version)
    usethis("kv_line")("Release name", release_name)
    usethis("kv_line")("Tag name", tag_name)
    usethis("kv_line")("SHA", dat$SHA)
    usethis("check_github_has_SHA")(SHA = dat$SHA, tr = tr)
    on_cran <- !is.null(usethis("cran_version")())
    news <- usethis("get_release_news")(
        SHA = dat$SHA, tr = tr, on_cran = on_cran
    )
    gh <- usethis("gh_tr")(tr)
    usethis("ui_bullets")("Publishing {tag_name} release to GitHub")
    release <- gh( # nolint
        "POST /repos/{owner}/{repo}/releases",
        name = release_name,
        tag_name = tag_name,
        target_commitish = dat$SHA,
        body = news,
        draft = !publish
    )
    usethis("ui_bullets")("Release at {.url {release$html_url}}")
    if (!is.null(dat$file)) {
        usethis("ui_bullets")("Deleting {.path {dat$file}}")
        getExportedValue("fs", "file_delete")(dat$file)
    }
    invisible()
}

############################################################
from_namespace <- local({
    namespace <- NULL
    function(package, name, mode = "any") {
        if (is.null(namespace)) namespace <<- getNamespace(package)
        get(x = name, envir = namespace, inherits = FALSE, mode = mode)
    }
})

# Need `rlang` package, can support `quosure`
on_exit <- function(expr, envir = parent.frame(), after = TRUE, add = TRUE) {
    expr <- getExportedValue("rlang", "enquo")(expr)
    defer(
        getExportedValue("rlang", "eval_tidy")(expr),
        envir = envir,
        after = after,
        add
    )
}

# Just like `withr::defer()`, don't depend on `rlang` package
defer <- function(expr, envir = parent.frame(), after = TRUE, add = TRUE) {
    thunk <- as.call(list(function() expr))
    do.call(base::on.exit, list(thunk, add = add, after = after), envir = envir)
}

# utils function to collapse characters ---------------------------
oxford_and <- function(x, code = TRUE, quote = TRUE, sep = ", ") {
    oxford_comma(code_quote(x, code, quote), sep = sep, final = "and")
}

oxford_or <- function(x, code = TRUE, quote = TRUE, sep = ", ") {
    oxford_comma(code_quote(x, code, quote), sep = sep, final = "or")
}

code_quote <- function(x, code = TRUE, quote = TRUE) {
    if (quote) x <- paste0("\"", x, "\"")
    if (code) x <- paste0("`", x, "`")
    x
}

oxford_comma <- function(x, sep = ", ", final = "and") {
    n <- length(x)

    if (n < 2L) return(x) # styler: off

    head <- x[seq_len(n - 1L)]
    last <- x[n]

    head <- paste(head, collapse = sep)

    # Write a or b. But a, b, or c.
    if (n > 2L) {
        paste0(head, sep, final, " ", last)
    } else {
        paste0(head, " ", final, " ", last)
    }
}

# Need `roxygen2` package
#' @description add `@eval rd_collect_family("myfamily")` to the functions in
#' your package. This will automatically generate a section listing all
#' functions tagged with `@family myfamily`.
#' @param family A string specifying the family name.
#' @param section_title A string specifying the section title.
#' @param code_style A boolean indicating whether to apply code formatting
#' to function names.
#' @noRd
rd_collect_family <- function(
    family,
    section_title = paste(family, "family"),
    code_style = TRUE) {
    # get blocks objects from the roxygenize function
    blocks <- NULL
    pos <- sys.nframe()
    while (pos > 0L) {
        if (!is.null(call <- sys.call(-pos))) {
            fn <- eval(.subset2(call, 1L), sys.frame(-(pos + 1L)))
            env <- sys.frame(-pos)
            if (
                identical(fn, getExportedValue("roxygen2", "roxygenize")) &&
                    exists("blocks", envir = env, inherits = FALSE)
            ) {
                blocks <- get("blocks", envir = env, inherits = FALSE)
                break
            }
        }
        pos <- pos - 1L
    }

    # identify the blocks with family of the same tag specified in `family`
    blocks <- blocks[
        vapply(
            blocks,
            function(block) {
                getExportedValue("roxygen2", "block_has_tags")(
                    block,
                    "family"
                ) &&
                    identical(
                        getExportedValue("roxygen2", "block_get_tag_value")(
                            block,
                            "family"
                        ),
                        family
                    )
            },
            logical(1L),
            USE.NAMES = FALSE
        )
    ]
    if (length(blocks) == 0L) return(character()) # styler: off

    # extracted the function name
    funs <- vapply(
        blocks,
        function(block) {
            as.character(.subset2(block$call, 2L))
        },
        character(1L),
        USE.NAMES = FALSE
    )
    if (code_style) {
        items <- sprintf("\\code{\\link[=%s]{%s()}}", funs, funs)
    } else {
        items <- sprintf("\\link[=%s]{%s()}", funs, funs)
    }
    c(
        sprintf("@section %s:", section_title),
        "\\itemize{",
        sprintf("  \\item %s", items),
        "}"
    )
}

# nocov end

#' Plot data Specifications
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' Transforms the plot data. Many functions in this package require a specific
#' data format to align observations, `scheme_data()` helps reformat data frames
#' as needed.
#'
#' @param data A function to transform the plot data before rendering.
#' Acceptable values include:
#'
#' - `NULL`: No action taken.
#' - [`waiver()`][ggplot2::waiver()]: Inherits from the parent layout.
#' - A `function` or purrr-style `formula`: Used to transform the plot data,
#'   which should accept a data frame and return a data frame. You can apply
#'   this after the parent layout `scheme_data` function, using the `inherit`
#'   argument.
#'
#' Use this hook to modify the data for all `geoms` after the layout is created
#' (for matrix data, it has been melted to a long format data frame) but before
#' rendering by `ggplot2`. The returned data must be a data frame for ggplot.
#'
#' @param inherit A single boolean value indicates whether to apply the parent
#' `scheme_data` first and then apply the specified `scheme_data` for the plot.
#' Defaults to `FALSE`.
#'
#' @details
#' Defaults will attempt to inherit from the parent layout if the actual data is
#' inherited from the parent layout, with one exception: `align_dendro()`, which
#' will not inherit the `scheme_data` by default.
#'
#' @export
scheme_data <- function(data, inherit = FALSE) {
    data <- check_scheme_data(data)
    assert_bool(inherit)
    new_scheme_data(data, inherit)
}

new_scheme_data <- function(data = NULL, inherit = FALSE) {
    new_scheme(
        name = "scheme_data",
        list(data = data, inherit = inherit),
        class = "scheme_data"
    )
}

#' @export
inherit_scheme.scheme_data <- function(scheme, pscheme) {
    if (is.null(o <- .subset2(scheme, "data"))) return(scheme) # styler: off
    if (is.waive(o)) return(pscheme) # inherit from parent; styler: off
    if (!is.function(p_function <- .subset2(pscheme, "data"))) {
        return(scheme)
    }
    # if both are function, we check if we should call parent first then call
    # itself
    if (.subset2(scheme, "inherit")) {
        user_scheme_data <- o # current action data function
        scheme$data <- function(data) {
            # we always restore the attached attribute
            ans <- ggalign_data_restore(p_function(data), data)
            user_scheme_data(ans)
        }
    }
    scheme
}

#' @export
plot_add_scheme.scheme_data <- function(plot, scheme) {
    # by default, we won't change the data
    if (!is.null(scheme_data <- .subset2(scheme, "data") %|w|% NULL) &&
        !is.null(raw_data <- plot$data)) {
        # To be compatible with ggplot2, it must be a data frame
        if (!is.null(data <- scheme_data(raw_data)) &&
            !is.waive(data) &&
            !is.data.frame(data)) {
            cli_abort("{.fn scheme_data} must return a {.cls data.frame}")
        }
        plot <- gguse_data(plot, data)
    }
    plot
}

#' Add z-aesthetic for geom_tile
#'
#' @section new aesthetics:
#'  - `z`: the third dimention (in the z direction), use
#'    [`scale_z_continuous()`] to control the ranges.
#'  - `theta`: Angle between x-axis and z-axis.
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::geom_path
#' @aesthetics GeomRect3d
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(81), nrow = 9)
#' rownames(small_mat) <- paste0("row", seq_len(nrow(small_mat)))
#' colnames(small_mat) <- paste0("column", seq_len(ncol(small_mat)))
#' ggheatmap(small_mat,
#'     filling = FALSE,
#'     theme = theme(
#'         legend.box.spacing = unit(10, "mm"),
#'         plot.margin = margin(t = 15, unit = "mm")
#'     )
#' ) +
#'     geom_tile3d(
#'         aes(fill = value, z = value, width = 0.8, height = 0.8),
#'         color = "black"
#'     ) +
#'     scale_fill_viridis_c(
#'         option = "plasma",
#'         breaks = scales::breaks_pretty(3L)
#'     ) +
#'     coord_cartesian(clip = "off")
#'
#' @export
geom_rect3d <- function(mapping = NULL, data = NULL, stat = "identity",
                        position = "identity", ...,
                        lineend = "butt", linejoin = "round", linemitre = 10,
                        na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomRect3d,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list(
            lineend = lineend,
            linejoin = linejoin,
            linemitre = linemitre,
            na.rm = na.rm, ...
        )
    )
}

#' @importFrom ggplot2 ggproto fill_alpha
GeomRect3d <- ggproto(
    "GeomRect3d",
    ggplot2::GeomRect,
    required_aes = c(ggplot2::GeomRect$required_aes, "z"),
    non_missing_aes = c(ggplot2::GeomRect$non_missing_aes, "z", "theta"),
    setup_data = function(self, data, params) {
        theta <- data$theta %||% .subset2(params, "theta")
        if (!is.null(theta) && any(theta <= 0 || theta >= 90)) {
            cli_abort(
                "value mapped to {.field theta} aesthetic must > 0 and < 90."
            )
        }
        data$theta <- theta %||% 60
        ggproto_parent(ggplot2::GeomRect, self)$setup_data(data, params)
    },
    draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                          linejoin = "round", linemitre = 10) {
        data <- setup_3d_data(data)
        # Transform to viewport coords
        coords <- coord$transform(data, panel_params)

        # collapse the gpar value
        data <- .subset2(
            vec_split(
                data[setdiff(names(data), c("x", "y", "width", "height"))],
                .subset2(data, "polygon_id")
            ),
            "val"
        )
        data <- vec_rbind(!!!lapply(data, vec_unique))

        # Draw as grob
        grid::polygonGrob(
            x = coords$x,
            y = coords$y,
            id = coords$polygon_id,
            default.units = "native",
            gp = gpar(
                col = data$colour,
                fill = fill_alpha(data$fill, data$alpha),
                lwd = data$linewidth,
                lty = data$linetype,
                lineend = lineend,
                linejoin = linejoin,
                linemitre = linemitre
            )
        )
    }
)

setup_3d_data <- function(data) {
    data <- vec_slice(
        data,
        order(
            .subset2(data, "xmin"),
            .subset2(data, "ymin"),
            decreasing = TRUE
        )
    )
    coords <- .mapply(
        function(xmin, xmax, ymin, ymax, z, theta, ...) {
            if (z == 0L) {
                # fallback to tile
                data_frame0(
                    x = vec_c(xmin, xmax, xmax, xmin),
                    y = vec_rep_each(c(ymin, ymax), 2L)
                )
            } else {
                offset_x <- z * cos(theta / 180 * pi)
                z_xmin <- xmin + offset_x
                z_xmax <- xmax + offset_x
                offset_y <- z * sin(theta / 180 * pi)
                z_ymin <- ymin + offset_y
                z_ymax <- ymax + offset_y
                data_frame0(
                    x = vec_c(
                        xmin, z_xmin, z_xmax, xmax, xmin, xmin,
                        z_xmin, z_xmin, z_xmin, z_xmax, z_xmax, z_xmin
                    ),
                    y = vec_c(
                        ymin, z_ymin, z_ymin, ymin, ymin, ymax,
                        z_ymax, z_ymin, z_ymax, z_ymax, z_ymin, z_ymin
                    )
                )
            }
        },
        data,
        MoreArgs = NULL
    )
    vec_cbind(
        vec_rbind(!!!coords),
        vec_rep_each(
            data[
                vec_set_difference(
                    names(data),
                    c("x", "xmin", "xmax", "y", "ymin", "ymax", "z")
                )
            ],
            list_sizes(coords)
        ),
        polygon_id = vec_rep_each(seq_along(coords), list_sizes(coords))
    )
}

#' @aesthetics GeomTile3d
#' @importFrom rlang list2
#' @export
#' @rdname geom_rect3d
geom_tile3d <- function(mapping = NULL, data = NULL, stat = "identity",
                        position = "identity", ...,
                        lineend = "butt", linejoin = "round", linemitre = 10,
                        na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomTile3d,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list(
            lineend = lineend,
            linejoin = linejoin,
            linemitre = linemitre,
            na.rm = na.rm, ...
        )
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
GeomTile3d <- ggproto(
    "GeomTile3d",
    ggplot2::GeomTile,
    required_aes = c(ggplot2::GeomTile$required_aes, "z"),
    non_missing_aes = c(ggplot2::GeomTile$non_missing_aes, "z", "theta"),
    setup_data = function(self, data, params) {
        theta <- data$theta %||% .subset2(params, "theta")
        if (!is.null(theta) && any(theta <= 0 || theta >= 90)) {
            cli_abort(
                "value mapped to {.field theta} aesthetic must > 0 and < 90."
            )
        }
        data$theta <- theta %||% 60
        ggproto_parent(ggplot2::GeomTile, self)$setup_data(data, params)
    },
    draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                          linejoin = "round", linemitre = 10) {
        ggproto_parent(GeomRect3d, self)$draw_panel(
            data = data, panel_params = panel_params, coord = coord,
            lineend = lineend, linejoin = linejoin, linemitre = linemitre
        )
    }
)

#' z scales
#'
#' @param ... Other arguments passed on to
#'   [`continuous_scale()`][ggplot2::continuous_scale],
#'   [`binned_scale()`][ggplot2::binned_scale], or
#'   [`discrete_scale()`][ggplot2::discrete_scale] as appropriate, to control
#'   name, limits, breaks, labels and so forth.
#' @param range Output range of z values. Must larger than 0.
#' @inheritParams ggplot2::continuous_scale
#' @seealso [`geom_tile3d()`]/[`geom_rect3d()`]
#' @export
#' @examples
#'
#' set.seed(7)
#' mat <- matrix(runif(100), 10)
#' rownames(mat) <- LETTERS[1:10]
#' colnames(mat) <- letters[1:10]
#' ggheatmap(mat,
#'     filling = FALSE,
#'     theme = theme(
#'         legend.box.spacing = unit(10, "mm"),
#'         plot.margin = margin(t = 15, unit = "mm")
#'     )
#' ) +
#'     geom_tile3d(aes(fill = value, z = value, width = 0.8, height = 0.8)) +
#'     scale_z_continuous(range = c(0.2, 1)) +
#'     coord_cartesian(clip = "off")
#' @export
scale_z_continuous <- function(name = waiver(), ..., range = c(0.1, 1),
                               guide = "none") {
    if (min(range) < 0) {
        cli_abort("{.arg range} must contain only positive values")
    }
    ggplot2::continuous_scale("z",
        name = name, palette = scales::pal_rescale(range), ...,
        guide = guide
    )
}

#' @rdname scale_z_continuous
#' @export
scale_z_binned <- function(name = waiver(), ..., range = c(0.1, 1),
                           guide = "none") {
    if (min(range) < 0) {
        cli_abort("{.arg range} must contain only positive values")
    }
    ggplot2::binned_scale("z",
        name = name, palette = scales::pal_rescale(range), ...,
        guide = guide
    )
}

#' @rdname scale_z_continuous
#' @export
scale_z_discrete <- function(...) {
    cli_warn("Using {z} for a discrete variable is not advised.")
    args <- list2(...)
    args$call <- args$call %||% current_call()
    rlang::exec(scale_z_ordinal, !!!args)
}

#' @rdname scale_z_continuous
#' @export
scale_z_ordinal <- function(name = waiver(), ..., range = c(0.1, 1),
                            guide = "none") {
    if (min(range) < 0) {
        cli_abort("{.arg range} must contain only positive values")
    }
    ggplot2::discrete_scale(
        "z",
        name = name,
        palette = function(n) seq(range[1], range[2], length.out = n),
        ...,
        gudie = guide
    )
}

#' @rdname scale_z_continuous
#' @export
#' @usage NULL
scale_z_datetime <- function(name = waiver(), ..., range = c(0.1, 1),
                             guide = "none") {
    if (min(range) < 0) {
        cli_abort("{.arg range} must contain only positive values")
    }
    ggplot2::datetime_scale(
        aesthetics = "z", transform = "time", name = name,
        palette = scales::pal_rescale(range),
        ..., guide = guide
    )
}

#' @rdname scale_z_continuous
#' @export
#' @usage NULL
scale_z_date <- function(name = waiver(), ..., range = c(0.1, 1),
                         guide = "none") {
    if (min(range) < 0) {
        cli_abort("{.arg range} must contain only positive values")
    }
    ggplot2::datetime_scale(
        aesthetics = "z", transform = "date", name = name,
        palette = scales::pal_rescale(range),
        ..., guide = guide
    )
}

#' Pie charts
#' @section new aesthetics:
#'  - `angle`: the pie circle angle.
#'  - `angle0`: the initial pie circle angle.
#'  - `radius`: the circle radius.
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_polygon
#' @inheritParams ggplot2::geom_path
#' @param steps An integer indicating the number of steps to generate the pie
#' chart radian. Increasing this value results in a smoother pie circular.
#' @param clockwise A single boolean value indicates clockwise or not.
#' @aesthetics GeomPie
#' @examples
#' ggplot(data.frame(x = 1:10, y = 1:10, value = 1:10 / sum(1:10))) +
#'     geom_pie(aes(x, y, angle = value * 360))
#' @export
geom_pie <- function(mapping = NULL, data = NULL, stat = "identity",
                     position = "identity", ...,
                     clockwise = TRUE, steps = 100,
                     lineend = "butt", linejoin = "round", linemitre = 10,
                     na.rm = FALSE,
                     show.legend = NA, inherit.aes = TRUE) {
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomPie,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list(
            lineend = lineend,
            linejoin = linejoin,
            linemitre = linemitre,
            clockwise = clockwise,
            na.rm = na.rm, steps = steps, ...
        )
    )
}

#' @importFrom grid gpar
#' @importFrom ggplot2 ggproto aes resolution fill_alpha
#' @importFrom rlang set_names
GeomPie <- ggproto("GeomPie",
    ggplot2::GeomPolygon,
    default_aes = aes(
        !!!set_names(
            ggplot2::GeomPolygon$default_aes,
            function(nms) {
                nms <- set_names(nms)
                vec_slice(nms, "subgroup") <- "radius"
                nms
            }
        ),
        angle0 = 0
    ),
    non_missing_aes = c("x", "y", "angle", "angle0", "radius"),
    required_aes = c("x", "y", "angle"),
    handle_na = ggplot2::Geom$handle_na,
    setup_params = function(self, data, params) {
        steps <- vec_cast(.subset2(params, "steps"), integer(),
            x_arg = "steps",
            call = call(snake_class(self))
        )
        assert_bool(.subset2(params, "clockwise"),
            arg = "clockwise", call = call(snake_class(self))
        )
        params$steps <- max(steps, 1L) + 1L
        params
    },
    setup_data = function(data, params) {
        # use the same strategy of geom_bar
        data$radius <- data$radius %||%
            params$radius %||% (
                min(
                    vapply(
                        split(data$x, data$PANEL, drop = TRUE),
                        resolution, numeric(1),
                        zero = FALSE,
                        USE.NAMES = FALSE
                    ),
                    vapply(
                        split(data$y, data$PANEL, drop = TRUE),
                        resolution, numeric(1),
                        zero = FALSE,
                        USE.NAMES = FALSE
                    )
                ) * 0.45)
        data
    },
    draw_panel = function(data, panel_params, coord, steps = 100L,
                          clockwise = TRUE, lineend = "butt",
                          linejoin = "round", linemitre = 10) {
        # Expand x, y, radius data to points along circle
        circular_data <- .mapply(
            function(x, y, radius, ang, ang0) {
                if (clockwise) {
                    ang0 <- 90 - ang0
                    radians <- seq(ang0, ang0 - ang, length.out = steps)[-1L]
                } else {
                    ang0 <- 90 + ang0
                    radians <- seq(ang0, ang0 + ang, length.out = steps)[-1L]
                }
                radians <- radians / 180 * pi
                data_frame0(
                    x = c(x, cos(radians) * radius + x),
                    y = c(y, sin(radians) * radius + y)
                )
            },
            list(
                x = data$x, y = data$y,
                radius = data$radius, ang = data$angle, ang0 = data$angle0
            ),
            MoreArgs = NULL
        )
        circular_data <- vec_rbind(!!!circular_data)

        # Transform to viewport coords
        circular_data <- coord$transform(circular_data, panel_params)

        # Draw as grob
        grid::polygonGrob(
            x = circular_data$x,
            y = circular_data$y,
            id.lengths = rep_len(steps, nrow(data)),
            default.units = "native",
            gp = gpar(
                col = data$colour,
                fill = fill_alpha(data$fill, data$alpha),
                lwd = data$linewidth,
                lty = data$linetype,
                lineend = lineend,
                linejoin = linejoin,
                linemitre = linemitre
            )
        )
    }
)

#' @export
ggalign_gtable.ggplot <- function(x) alignpatch(x)$patch_gtable()

#' @export
ggalign_build.ggplot <- function(x) x

##################################################
#' @export
#' @include alignpatch-build.R
print.patch_ggplot <- print.alignpatches

#' @importFrom grid grid.draw
#' @exportS3Method
grid.draw.patch_ggplot <- grid.draw.alignpatches

#################################################
#' @importFrom ggplot2 ggproto
#' @export
alignpatch.ggplot <- function(x) ggproto(NULL, PatchGgplot, plot = x)

# ggplot2 has following grobs:
#    panel
#    axis: must follow panel
#    strip: must follow the panel
#    xlab/ylab: can be aligned or follow the panel
#    subtitle
#    title
#    caption
#    guide: can be collected or kept
#' @importFrom ggplot2 ggplotGrob update_labels
#' @include alignpatch-.R
PatchGgplot <- ggproto("PatchGgplot", Patch,
    set_guides = function(guides) guides,
    patch_gtable = function(self, theme, guides, plot = self$plot) {
        # extract patch titles --------------------------------
        patch_titles <- plot$ggalign_patch_labels

        # complete_theme() will ensure elements exist --------
        theme <- complete_theme(plot$theme)
        # here: we remove tick length when the tick is blank
        theme <- setup_tick_length_element(theme)
        plot$theme <- theme

        # build the grob -------------------------------------
        ans <- ggplotGrob(plot)
        strip_pos <- find_strip_pos(ans)
        # always add strips columns and/or rows
        ans <- add_strips(ans, strip_pos)
        setup_patch_titles(ans, patch_titles = patch_titles, theme = theme)
    },
    respect = function(self, gt = self$gt) .subset2(gt, "respect"),

    #' @importFrom ggplot2 find_panel
    align_panel_sizes = function(self, panel_width, panel_height,
                                 gt = self$gt) {
        panel_pos <- find_panel(gt)
        rows <- c(.subset2(panel_pos, "t"), .subset2(panel_pos, "b"))
        cols <- c(.subset2(panel_pos, "l"), .subset2(panel_pos, "r"))
        respect <- .subset2(gt, "respect")
        if (rows[1L] == rows[2L] && cols[1L] == cols[2L]) {
            if (respect) {
                can_set_width <- is.na(as.numeric(panel_width))
                can_set_height <- is.na(as.numeric(panel_height))
                w <- .subset2(gt, "widths")[LEFT_BORDER + 1L]
                h <- .subset2(gt, "heights")[TOP_BORDER + 1L]
                if (can_set_width && can_set_height) {
                    panel_width <- w
                    panel_height <- h
                } else if (can_set_width) {
                    panel_width <- as.numeric(w) / as.numeric(h) * panel_height
                } else if (can_set_height) {
                    panel_height <- as.numeric(h) / as.numeric(w) * panel_width
                } else {
                    respect <- FALSE
                }
            }
        } else {
            respect <- FALSE
        }
        list(width = panel_width, height = panel_height, respect = respect)
    },

    #' @importFrom gtable gtable_add_grob gtable_height gtable_width
    #' @importFrom grid unit viewport
    #' @importFrom ggplot2 find_panel
    free_border = function(self, borders, gt = self$gt) {
        panel_pos <- find_panel(gt)
        for (border in borders) {
            if (border == "top") {
                gt <- liberate_area(
                    gt,
                    1L,
                    1L,
                    .subset2(panel_pos, "t") - 1L,
                    ncol(gt),
                    clip = "off",
                    name = "free-border-top",
                    vp = ~ viewport(
                        y = 0L, just = "bottom",
                        height = gtable_height(.x)
                    )
                )
            } else if (border == "left") {
                gt <- liberate_area(
                    gt,
                    1L,
                    1L,
                    nrow(gt),
                    .subset2(panel_pos, "l") - 1L,
                    clip = "off",
                    name = "free-border-left",
                    vp = ~ viewport(
                        x = 1L, just = "right",
                        width = gtable_width(.x)
                    )
                )
            } else if (border == "bottom") {
                gt <- liberate_area(
                    gt,
                    .subset2(panel_pos, "b") + 1L,
                    1L,
                    nrow(gt),
                    ncol(gt),
                    clip = "off",
                    name = "free-border-bottom",
                    vp = ~ viewport(
                        y = 1L, just = "top",
                        height = gtable_height(.x)
                    )
                )
            } else if (border == "right") {
                gt <- liberate_area(
                    gt,
                    1L,
                    .subset2(panel_pos, "r") + 1L,
                    nrow(gt),
                    ncol(gt),
                    clip = "off",
                    name = "free-border-right",
                    vp = ~ viewport(
                        x = 0L, just = "left",
                        width = gtable_width(.x)
                    )
                )
            }
        }
        gt
    },
    align_free_border = function(self, borders,
                                 t = NULL, l = NULL, b = NULL, r = NULL,
                                 gt = self$gt) {
        if (is.null(t) && is.null(l) && is.null(b) && is.null(r)) {
            return(gt)
        }
        # For free borders, we also align the margins
        for (border in borders) {
            i <- .subset2(.subset2(gt, "layout"), "name") ==
                sprintf("free-border-%s", border)
            if (any(i)) {
                i <- which(i)
                gt$grobs[[i]] <- switch_position(
                    border,
                    Patch$align_border(l = l, r = r, gt = gt$grobs[[i]]),
                    Patch$align_border(t = t, b = b, gt = gt$grobs[[i]])
                )
            }
        }
        gt
    },

    #' @importFrom ggplot2 find_panel
    #' @importFrom gtable is.gtable gtable_height gtable_width gtable_add_grob
    #' @importFrom grid grobHeight grobWidth viewport
    free_lab = function(self, labs, gt = self$gt) {
        panel_pos <- find_panel(gt)
        for (lab in labs) {
            name <- paste(
                switch_position(lab, "xlab", "ylab"),
                "axis", lab,
                sep = "-"
            )
            if (lab == "top") {
                panel_border <- .subset2(panel_pos, "t")
                gt <- liberate_area(
                    gt,
                    panel_border - 3L,
                    .subset2(panel_pos, "l"),
                    panel_border - 1L,
                    .subset2(panel_pos, "r"),
                    name = name,
                    vp = ~ viewport(
                        y = 0L, just = "bottom",
                        height = gtable_height(.x)
                    )
                )
            } else if (lab == "left") {
                panel_border <- .subset2(panel_pos, "l")
                gt <- liberate_area(
                    gt,
                    .subset2(panel_pos, "t"),
                    panel_border - 3L,
                    .subset2(panel_pos, "b"),
                    panel_border - 1L,
                    name = name,
                    vp = ~ viewport(
                        x = 1L, just = "right",
                        width = gtable_width(.x)
                    )
                )
            } else if (lab == "bottom") {
                panel_border <- .subset2(panel_pos, "b")
                gt <- liberate_area(
                    gt,
                    panel_border + 1L,
                    .subset2(panel_pos, "l"),
                    panel_border + 3L,
                    .subset2(panel_pos, "r"),
                    name = name,
                    vp = ~ viewport(
                        y = 1L, just = "top",
                        height = gtable_height(.x)
                    )
                )
            } else if (lab == "right") {
                panel_border <- .subset2(panel_pos, "r")
                gt <- liberate_area(
                    gt,
                    .subset2(panel_pos, "t"),
                    panel_border + 1L,
                    .subset2(panel_pos, "b"),
                    panel_border + 3L,
                    name = name,
                    vp = ~ viewport(
                        x = 0L, just = "left",
                        width = gtable_width(.x)
                    )
                )
            }
        }
        gt
    }
)

#' @importFrom ggplot2 calc_element
#' @importFrom grid unit
setup_tick_length_element <- function(theme) {
    for (tick in c("x.top", "y.left", "x.bottom", "y.right")) {
        for (axis in c("axis.minor", "axis")) {
            blank <- inherits(calc_element(
                paste(axis, "ticks", tick, sep = "."), theme
            ), "element_blank")
            if (blank) { # No ticks, no length
                element <- paste(axis, "ticks.length", tick, sep = ".")
                theme[[element]] <- unit(0, "mm")
            }
        }
    }
    theme
}

#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @importFrom ggplot2 find_panel
#' @importFrom grid unit
add_strips <- function(gt, strip_pos) {
    panel_loc <- find_panel(gt)
    strip_pos <- switch(strip_pos, inside = 0L, outside = 2L) # styler: off
    layout <- .subset2(gt, "layout")
    if (!any(grepl("strip-b", layout$name))) { # No strips
        gt <- gtable_add_rows(
            gt, unit(0L, "mm"),
            panel_loc$b + strip_pos
        )
    } else if (strip_pos == 2L && !any(layout$b == panel_loc$b + 2L)) {
        # Merge the strip-gap height into the axis and remove it. Only performed
        # if an axis exist
        gt$heights[panel_loc$b + 1L] <- sum(gt$heights[panel_loc$b + 1:2])
        gt <- gt[-(panel_loc$b + 2L), ]
    }
    if (!any(grepl("strip-t", layout$name))) {
        gt <- gtable_add_rows(
            gt, unit(0L, "mm"),
            panel_loc$t - 1L - strip_pos
        )
    } else if (strip_pos == 2L && !any(layout$t == panel_loc$t - 2L)) {
        gt$heights[panel_loc$t - 1L] <- sum(gt$heights[panel_loc$t - 1:2])
        gt <- gt[-(panel_loc$t - 2L), ]
    }
    if (!any(grepl("strip-r", layout$name))) {
        gt <- gtable_add_cols(
            gt, unit(0L, "mm"),
            panel_loc$r + strip_pos
        )
    } else if (strip_pos == 2L && !any(layout$r == panel_loc$r + 2L)) {
        gt$widths[panel_loc$r + 1L] <- sum(gt$widths[panel_loc$r + 1:2])
        gt <- gt[, -(panel_loc$r + 2L)]
    }
    if (!any(grepl("strip-l", layout$name))) {
        gt <- gtable_add_cols(
            gt, unit(0L, "mm"),
            panel_loc$l - 1L - strip_pos
        )
    } else if (strip_pos == 2L && !any(layout$l == panel_loc$l - 2L)) {
        gt$widths[panel_loc$l - 1L] <- sum(gt$widths[panel_loc$l - 1:2])
        gt <- gt[, -(panel_loc$l - 2L)]
    }
    gt
}

# theme(strip.placement)
#' @importFrom ggplot2 find_panel
find_strip_pos <- function(gt) {
    panel_loc <- find_panel(gt)
    layout <- .subset2(gt, "layout")
    nms <- .subset2(layout, "name")
    ind <- grep("strip-t", nms)
    if (length(ind) != 0L && panel_loc$t - min(layout$t[ind]) != 1L) {
        return("outside")
    }
    ind <- grep("strip-l", nms)
    if (length(ind) != 0L && panel_loc$l - min(layout$l[ind]) != 1L) {
        return("outside")
    }
    ind <- grep("strip-r", nms)
    if (length(ind) != 0L && max(layout$r[ind]) - panel_loc$r != 1L) {
        return("outside")
    }
    ind <- grep("strip-b", nms)
    if (length(ind) != 0L && max(layout$b[ind]) - panel_loc$b != 1L) {
        return("outside")
    }
    "inside"
}

#' Subdivide Rectangles
#'
#' @description
#' These geoms subdivide rectangles with shared borders into a grid. Both geoms
#' achieve the same result but differ in how the rectangles are parameterized:
#' - **`geom_subrect()`**: Defines rectangles using their four corners (`xmin`,
#'   `xmax`, `ymin`, `ymax`).
#' - **`geom_subtile()`**: Defines rectangles using the center (`x`, `y`) and
#'   dimensions (`width`, `height`).
#'
#' @param byrow A single boolean value indicates whether we should arrange the
#' divided rectangles in the row-major order.
#' @param nrow,ncol A single positive integer specifying the number of rows or
#' columns in the layout of the subdivided cell. By default, the layout
#' dimensions are determined automatically using logic similar to
#' [`facet_wrap()`][ggplot2::facet_wrap].
#' @param direction `r lifecycle::badge("deprecated")` A string specifying the
#' arrangement direction:
#' - `"h"`(`horizontal`): Creates a single row (one-row layout).
#' - `"v"`(`vertical`): Creates a single column (one-column layout).
#' @inheritParams ggplot2::geom_rect
#' @inheritParams ggplot2::geom_segment
#' @aesthetics GeomSubrect
#' @examples
#' # arranges by row
#' ggplot(data.frame(value = letters[seq_len(5)])) +
#'     geom_subtile(aes(x = 1, y = 1, fill = value), byrow = TRUE)
#'
#' # arranges by column
#' ggplot(data.frame(value = letters[seq_len(9)])) +
#'     geom_subtile(aes(x = 1, y = 1, fill = value))
#'
#' # one-row
#' ggplot(data.frame(value = letters[seq_len(4)])) +
#'     geom_subtile(aes(x = 1, y = 1, fill = value), nrow = 1)
#'
#' # one-column
#' ggplot(data.frame(value = letters[seq_len(4)])) +
#'     geom_subtile(aes(x = 1, y = 1, fill = value), ncol = 1)
#'
#' @importFrom rlang list2
#' @export
geom_subrect <- function(mapping = NULL, data = NULL,
                         stat = "identity", position = "identity",
                         ...,
                         byrow = FALSE, nrow = NULL, ncol = NULL,
                         lineend = "butt", linejoin = "mitre",
                         na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
                         direction = deprecated()) {
    assert_bool(byrow)
    assert_number_whole(nrow, min = 1, allow_null = TRUE)
    assert_number_whole(ncol, min = 1, allow_null = TRUE)
    if (lifecycle::is_present(direction)) {
        lifecycle::deprecate_warn(
            "1.0.2",
            "geom_subtile(direction = )",
            details = "Please use the `nrow`/`ncol` argument instead."
        )
        if (is_horizontal(direction)) {
            nrow <- 1L
            ncol <- NULL
        } else {
            nrow <- NULL
            ncol <- 1L
        }
    }
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomSubrect,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list2(
            byrow = byrow,
            nrow = nrow,
            ncol = ncol,
            lineend = lineend,
            linejoin = linejoin,
            na.rm = na.rm,
            ...
        )
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent wrap_dims
GeomSubrect <- ggproto(
    "GeomSubrect",
    ggplot2::GeomRect,
    extra_params = c(ggplot2::GeomRect$extra_params, "byrow", "nrow", "ncol"),
    setup_data = function(self, data, params) {
        data <- ggproto_parent(ggplot2::GeomRect, self)$setup_data(data, params)
        indices <- vec_group_loc(data[c("xmin", "xmax", "ymin", "ymax")])
        data_list <- vec_chop(data, indices = .subset2(indices, "loc"))
        max_n_tiles <- max(list_sizes(data_list))
        if (max_n_tiles == 1L) return(data) # styler: off
        cli_inform(paste(
            "{.fn {snake_class(self)}} subdivide tile into a maximal",
            "of {max_n_tiles} rectangles"
        ))
        nrow <- .subset2(params, "nrow")
        ncol <- .subset2(params, "ncol")
        vec_rbind(!!!lapply(data_list, function(data) {
            n <- vec_size(data)
            if (n == 1L) return(data) # styler: off
            dims <- wrap_dims(n, nrow = nrow, ncol = ncol)
            n_rows <- dims[1L]
            n_cols <- dims[2L]
            one_row <- vec_slice(data, 1L)
            width <- (one_row$xmax - one_row$xmin) / n_cols
            height <- (one_row$ymax - one_row$ymin) / n_rows

            if (.subset2(params, "byrow")) {
                # we arrange the rectangles from from left to
                # right, then from top to bottom
                data$xmin <- data$xmin +
                    vec_rep(width * (seq_len(n_cols) - 1L), n_rows)[
                        seq_len(n)
                    ]
                data$xmax <- data$xmax -
                    vec_rep(width * rev(seq_len(n_cols) - 1L), n_rows)[
                        seq_len(n)
                    ]

                data$ymin <- data$ymin +
                    vec_rep_each(height * rev(seq_len(n_rows) - 1L), n_cols)[
                        seq_len(n)
                    ]
                data$ymax <- data$ymax -
                    vec_rep_each(height * (seq_len(n_rows) - 1L), n_cols)[
                        seq_len(n)
                    ]
            } else {
                # we arrange the rectangles from top to bottom,
                # then from left to right
                data$xmin <- data$xmin +
                    vec_rep_each(width * (seq_len(n_cols) - 1L), n_rows)[
                        seq_len(n)
                    ]
                data$xmax <- data$xmax -
                    vec_rep_each(width * rev(seq_len(n_cols) - 1L), n_rows)[
                        seq_len(n)
                    ]

                data$ymin <- data$ymin +
                    vec_rep(height * rev(seq_len(n_rows) - 1L), n_cols)[
                        seq_len(n)
                    ]
                data$ymax <- data$ymax -
                    vec_rep(height * (seq_len(n_rows) - 1L), n_cols)[
                        seq_len(n)
                    ]
            }

            data
        }))
    }
)

#' @aesthetics GeomSubtile
#' @importFrom rlang list2
#' @export
#' @rdname geom_subrect
geom_subtile <- function(mapping = NULL, data = NULL,
                         stat = "identity", position = "identity",
                         ...,
                         byrow = TRUE, nrow = NULL, ncol = NULL,
                         lineend = "butt", linejoin = "mitre",
                         na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
                         direction = deprecated()) {
    assert_bool(byrow)
    assert_number_whole(nrow, min = 1, allow_null = TRUE)
    assert_number_whole(ncol, min = 1, allow_null = TRUE)
    if (lifecycle::is_present(direction)) {
        lifecycle::deprecate_warn(
            "1.0.2",
            "geom_subtile(direction = )",
            details = "Please use the `nrow`/`ncol` argument instead."
        )
        if (is_horizontal(direction)) {
            nrow <- 1L
            ncol <- NULL
        } else {
            nrow <- NULL
            ncol <- 1L
        }
    }
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomSubtile,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list2(
            byrow = byrow,
            nrow = nrow,
            ncol = ncol,
            lineend = lineend,
            linejoin = linejoin,
            na.rm = na.rm,
            ...
        )
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
GeomSubtile <- ggproto(
    "GeomSubtile",
    ggplot2::GeomTile,
    extra_params = c(ggplot2::GeomRect$extra_params, "byrow", "nrow", "ncol"),
    setup_data = function(self, data, params) {
        data <- ggproto_parent(ggplot2::GeomTile, self)$setup_data(data, params)
        ggproto_parent(GeomSubrect, self)$setup_data(data, params)
    }
)

#########################################################
#' Determine the active context of circle layout
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams circle_discrete
#' @param what What should get activated for the [`circle_layout()`]?
#' `r rd_chain_what()`.
#' @return A `circle_switch` object which can be added to [`circle_layout()`].
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 7)
#' rownames(small_mat) <- paste0("row", seq_len(nrow(small_mat)))
#' colnames(small_mat) <- paste0("column", seq_len(ncol(small_mat)))
#' circle_discrete(small_mat) +
#'     ggalign() +
#'     geom_tile(aes(y = .column_index, fill = value)) +
#'     scale_fill_viridis_c() +
#'     align_dendro(aes(color = branch), k = 3L) +
#'     scale_color_brewer(palette = "Dark2")
#' @export
circle_switch <- function(radial = waiver(), direction = NULL,
                          what = waiver(), ...) {
    rlang::check_dots_empty()
    if (!is.waive(radial) && !is.null(radial)) {
        assert_s3_class(radial, "CoordRadial")
        if (abs(diff(radial$arc)) < pi / 2L) {
            cli_abort("Cannot use circle of acute angle < 90 in {.arg radial}")
        }
    }
    if (!is.null(direction)) {
        direction <- arg_match0(direction, c("inward", "outward"))
    }
    if (!is.waive(what)) what <- check_stack_context(what)
    structure(list(what = what, radial = radial, direction = direction),
        class = "circle_switch"
    )
}

#' Layer with Grid or Function
#'
#' Draw a ggplot2 layer using a grob or a function.
#'
#' @param draw Either a [grob][grid::grob] object or a function (can be
#'   purrr-style) that accepts at least one argument (a data frame of
#'   transformed coordinates) and returns a [grob][grid::grob].
#'
#' @param type A single string of `r oxford_or(c("group", "panel"))`, `"group"`
#'   draws geoms with `draw_group`, which displays multiple observations as one
#'   geometric object, and `"panel"` draws geoms with `draw_panel`, displaying
#'   individual graphical objects for each observation (row). Default:
#'   `"group"`.
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @details If you want to combine the functionality of multiple geoms, it can
#'   typically be achieved by preparing the data for each geom inside the
#'   `draw_*()` call and sending it off to the different geoms, collecting the
#'   output in a [`grid::gList`] (a list of grobs) for `draw_group()` or a
#'   [`grid::gTree`] (a grob containing multiple child grobs) for
#'   `draw_panel()`.
#' @seealso <https://ggplot2.tidyverse.org/reference/ggplot2-ggproto.html>
#' @examples
#' text <- grid::textGrob(
#'     "ggdraw",
#'     x = c(0, 0, 0.5, 1, 1),
#'     y = c(0, 1, 0.5, 0, 1),
#'     hjust = c(0, 0, 0.5, 1, 1),
#'     vjust = c(0, 1, 0.5, 0, 1)
#' )
#' ggplot(data.frame(x = 1, y = 2)) +
#'     geom_draw(text)
#' @importFrom rlang list2 arg_match0
#' @importFrom ggplot2 ggproto aes
#' @export
geom_draw <- function(draw, mapping = NULL, data = NULL,
                      type = "group", stat = "identity",
                      position = "identity", ...,
                      na.rm = FALSE, show.legend = FALSE, inherit.aes = TRUE) {
    type <- arg_match0(type, c("group", "panel"))
    if (!is.grob(draw) && !is.gList(draw)) draw <- rlang::as_function(draw)
    dots <- list2(...)
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = switch(type,
            panel = ggproto(
                "GeomDraw",
                ggplot2::Geom,
                default_aes = GeomGshape$default_aes,
                setup_data = draw_setup_data,
                draw_panel = draw_geom_draw,
                draw_key = ggplot2::draw_key_blank
            ),
            group = ggproto(
                "GeomDraw",
                ggplot2::Geom,
                default_aes = GeomGshape$default_aes,
                setup_data = draw_setup_data,
                draw_group = draw_geom_draw,
                draw_key = ggplot2::draw_key_blank
            )
        ),
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = c(
            list(na.rm = na.rm, draw = draw, .__draw_dots__ = dots), dots
        )
    )
}

# GeomTile will respect width and height
draw_setup_data <- function(self, data, params) {
    data$x <- data$x %||% 0.5
    data$y <- data$y %||% 0.5
    ggplot2::GeomTile$setup_data(data, params)
}

draw_geom_draw <- function(data, panel_params, coord, draw, .__draw_dots__) {
    if (is.function(draw)) {
        data <- coord$transform(data, panel_params)
        # restore colour
        if (!is.null(data$colour) && is.null(data$color)) {
            data$color <- data$colour
        }
        if (!is.null(data$color) && is.null(data$colour)) {
            data$colour <- data$color
        }

        # restore width and height
        if (!is.null(data$xmin) && !is.null(data$xmax)) {
            data$width <- data$xmax - data$xmin
        }
        if (!is.null(data$ymin) && !is.null(data$ymax)) {
            data$height <- data$ymax - data$ymin
        }
    }
    make_draw_grob(draw, data, .__draw_dots__)
}

#' @return A [grob][grid::grob] object.
#' @importFrom rlang inject
#' @importFrom methods formalArgs
#' @importFrom ggplot2 zeroGrob
#' @keywords internal
#' @noRd
make_draw_grob <- function(draw, data, dots) {
    if (is.function(draw)) {
        args <- formalArgs(draw)
        if (any(args == "...")) {
            draw <- inject(draw(!!!data, !!!dots))
        } else {
            draw <- inject(draw(
                !!!.subset(data, intersect(names(data), args)),
                !!!.subset(dots, intersect(
                    setdiff(names(dots), names(data)), args
                ))
            ))
        }
    }
    ensure_grob(draw, zeroGrob())
}

#' Layer with a customized shape graphic using grid functions.
#'
#' @description
#' `r lifecycle::badge('questioning')`
#'
#' `geom_gshape` depends on the new aesthetics `gshape` (shape with grid
#' functions), which should always be provided with [`scale_gshape_manual()`],
#' in which, we can provide a list of grobs or functions that define how each
#' value should be drawn. Any ggplot2 aesthetics can be used as the arguments.
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @section Life cycle:
#' We're unsure whether this function is truly necessary, which is why it is
#' marked as questioning. So far, we've found that [`geom_subrect()`] and
#' [`geom_subtile()`] handle most use cases effectively.
#'
#' @aesthetics GeomGshape
#' @examples
#' library(grid)
#' ggplot(data.frame(value = letters[seq_len(5)], y = seq_len(5))) +
#'     geom_gshape(aes(x = 1, y = y, gshape = value, fill = value)) +
#'     scale_gshape_manual(values = list(
#'         a = function(x, y, width, height, fill) {
#'             rectGrob(x, y,
#'                 width = width, height = height,
#'                 gp = gpar(fill = fill),
#'                 default.units = "native"
#'             )
#'         },
#'         b = function(x, y, width, height, fill) {
#'             rectGrob(x, y,
#'                 width = width, height = height,
#'                 gp = gpar(fill = fill),
#'                 default.units = "native"
#'             )
#'         },
#'         c = function(x, y, width, height, fill) {
#'             rectGrob(x, y,
#'                 width = width, height = height,
#'                 gp = gpar(fill = fill),
#'                 default.units = "native"
#'             )
#'         },
#'         d = function(x, y, width, height, shape) {
#'             gList(
#'                 pointsGrob(x, y, pch = shape),
#'                 # To ensure the rectangle color is shown in the legends, you
#'                 # must explicitly provide a color argument and include it in
#'                 # the `gpar()` of the graphical object
#'                 rectGrob(x, y, width, height,
#'                     gp = gpar(col = "black", fill = NA)
#'                 )
#'             )
#'         },
#'         e = function(xmin, xmax, ymin, ymax) {
#'             segmentsGrob(
#'                 xmin, ymin,
#'                 xmax, ymax,
#'                 gp = gpar(lwd = 2)
#'             )
#'         }
#'     )) +
#'     scale_fill_brewer(palette = "Dark2") +
#'     theme_void()
#'
#' @importFrom rlang list2
#' @export
geom_gshape <- function(mapping = NULL, data = NULL, stat = "identity",
                        position = "identity", ..., na.rm = FALSE,
                        show.legend = NA, inherit.aes = TRUE) {
    dots <- list2(...)
    ggplot2::layer(
        data = data,
        mapping = mapping,
        stat = stat,
        geom = GeomGshape,
        position = position,
        show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = c(list(na.rm = na.rm), dots, list(.__gshape_dots__ = dots))
    )
}

#' @inherit ggplot2::draw_key_point
#' @description
#' Each geom has an associated function that draws the key when the geom needs
#' to be displayed in a legend. These functions are called `draw_key_*()`, where
#' `*` stands for the name of the respective key glyph. The key glyphs can be
#' customized for individual geoms by providing a geom with the `key_glyph`
#' argument. The `draw_key_gshape` function provides this interface for custom
#' key glyphs used with [`geom_gshape()`].
#'
#' @importFrom rlang inject
#' @importFrom methods formalArgs
#' @importFrom grid gTree
#' @export
draw_key_gshape <- function(data, params, size) {
    gshape <- .subset2(data$gshape, 1L)
    data$gshape <- NULL
    if (is.function(gshape)) {
        for (d in formalArgs(gshape)) {
            if (is.null(.subset2(data, d))) {
                data[[d]] <- switch(d,
                    x = ,
                    y = 0.5,
                    xmin = ,
                    ymin = 0,
                    xmax = ,
                    ymax = 1,
                    width = ,
                    height = 1,
                    color = data$colour %||% GeomGshape$default_aes[["colour"]],
                    fill = data$colour %||% GeomGshape$default_aes[["fill"]],
                    GeomGshape$default_aes[[d]]
                )
            }
        }
    }
    make_draw_grob(gshape, data, .subset2(params, ".__gshape_dots__"))
}

#' @importFrom ggplot2 ggproto zeroGrob
#' @importFrom rlang inject
#' @importFrom grid gList
GeomGshape <- ggproto(
    "GeomGshape",
    ggplot2::Geom,
    required_aes = c("x", "y", "gshape"),
    default_aes = aes(
        shape = 19,
        colour = "black",
        size = 1.5,
        fill = NA,
        alpha = NA,
        stroke = 0.5,
        linewidth = 0.5,
        linetype = 1
    ),
    setup_data = ggplot2::GeomTile$setup_data,
    draw_panel = function(data, panel_params, coord, .__gshape_dots__) {
        coords <- coord$transform(data, panel_params)

        if (!is.null(coords$colour) && is.null(coords$color)) {
            coords$color <- coords$colour
        }
        if (!is.null(coords$color) && is.null(coords$colour)) {
            coords$colour <- coords$color
        }

        # restore width and height
        if (!is.null(coords$xmin) && !is.null(coords$xmax)) {
            coords$width <- coords$xmax - coords$xmin
        }
        if (!is.null(coords$ymin) && !is.null(coords$ymax)) {
            coords$height <- coords$ymax - coords$ymin
        }

        groups <- vec_group_loc(.subset2(coords, "gshape"))
        coords$gshape <- NULL

        # reordering by drawing order
        ordering <- vapply(
            .subset2(groups, "key"),
            function(gshape) {
                attr(gshape, "gshape_ordering", exact = TRUE) %||% NA_integer_
            },
            integer(1L),
            USE.NAMES = FALSE
        )
        groups <- vec_slice(groups, order(ordering))
        coords <- vec_chop(coords, indices = .subset2(groups, "loc"))

        grobs <- .mapply(
            make_draw_grob,
            list(draw = .subset2(groups, "key"), data = coords),
            list(dots = .__gshape_dots__)
        )
        grobs <- grobs[vapply(grobs, is.grob, logical(1L), USE.NAMES = FALSE)]
        if (is_empty(grobs)) {
            zeroGrob()
        } else {
            gTree(children = inject(gList(!!!grobs)))
        }
    },
    draw_key = draw_key_gshape
)

#' Scale for `gshape` aesthetic
#'
#' @inheritDotParams ggplot2::discrete_scale -expand -position -aesthetics -palette -scale_name
#' @param values A list of grobs or functions (including purrr-like lambda
#' syntax) that define how each cell's grob (graphical object) should be drawn.
#' @inheritParams ggplot2::scale_discrete_manual
#' @inherit geom_gshape
#' @export
scale_gshape_manual <- function(..., values, breaks = waiver(), na.value = NA) {
    ggplot2::scale_discrete_manual(
        aesthetics = "gshape",
        values = .mapply(function(f, i) {
            f <- allow_lambda(f)
            attr(f, "gshape_ordering") <- i # save the drawing order
            f
        }, list(values, seq_along(values)), NULL),
        breaks = breaks,
        na.value = na.value,
        ...
    )
}

# `gshape` should be provided manually
scale_gshape_discrete <- function(name = waiver(), ...) {
    cli_abort(paste(
        "You must provide {.fn scale_gshape_manual}",
        "to use {.field draw} aesthetic"
    ))
}

# `gshape` should be provided manually
scale_gshape_continuous <- scale_gshape_discrete

#' @keywords internal
stack_composer <- function(direction) {
    structure(
        list(
            t = integer(), l = integer(),
            b = integer(), r = integer(),
            plots = list(), sizes = list(),
            direction = direction,
            align = 1L,
            # attributes used by `stack_layout()`
            left_or_top = FALSE, right_or_bottom = FALSE
        ),
        class = "stack_composer"
    )
}

stack_composer_add_plot <- function(composer, plot, t, l, b = t, r = l) {
    composer$t <- c(.subset2(composer, "t"), t)
    composer$l <- c(.subset2(composer, "l"), l)
    composer$b <- c(.subset2(composer, "b"), b)
    composer$r <- c(.subset2(composer, "r"), r)
    composer$plots <- c(.subset2(composer, "plots"), list(plot))
    composer
}

#' @importFrom rlang is_empty
stack_composer_align_plot <- function(composer, plot, size) {
    if (is.null(plot)) {
        return(composer)
    }
    if (is_horizontal(.subset2(composer, "direction"))) {
        r_border <- .subset2(composer, "r")
        if (is_empty(r_border)) {
            l <- 1L
        } else {
            l <- max(r_border) + 1L
        }
        t <- .subset2(composer, "align")
    } else {
        b_border <- .subset2(composer, "b")
        if (is_empty(b_border)) {
            t <- 1L
        } else {
            t <- max(b_border) + 1L
        }
        l <- .subset2(composer, "align")
    }
    composer$sizes <- c(.subset2(composer, "sizes"), list(size))
    stack_composer_add_plot(composer, plot, t, l)
}

stack_composer_add <- function(plot, stack, composer, ...) {
    UseMethod("stack_composer_add")
}

#' @importFrom utils packageVersion
#' @export
stack_composer_add.CraftBox <- function(plot, stack, composer, design, ...,
                                        schemes, theme,
                                        released_spaces,
                                        direction, position) {
    size <- plot@size

    # for `released_spaces`, release the `free_spaces` in a single plot
    plot_schemes <- inherit_schemes(plot@schemes, schemes)
    if (!is.null(released_spaces)) {
        plot_spaces <- .subset2(
            .subset2(plot_schemes, "scheme_align"), "free_spaces"
        )
        if (is_string(plot_spaces)) {
            plot_spaces <- setdiff_position(plot_spaces, released_spaces)
            if (!nzchar(plot_spaces)) plot_spaces <- NULL
            plot_schemes$scheme_align["free_spaces"] <- list(plot_spaces)
        }
    }

    # let `Align` to determine how to build the plot
    craftsman <- plot@craftsman # `Craftsman` object
    plot <- plot@plot
    if (!craftsman$free_facet && is_discrete_design(design)) {
        if (nlevels(.subset2(design, "panel")) > 1L) {
            if (is_horizontal(direction)) {
                facet <- ggplot2::facet_grid(
                    rows = ggplot2::vars(.data$.panel),
                    scales = "free_y", space = "free",
                    drop = FALSE, as.table = FALSE
                )
                free_row <- FALSE
                free_column <- TRUE
            } else {
                facet <- ggplot2::facet_grid(
                    cols = ggplot2::vars(.data$.panel),
                    scales = "free_x", space = "free",
                    drop = FALSE, as.table = FALSE
                )
                free_row <- TRUE
                free_column <- FALSE
            }
        } else {
            facet <- facet_stack(direction, craftsman$layout_name)
        }
        plot <- ggmelt_facet(plot, facet,
            free_row = free_row, free_column = free_column
        )
    }
    if (!craftsman$free_coord) {
        plot <- gguse_linear_coord(plot, layout_name = craftsman$layout_name)
    }

    # set limits and default scales
    if (!craftsman$free_limits) {
        if (is_horizontal(direction)) {
            plot <- plot + ggalign_design(
                y = design,
                ylabels = .subset(craftsman$labels, .subset2(design, "index"))
            )
        } else {
            plot <- plot + ggalign_design(
                x = design,
                xlabels = .subset(craftsman$labels, .subset2(design, "index"))
            )
        }
    }

    # let `Craftsman` add other components
    plot <- craftsman$build_plot(plot, design = design, ...)
    plot <- craftsman$finish_plot(plot, plot_schemes, theme)

    # Let layout finally modify the plot
    plot <- chain_decorate(stack, plot)

    # add the plot to the composer
    stack_composer_align_plot(composer, plot, size)
}

#' @importFrom grid unit.c unit
stack_composer_add.QuadLayout <- function(plot, stack, composer, schemes, theme,
                                          direction, ...) {
    patches <- quad_build(plot, schemes, theme, direction)
    plots <- .subset2(patches, "plots")
    sizes <- .subset2(patches, "sizes")

    if (is_horizontal(.subset2(composer, "direction"))) {
        composer$left_or_top <- .subset2(composer, "left_or_top") ||
            !is.null(.subset2(plots, "top"))
        composer$right_or_bottom <- .subset2(composer, "right_or_bottom") ||
            !is.null(.subset2(plots, "bottom"))
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "left"),
            .subset2(sizes, "left")
        )
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "main"),
            .subset2(.subset2(sizes, "main"), "width")
        )
        l <- max(.subset2(composer, "r"))
        if (!is.null(top <- .subset2(plots, "top"))) {
            if (.subset2(composer, "align") == 1L) {
                composer$t <- .subset2(composer, "t") + 1L
                composer$b <- .subset2(composer, "b") + 1L
                composer$align <- .subset2(composer, "align") + 1L
            }
            if (!is_null_unit(size <- .subset2(sizes, "top"))) {
                attr(top, "vp")$height <- size
            }
            composer <- stack_composer_add_plot(composer, top, t = 1L, l = l)
        }
        if (!is.null(bottom <- .subset2(plots, "bottom"))) {
            if (!is_null_unit(size <- .subset2(sizes, "bottom"))) {
                attr(bottom, "vp")$height <- size
            }
            composer <- stack_composer_add_plot(composer, bottom,
                t = .subset2(composer, "align") + 1L, l = l
            )
        }
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "right"),
            .subset2(sizes, "right")
        )
    } else {
        composer$left_or_top <- .subset2(composer, "left_or_top") ||
            !is.null(.subset2(plots, "left"))
        composer$right_or_bottom <- .subset2(composer, "right_or_bottom") ||
            !is.null(.subset2(plots, "right"))
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "top"),
            .subset2(sizes, "top")
        )
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "main"),
            .subset2(.subset2(sizes, "main"), "height")
        )
        t <- max(.subset2(composer, "b"))
        if (!is.null(left <- .subset2(plots, "left"))) {
            if (.subset2(composer, "align") == 1L) {
                composer$l <- .subset2(composer, "l") + 1L
                composer$r <- .subset2(composer, "r") + 1L
                composer$align <- .subset2(composer, "align") + 1L
            }
            if (!is_null_unit(size <- .subset2(sizes, "left"))) {
                attr(left, "vp")$width <- size
            }
            composer <- stack_composer_add_plot(composer, left, t = t, l = 1L)
        }
        if (!is.null(right <- .subset2(plots, "right"))) {
            if (!is_null_unit(size <- .subset2(sizes, "right"))) {
                attr(right, "vp")$width <- size
            }
            composer <- stack_composer_add_plot(composer, right,
                t = t, l = .subset2(composer, "align") + 1L
            )
        }
        composer <- stack_composer_align_plot(
            composer,
            .subset2(plots, "bottom"),
            .subset2(sizes, "bottom")
        )
    }
    composer
}

#' @export
stack_composer_add.list <- function(plot, stack, composer, ...) {
    for (p in plot) {
        composer <- stack_composer_add(
            plot = p, stack = stack, composer = composer, ...
        )
    }
    composer
}

#' Arrange plots crosswise horizontally or vertically
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' The `stack_cross` function is derived from [`stack_discrete()`] and allows
#' for different layout ordering indices within a single layout.
#'
#' Two aliases are provided for convenience:
#' - `stack_crossv`: A special case of `stack_cross` that sets
#'   `direction = "v"` for vertical alignment.
#' - `stack_crossh`: A special case of `stack_cross` that sets
#'   `direction = "h"` for horizontal alignment.
#'
#' @param data `r rd_layout_data()`, [`fortify_matrix()`] will be used to
#' convert the data to a matrix.
#' @param ... Additional arguments passed to [`fortify_matrix()`].
#' @inheritParams stack_layout
#' @seealso [`ggcross()`]
#' @export
stack_cross <- function(direction, data = NULL, ...,
                        theme = NULL, sizes = NA) {
    UseMethod("stack_cross", data)
}

#' @export
#' @rdname stack_cross
stack_crossv <- function(data = NULL, ...) {
    stack_cross(data = data, direction = "v", ...)
}

#' @export
#' @rdname stack_cross
stack_crossh <- function(data = NULL, ...) {
    stack_cross(data = data, direction = "h", ...)
}

#' @include layout-chain-stack-.R
methods::setClass(
    "StackCross",
    contains = "StackLayout",
    # A list of old design
    list(odesign = "list", cross_points = "integer", break_points = "integer"),
    prototype = list(
        odesign = list(),
        cross_points = integer(),
        break_points = integer()
    )
)

#' @export
stack_cross.default <- function(direction, data = NULL, ...) {
    ans <- stack_discrete(data = data, direction = direction, ...)
    ans <- methods::as(ans, "StackCross")
    ans@name <- "stack_cross"
    ans
}

#' @importFrom grid unit.c
#' @importFrom rlang is_empty is_string
resolve_stack_layout.StackCross <- function(stack, schemes, theme,
                                            extra_design) {
    # check if we should initialize the layout observations
    layout_design <- stack@design
    if (is_discrete_design(layout_design) &&
        is.null(.subset2(layout_design, "nobs")) &&
        any(vapply(plot_list, is_cross_plot, logical(1L), USE.NAMES = FALSE))) {
        cli_abort(sprintf(
            "You must initialize the layout observations to plot the %s",
            object_name(stack)
        ))
    }
    plot_list <- stack@plot_list

    direction <- stack@direction
    position <- .subset2(stack@heatmap, "position")
    plot_list <- vec_chop(
        plot_list,
        sizes = diff(c(0L, stack@cross_points, length(plot_list)))
    )
    design_list <- c(stack@odesign, list(layout_design))

    # build the stack
    composer <- stack_composer(direction)

    # for `free_spaces`, if we have applied it in the whole stack layout we
    # shouln't use it for a single plot. Otherwise, the guide legends collected
    # by the layout will overlap with the axis of the plot in the layout.
    #
    # this occurs in the annotation stack (`position` is not `NULL`).
    stack_spaces <- .subset2(.subset2(schemes, "scheme_align"), "free_spaces")
    if (is_string(stack_spaces) && !is.null(position)) {
        released_spaces <- stack_spaces
    } else {
        released_spaces <- NULL
    }
    previous_design <- NULL
    for (i in seq_along(plot_list)) {
        plots <- .subset2(plot_list, i)

        # prepare design for current group
        design <- .subset2(design_list, i)
        design <- setup_design(design)

        if (is_empty(plots)) {
            previous_design <- design
            next
        }

        # we remove the plot without actual plot area
        keep <- vapply(plots, function(plot) {
            # we remove objects without plot area
            # Now, only `CraftBox` will contain `NULL`
            !is_craftbox(plot) || !is.null(plot@plot)
        }, logical(1L), USE.NAMES = FALSE)
        plots <- .subset(plots, keep)

        if (is_empty(plots)) {
            previous_design <- design
            next
        }

        # we reorder the plots based on the `order` slot
        plot_order <- vapply(plots, function(plot) {
            # always keep cross() in the start
            if (is_cross_plot(plot)) {
                1L
            } else if (is_craftbox(plot)) {
                .subset2(plot@active, "order")
            } else {
                .subset2(plot@plot_active, "order")
            }
        }, integer(1L), USE.NAMES = FALSE)
        plots <- .subset(plots, make_order(plot_order))
        composer <- stack_composer_add(
            plots,
            stack = stack,
            composer,
            schemes = schemes,
            theme = theme,
            design = design,
            extra_design = extra_design,
            direction = direction,
            position = position,
            released_spaces = released_spaces,
            previous_design = previous_design
        )
        previous_design <- design
    }
    composer
}

#' Align Specifications in the Layout
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' The `scheme_align()` function defines the align Specifications for plots.
#'
#' @param guides A string with one or more of `r oxford_and(c(.tlbr, "i"))`
#' indicating which side of guide legends should be collected. Defaults to
#' [`waiver()`][ggplot2::waiver()], which inherits from the parent layout. If no
#' parent layout, all guides will be collected. If `NULL`, no guides will be
#' collected.
#'
#' @param free_spaces A string with one or more of `r oxford_and(.tlbr)`
#' indicating which border spaces should be removed. Defaults to
#' [`waiver()`][ggplot2::waiver()], which inherits from the parent layout. If no
#' parent, the default is `NULL`, meaning no spaces are removed.
#'
#' Usually you want to apply this with the whole layout, instead of individual
#' plots.
#'
#' @param free_labs A string with one or more of `r oxford_and(.tlbr)`
#' indicating which axis titles should be free from alignment. Defaults to
#' [`waiver()`][ggplot2::waiver()], which inherits from the parent layout. If no
#' parent layout, no axis titles will be aligned. If `NULL`, all axis titles
#' will be aligned.
#'
#' @return A `scheme_align` object.
#' @examples
#' set.seed(123)
#' mat <- matrix(rnorm(72), nrow = 8)
#' # used in the layout, define the default action for all plots in the layout
#' ggheatmap(mat) -
#'     scheme_align(guides = NULL) +
#'     anno_right() +
#'     align_dendro(aes(color = branch), k = 3)
#'
#' # You can also add it for a single plot
#' ggheatmap(mat) -
#'     # for all plots in the layout, we default won't collect any guide legends
#'     scheme_align(guides = NULL) +
#'     # for the heatmap body, we collect guide legends in the right
#'     # note, the guide legends will be collected to the right side of the
#'     # layout which will overlap the legends in the right annotation
#'     scheme_align(guides = "r") +
#'     anno_right() +
#'     align_dendro(aes(color = branch), k = 3)
#'
#' # to avoid overlapping, we can also collect the guide legends in the
#' # right annotation
#' ggheatmap(mat) -
#'     scheme_align(guides = NULL) +
#'     scheme_align(guides = "r") +
#'     anno_right() +
#'     align_dendro(aes(color = branch), k = 3) +
#'     scheme_align(guides = "r")
#' @export
scheme_align <- function(guides = NA, free_spaces = NA, free_labs = NA) {
    if (!identical(guides, NA)) assert_layout_guides(guides)
    if (!identical(free_spaces, NA)) assert_layout_position(free_spaces)
    if (!identical(free_labs, NA)) assert_layout_position(free_labs)
    new_scheme_align(
        free_spaces = free_spaces,
        free_labs = free_labs,
        guides = guides
    )
}

new_scheme_align <- function(guides = waiver(), free_spaces = waiver(),
                             free_labs = waiver()) {
    new_scheme(
        name = "scheme_align",
        list(free_spaces = free_spaces, free_labs = free_labs, guides = guides),
        class = "scheme_align"
    )
}

#' @importFrom utils modifyList
#' @export
update_scheme.scheme_align <- function(new, old, object_name) {
    modifyList(old,
        new[!vapply(new, identical, logical(1L), y = NA, USE.NAMES = FALSE)],
        keep.null = TRUE
    )
}

#' @export
inherit_scheme.scheme_align <- function(scheme, pscheme) {
    # `align_plots` control how to inherit `guides` from the layout
    # we don't need to inherit it here
    scheme["free_spaces"] <- list(.subset2(scheme, "free_spaces") %|w|%
        .subset2(pscheme, "free_spaces"))
    scheme["free_labs"] <- list(.subset2(scheme, "free_labs") %|w|%
        .subset2(pscheme, "free_labs"))
    scheme
}

#' @param theme Additional default theme elements to be added for the plot
#' @noRd
plot_add_scheme.scheme_align <- function(plot, scheme) {
    if (!is.waive(free_guides <- .subset2(scheme, "guides"))) {
        plot <- free_guide(plot, free_guides)
    }
    # by default, we'll attach all labs to the axis
    if (!is.null(free_labs <- .subset2(scheme, "free_labs") %|w|% "tlbr")) {
        plot <- free_lab(plot, free_labs)
    }
    # by default, we won't remove any spaces
    if (!is.null(free_spaces <- .subset2(scheme, "free_spaces") %|w|% NULL)) {
        plot <- free_space(free_border(plot, free_spaces), free_spaces)
    }
    plot
}

#' Create an UpSet plot
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' `ggupset` is a specialized version of [`quad_discrete()`], which simplifies
#' the creation of Upset plot.
#'
#' @param data Data used to create the UpSet plot. [`fortify_matrix()`] will be
#' used to convert the data to a matrix. Currently, only
#' [`fortify_matrix.list_upset`] and [`fortify_matrix.matrix_upset`] are
#' suitable for creating an UpSet plot.
#' @param ... Additional arguments passed to [`fortify_matrix()`].
#' @inheritParams quad_layout
#' @param direction A string indicating the direction of the UpSet plot,
#' `"h"`(`horizontal`) or `"v"`(`vertical`). In a vertical UpSet plot, the
#' columns of the matrix correspond to the sets, and the rows correspond to the
#' intersections. By default, the horizontal UpSet plot is used, where the rows
#' of the matrix correspond to the sets and the columns correspond to the
#' intersections.
#' @param point A list of parameters passed to
#' [`geom_point()`][ggplot2::geom_point()].
#' @param line A list of parameters passed to
#' [`geom_line()`][ggplot2::geom_line()].
#' @param rect A list of parameters passed to
#' [`geom_rect()`][ggplot2::geom_rect()].
#'
#' @inheritSection heatmap_layout ggplot2 specification
#' @examples
#' set.seed(123)
#' lt <- list(
#'     a = sample(letters, 5),
#'     b = sample(letters, 10),
#'     c = sample(letters, 15)
#' )
#' ggupset(tune(lt)) +
#'     scale_fill_manual(values = c("#F0F0F0", "white"), guide = "none") +
#'     scale_color_manual(values = c("grey", "black"), guide = "none") +
#'     anno_top() +
#'     ggalign(data = function(d) ggalign_attr(d, "intersection_sizes")) +
#'     ggplot2::geom_bar(aes(y = .data$value), stat = "identity") +
#'     anno_right() +
#'     ggalign(data = function(d) ggalign_attr(d, "set_sizes")) +
#'     ggplot2::geom_bar(aes(x = .data$value),
#'         stat = "identity",
#'         orientation = "y"
#'     )
#' @importFrom ggplot2 aes
#' @export
ggupset <- function(data = NULL, mapping = aes(),
                    ...,
                    direction = "h",
                    point = NULL, line = NULL, rect = NULL,
                    width = NA, height = NA,
                    theme = NULL, active = NULL) {
    UseMethod("ggupset")
}

# Don't allow inherit from the parent layout, since data for upset plot is
# usually different with others
#' @export
ggupset.NULL <- function(data, ...) {
    cli_abort("{.arg data} must be provided to create upset plot")
}

#' @export
ggupset.waiver <- ggupset.NULL

#' @importFrom ggplot2 aes
#' @export
ggupset.default <- function(data = NULL, mapping = aes(),
                            ...,
                            direction = "h",
                            point = NULL, line = NULL, rect = NULL,
                            width = NA, height = NA,
                            theme = NULL, active = NULL) {
    direction <- check_direction(direction)
    # we need a matrix to melted into long formated data frame
    data <- fortify_matrix(data = data, ...)
    if (is_vertical(direction)) data <- ggalign_data_restore(t(data), data)
    ans <- new_quad_layout(
        name = "ggupset",
        data = data,
        mapping = mapping,
        theme = theme,
        active = active
    )
    ans@plot <- ggadd_default(ans@plot, mapping = aes(.data$.x, .data$.y)) +
        ggplot2::labs(x = NULL, y = NULL) +
        upset_rect(direction, rect) +
        upset_point(point) +
        upset_line(direction, line)
    ans
}

merge_mapping <- function(x, y) {
    if (is.null(x)) {
        return(y)
    }
    for (i in names(y)) {
        x[[i]] <- .subset2(y, i)
    }
    x
}

merge_data_fn <- function(plot_data, user_data) {
    if (is.null(user_data) || is.waive(user_data)) {
        plot_data
    } else if (is.function(user_data <- allow_lambda(user_data))) {
        force(plot_data)
        function(data) user_data(plot_data(data))
    } else {
        user_data
    }
}

upset_rect <- function(direction, rect) {
    if (is_horizontal(direction)) {
        rect$mapping <- merge_mapping(rect$mapping, aes(
            ymin = .data$.ymin, ymax = .data$.ymax, fill = .data$rect_group
        ))
        rect$data <- merge_data_fn(function(data) {
            column <- c(
                ".y", ".panel_x", ".panel_y",
                ".row_index", ".row_names", ".discrete_y"
            )
            o <- vec_unique(data[vec_set_intersect(column, names(data))])
            o$rect_group <- (.subset2(o, ".y") %% 2L) == 0L
            o$.ymin <- o$.y - 0.5
            o$.ymax <- o$.y + 0.5
            o
        }, rect$data)
        inject(ggplot2::geom_rect(!!!rect,
            xmin = -Inf, xmax = Inf, inherit.aes = FALSE
        ))
    } else {
        rect$mapping <- merge_mapping(rect$mapping, aes(
            xmin = .data$.xmin, xmax = .data$.xmax,
            fill = .data$rect_group
        ))
        rect$data <- merge_data_fn(function(data) {
            column <- c(
                ".x", ".panel_x", ".panel_y",
                ".column_index", ".column_names", ".discrete_x"
            )
            o <- vec_unique(data[vec_set_intersect(column, names(data))])
            o$rect_group <- (.subset2(o, ".x") %% 2L) == 0L
            o$.xmin <- o$.x - 0.5
            o$.xmax <- o$.x + 0.5
            o
        }, rect$data)
        inject(ggplot2::geom_rect(!!!rect,
            ymin = -Inf, ymax = Inf, inherit.aes = FALSE
        ))
    }
}

upset_point <- function(point) {
    point$mapping <- merge_mapping(point$mapping, aes(
        x = .data$.x, y = .data$.y, color = .data$point_group
    ))
    point$data <- merge_data_fn(function(data) {
        data$point_group <- .subset2(data, "value")
        data
    }, point$data)
    inject(ggplot2::geom_point(!!!point, inherit.aes = FALSE))
}

upset_line <- function(direction, line) {
    line$mapping <- merge_mapping(line$mapping, switch_direction(
        direction,
        aes(.data$.x, .data$.y, group = paste(.data$.panel_x, .data$.x)),
        aes(.data$.x, .data$.y, group = paste(.data$.panel_y, .data$.y))
    ))
    line$data <- merge_data_fn(function(data) {
        if (is_horizontal(direction)) {
            dlist <- vec_split(data, data[c(".panel_x", ".x")])
            dlist <- lapply(.subset2(dlist, "val"), function(d) {
                o <- vec_slice(d, .subset2(d, "value"))
                if (vec_size(o) < 2L) {
                    return(NULL)
                }
                vec_slice(o, c(
                    which.min(.subset2(o, ".y")),
                    which.max(.subset2(o, ".y"))
                ))
            })
            vec_rbind(!!!dlist)
        } else {
            dlist <- vec_split(data, data[c(".panel_y", ".y")])
            dlist <- lapply(.subset2(dlist, "val"), function(d) {
                o <- vec_slice(d, .subset2(d, "value"))
                if (vec_size(o) < 2L) {
                    return(NULL)
                }
                vec_slice(o, c(
                    which.min(.subset2(o, ".x")),
                    which.max(.subset2(o, ".x"))
                ))
            })
            vec_rbind(!!!dlist)
        }
    }, line$data)
    inject(ggplot2::geom_line(!!!line, inherit.aes = FALSE))
}

#' Rasterize a grob object with magick
#'
#' @param grob A [`grob()`][grid::grob]. Use [`patch()`] to convert any objects
#' into a `grob`.
#' @param magick A function (purrr-style formula is accepted) that takes an
#' [`image_read()`][magick::image_read] object as input and returns an object
#' compatible with [`as.raster()`][grDevices::as.raster]. You can use any of
#' the `image_*()` functions from the **magick** package to process the raster
#' image.
#' @param res An integer sets the desired resolution in pixels.
#' @inheritParams rlang::args_dots_empty
#' @inheritParams grid::rasterGrob
#' @return A `magickGrob` object.
#' @export
magickGrob <- function(grob, magick = NULL, ...,
                       res = NULL, interpolate = FALSE,
                       name = NULL, vp = NULL) {
    rlang::check_installed("magick", "to use `magickGrob()`")
    if (!is.null(magick) && !is.function(magick <- allow_lambda(magick))) {
        cli_abort("{.arg magick} must be a function")
    }
    assert_number_whole(res, min = 1, allow_null = TRUE)
    assert_bool(interpolate)
    magickGrob0(
        grob = grob, magick = magick, ..., res = res,
        interpolate = interpolate, name = name, vp = vp
    )
}

magickGrob0 <- function(grob, ...) UseMethod("magickGrob0")

#' @importFrom grid gTree
#' @export
magickGrob0.grob <- function(grob, magick = NULL, ...,
                             res = NULL, interpolate = FALSE,
                             name = NULL, vp = NULL) {
    rlang::check_dots_empty()
    gTree(
        grob = grob, magick = magick, res = res,
        interpolate = interpolate, name = name, vp = vp,
        cl = "magickGrob"
    )
}

#' @importFrom grid gTree
#' @export
magickGrob0.gList <- function(grob, ...) {
    magickGrob0(grob = gTree(children = grob), ...)
}

#' @importFrom grid editGrob
#' @importFrom rlang inject
#' @export
magickGrob0.magickGrob <- function(grob, magick = waiver(), ...,
                                   res = waiver(), interpolate = waiver(),
                                   name = waiver(), vp = waiver()) {
    rlang::check_dots_empty()
    params <- list(
        magick = magick, res = res,
        interpolate = interpolate, name = name, vp = vp
    )
    params <- params[!vapply(params, is.waive, logical(1L), USE.NAMES = FALSE)]
    inject(editGrob(grob, !!!params))
}

#' @export
magickGrob0.default <- function(grob, ...) {
    cli_abort("{.arg grob} must be a {.cls grob} object")
}

# preDraw:
#  - makeContext
#  - pushvpgp
#  - preDrawDetails: by default, do noting
# makeContent:
# drawDetails:
# postDraw:
#  - postDrawDetails: by default, do noting
#  - popgrobvp
#' @importFrom grid makeContent unit convertHeight convertWidth viewport gList
#' @export
makeContent.magickGrob <- function(x) {
    # Grab viewport information
    width <- convertWidth(unit(1, "npc"), "pt", valueOnly = TRUE)
    height <- convertHeight(unit(1, "npc"), "pt", valueOnly = TRUE)

    # Grab grob metadata
    plot_res <- convertWidth(unit(1, "inch"), "pt", valueOnly = TRUE)
    res <- .subset2(x, "res") %||% plot_res

    magick <- .subset2(x, "magick")
    interpolate <- .subset2(x, "interpolate")

    # Track current device
    old_dev <- grDevices::dev.cur()

    # Reset current device upon function exit
    on.exit(grDevices::dev.set(old_dev), add = TRUE)

    # open the magick raster device
    image <- magick::image_graph(
        width = width * res / plot_res,
        height = height * res / plot_res,
        bg = NA_character_, res = res,
        clip = FALSE, antialias = FALSE
    )

    # Render the grob
    grid::pushViewport(viewport())

    # Clean up the grob for rendering
    grid::grid.draw(.subset2(x, "grob")) # should respect the viewport of `x`
    grid::popViewport()
    grDevices::dev.off()
    on.exit(magick::image_destroy(image), add = TRUE)

    # run `magick` when necessary
    if (!is.null(magick)) image <- magick(image)

    # Use native raster instead
    raster <- grDevices::as.raster(image, native = TRUE)

    # Forward raster grob
    setChildren(x, children = gList(
        grid::rasterGrob(
            raster, # should contain current area of full viewport
            x = 0.5, y = 0.5,
            height = unit(height, "pt"),
            width = unit(width, "pt"),
            default.units = "npc",
            just = "center",
            interpolate = interpolate
        )
    ))
}

#' Free from alignment
#'
#' [align_plots] will try to align plot panels, and every elements of the plot,
#' following functions romove these restrictions:
#' - `free_align`: if we want to compose plots without alignment of some panel
#' axes (panel won't be aligned). we can wrap the plot with `free_align`.
#' - `free_border`: attaches borders (e.g., axis titles, tick marks) directly to
#'   the plot panel. This keeps them visually close to the panel during
#'   alignment.
#' - `free_lab()`: Similar to `free_border()`, but only attaches axis titles
#'   and tick labels, not full borders. It’s mainly included for completeness;
#'   in most cases, combining `free_border()` and `free_space()` is sufficient.
#' - `free_space`: Removing the ggplot element sizes when aligning.
#' - `free_vp`: Customize the [viewport][grid::viewport] when aligning.
#' - `free_guide`: If we want to override the behaviour of the overall guides
#'   behaviour, we can wrap the plot with `free_guide`.
#'
#' @param plot A [ggplot][ggplot2::ggplot] or [alignpatches][align_plots]
#' object.
#' @param axes Which axes shouldn't be aligned? A string containing
#' one or more of `r oxford_and(.tlbr)`.
#' @return
#' - `free_align`: A modified version of `plot` with a `free_align` class.
#' @examples
#' # directly copied from `patchwork`
#' # Sometimes you have a plot that defies good composition alginment, e.g. due
#' # to long axis labels
#' p1 <- ggplot(mtcars) +
#'     geom_bar(aes(y = factor(gear), fill = factor(gear))) +
#'     scale_y_discrete(
#'         "",
#'         labels = c(
#'             "3 gears are often enough",
#'             "But, you know, 4 is a nice number",
#'             "I would def go with 5 gears in a modern car"
#'         )
#'     )
#'
#' # When combined with other plots it ends up looking bad
#' p2 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp))
#'
#' align_plots(p1, p2, ncol = 1L)
#'
#' # We can fix this be using `free_align`
#' align_plots(free_align(p1), p2, ncol = 1L)
#'
#' # If we still want the panels to be aligned to the right, we can choose to
#' # free only the left side
#' align_plots(free_align(p1, axes = "l"), p2, ncol = 1L)
#'
#' # We could use `free_lab` to fix the layout in a different way
#' align_plots(p1, free_lab(p2), ncol = 1L)
#'
#' # `free_border` is similar with `free_lab`, they have a distinction in terms
#' # of placement on either the top or bottom side of the panel. Specifically,
#' # the top side contains the `title` and `subtitle`, while the bottom side
#' # contains the `caption`. free_lab() does not attach these elements in the
#' # panel area.
#' p3 <- ggplot(mtcars) +
#'     geom_point(aes(hp, wt, colour = mpg)) +
#'     ggtitle("Plot 3")
#' p_axis_top <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp)) +
#'     ggtitle("Plot axis in top") +
#'     scale_x_continuous(position = "top")
#' align_plots(p_axis_top, free_lab(p3))
#' align_plots(p_axis_top, free_border(p3))
#'
#' # Another issue is that long labels can occupy much spaces
#' align_plots(NULL, p1, p2, p2)
#'
#' # This can be fixed with `free_space`
#' align_plots(NULL, free_space(p1, "l"), p2, p2)
#'
#' @export
#' @rdname free
free_align <- function(plot, axes = "tlbr") {
    UseMethod("free_align")
}

# free_guides: set_guides
# free_lab: collect_guides
# free_border: collect_guides and align_border
# free_space: get_sizes
# free_align: get_sizes and align_border
# free_vp: align_border

#' @export
free_align.ggplot <- function(plot, axes = "tlbr") {
    assert_position(axes)
    attr(plot, "free_axes") <- axes
    add_class(plot, "free_align")
}

#' @export
free_align.alignpatches <- free_align.ggplot

#' @importFrom rlang is_empty
#' @export
free_align.free_lab <- function(plot, axes = "tlbr") {
    assert_position(axes)
    # if axes are free, it's not necessary to free the labs
    free_labs <- setdiff_position(attr(plot, "free_labs"), axes)
    if (nzchar(free_labs)) {
        attr(plot, "free_labs") <- free_labs
    } else {
        attr(plot, "free_labs") <- NULL
        plot <- remove_class(plot, "free_lab")
    }
    NextMethod()
}

#' @importFrom rlang is_empty
#' @export
free_align.free_space <- function(plot, axes = "tlbr") {
    assert_position(axes)
    free_spaces <- setdiff_position(attr(plot, "free_spaces"), axes)
    if (nzchar(free_spaces)) {
        attr(plot, "free_spaces") <- free_spaces
    } else {
        attr(plot, "free_spaces") <- NULL
        plot <- remove_class(plot, "free_space")
    }
    NextMethod()
}

#' @importFrom rlang is_empty
#' @export
free_align.free_border <- function(plot, axes = "tlbr") {
    assert_position(axes)
    free_borders <- setdiff_position(attr(plot, "free_borders"), axes)
    if (nzchar(free_borders)) {
        attr(plot, "free_borders") <- free_borders
    } else {
        attr(plot, "free_borders") <- NULL
        plot <- remove_class(plot, "free_border")
    }
    NextMethod()
}

#' @export
free_align.free_align <- function(plot, axes = "tlbr") {
    assert_position(axes)
    attr(plot, "free_axes") <- union_position(attr(plot, "free_axes"), axes)
    plot
}

#' @export
free_align.default <- function(plot, axes = "tlbr") {
    cli_abort("Cannot use with {.obj_type_friendly {plot}}")
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.free_align <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchFreeAlign", Parent,
        free_axes = split_position(attr(x, "free_axes")),
        get_sizes = function(self, free = NULL, gt = self$gt) {
            ggproto_parent(Parent, self)$get_sizes(
                union(free, self$free_axes),
                gt = gt
            )
        },
        align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                                gt = self$gt) {
            for (axis in self$free_axes) {
                assign(x = axis, value = NULL, envir = environment())
            }
            ggproto_parent(Parent, self)$align_border(
                t = t, l = l, b = b, r = r, gt = gt
            )
        }
    )
}

#' Get Data from the Attribute Attached by ggalign
#'
#' @description
#' `ggalign_attr` retrieves supplementary information stored as attributes
#' during the layout rendering process. These attributes—typically added during
#' data transformation by functions such as [`fortify_matrix()`] or
#' [`fortify_data_frame()`]—may contain filtered data, auxiliary metadata, or
#' other context essential for downstream operations.
#'
#' Factor level information, stored as a separate attribute, can be accessed via
#' `ggalign_lvls`.
#'
#' @details
#' Attributes attached to the data are especially useful when the input data is
#' transformed in ways that limit access to the complete dataset. For example,
#' [`fortify_matrix.MAF()`] might filter mutation data while adding attributes
#' that retain important context, such as the total number of observations, for
#' detailed or aggregated analyses. Additionally, it stores the levels of
#' `Variant_Classification` for further usage.
#'
#' @param x Data used, typically inherited from the layout `r rd_layout()`.
#' @param field A string specifying the particular data to retrieve from the
#' attached attribute. If `NULL`, the entire attached attribute list will be
#' returned.
#' @param check A boolean indicating whether to check if the `field` exists. If
#' `TRUE`, an error will be raised if the specified `field` does not exist.
#' @return
#' - `ggalign_attr`: The specified data from the attached supplementary data or
#' `NULL` if it is unavailable.
#' - `ggalign_lvls`: The attached supplementary levels or `NULL` if it is
#'   unavailable.
#'
#' @export
ggalign_attr <- function(x, field = NULL, check = TRUE) {
    assert_string(field, allow_empty = FALSE, allow_null = TRUE)
    if (is.null(x <- ggalign_attr_get(x)) || is.null(field)) {
        return(x)
    }
    if (isTRUE(check) && !rlang::has_name(x, field)) {
        cli_abort("Cannot find {field} in {.arg x}")
    }
    .subset2(x, field)
}

#' @export
#' @rdname ggalign_attr
ggalign_lvls <- function(x) ggalign_lvls_get(x)

#' Attach supplementary data and levels for ggalign
#'
#' @param .data Input data for the layout.
#' @param ... <[dyn-dots][rlang::dyn-dots]> A list of data to be attached.
#' @param .lvls A character vector representing the attached levels.
#' @note Used by developers in [`fortify_matrix()`], [`fortify_data_frame()`],
#'   and other related methods.
#' @seealso [`ggalign_attr()`]/[`ggalign_lvls()`]
#' @importFrom rlang list2
#' @export
ggalign_data_set <- function(.data, ..., .lvls = NULL) {
    if (...length() > 0L) {
        .data <- ggalign_attr_set(.data, list2(...))
    }
    if (!is.null(.lvls)) {
        .data <- ggalign_lvls_set(.data, .lvls)
    }
    # to prevent the print of attributes
    if (!is.null(ggalign_attr_get(.data)) ||
        !is.null(ggalign_lvls_get(.data))) {
        .data <- add_class(.data, "ggalign_data")
    }
    .data
}

#' @export
print.ggalign_data <- function(x, ...) {
    print(
        remove_class(
            ggalign_lvls_remove(ggalign_attr_remove(x)),
            "ggalign_data"
        )
    )
    invisible(x)
}

ggalign_attr_set <- function(x, values) {
    attr(x, ".__ggalign_attr__") <- values
    x
}

ggalign_attr_get <- function(x) attr(x, ".__ggalign_attr__", exact = TRUE)

ggalign_attr_remove <- function(x) ggalign_attr_set(x, NULL)

ggalign_lvls_set <- function(x, lvls) {
    attr(x, ".__ggalign_levels__") <- lvls
    x
}

ggalign_lvls_get <- function(x) attr(x, ".__ggalign_levels__", exact = TRUE)

ggalign_lvls_remove <- function(x) ggalign_lvls_set(x, NULL)

# we keep a special attribute across all data
# this is used to pass additional annotation informations
ggalign_data_restore <- function(data, original) {
    if (is.null(data) || is.waive(data)) return(data) # styler: off
    if (is.null(ggalign_attr_get(data)) && # no attached attribute
        # the original has attached attribute
        !is.null(value <- ggalign_attr_get(original))) {
        data <- ggalign_attr_set(data, value)
    }

    if (is.null(ggalign_lvls_get(data)) && # no attached levels
        # the original has attached levels
        !is.null(value <- ggalign_lvls_get(original))) {
        data <- ggalign_lvls_set(data, value)
    }
    # to prevent the print of attributes
    if (!is.null(ggalign_attr_get(data)) ||
        !is.null(ggalign_lvls_get(data))) {
        data <- add_class(data, "ggalign_data")
    }
    data
}

#' Group and align observations based on a group vector
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Splits observations into groups, with slice ordering based on group levels.
#'
#' @param group A character define the groups of the observations.
#' @inheritParams align
#' @examples
#' set.seed(1L)
#' small_mat <- matrix(rnorm(81), nrow = 9)
#' ggheatmap(small_mat) +
#'     anno_top() +
#'     align_group(sample(letters[1:4], ncol(small_mat), replace = TRUE))
#' @export
align_group <- function(group, active = NULL) {
    assert_active(active)
    if (vec_size(group) == 0L) {
        cli_abort("{.arg group} cannot be empty")
    }
    active <- update_active(active, new_active(use = FALSE))
    align(
        align = AlignGroup,
        group = group,
        active = active,
        check.param = TRUE
    )
}

#' @importFrom ggplot2 ggproto
AlignGroup <- ggproto("AlignGroup", CraftAlign,
    interact_layout = function(self, layout) {
        layout <- ggproto_parent(CraftAlign, self)$interact_layout(layout)
        if (is.null(layout_nobs <- .subset2(layout@design, "nobs"))) {
            layout@design["nobs"] <- list(vec_size(self$group))
        } else {
            assert_mismatch_nobs(
                self, layout_nobs, vec_size(self$group),
                arg = "group"
            )
        }
        layout
    },
    align = function(self, panel, index) list(self$group, index),
    summary_align = function(self) c(FALSE, TRUE)
)

# Will ensure serialisation includes a link to the ggalign namespace
# Copied from patchwork
namespace_link <- function() NULL

# https://stackoverflow.com/questions/65817557/s3-methods-extending-ggplot2-gg-function
# Here we use S4 object to override the double dispatch of `+.gg` method
# TO-DO: use S7
#' A `Layout` object
#'
#' A `Layout` object defines how to place the plots.
#'
#' @keywords internal
# add suffix "Proto" to avoid conflict with ggplot2
methods::setClass("LayoutProto",
    list(
        active = "ANY", # current active plot
        schemes = "list", # used to provide global parameters for all plots
        # control the layout, `theme` will also be used by `ggsave`
        titles = "list",
        annotation = "list", # To-Do add `pacth_titles` for layout
        theme = "ANY",
        `_namespace` = "ANY"
    ),
    prototype = list(
        active = NULL, titles = list(),
        annotation = list(), theme = NULL,
        `_namespace` = namespace_link
    )
)

#' @export
print.LayoutProto <- print.alignpatches

#' @importFrom grid grid.draw
#' @exportS3Method
grid.draw.LayoutProto <- grid.draw.alignpatches

#' @export
alignpatch.LayoutProto <- function(x) alignpatch(ggalign_build(x))

#' Print Layout object
#'
#' @param object A `r rd_layout()`.
#' @return The input invisiblely.
#' @importFrom methods show
#' @export
#' @keywords internal
methods::setMethod("show", "LayoutProto", function(object) {
    print(object)
})

#' Subset a `Layout` object
#'
#' Used by [`ggplot_build`][ggplot2::ggplot_build] and
#' [`ggsave`][ggplot2::ggsave]
#'
#' @param x A `Layout` object
#' @param name A string of slot name in `Layout` object.
#' @return The slot value.
#' @importFrom methods slot
#' @export
#' @keywords internal
methods::setMethod("$", "LayoutProto", function(x, name) {
    slot(x, name)
})

###########################################################
default_layout <- function(layout) { # setup default value for the layout
    layout@theme <- complete_theme(default_theme() + layout@theme)

    # we by default, collect all guides
    layout@schemes$scheme_align["guides"] <- list(
        .subset2(.subset2(layout@schemes, "scheme_align"), "guides") %|w|% "tlbr"
    )

    # we by default, use `default_theme()`
    layout@schemes$scheme_theme <- update_scheme(
        .subset2(layout@schemes, "scheme_theme"),
        new_scheme_theme(complete_theme(default_theme()))
    )
    layout
}

is_linear <- function(layout) UseMethod("is_linear")

#' @export
is_linear.StackLayout <- function(layout) TRUE

#' @export
is_linear.CircleLayout <- function(layout) FALSE

###########################################################
inherit_parent_layout_schemes <- function(layout, schemes) {
    if (is.null(schemes)) {
        return(layout@schemes)
    }
    inherit_schemes(layout@schemes, schemes)
}

inherit_parent_layout_theme <- function(layout, theme, spacing = NULL) {
    if (is.null(theme)) return(layout@theme) # styler: off
    # parent theme, set the global panel spacing,
    # so that every panel aligns well
    if (is.null(layout@theme)) return(theme) # styler: off
    ans <- theme + layout@theme
    if (is.null(spacing)) return(ans) # styler: off
    switch(spacing,
        x = ans + theme(
            panel.spacing.x = calc_element("panel.spacing.x", theme)
        ),
        y = ans + theme(
            panel.spacing.y = calc_element("panel.spacing.y", theme)
        )
    )
}

############################################################
#' Get the statistics from the layout
#'
#' @param x A `r rd_layout()`.
#' @inheritParams rlang::args_dots_used
#' @return The statistics
#' @export
ggalign_stat <- function(x, ...) {
    UseMethod("ggalign_stat")
}

#' @param position A string of `r oxford_or(.TLBR)`.
#' @export
#' @rdname ggalign_stat
ggalign_stat.QuadLayout <- function(x, position, ...) {
    ggalign_stat(x = slot(x, position), ...)
}

#' @param what A single number or string of the plot elements in the stack
#' layout.
#' @export
#' @rdname ggalign_stat
ggalign_stat.StackLayout <- function(x, what, ...) {
    plot_list <- x@plot_list
    index <- vec_as_location2(
        what,
        n = length(plot_list),
        names = names(plot_list),
        missing = "error"
    )
    ggalign_stat(x = .subset2(plot_list, index), ...)
}

#' @export
ggalign_stat.CraftBox <- function(x, ...) {
    ggalign_stat(x@craftsman, ...)
}

#' @export
ggalign_stat.CraftAlign <- function(x, ...) {
    rlang::check_dots_empty()
    .subset2(x, "statistics")
}

#' @export
ggalign_stat.default <- function(x, ...) {
    cli_abort(sprintf("no statistics found for %s", object_name(x)))
}

#############################################################
#' Reports whether `x` is layout object
#'
#' @param x An object to test.
#' @return A single boolean value.
#' @examples
#' is_layout(ggheatmap(1:10))
#'
#' @importFrom methods is
#' @export
is_layout <- function(x) is(x, "LayoutProto")

#' @examples
#' # for quad_layout()
#' is_quad_layout(quad_alignb(1:10))
#' is_quad_layout(quad_alignh(1:10))
#' is_quad_layout(quad_alignv(1:10))
#' is_quad_layout(quad_free(mtcars))
#'
#' @export
#' @rdname is_layout
is_quad_layout <- function(x) is(x, "QuadLayout")

#' @examples
#' # for stack_layout()
#' is_stack_layout(stack_discrete("h", 1:10))
#' is_stack_layout(stack_continuous("h", 1:10))
#'
#' @export
#' @rdname is_layout
is_stack_layout <- function(x) is(x, "StackLayout")

#' @export
#' @rdname is_layout
is_stack_cross <- function(x) is(x, "StackCross")

#' @export
#' @rdname is_layout
is_circle_layout <- function(x) is(x, "CircleLayout")

#' @examples
#' # for heatmap_layout()
#' is_heatmap_layout(ggheatmap(1:10))
#' @export
#' @rdname is_layout
is_heatmap_layout <- function(x) is(x, "HeatmapLayout")

#' @examples
#' is_ggheatmap(ggheatmap(1:10))
#' @export
#' @rdname is_layout
is_ggheatmap <- is_heatmap_layout

is_cross_layout <- function(x) is_stack_cross(x)

#' Change the layer adding order
#'
#' @description
#' This function allows you to change the order in which layers are added to a
#' ggplot.
#'
#' @param layer A [`layer geometry`][ggplot2::layer_geoms] object to be added.
#' @param order An integer indicating the position at which the layer should be
#' added. If `<= 0`, the layer will be added at the beginning. If greater than
#' the number of plot layers, it will be added at the end.
#' @return A `layer_order` object.
#' @examples
#' ggplot(faithfuld, aes(waiting, eruptions)) +
#'     geom_raster(aes(fill = density)) +
#'     geom_point(color = "red", size = 1)
#' ggplot(faithfuld, aes(waiting, eruptions)) +
#'     geom_raster(aes(fill = density)) +
#'     layer_order(geom_point(color = "red", size = 1))
#' @export
layer_order <- function(layer, order = 0) {
    assert_number_decimal(order)
    UseMethod("layer_order")
}

#' @export
layer_order.default <- function(layer, order = 0) {
    cli_abort("{.arg layer} must be a {.fn geom_*} object")
}

#' @export
layer_order.Layer <- function(layer, order = 0) {
    if (!is.infinite(order)) order <- vec_cast(order, integer())
    structure(
        list(
            object = layer,
            order = order,
            # used for `ggplot_add`
            object_name = paste(deparse(substitute(layer)), collapse = " ")
        ),
        class = "ggalign_layer_order"
    )
}

#' @export
layer_order.ggalign_layer_order <- function(layer, order = 0) {
    if (!is.infinite(order)) order <- vec_cast(order, integer())
    layer$order <- order
    layer
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.ggalign_layer_order <- function(object, plot, object_name, ...) {
    # ggplot2 will do something special for the layer
    # add layer_name, we re-call the method for the layer
    ans <- ggplot_add(
        .subset2(object, "object"),
        plot, .subset2(object, "object_name")
    )
    if ((cur <- length(layers <- ans$layers)) == 1L) {
        return(ans)
    }
    order <- .subset2(object, "order")
    layer <- .subset2(layers, cur)
    if (order >= length(layers)) return(ans) # styler: off
    if (order <= 0L) {
        layers <- append(vec_slice(layers, -cur), layer, 0L)
    } else {
        layers <- append(vec_slice(layers, -cur), layer, order)
    }
    ans$layers <- layers
    ans
}

#' @importFrom ggplot2 theme_bw element_blank
default_theme <- function() {
    if (is_theme_unset()) {
        theme_bw() +
            theme(
                axis.text = ggplot2::element_text(color = "black"),
                strip.text = ggplot2::element_text(color = "black"),
                panel.border = element_blank(),
                panel.grid = element_blank()
            )
    } else {
        theme_get()
    }
}

# Check if user has set the theme
is_theme_unset <- function() {
    isTRUE(all.equal(
        complete_theme(ggfun("ggplot_global")$theme_default),
        complete_theme(theme_get())
    ))
}

is_theme_complete <- function(x) isTRUE(attr(x, "complete", exact = TRUE))

#' @importFrom ggplot2 rel element_blank
theme_no_strip <- function() {
    theme(
        strip.text = element_blank(),
        strip.background = element_blank()
    )
}

theme_panel_border <- function() theme(panel.border = element_rect(fill = NA))

#' @importFrom utils packageVersion
#' @importFrom rlang try_fetch
complete_theme <- function(theme) {
    if (packageVersion("ggplot2") > "3.5.2") {
        ggfun("complete_theme")(theme)
    } else {
        ggfun("plot_theme")(list(theme = theme))
    }
}

#' @importFrom ggplot2 register_theme_elements el_def element_line
theme_elements <- function() {
    register_theme_elements(
        ggalign.line = element_line(
            color = "black",
            linewidth = 0.5,
            linetype = 1,
            lineend = "butt",
            linejoin = "round"
        ),
        ggalign.polygon = element_polygon(
            fill = NA,
            color = "black",
            linewidth = 0.5,
            linetype = 1,
            alpha = NA,
            lineend = "butt",
            linejoin = "round",
            linemitre = 10
        ),
        element_tree = list(
            plot.patch_title = el_def("element_text", "text"),
            plot.patch_title.top = el_def("element_text", "text"),
            plot.patch_title.left = el_def("element_text", "text"),
            plot.patch_title.bottom = el_def("element_text", "text"),
            plot.patch_title.right = el_def("element_text", "text"),
            plot.patch_title.position = el_def("character"),
            plot.patch_title.position.top = el_def("character"),
            plot.patch_title.position.left = el_def("character"),
            plot.patch_title.position.bottom = el_def("character"),
            plot.patch_title.position.right = el_def("character"),
            panel.spacing.r = el_def(c("unit", "rel"), "panel.spacing"),
            ggalign.line = el_def("element_line"),
            ggalign.curve = el_def("element_curve"),
            ggalign.polygon = el_def("element_polygon")
        )
    )
}

#' Used to match theme
#'
#' @keywords internal
#' @noRd
theme_recycle <- function() structure(list(), class = "theme_recycle")

#' @importFrom ggplot2 ggplot_add ggproto ggproto_parent
#' @export
ggplot_add.theme_recycle <- function(object, plot, object_name, ...) {
    ParentFacet <- plot$facet
    if (!inherits(ParentFacet, c("FacetGrid", "FacetWrap"))) {
        return(plot)
    }
    # recycle axis theme elements
    plot$facet <- ggproto(
        NULL, ParentFacet,
        draw_panels = function(self, panels, layout,
                               x_scales = NULL, y_scales = NULL,
                               ranges, coord, data = NULL, theme, params) {
            # we recycle the theme elements of the guide axis
            theme <- recycle_theme_axis("x", theme, x_scales)
            theme <- recycle_theme_axis("y", theme, y_scales)
            ParentCoord <- coord
            h_tick0 <- h_text0 <- 0L
            v_tick0 <- v_text0 <- 0L
            # subset theme for each panel
            coord <- ggproto(NULL, ParentCoord,
                # `align_scales` will attach the `.__plot_index__`
                render_axis_h = function(self, panel_params, theme) {
                    scale <- (.subset2(panel_params, "x") %||%
                        .subset2(panel_params, "theta")
                    )$scale
                    h_tick1 <- h_tick0 + length(scale$get_breaks())
                    h_text1 <- h_text0 + length(scale$get_labels())
                    theme <- subset_theme_axis(
                        "x", theme, h_tick0, h_text0, h_tick1, h_text1
                    )
                    h_tick0 <<- h_tick1
                    h_text0 <<- h_text1
                    ggproto_parent(ParentCoord, self)$render_axis_h(
                        panel_params, theme
                    )
                },
                render_axis_v = function(self, panel_params, theme) {
                    scale <- (.subset2(panel_params, "y") %||%
                        .subset2(panel_params, "r")
                    )$scale
                    v_tick1 <- v_tick0 + length(scale$get_breaks())
                    v_text1 <- v_text0 + length(scale$get_labels())
                    theme <- subset_theme_axis(
                        "y", theme, v_tick0, v_text0, v_tick1, v_text1
                    )
                    v_tick0 <<- v_tick1
                    v_text0 <<- v_text1
                    ggproto_parent(ParentCoord, self)$render_axis_v(
                        panel_params, theme
                    )
                }
            )
            ggproto_parent(ParentFacet, self)$draw_panels(
                panels = panels, layout = layout,
                x_scales = x_scales, y_scales = y_scales,
                ranges = ranges, coord = coord, data = data,
                theme = theme, params = params
            )
        }
    )
    plot
}

#################################################################
# Apply a function to the vectorized field of the theme object
theme_vec <- function(.th, .el, .fn, ...) {
    element <- calc_element(.el, .th)
    if (inherits(element, "element")) {
        .th[[.el]] <- element_vec(element, .fn, ...)
    } else if (!is.null(element)) {
        .th[[.el]] <- .fn(element, ...)
    }
    .th
}

recycle_theme_axis <- function(axis, theme, scales) {
    breaks <- unlist(lapply(scales, function(s) s$get_breaks()), FALSE, FALSE)
    labels <- unlist(lapply(scales, function(x) x$get_labels()), FALSE, FALSE)
    align_theme_axis(axis, theme,
        tick_fn = function(v, arg) rep(v, length.out = length(breaks)),
        text_fn = function(v, arg) rep(v, length.out = length(labels))
    )
}

subset_theme_axis <- function(axis, theme, tick0, text0, tick1, text1) {
    tick_index <- (tick0 + 1L):tick1
    text_index <- (text0 + 1L):text1
    align_theme_axis(
        axis, theme,
        tick_fn = function(value) vec_slice(value, tick_index),
        text_fn = function(value) vec_slice(value, text_index)
    )
}

align_theme_axis <- function(axis, theme, text_fn, tick_fn) {
    if (axis == "y") {
        positions <- c("left", "right")
    } else {
        positions <- c("top", "bottom")
    }
    # only apply the function when the element values is not a scalar
    .text_fn <- function(v) if (length(v) > 1L) text_fn(v) else v
    .tick_fn <- function(v) if (length(v) > 1L) tick_fn(v) else v
    for (element in paste("axis.text", axis, positions, sep = ".")) {
        theme <- theme_vec(theme, element, .text_fn)
    }
    for (element in paste("axis.ticks", axis, positions, sep = ".")) {
        theme <- theme_vec(theme, element, .tick_fn)
    }
    for (element in paste("axis.ticks.length", axis, positions, sep = ".")) {
        theme <- theme_vec(theme, element, .tick_fn)
    }
    theme
}

# Standalone file: do not edit by hand
# Source: https://github.com/Yunuuuu/standalone/blob/HEAD/R/standalone-tibble.R
# Generated by: usethis::use_standalone("Yunuuuu/standalone", "tibble")
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-tibble.R
# last-updated: 2024-11-14
# license: https://unlicense.org
# imports: [vctrs (>= 0.5.0), rlang]
# ---

# when developing R package, instead of depending on `dplyr`, `tidyr`, `tibble`.
# we prefer use the basic function from `vctrs`
#
# Note: these functions won't check arguments
#
# Since `vctrs` also depends on `rlang` and `cli`, it has no harm to use
# function from `rlang` and `cli`.
#
# Please initialize the package docs and import vctrs
# 1. run `usethis::use_package_doc()`
# 2. in package docs, please add #' @import vctrs

# ## Changelog
# 2025-03-12
# - Added `case_when()`
#
# 2024-11-14
# - Added `column_to_rownames()`
#
# 2024-11-13
# - fix wrong results in `coalesce()`: we should assign value in the missing
#   index
#
# 2024-11-12
# - Added `rename`
# - coalesce() now will return value immediately when no missing value exists.
#
# 2024-11-11:
# - Added `inner_join`
# - Added `left_join`
# - Added `right_join`
# - Added `cross_join`
# - Added `replace_na`
# - Added `coalesce`
# - Added `deframe`
# - Added `enframe`
# - Added `remove_rownames`
# - Added `rownames_to_column`
#
# 2024-11-10:
# - Added `full_join`
# - Added `if_else`
#
# nocov start

#' @importFrom rlang set_names
full_join <- function(
    x,
    y,
    by = vec_set_intersect(names(x), names(y)),
    by.x = by,
    by.y = by,
    suffix = c(".x", ".y")
) {
    loc <- vec_locate_matches(x[by.x], set_names(y[by.y], by.x), remaining = NA)
    x_slicer <- .subset2(loc, "needles")
    y_slicer <- .subset2(loc, "haystack")
    ans <- join_bind(
        vec_slice(x, x_slicer),
        # drop duplicated join column
        vec_slice(y[vec_set_difference(names(y), by.y)], y_slicer),
        suffix = suffix
    )
    new_rows <- which(vec_detect_missing(x_slicer)) # should come from `y`
    if (length(new_rows)) {
        ans[new_rows, by.x] <- vec_slice(y[by.y], y_slicer[new_rows])
    }
    ans
}

#' @importFrom rlang set_names
inner_join <- function(
    x,
    y,
    by = vec_set_intersect(names(x), names(y)),
    by.x = by,
    by.y = by,
    suffix = c(".x", ".y")
) {
    loc <- vec_locate_matches(
        x[by.x],
        set_names(y[by.y], by.x),
        no_match = "drop"
    )
    x_slicer <- .subset2(loc, "needles")
    y_slicer <- .subset2(loc, "haystack")
    join_bind(
        vec_slice(x, x_slicer),
        # drop duplicated join column
        vec_slice(y[vec_set_difference(names(y), by.y)], y_slicer),
        suffix = suffix
    )
}

#' @importFrom rlang set_names
left_join <- function(
    x,
    y,
    by = vec_set_intersect(names(x), names(y)),
    by.x = by,
    by.y = by,
    suffix = c(".x", ".y")
) {
    loc <- vec_locate_matches(x[by.x], set_names(y[by.y], by.x))
    x_slicer <- .subset2(loc, "needles")
    y_slicer <- .subset2(loc, "haystack") # can have NA value
    join_bind(
        vec_slice(x, x_slicer),
        # drop duplicated join column
        vec_slice(y[vec_set_difference(names(y), by.y)], y_slicer),
        suffix = suffix
    )
}

#' @importFrom rlang set_names
right_join <- function(
    x,
    y,
    by = vec_set_intersect(names(x), names(y)),
    by.x = by,
    by.y = by,
    suffix = c(".x", ".y")
) {
    loc <- vec_locate_matches(
        x[by.x],
        set_names(y[by.y], by.x),
        no_match = "drop",
        remaining = NA
    )
    x_slicer <- .subset2(loc, "needles") # can have NA value
    y_slicer <- .subset2(loc, "haystack")
    join_bind(
        # drop duplicated join column
        vec_slice(x[vec_set_difference(names(x), by.x)], x_slicer),
        vec_slice(y, y_slicer),
        suffix = suffix
    )
}

cross_join <- function(x, y, suffix = c(".x", ".y")) {
    x_size <- vec_size(x)
    y_size <- vec_size(y)
    x_out <- vec_rep_each(x, times = y_size)
    y_out <- vec_rep(y, times = x_size)
    join_bind(x_out, y_out, suffix)
}

join_bind <- function(x, y, suffix) {
    x_names <- names(x)
    y_names <- names(y)
    common <- vec_set_intersect(x_names, y_names)
    if (length(common)) {
        # add suffix to duplicated names
        index <- vec_match(common, x_names)
        names(x)[index] <- paste0(x_names[index], .subset(suffix, 1L))
        index <- vec_match(common, y_names)
        names(y)[index] <- paste0(y_names[index], .subset(suffix, 2L))
    }
    vec_cbind(x, y, .name_repair = "check_unique")
}

#' Rename elements in a list, data.frame or vector
#'
#' This is akin to `dplyr::rename` and `plyr::rename`. It renames elements given
#' as names in the `replace` vector to the values in the `replace` vector
#' without touching elements not referenced.
#'
#' @param x A data.frame or a named vector or list
#' @param replace A named character vector. The names identifies the elements in
#' `x` that should be renamed and the values gives the new names.
#'
#' @return `x`, with new names according to `replace`
#' @noRd
rename <- function(x, replace) {
    nms <- names(x)
    names(x) <- vec_assign(nms, match(names(replace), nms), replace)
    x
}

if_else <- function(condition, true, false, na = NULL) {
    # output size from `condition`
    size <- vec_size(condition)

    # output type from `true`/`false`/`na`
    ptype <- vec_ptype_common(true = true, false = false, na = na)

    args <- vec_recycle_common(
        true = true,
        false = false,
        na = na,
        .size = size
    )
    args <- vec_cast_common(!!!args, .to = ptype)

    out <- vec_init(ptype, size)

    loc_true <- condition
    loc_false <- !condition

    out <- vec_assign(out, loc_true, vec_slice(args$true, loc_true))
    out <- vec_assign(out, loc_false, vec_slice(args$false, loc_false))

    if (!is.null(na)) {
        loc_na <- vec_detect_missing(condition)
        out <- vec_assign(out, loc_na, vec_slice(args$na, loc_na))
    }

    out
}

case_when <- function(.default, ..., .ptype = NULL) {
    if (is.null(.ptype)) {
        .ptype <- vec_ptype(.default)
    } else {
        .default <- vec_cast(.default, .ptype)
    }
    env <- rlang::caller_env()
    dots <- rlang::list2(...)
    unused <- vec_rep(TRUE, times = vec_size(.default))
    for (i in seq_along(dots)) {
        if (!any(unused)) {
            break
        }
        dot <- .subset2(dots, i)
        loc <- unused & rlang::eval_tidy(rlang::f_lhs(dot), env = env)
        value <- rlang::eval_tidy(rlang::f_rhs(dot), env = env)
        value <- vec_cast(value, .ptype, x_arg = sprintf("`...` (%d)", i))
        if (length(value) > 1L) value <- vec_slice(value, loc)
        .default <- vec_assign(
            .default,
            loc,
            value,
            value_arg = sprintf("`...` (%d)", i)
        )
        unused[loc] <- FALSE
    }
    .default
}

#' Replace NAs with specified values
#' @param value A single value.
#' @noRd
replace_na <- function(x, value) {
    value <- vec_cast(x = value, to = x, x_arg = "value", to_arg = "x")
    vec_assign(x, vec_detect_missing(x), value)
}

#' Find the first non-missing element
#' @param ... A list of atomic vector (You shouldn't input `NULL`).
#' @noRd
coalesce <- function(...) {
    dots <- vec_recycle_common(...)
    out <- .subset2(dots, 1L)
    for (i in 2:length(dots)) {
        if (vec_any_missing(out)) {
            missing <- vec_detect_missing(out)
            out <- vec_assign(
                out,
                missing,
                vec_slice(.subset2(dots, i), missing)
            )
        } else {
            return(out)
        }
    }
    out
}

#' Convert values to `NA`
#' @noRd
na_if <- function(x, y) {
    y <- vec_cast(x = y, to = x, x_arg = "y", to_arg = "x")
    y <- vec_recycle(y, size = vec_size(x), x_arg = "y")
    na <- vec_init(x)
    vec_assign(x, vec_equal(x, y, na_equal = TRUE), na)
}

deframe <- function(x) {
    if (ncol(x) == 1L) {
        return(x[[1]])
    }
    vec_set_names(x[[1L]], x[[2]])
}

enframe <- function(x, name = "name", value = "value") {
    if (!is.null(names(x))) {
        data <- list(names(x), unname(x))
    } else {
        data <- list(seq_along(x), unname(x))
    }
    new_data_frame(vec_set_names(data, c(name, value)))
}

remove_rownames <- function(.data) {
    rownames(.data) <- NULL
    .data
}

rownames_to_column <- function(.data, var = "rowname") {
    if (!is.null(var_col <- rownames(.data))) {
        nms <- names(.data)
        .data[[var]] <- var_col
        .data <- .data[c(var, nms)]
    }
    .data
}

column_to_rownames <- function(.data, var = 1L) {
    rownames(.data) <- .subset2(.data, var)
    .data[[var]] <- NULL
    .data
}

# nocov end

#' Plot Adding Context Settings
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' These settings control the behavior of the plot when added to a layout, as
#' well as the arrangement of individual plot areas within the layout.
#'
#' @details
#' By default, the active context is set only for functions that add plot areas.
#' This allows other `ggplot2` elements-such as `geoms`, `stats`, `scales`, or
#' `themes`- to be seamlessly added to the current plot area.
#'
#' The default ordering of the plot areas is from top to bottom or from left to
#' right, depending on the layout orientation. However, users can customize this
#' order using the `order` argument.
#'
#' @param order An integer specifying the order of the plot area within the
#'   layout.
#' @param use A logical (`TRUE`/`FALSE`) indicating whether to set the
#'   active context to the current plot when added to a layout. If `TRUE`,
#'   any subsequent `ggplot` elements will be applied to this plot.
#' @param name A string specifying the plot's name, useful for switching active
#'   contexts through the `what` argument in functions like
#'   [`quad_anno()`]/[`stack_switch()`].
#' @export
active <- function(order = waiver(), use = waiver(), name = waiver()) {
    if (!is.waive(order)) order <- check_order(order)
    if (!is.waive(use)) assert_bool(use)
    if (!is.waive(name)) {
        assert_string(name,
            empty_ok = FALSE, allow_na = TRUE,
            allow_null = FALSE
        )
    }
    new_active(order = order, use = use, name = name)
}

# for internal function, we only adjust to the `use` argument
# here, we put it in the first
new_active <- function(use, order = NA_integer_, name = NA_character_) {
    structure(
        list(order = order, use = use, name = name),
        class = "ggalign_active"
    )
}

#' @importFrom utils modifyList
update_active <- function(active, default) {
    if (is.null(active)) return(default) # styler: off
    modifyList(default,
        active[!vapply(active, is.waive, logical(1L), USE.NAMES = FALSE)],
        keep.null = TRUE
    )
}

#' Create a heatmap
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' `heatmap_layout` is a specialized version of [`quad_discrete()`], which
#' simplifies the creation of heatmap plots by integrating essential elements
#' for a standard heatmap layout, ensuring that the appropriate data mapping and
#' visualization layers are automatically applied. `ggheatmap` is an alias for
#' `heatmap_layout`.
#'
#' @param data `r rd_layout_data()`. By default, it will try to inherit from
#' parent layout. [`fortify_matrix()`] will be used to convert data to a
#' matrix.
#' @param ... Additional arguments passed to [`fortify_matrix()`].
#' @inheritParams quad_layout
#' @param filling A single string of `r oxford_or(c("raster", "tile"))` to
#' indicate the filling style. By default, `waiver()` is used, which means that
#' if the input matrix has more than 20,000 cells (`nrow * ncol > 20000`),
#' [`geom_raster()`][ggplot2::geom_raster] will be used for performance
#' efficiency; for smaller matrices, [`geom_tile()`][ggplot2::geom_tile] will be
#' used. To customize the filling style, set this to `NULL`.
#'
#' For backward compatibility, a single boolean value is acceptable: `TRUE`
#' means `waiver()`, and `FALSE` means `NULL`.
#'
#' By default, the classic heatmap color scheme
#' [`scale_fill_gradient2(low = "blue", high = "red")`][ggplot2::scale_fill_gradient2]
#' is utilized for continuous values.
#'
#' You can use the options
#' `r code_quote(sprintf("%s.heatmap_continuous_fill", pkg_nm()))` or
#' `r code_quote(sprintf("%s.heatmap_discrete_fill", pkg_nm()))` to modify the
#' default heatmap body filling color scale. See
#' [`scale_fill_continuous()`][ggplot2::scale_fill_continuous] or
#' [`scale_fill_discrete()`][ggplot2::scale_fill_discrete] for details on
#' option settings.
#'
#' @section ggplot2 specification:
#' The data input will be converted to a matrix using [`fortify_matrix()`], and
#' the data in the underlying main plot will contain the following columns:
#'
#'  - `.panel_x` and `.panel_y`: the column and row panel groups.
#'
#'  - `.x` and `.y`: an integer index of `x` and `y` coordinates
#'
#'  - `.discrete_x` and `.discrete_y`: a factor of the data labels (only
#'    applicable when `.row_names` and `.column_names` exists).
#'
#'  - `.row_names` and `.column_names`: A character of the row and column names
#'    of the original matrix (only applicable when names exist).
#'
#'  - `.row_index` and `.column_index`: the row and column index of the original
#'    matrix.
#'
#'  - `value`: the actual matrix value.
#'
#' @return A `HeatmapLayout` object.
#' @examples
#' ggheatmap(1:10)
#' ggheatmap(letters)
#' ggheatmap(matrix(rnorm(81), nrow = 9L))
#' @importFrom ggplot2 aes
#' @export
heatmap_layout <- function(data = NULL, mapping = aes(),
                           ...,
                           width = NA, height = NA, filling = waiver(),
                           theme = NULL, active = NULL) {
    UseMethod("heatmap_layout")
}

#' @usage NULL
#' @export
#' @rdname heatmap_layout
ggheatmap <- heatmap_layout

#' @importFrom ggplot2 aes
#' @importFrom rlang arg_match0
#' @export
heatmap_layout.default <- function(data = NULL, mapping = aes(),
                                   ...,
                                   width = NA, height = NA, filling = waiver(),
                                   theme = NULL, active = NULL) {
    # A single boolean value for compatible with `version <= 0.0.4`
    if (isTRUE(filling)) {
        filling <- waiver()
    } else if (isFALSE(filling)) {
        filling <- NULL
    } else if (!is.waive(filling) && !is.null(filling)) {
        filling <- arg_match0(filling, c("tile", "raster"))
    }
    data <- data %|w|% NULL
    # we need a matrix to melted into long formated data frame
    data <- fortify_matrix(data = data, ...)
    ans <- new_quad_layout(
        name = "ggheatmap",
        data = data,
        mapping = mapping,
        theme = theme, active = active,
        width = width, height = height,
        class = "HeatmapLayout"
    )
    # add default mapping
    ans@plot <- ggadd_default(ans@plot, mapping = aes(.data$.x, .data$.y)) +
        ggplot2::labs(x = NULL, y = NULL)
    ans@filling <- filling
    ans
}

# used to create the heatmap layout
#' @keywords internal
#' @include layout-quad-.R
methods::setClass(
    "HeatmapLayout",
    contains = "QuadLayout",
    list(filling = "ANY") # parameters for heatmap body
)

#' @importFrom ggplot2 .pt
ggfun <- function(fn, mode = "any") from_namespace("ggplot2", fn, mode = mode)

allow_lambda <- function(x) {
    if (rlang::is_formula(x)) rlang::as_function(x) else x
}

is.waive <- function(x) inherits(x, "waiver")

`%|w|%` <- function(x, y) if (inherits(x, "waiver")) y else x

snake_class <- function(x) ggfun("snake_class")(x)

ggadd_default <- function(plot, mapping = NULL, theme = NULL) {
    if (!is.null(mapping)) {
        plot <- plot + mapping + plot$mapping
    }
    if (!is.null(theme)) plot$theme <- theme + plot$theme
    plot
}

is_palette_unset <- function(type, aes) {
    type <- match.arg(type, c("discrete", "continuous", "binned"))
    aes <- match.arg(aes, c("fill", "colour"))
    is.null(getOption(sprintf("ggplot2.%s.%s", type, aes)))
}

# A guide-box should be a `zeroGrob()` or a `gtable` object
#' @importFrom gtable is.gtable
maybe_guide_box <- function(x) inherits(x, "zeroGrob") || is.gtable(x)

######################################################
gguse_data <- function(plot, data) {
    # ggplot use waiver() to indicate no data
    plot["data"] <- list(data %||% waiver())
    plot
}

ggremove_margin <- function(plot, direction) {
    if (!is.null(direction) && packageVersion("ggplot2") > "3.5.2") {
        plot <- plot + switch_direction(
            direction,
            theme(plot.margin = margin(t = 0, r = NA, b = 0, l = NA)),
            theme(plot.margin = margin(t = NA, r = 0, b = NA, l = 0))
        )
    }
    plot
}

######################################################
default_expansion <- function(x = NULL, y = NULL) {
    structure(list(x = x, y = y), class = c("ggalign_default_expansion"))
}

#' @importFrom ggplot2 ggplot_add ggproto ggproto_parent
#' @export
ggplot_add.ggalign_default_expansion <- function(object, plot, object_name,
                                                 ...) {
    if (is.null(.subset2(object, "x")) && is.null(.subset2(object, "y"))) {
        return(plot)
    }
    ParentFacet <- plot$facet
    plot$facet <- ggproto(
        NULL,
        ParentFacet,
        init_scales = function(self, layout, x_scale = NULL, y_scale = NULL,
                               params) {
            if (!is.null(x_scale) && !is.null(.subset2(object, "x"))) {
                x_scale$expand <- x_scale$expand %|w|% .subset2(object, "x")
            }
            if (!is.null(y_scale) && !is.null(.subset2(object, "y"))) {
                y_scale$expand <- y_scale$expand %|w|% .subset2(object, "y")
            }
            ggproto_parent(ParentFacet, self)$init_scales(
                layout = layout,
                x_scale = x_scale,
                y_scale = y_scale,
                params = params
            )
        }
    )
    plot
}

######################################################
reverse_continuous_axis <- function(plot, axis) {
    if (plot$scales$has_scale(axis)) {
        # modify scale in place
        scale <- plot$scales$get_scales(axis)
        if (!scale$is_discrete()) {
            if (identical(scale$trans$name, "identity")) {
                scale$trans <- scales::as.transform("reverse")
            } else if (identical(scale$trans$name, "reverse")) {
                scale$trans <- scales::as.transform("identity")
            }
        }
    } else {
        plot <- plot +
            switch(axis,
                x = ggplot2::scale_x_reverse(),
                y = ggplot2::scale_y_reverse()
            )
    }
    plot
}

#' @keywords internal
chain_layout_subtract <- function(object, layout, object_name) {
    UseMethod("chain_layout_subtract")
}

#' @export
chain_layout_subtract.default <- function(object, layout, object_name) {
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        layout@plot_list <- lapply(layout@plot_list, function(plot) {
            if (is_craftbox(plot)) {
                chain_plot_add(plot, object, object_name, force = FALSE)
            } else {
                plot
            }
        })
    } else {
        layout@plot_list[[active_index]] <- quad_layout_subtract(
            object, plot, object_name
        )
    }
    layout
}

# for objects can inherit from layout
#' @export
chain_layout_subtract.ggalign_scheme <- function(object, layout, object_name) {
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        layout <- update_layout_scheme(object, layout, object_name)
    } else {
        layout@plot_list[[active_index]] <- quad_layout_subtract(
            object, plot, object_name
        )
    }
    layout
}

#' @export
chain_layout_subtract.ggalign_with_quad <- function(object, layout,
                                                    object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(sprintf(
            "Cannot add {.var {object_name}} to %s",
            object_name(layout)
        ))
    }
    if (is.null(active_index <- layout@active) ||
        is_craftbox(plot <- .subset2(layout@plot_list, active_index))) {
        inner <- .subset2(object, "object")
        inner_name <- .subset2(object, "object_name")

        # subtract set at layout level, if it is a plot option
        # we only apply to current active layout
        if (inherits(inner, "ggalign_scheme")) {
            layout <- update_layout_scheme(inner, layout, inner_name)
            return(layout)
        }

        # otherwise, we apply the object to all plots in the stack layout
        direction <- layout@direction
        layout@plot_list <- lapply(layout@plot_list, function(plot) {
            if (is_craftbox(plot)) {
                plot <- chain_plot_add(plot, inner, inner_name, force = FALSE)
            } else if (is.waive(.subset2(object, "position"))) {
                # default behaviour for object wrap with `with_quad()`
                # we add the object along the stack layout
                # if means for horizontal stack, we'll add it
                # to the left and right annotation, and the main plot
                positions <- switch_direction(
                    direction,
                    c("left", "right"),
                    c("top", "bottom")
                )
                for (position in positions) {
                    if (!is.null(slot(plot, position))) {
                        slot(plot, position) <- chain_layout_subtract(
                            inner, slot(plot, position), inner_name
                        )
                    }
                }
                if (is.null(main <- .subset2(object, "main")) || main) {
                    plot <- quad_body_add(inner, plot, inner_name)
                }
            } else {
                # we respect the context setting
                plot <- quad_layout_subtract(object, plot, object_name)
            }
            plot
        })
    } else {
        layout@plot_list[[active_index]] <- quad_layout_subtract(
            object, plot, object_name
        )
    }
    layout
}

##################################################################
#' @keywords internal
chain_layout_and_add <- function(object, layout, object_name) {
    UseMethod("chain_layout_and_add")
}

#' @export
chain_layout_and_add.ggalign_with_quad <- function(object, layout, object_name) {
    if (!is_stack_layout(layout)) {
        cli_abort(sprintf(
            "Cannot add {.var {object_name}} to %s",
            object_name(layout)
        ))
    }
    object <- .subset2(object, "object")
    object_name <- .subset2(object, "object_name")
    NextMethod()
}

#' @export
chain_layout_and_add.default <- function(object, layout, object_name) {
    layout@plot_list <- lapply(layout@plot_list, function(plot) {
        if (is_craftbox(plot)) {
            plot <- chain_plot_add(plot, object, object_name, force = FALSE)
        } else {
            plot <- quad_layout_and_add(object, plot, object_name)
        }
        plot
    })
    layout
}

#' @export
chain_layout_and_add.theme <- function(object, layout, object_name) {
    ans <- NextMethod()
    # to align with `patchwork`, we also modify the layout theme
    # when using `&` to add the theme object.
    ans@theme <- ggfun("add_theme")(ans@theme, object)
    ans
}

########################################
#' @importFrom utils modifyList getFromNamespace
#' @export
alignpatch.patchwork <- function(x) {
    rlang::check_installed("patchwork", "to align patchwork")
    get_patches <- getFromNamespace("get_patches", "patchwork")
    # patchwork will keep the class when extracting patches from it.
    # we removed the classes for patchwork, added behind patchwork
    # in this way, the last plot won't have class like `free_align`,
    # `free_border`, `free_lab`, et al. which is added for the patchwork
    sub_patchwork_cls <- which(class(x) == "patchwork") - 1L # nolint
    if (sub_patchwork_cls > 0L) {
        class(x) <- class(x)[-seq_len(sub_patchwork_cls)]
    }
    x <- get_patches(x)
    plots <- .subset2(x, "plots")
    layout <- .subset2(x, "layout")
    annotation <- .subset2(x, "annotation")
    default <- getFromNamespace("default_layout", "patchwork")
    layout <- modifyList(default, layout[
        !vapply(layout, is.null, logical(1L), USE.NAMES = FALSE)
    ])
    if (identical(.subset2(layout, "guides"), "collect")) {
        layout$guides <- .TLBR
    } else {
        layout$guides <- NULL
    }
    alignpatch(AlignPatches(
        plots,
        layout = layout,
        titles = .subset(annotation, names(layout_title())),
        theme = .subset2(annotation, "theme")
    ))
}

#' @export
alignpatch.free_plot <- function(x) {
    if (inherits(x, "patchwork")) {
        free_settings <- attr(x, "patchwork_free_settings")
    } else {
        free_settings <- attr(x, "free_settings")
    }
    free_settings <- split(
        names(free_settings),
        factor(free_settings, rev(unique(free_settings)))
    )
    class(x) <- vec_set_difference(class(x), "free_plot")
    for (type in names(free_settings)) {
        side <- paste(.subset2(free_settings, type), collapse = "")
        x <- switch(type,
            panel = free_align(x, side),
            label = free_lab(x, side),
            space = free_space(free_border(x, side), side),
        )
    }
    alignpatch(x)
}

######################################
# `patch` from `patchwork`: patchwork::plot_spacer
#' @importFrom ggplot2 ggproto
#' @export
alignpatch.patch <- function(x) {
    rlang::check_installed(
        "patchwork", sprintf("to align %s plot", obj_type_friendly(x))
    )
    ggproto(NULL, PatchPatchworkPatch, plot = x)
}

#' @importFrom ggplot2 ggproto
PatchPatchworkPatch <- ggproto(
    "PatchPatchworkPatch", Patch,
    # `patch` from `patchwork`: patchwork::plot_spacer
    #' @importFrom gtable gtable_add_rows gtable_add_cols
    #' @importFrom ggplot2 find_panel
    patch_gtable = function(self, theme, guides, plot = self$plot) {
        guides <- if (length(guides)) "collect" else "keep"
        ans <- patchwork::patchGrob(patch, guides = guides)
        for (border in .TLBR) {
            panel_pos <- find_panel(ans)
            if (border == "top") {
                h <- .subset2(panel_pos, "t") - 4L # above original xlab
                ans <- gtable_add_rows(ans, unit(0L, "mm"), pos = h)
            } else if (border == "left") {
                v <- .subset2(panel_pos, "l") - 4L # left of the ylab
                ans <- gtable_add_cols(ans, unit(0, "mm"), pos = v)
            } else if (border == "bottom") {
                h <- .subset2(panel_pos, "b") + 3L # below original xlab
                ans <- gtable_add_rows(ans, unit(0L, "mm"), pos = h)
            } else if (border == "right") {
                v <- .subset2(panel_pos, "r") + 3L # right of the ylab
                ans <- gtable_add_cols(ans, unit(0, "mm"), pos = v)
            }
        }
        ans
    }
)

#' @export
alignpatch.spacer <- function(x) NULL

#########################################
# `patch` from `patchwork`: patchwork::wrap_elements
#' @export
alignpatch.wrapped_patch <- alignpatch.patch

#' @param labs Which axis labs to be free? A string containing one or more of
#' `r oxford_and(.tlbr)`.
#' @return
#' - `free_lab`: A modified version of `plot` with a `free_lab` class.
#' @export
#' @rdname free
free_lab <- function(plot, labs = "tlbr") {
    UseMethod("free_lab")
}

#' @export
free_lab.ggplot <- function(plot, labs = "tlbr") {
    assert_position(labs)
    attr(plot, "free_labs") <- labs
    add_class(plot, "free_lab")
}

#' @export
free_lab.alignpatches <- free_lab.ggplot

#' @export
free_lab.free_align <- function(plot, labs = "tlbr") {
    assert_position(labs)
    labs <- setdiff_position(labs, attr(plot, "free_axes"))
    if (!nzchar(labs)) return(plot) # styler: off
    NextMethod()
}

#' @export
free_lab.free_borders <- function(plot, labs = "tlbr") {
    assert_position(labs)
    labs <- setdiff_position(labs, attr(plot, "free_borders"))
    if (!nzchar(labs)) return(plot) # styler: off
    NextMethod()
}

#' @export
free_lab.free_lab <- function(plot, labs = "tlbr") {
    assert_position(labs)
    attr(plot, "free_labs") <- union_position(attr(plot, "free_labs"), labs)
    plot
}

#' @export
free_lab.default <- function(plot, labs = "tlbr") {
    cli_abort("Cannot use with {.obj_type_friendly {plot}}")
}

####################################################
#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.free_lab <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchFreeLab", Parent,
        free_labs = setup_pos(attr(x, "free_labs")),
        collect_guides = function(self, guides, gt = self$gt) {
            ans <- ggproto_parent(Parent, self)$collect_guides(
                guides = guides, gt = gt
            )
            self$gt <- ggproto_parent(Parent, self)$free_lab(
                labs = self$free_labs, gt = self$gt
            )
            ans
        },
        free_lab = function(self, labs, gt = self$gt) {
            if (length(labs <- vec_set_difference(labs, self$free_labs))) {
                gt <- ggproto_parent(Parent, self)$free_lab(
                    labs = labs, gt = gt
                )
            }
            gt
        }
    )
}

#' Wrap Arbitrary Graphics to ggplot
#'
#' The `ggwrap()` function allows non-ggplot2 elements to be converted into a
#' compliant representation for use with [`align_plots()`]. This is useful for
#' adding any graphics that can be converted into a [`grob`][grid::grob] with
#' the [`patch()`] method.
#'
#' @param plot Any graphic that can be converted into a [`grob`][grid::grob]
#' using [`patch()`].
#' @param ... Additional arguments passed to the [`patch()`] method.
#' @param align A string specifying the area to place the plot: `"full"` for the
#' full area, `"plot"` for the full plotting area (including the axis label), or
#' `"panel"` for only the actual area where data is drawn.
#' @param clip A single boolean value indicating whether the grob should be
#' clipped if they expand outside their designated area.
#' @param on_top A single boolean value indicates whether the graphic plot
#' should be put frontmost. Note: the graphic plot will always put above the
#' background.
#' @param vp A [`viewport`][grid::viewport] object, you can use this to define
#' the plot area.
#' @return A `wrapped_plot` object that can be directly placed into
#' [`align_plots()`].
#' @inherit patch seealso
#' @examples
#' library(grid)
#' ggwrap(rectGrob(gp = gpar(fill = "goldenrod")), align = "full") +
#'     inset(rectGrob(gp = gpar(fill = "steelblue")), align = "panel") +
#'     inset(textGrob("Here are some text", gp = gpar(color = "black")),
#'         align = "panel"
#'     )
#' p1 <- ggplot(mtcars) +
#'     geom_point(aes(mpg, disp)) +
#'     ggtitle("Plot 1")
#' align_plots(p1, ggwrap(
#'     ~ plot(mtcars$mpg, mtcars$disp),
#'     mar = c(0, 2, 0, 0), bg = NA
#' ))
#'
#' @importFrom ggplot2 theme element_blank ggplot
#' @importFrom grid is.grob
#' @export
ggwrap <- function(plot, ..., align = "panel", on_top = FALSE,
                   clip = TRUE, vp = NULL) {
    patch <- ggplot() +
        theme(
            plot.background = element_blank(),
            panel.background = element_blank()
        )
    inset <- make_inset(
        plot = plot, ..., align = align, on_top = on_top,
        clip = clip, vp = vp
    )
    make_wrap(patch, inset)
}

make_wrap <- function(patch, inset) UseMethod("make_wrap")

make_wrapped_plot <- function(patch, inset) {
    if (.subset2(inset, "on_top")) {
        patch$ggalign_wrapped_insets_above <- c(
            patch$ggalign_wrapped_insets_above, list(inset)
        )
    } else {
        patch$ggalign_wrapped_insets_under <- c(
            patch$ggalign_wrapped_insets_under, list(inset)
        )
    }
    add_class(patch, "wrapped_plot")
}

#' @export
make_wrap.ggplot <- function(patch, inset) {
    patch <- add_class(patch, "patch_ggplot")
    make_wrap(patch, inset)
}

#' @export
make_wrap.patch_ggplot <- make_wrapped_plot

#' @export
make_wrap.alignpatches <- make_wrapped_plot

#################################################
#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.wrapped_plot <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchWrapped", Parent,
        ggalign_wrapped_insets_under = x$ggalign_wrapped_insets_under,
        ggalign_wrapped_insets_above = x$ggalign_wrapped_insets_above,
        patch_gtable = function(self, theme, guides, plot = Parent$plot) {
            ans <- ggproto_parent(Parent, self)$patch_gtable(
                theme = theme, guides = guides, plot = plot
            )
            ans <- add_wrapped_insets(
                ans, self$ggalign_wrapped_insets_under, FALSE
            )
            add_wrapped_insets(ans, self$ggalign_wrapped_insets_above, TRUE)
        }
    )
}

# For wrapped plot -------------------
#' @export
alignpatch.grob <- function(x) alignpatch(ggwrap(x))

#' @export
alignpatch.gList <- alignpatch.grob

#' @export
alignpatch.formula <- alignpatch.grob

#' @export
alignpatch.function <- alignpatch.grob

#' @export
alignpatch.recordedplot <- alignpatch.grob

#' @export
alignpatch.trellis <- alignpatch.grob

#' @export
alignpatch.Heatmap <- function(x) alignpatch(ggwrap(x, align = "full"))

#' @export
alignpatch.HeatmapList <- alignpatch.Heatmap

#' @export
alignpatch.HeatmapAnnotation <- alignpatch.Heatmap

#' @export
alignpatch.pheatmap <- function(x) alignpatch(ggwrap(x, align = "full"))

################################################## 3
add_wrapped_insets <- function(gt, insets, on_top) {
    if (is.null(insets)) return(gt) # styler: off
    for (i in seq_along(insets)) {
        gt <- add_wrapped_inset(gt, .subset2(insets, i), on_top, i)
    }
    gt
}

#' @importFrom gtable gtable is.gtable gtable_add_grob
add_wrapped_inset <- function(gt, inset, on_top, i) {
    align <- .subset2(inset, "align")
    clip <- .subset2(inset, "clip")
    layout <- .subset2(gt, "layout")
    grob <- .subset2(inset, "grob")
    if (on_top) {
        z <- Inf
    } else {
        background <- .subset2(layout, "name") == "background"
        z <- .subset2(layout, "z")[background] + 1L
        gt$layout$z[layout$z >= z] <- layout$z[layout$z >= z] + 1L
    }

    # add the grob to the gtable
    if (align == "full") {
        gt <- gtable_add_grob(gt,
            list(grob), 1L, 1L, nrow(gt), ncol(gt),
            clip = clip, name = sprintf("wrap-full-%d", i), z = z
        )
    } else {
        panel_loc <- find_panel(gt)
        gt <- switch(align,
            plot = gtable_add_grob(gt,
                list(grob),
                .subset2(panel_loc, "t") - 3L,
                .subset2(panel_loc, "l") - 3L,
                .subset2(panel_loc, "b") + 3L,
                .subset2(panel_loc, "r") + 3L,
                clip = clip, name = sprintf("wrap-plot-%d", i), z = z
            ),
            panel = gtable_add_grob(gt,
                list(grob),
                .subset2(panel_loc, "t"),
                .subset2(panel_loc, "l"),
                .subset2(panel_loc, "b"),
                .subset2(panel_loc, "r"),
                clip = clip, name = sprintf("wrap-panel-%d", i), z = z
            )
        )
    }
    gt
}

#' @inheritParams grid::viewport
#' @inheritDotParams grid::viewport -x -y -width -height
#' @return
#' - `free_vp`: A modified version of `plot` with a `free_vp` class.
#' @importFrom grid viewport
#' @export
#' @rdname free
free_vp <- function(plot, x = 0.5, y = 0.5, width = NA, height = NA, ...) {
    UseMethod("free_vp")
}

#' @export
free_vp.default <- function(plot, x = 0.5, y = 0.5,
                            width = NA, height = NA, ...) {
    cli_abort("Cannot use with {.obj_type_friendly {plot}}")
}

#' @export
free_vp.ggplot <- function(plot, x = 0.5, y = 0.5,
                           width = NA, height = NA, ...) {
    attr(plot, "vp") <- viewport(
        x = x, y = y, width = width, height = height, ...,
    )
    add_class(plot, "free_vp")
}

#' @export
free_vp.alignpatches <- free_vp.ggplot

####################################################
#' @importFrom gtable gtable_width gtable_height
#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.free_vp <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchFreeViewport", Parent,
        vp = attr(x, "vp"),
        align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                                gt = self$gt) {
            ans <- ggproto_parent(Parent, self)$align_border(
                t = t, l = l, b = b, r = r, gt = gt
            )
            vp <- self$vp

            if (!any(is_null_unit(widths <- .subset2(ans, "widths")))) {
                horizontal_just <- TRUE
                vp$width <- sum(widths)
            } else if (!is.na(as.numeric(vp$width))) {
                # we guess the width from the gtable
                horizontal_just <- TRUE
                vp$width <- max(vp$width, sum(widths))
            } else {
                vp$width <- unit(1, "npc")
                horizontal_just <- FALSE
            }
            if (!any(is_null_unit(heights <- .subset2(ans, "heights")))) {
                vertical_just <- TRUE
                vp$height <- sum(heights)
            } else if (!is.na(as.numeric(vp$height))) {
                # we guess the height from the gtable
                vertical_just <- TRUE
                vp$height <- max(vp$height, sum(heights))
            } else {
                vp$height <- unit(1, "npc")
                vertical_just <- FALSE
            }
            if (horizontal_just || vertical_just) ans$vp <- vp
            ans
        }
    )
}

#########################################################
#' Determine the active context of stack layout
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' `stack_active` is an alias for `stack_switch()`, which sets `what = NULL` by
#' default.
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams quad_switch
#' @inheritParams stack_discrete
#' @param what What should get activated for the stack layout?
#' `r rd_chain_what()`, this is useful when the active context is a
#' [`quad_layout()`] object, where any `align_*()` will be added to the
#' [`quad_layout()`]. By removing the active context, we can add `align_*()`
#' into the [`stack_layout()`].
#' @return A `stack_switch` object which can be added to [stack_layout()].
#' @examples
#' stack_discrete("h", matrix(1:9, nrow = 3L)) +
#'     ggheatmap() +
#'     # ggheamtap will set the active context, directing following addition
#'     # into the heatmap plot area. To remove the heatmap active context,
#'     # we can use `stack_active()` which will direct subsequent addition into
#'     # the stack
#'     stack_active() +
#'     # here we add a dendrogram to the stack.
#'     align_dendro()
#' @export
stack_switch <- function(sizes = NULL, what = waiver(), ...) {
    rlang::check_dots_empty()
    if (!is.waive(what)) what <- check_stack_context(what)
    if (!is.null(sizes)) sizes <- check_stack_sizes(sizes)
    structure(list(what = what, sizes = sizes), class = "stack_switch")
}

#' @export
#' @rdname stack_switch
stack_active <- function(sizes = NULL, ...) {
    rlang::check_dots_empty()
    stack_switch(sizes, what = NULL)
}

#' Convert Object into a Grob
#'
#' The `patch()` function is used by [`ggwrap()`] and [inset()] to convert
#' objects into a [`grob`][grid::grob].
#'
#' @param x An object to be converted into a [`grob`][grid::grob].
#' @param ... Additional arguments passed to specific methods.
#' @return A [`grob`][grid::grob] object.
#' @eval rd_collect_family("patch", "`patch` method collections")
#' @export
#' @keywords internal
patch <- function(x, ...) {
    UseMethod("patch")
}

# Following methods much are copied from `cowplot` or `ggplotify`
#' @export
patch.default <- function(x, ...) {
    cli_abort("Cannot make grob from {.obj_type_friendly {x}}")
}

#' @inherit patch title description return
#' @inheritParams patch
#' @param ... Not used currently.
#' @family patch
#' @export
patch.grob <- function(x, ...) {
    rlang::check_dots_empty()
    x
}

#' @importFrom grid gTree
#' @export
#' @rdname patch.grob
patch.gList <- function(x, ...) {
    rlang::check_dots_empty()
    # gLists need to be wrapped in a gTree
    gTree(children = x)
}

#' @importFrom ggplot2 ggplotGrob
#' @inherit patch.grob
#' @seealso [ggplot][ggplot2::ggplot]
#' @family patch
#' @export
patch.ggplot <- function(x, ...) {
    ggplotGrob(x, ...)
}

#' @inherit patch.grob
#' @seealso
#' - [`patch_titles()`]
#' - [`inset()`]
#' - [`ggwrap()`]
#' @family patch
#' @export
patch.patch_ggplot <- function(x, ...) {
    ggalignGrob(x, ...)
}

#' @inherit patch.grob
#' @seealso [`alignpatches`][align_plots]
#' @family patch
#' @export
patch.alignpatches <- function(x, ...) {
    ggalignGrob(x, ...)
}

#' @inherit patch.grob
#' @seealso [`patchwork`][patchwork::patchworkGrob]
#' @family patch
#' @export
patch.patchwork <- function(x, ...) {
    rlang::check_installed("patchwork", "to make grob from patchwork")
    patchwork::patchworkGrob(x, ...)
}

#' @inherit patch.grob
#' @seealso [`patch`][patchwork::patchGrob]
#' @family patch
#' @export
patch.patch <- function(x, ...) {
    rlang::check_installed("patchwork", "to make grob from patch")
    patchwork::patchGrob(x, ...)
}

#' @inherit patch.grob
#' @param ... Graphical Parameters passed on to [par()][graphics::par].
#' @inheritParams gridGraphics::echoGrob
#' @seealso [`plot()`]
#' @family patch
#' @export
patch.formula <- function(x, ..., device = NULL, name = NULL) {
    rlang::check_installed("gridGraphics", "to make grob from base plot")
    gp <- graphics::par(..., no.readonly = TRUE)
    gridGraphics::echoGrob(
        function() {
            old_gp <- graphics::par(no.readonly = TRUE)
            graphics::par(gp)
            on.exit(try(graphics::par(old_gp)))
            suppressMessages(eval(x[[2]], attr(x, ".Environment")))
            invisible(NULL)
        },
        name = name,
        device = device %||% offscreen
    )
}

#' @export
#' @rdname patch.formula
patch.function <- function(x, ..., device = NULL, name = NULL) {
    rlang::check_installed("gridGraphics", "to make grob from base plot")
    gp <- graphics::par(..., no.readonly = TRUE)
    gridGraphics::echoGrob(
        function() {
            old_gp <- graphics::par(no.readonly = TRUE)
            graphics::par(gp)
            on.exit(try(graphics::par(old_gp)))
            suppressMessages(x())
            invisible(NULL)
        },
        name = name,
        device = device %||% offscreen
    )
}

#' @inherit patch.grob
#' @inheritParams gridGraphics::echoGrob
#' @seealso [`recordPlot()`][grDevices::recordPlot]
#' @family patch
#' @export
patch.recordedplot <- function(x, ..., device = NULL) {
    rlang::check_installed("gridGraphics", "to make grob from recordedplot")
    rlang::check_dots_empty()
    gridGraphics::echoGrob(x, device = device %||% offscreen)
}

offscreen <- function(width, height) {
    if (requireNamespace("ragg", quietly = TRUE)) {
        ragg::agg_capture(width = width, height = height, units = "in")
        grDevices::dev.control("enable")
    } else {
        grDevices::pdf(NULL, width = width, height = height)
        grDevices::dev.control("enable")
    }
}

#' @inherit patch.grob
#' @inheritDotParams grid::grid.grabExpr -expr -device
#' @inheritParams grid::grid.grabExpr
#' @seealso [`trellis`][lattice::trellis.object]
#' @family patch
#' @export
patch.trellis <- function(x, ..., device = NULL) {
    grid::grid.grabExpr(expr = print(x), ..., device = device %||% offscreen)
}

#' @inherit patch.grob
#' @param ... Additional arguments passed to [draw()][ComplexHeatmap::draw].
#' @inheritParams grid::grid.grabExpr
#' @seealso
#'  - [`Heatmap()`][ComplexHeatmap::Heatmap]
#'  - [`HeatmapAnnotation()`][ComplexHeatmap::HeatmapAnnotation]
#' @family patch
#' @export
patch.Heatmap <- function(x, ..., device = NULL) {
    rlang::check_installed(
        "ComplexHeatmap",
        sprintf("to make grob from %s plot", obj_type_friendly(x))
    )
    draw <- getExportedValue("ComplexHeatmap", "draw")
    grid::grid.grabExpr(
        expr = draw(object = x, ...),
        device = device %||% offscreen
    )
}

#' @export
#' @rdname patch.Heatmap
patch.HeatmapList <- patch.Heatmap

#' @export
#' @rdname patch.Heatmap
patch.HeatmapAnnotation <- patch.HeatmapList

#' @inherit patch.grob
#' @seealso [`pheatmap()`][pheatmap::pheatmap]
#' @family patch
#' @export
patch.pheatmap <- function(x, ...) {
    rlang::check_dots_empty()
    .subset2(x, "gtable")
}

#' @param borders Which border shouldn't be aligned? A string containing one or
#' more of `r oxford_and(.tlbr)`.
#' @return
#' - `free_border`: A modified version of `plot` with a `free_border` class.
#' @export
#' @rdname free
free_border <- function(plot, borders = "tlbr") {
    UseMethod("free_border")
}

#' @export
free_border.ggplot <- function(plot, borders = "tlbr") {
    assert_position(borders)
    attr(plot, "free_borders") <- borders
    add_class(plot, "free_border")
}

#' @export
free_border.alignpatches <- free_border.ggplot

#' @export
free_border.free_align <- function(plot, borders = "tlbr") {
    assert_position(borders)
    borders <- setdiff_position(borders, attr(plot, "free_axes"))
    if (!nzchar(borders)) {
        return(plot)
    }
    NextMethod()
}

#' @export
free_border.free_lab <- function(plot, borders = "tlbr") {
    assert_position(borders)
    free_labs <- setdiff_position(attr(plot, "free_labs"), borders)
    if (nzchar(free_labs)) {
        attr(plot, "free_labs") <- free_labs
    } else {
        attr(plot, "free_labs") <- NULL
        plot <- remove_class(plot, "free_lab")
    }
    NextMethod()
}

#' @export
free_border.free_border <- function(plot, borders = "tlbr") {
    assert_position(borders)
    attr(plot, "free_borders") <- union_position(
        attr(plot, "free_borders"), borders
    )
    plot
}

#' @export
free_border.default <- function(plot, borders = "tlbr") {
    cli_abort("Cannot use with {.obj_type_friendly {plot}}")
}

################################################################
#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.free_border <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchFreeBorder", Parent,
        free_borders = setup_pos(attr(x, "free_borders")),
        collect_guides = function(self, guides, gt = self$gt) {
            ans <- ggproto_parent(Parent, self)$collect_guides(
                guides = guides, gt = gt
            )
            self$gt <- ggproto_parent(Parent, self)$free_border(
                borders = self$free_borders, gt = self$gt
            )
            ans
        },
        align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                                gt = self$gt) {
            gt <- ggproto_parent(Parent, self)$align_border(
                t = t, l = l, b = b, r = r, gt = gt
            )
            ggproto_parent(Parent, self)$align_free_border(
                borders = self$free_borders,
                t = t, l = l, b = b, r = r, gt = gt
            )
        },
        free_border = function(self, borders, gt = self$gt) {
            borders <- vec_set_difference(borders, self$free_borders)
            if (length(borders)) {
                gt <- ggproto_parent(Parent, self)$free_border(
                    borders = borders, gt = gt
                )
            }
            gt
        },
        align_free_border = function(self, borders,
                                     t = NULL, l = NULL, b = NULL, r = NULL,
                                     gt = self$gt) {
            borders <- vec_set_difference(borders, self$free_borders)
            if (length(borders)) {
                gt <- ggproto_parent(Parent, self)$align_free_border(
                    borders = borders,
                    t = t, l = l, b = b, r = r, gt = gt
                )
            }
            gt
        }
    )
}

#' Plot default theme
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' `scheme_theme()` serves as the default theme and will always be overridden by
#' any `theme()` settings applied directly to the plot. The default theme
#' (`scheme_theme()`) is applied first, followed by any specific `theme()`
#' settings, even if `theme()` is added before `scheme_theme()`.
#'
#' @inherit ggplot2::theme
#' @param ... A [`theme()`][ggplot2::theme] object or additional element
#' specifications not part of base ggplot2. In general, these should also be
#' defined in the `element tree` argument. [`Splicing`][rlang::splice] a list
#' is also supported.
#' @examples
#' set.seed(123)
#' small_mat <- matrix(rnorm(56), nrow = 8)
#' ggheatmap(small_mat) +
#'     scheme_theme(plot.background = element_rect(fill = "red"))
#'
#' # `scheme_theme()` serves as the default theme and will always be
#' # overridden by any `theme()` settings applied directly to the plot
#' ggheatmap(small_mat) +
#'     theme(plot.background = element_rect(fill = "blue")) +
#'     scheme_theme(plot.background = element_rect(fill = "red"))
#'
#' @importFrom ggplot2 theme
#' @importFrom rlang inject
#' @export
scheme_theme <- rlang::new_function(
    # We utilize editor completion by listing all `theme()` arguments here.
    # By placing `...` at the beginning, we can check if the first
    # following argument is a `theme()` object rather than individual theme
    # elements.
    c(
        rlang::exprs(... = ),
        .subset(
            rlang::fn_fmls(theme),
            vec_set_difference(names(rlang::fn_fmls(theme)), "...")
        )
    ),
    quote({
        elements <- ggfun("find_args")(..., complete = NULL, validate = NULL)
        ans <- theme(!!!elements)
        th <- NULL
        for (i in seq_len(...length())) {
            if (inherits(t <- ...elt(i), "theme")) {
                th <- ggfun("add_theme")(th, t)
            }
        }
        new_scheme_theme(ggfun("add_theme")(th, ans))
    })
)

#' @importFrom ggplot2 theme
new_scheme_theme <- function(th = theme()) {
    # I don't know why, if I omit the `object = th` argument, it won't work
    UseMethod("new_scheme_theme", th)
}

#' @importFrom rlang inject
#' @export
new_scheme_theme.theme <- function(th = theme()) {
    attrs <- attributes(th)
    attrs <- vec_slice(
        attrs, vec_set_difference(names(attrs), c("names", "class"))
    )
    inject(new_scheme(
        name = "scheme_theme", th, !!!attrs,
        class = c("scheme_theme", class(th))
    ))
}

#' @export
new_scheme_theme.scheme_theme <- function(th = theme()) th

###############################################################
#' @export
update_scheme.scheme_theme <- function(new, old, object_name) {
    ggfun("add_theme")(old, new, object_name)
}

#' @export
inherit_scheme.scheme_theme <- function(scheme, pscheme) {
    pscheme + scheme
}

#' @export
plot_add_scheme.scheme_theme <- function(plot, scheme) {
    # setup plot theme
    plot$theme <- scheme + plot$theme
    plot
}

#' @param spaces Which border spaces should be removed? A string containing one
#' or more of `r oxford_and(.tlbr)`.
#' @return
#' - `free_space`: A modified version of `plot` with a `free_space` class.
#' @export
#' @rdname free
free_space <- function(plot, spaces = "tlbr") {
    UseMethod("free_space")
}

#' @export
free_space.default <- function(plot, spaces = "tlbr") {
    cli_abort("Cannot use with {.obj_type_friendly {plot}}")
}

#' @export
free_space.ggplot <- function(plot, spaces = "tlbr") {
    assert_position(spaces)
    attr(plot, "free_spaces") <- spaces
    add_class(plot, "free_space")
}

#' @export
free_space.alignpatches <- free_space.ggplot

#' @export
free_space.free_align <- function(plot, spaces = "tlbr") {
    assert_position(spaces)
    spaces <- setdiff_position(spaces, attr(plot, "free_axes"))
    if (!nzchar(spaces)) {
        return(plot)
    }
    NextMethod()
}

#' @export
free_space.free_space <- function(plot, spaces = "tlbr") {
    assert_position(spaces)
    attr(plot, "free_spaces") <- union_position(
        attr(plot, "free_spaces"), spaces
    )
    plot
}

##########################################################
#' @importFrom ggplot2 ggproto ggproto_parent
#' @importFrom grid unit
#' @export
alignpatch.free_space <- function(x) {
    Parent <- NextMethod()
    ggproto(
        "PatchFreeSpace", Parent,
        free_spaces = split_position(attr(x, "free_spaces")),
        get_sizes = function(self, free = NULL, gt = self$gt) {
            ggproto_parent(Parent, self)$get_sizes(
                union(free, self$free_spaces),
                gt = gt
            )
        }
    )
}

#' @export
quad_build.HeatmapLayout <- function(quad, schemes = NULL, theme = NULL,
                                     direction = NULL) {
    ans <- NextMethod()

    # add heatmap filling in the first layer --------------
    if (!is.null(filling <- quad@filling)) {
        # we always ensure the filling layer has a fill mapping
        if (is.null(.subset2(ans$plots$main$mapping, "fill"))) {
            mapping <- aes(.data$.x, .data$.y, fill = .data$value)
        } else {
            mapping <- aes(.data$.x, .data$.y)
        }
        if (is.waive(filling)) {
            if (nrow(quad@data) * ncol(quad@data) > 20000L) {
                cli_inform(c(">" = "heatmap built with {.fn geom_raster}"))
                filling <- "raster"
            } else {
                cli_inform(c(">" = "heatmap built with {.fn geom_tile}"))
                filling <- "tile"
            }
        }
        ans$plots$main <- ans$plots$main + layer_order(switch(filling,
            raster = ggplot2::geom_raster(mapping = mapping),
            tile = ggplot2::geom_tile(mapping = mapping)
        ))
    }
    # add class to set the default color mapping --------
    ans$plots$main <- add_class(ans$plots$main, "ggalign_heatmap")
    ans
}

#' @importFrom ggplot2 ggplot_build
#' @export
ggplot_build.ggalign_heatmap <- function(plot, ...) {
    with_options(
        NextMethod(),
        ggplot2.discrete.fill = heatmap_fill("discrete"),
        ggplot2.continuous.fill = heatmap_fill("continuous")
    )
}

heatmap_fill <- function(type) {
    opt <- sprintf("%s.heatmap_%s_fill", pkg_nm(), type)
    if (is.null(ans <- getOption(opt, default = NULL))) {
        if (type == "continuous") {
            ans <- function(...) {
                ggplot2::scale_fill_gradient2(low = "blue", high = "red")
            }
        } else {
            ans <- getOption("ggplot2.discrete.fill")
        }
    }
    ans
}

#' @param guides A string containing one or more of
#' `r oxford_and(c(.tlbr, "i"))` indicates which side of guide legends should be
#' collected for the plot. If `NULL`, no guide legends will be collected.
#' @return
#' - `free_guide`: A modified version of `plot` with a `free_guide` class.
#' @export
#' @rdname free
free_guide <- function(plot, guides = "tlbr") {
    UseMethod("free_guide")
}

#' @export
free_guide.ggplot <- function(plot, guides = "tlbr") {
    if (!is.null(guides)) assert_guides(guides)
    attr(plot, "free_guides") <- guides
    add_class(plot, "free_guide")
}

#' @export
free_guide.alignpatches <- free_guide.ggplot

#' @export
free_guide.free_guide <- function(plot, guides = "tlbr") {
    if (is.null(guides)) {
        attr(plot, "free_guides") <- NULL
    } else {
        assert_guides(guides)
        if (is.null(old <- attr(plot, "free_guides", exact = TRUE))) {
            attr(plot, "free_guides") <- guides
        } else {
            attr(plot, "free_guides") <- union_position(old, guides)
        }
    }
    plot
}

################################################################
#' @importFrom ggplot2 ggproto ggproto_parent
#' @export
alignpatch.free_guide <- function(x) {
    Parent <- NextMethod()
    if (!is.null(free_guides <- attr(x, "free_guides", exact = TRUE))) {
        free_guides <- setup_guides(free_guides)
    }
    ggproto("PatchFreeGuide", Parent,
        set_guides = function(self, guides) free_guides
    )
}

#' Change the shape of the input object
#'
#' @param data An R object.
#' @param shape Usually `NULL` or a string, specifying the new shape for the
#' object. Refer to the detailed method for allowed values.
#' @details
#' In most cases, [`fortify_matrix()`] or [`fortify_data_frame()`] provide full
#' support for transforming objects. However, some objects may require two
#' completely different approaches to be fortified. The `tune` function acts as
#' a helper to create a new class tailored for these objects.
#' @eval rd_collect_family("tune", "`tune` method collections")
#' @export
tune <- function(data, shape = NULL) UseMethod("tune")

#' @inherit tune title
#' @description
#' - `new_tune`: Creates a new object by wrapping it in a scalar list with
#'   the specified attributes and class.
#' - `tune_data`: Retrieves the original input data.
#'
#' @param x An R object.
#' @param ... Additional attributes passed to [`structure()`].
#' @param class A character vector specifying the class name to be added.
#' @export
new_tune <- function(x, ..., class = character()) {
    structure(list(x), ..., class = c(class, "ggalign_tune"))
}

#' @export
#' @rdname new_tune
tune_data <- function(x) .subset2(x, 1L)

#' @export
print.ggalign_tune <- function(x, ...) {
    print(tune_data(x))
    invisible(x)
}

#' @export
fortify_matrix.ggalign_tune <- function(data, ...) {
    cli_abort("No {.fn fortify_matrix} method for {.obj_type_friendly {data}}")
}

#' @export
fortify_data_frame.ggalign_tune <- function(data, ...) {
    cli_abort(
        "No {.fn fortify_data_frame} method for {.obj_type_friendly {data}}"
    )
}

new_schemes <- function(...) {
    default <- list(
        new_scheme_data(),
        new_scheme_align(),
        new_scheme_theme()
    )
    names(default) <- vapply(default, ggalign_scheme_name,
        character(1L),
        USE.NAMES = FALSE
    )
    for (i in seq_len(...length())) {
        scheme <- ...elt(i)
        default[[ggalign_scheme_name(scheme)]] <- scheme
    }
    default
}

new_scheme <- function(name, data, ..., class = character()) {
    structure(data,
        `__ggalign.scheme_name__` = name, ...,
        class = c(class, "ggalign_scheme")
    )
}

ggalign_scheme_name <- function(x) {
    attr(x, "__ggalign.scheme_name__", exact = TRUE)
}

#' @importFrom ggplot2 theme
default_schemes <- function(data = NULL, th = theme()) {
    if (!is.waive(data)) data <- NULL
    new_schemes(
        new_scheme_data(data),
        new_scheme_theme(th)
    )
}

###############################################################
#' Used to update global data
#' @noRd
update_scheme <- function(new, old, object_name) {
    UseMethod("update_scheme", old)
}

#' @export
update_scheme.default <- function(new, old, object_name) new

update_layout_scheme <- function(object, layout, object_name) {
    name <- ggalign_scheme_name(object)
    layout@schemes[name] <- list(update_scheme(
        object, .subset2(layout@schemes, name), object_name
    ))
    layout
}

###############################################################
inherit_scheme <- function(scheme, pscheme) {
    UseMethod("inherit_scheme", pscheme)
}

# If no parent scheme, use child scheme directly
#' @export
inherit_scheme.NULL <- function(scheme, pscheme) scheme

inherit_schemes <- function(schemes, pschemes) {
    nms <- vapply(pschemes,
        ggalign_scheme_name, character(1L),
        USE.NAMES = FALSE
    )
    ans <- lapply(nms, function(opt) {
        inherit_scheme(.subset2(schemes, opt), .subset2(pschemes, opt))
    })
    names(ans) <- nms
    ans
}

###############################################################
plot_add_scheme <- function(plot, scheme) UseMethod("plot_add_scheme", scheme)

#' @export
plot_add_scheme.NULL <- function(plot, scheme) plot

plot_add_schemes <- function(plot, schemes) {
    for (i in seq_along(schemes)) {
        plot <- plot_add_scheme(plot, scheme = .subset2(schemes, i))
    }
    plot
}

# Standalone file: do not edit by hand
# Source: <https://github.com/Yunuuuu/standalone/blob/main/R/standalone-purrr.R>
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-purrr.R
# last-updated: 2024-11-13
# license: https://unlicense.org
# ---

# This file provides a minimal shim to provide a purrr-like API on top of
# base R functions. They are not drop-in replacements but allow a similar style
# of programming.
#
# Note: these functions won't support lambda syntax.

# ## Changelog
# 2024-11-13:
# rename `transpose()` to `list_transpose()`
#
# 2024-11-12:
# First release
#
# nocov start

map <- function(.x, .f, ...) lapply(.x, .f, ...)

walk <- function(.x, .f, ...) {
    lapply(.x, .f, ...)
    invisible(.x)
}

map_lgl <- function(.x, .f, ...) {
    vapply(X = .x, FUN = .f, logical(1L), ...)
}

map_int <- function(.x, .f, ...) {
    vapply(X = .x, FUN = .f, integer(1L), ...)
}

map_dbl <- function(.x, .f, ...) {
    vapply(X = .x, FUN = .f, double(1L), ...)
}

map_chr <- function(.x, .f, ...) {
    vapply(X = .x, FUN = .f, character(1L), ...)
}

pmap <- function(.l, .f, ...) {
    out <- .mapply(.f, .l, list(...))
    if (!is.null(nms <- names(.subset2(.l, 1L)))) names(out) <- nms
    out
}

pmap_lgl <- function(.l, .f, ...) {
    .purrr_pmap_mold(.l, .f, ..., mold = logical(1L))
}

pmap_int <- function(.l, .f, ...) {
    .purrr_pmap_mold(.l, .f, ..., mold = integer(1L))
}

pmap_dbl <- function(.l, .f, ...) {
    .purrr_pmap_mold(.l, .f, ..., mold = double(1L))
}

pmap_chr <- function(.l, .f, ...) {
    .purrr_pmap_mold(.l, .f, ..., mold = character(1L))
}

.purrr_pmap_mold <- function(.l, .f, ..., mold) {
    nms <- names(.subset2(.l, 1L))
    dots <- list(...)
    out <- vapply(seq_along(nms), function(i) {
        do.call(.f, args = c(lapply(.l, .subset2, i), dots))
    }, mold, USE.NAMES = FALSE)
    if (!is.null(nms)) names(out) <- nms
    out
}

map2 <- function(.x, .y, .f, ...) pmap(list(.x, .y), .f, ...)

map2_lgl <- function(.x, .y, .f, ...) {
    .purrr_pmap_mold(list(.x, .y), .f, ..., mold = logical(1L))
}

map2_int <- function(.x, .y, .f, ...) {
    .purrr_pmap_mold(list(.x, .y), .f, ..., mold = integer(1L))
}

map2_dbl <- function(.x, .y, .f, ...) {
    .purrr_pmap_mold(list(.x, .y), .f, ..., mold = double(1L))
}

map2_chr <- function(.x, .y, .f, ...) {
    .purrr_pmap_mold(list(.x, .y), .f, ..., mold = character(1L))
}

imap <- function(.x, .f, ...) {
    nms <- names(.x)
    if (is.null(nms)) {
        .l <- list(.x, seq_along(.x))
    } else {
        .l <- list(.x, nms)
    }
    pmap(.l, .f, ...)
}

.purrr_imap_mold <- function(.x, .f, ..., mold) {
    if (is.null(nms <- names(.x))) {
        .l <- list(.x, seq_along(.x))
    } else {
        .l <- list(.x, nms)
    }
    .purrr_pmap_mold(.l, .f, ..., mold = mold)
}

imap_lgl <- function(.l, .f, ...) {
    .purrr_imap_mold(.l, .f, ..., mold = logical(1L))
}

imap_int <- function(.l, .f, ...) {
    .purrr_imap_mold(.l, .f, ..., mold = integer(1L))
}

imap_dbl <- function(.l, .f, ...) {
    .purrr_imap_mold(.l, .f, ..., mold = double(1L))
}

imap_chr <- function(.l, .f, ...) {
    .purrr_imap_mold(.l, .f, ..., mold = character(1L))
}

list_transpose <- function(.l) {
    if (!length(.l)) return(.l) # styler: off
    inner_names <- names(.subset2(.l, 1L))
    if (is.null(inner_names)) {
        fields <- seq_along(.subset2(.l, 1L))
    } else {
        fields <- inner_names
        names(fields) <- fields
        .l <- lapply(.l, function(x) {
            if (is.null(names(x))) names(x) <- inner_names # styler: off
            x
        })
    }

    # This way missing fields are subsetted as `NULL` instead of causing
    # an error
    .l <- lapply(.l, as.list)

    lapply(fields, function(i) lapply(.l, .subset2, i))
}

# nocov end

rd_layout <- function() {
    sprintf("%s or [`stack_layout()`] object", rd_quad())
}

rd_quad <- function() "[`quad_layout()`]/[`ggheatmap()`]"

rd_chain_what <- function() {
    paste(
        "A single number or string of the plot elements in the layout.",
        "If `NULL`, will remove any active context"
    )
}

rd_quad_position <- function(action) {
    sprintf(
        "A string of %s indicates which annotation stack should be %s",
        oxford_or(.TLBR),
        action
    )
}

rd_layout_data <- function() {
    paste(
        "Default dataset to use for the layout. If not specified, it must be",
        "supplied in each plot added to the layout"
    )
}

rd_gg_aesthetics <- function(...) {
    ans <- ggfun("rd_aesthetics")(...)
    ans <- sub("link[=", "link[ggplot2:", ans, fixed = TRUE)
    sub("(vignette\\([^)]+)\\)", "\\1, package = \"ggplot2\")", ans)
}

#' Reset layout ordering and panel group
#'
#' @param data The dataset to use for the layout. By default,
#'   [`fortify_matrix()`] will convert the data to a matrix. This argument
#'   allows you to change the layout data. If not specified, the original data
#'   will be used.
#' @param ... <[dyn-dots][rlang::dyn-dots]> Additional arguments passed to
#' [`fortify_matrix()`].
#' @param inherit_index A boolean value indicating whether to inherit the
#'   ordering index. If `TRUE`, will match the layout ordering index with the
#'   data names.
#' @param inherit_panel A boolean value indicating whether to inherit the
#'   panel group. If `TRUE`, will match the layout panel with the data names.
#' @param inherit_nobs A boolean value indicating whether to inherit the
#'   number of observations (nobs). If `TRUE`, the `data` input must be
#'   compatible with the layout data.
#' @export
cross_none <- function(data = waiver(), ...,
                       inherit_index = NULL,
                       inherit_panel = NULL,
                       inherit_nobs = NULL) {
    cross(CrossNone,
        data = data, data_params = list2(...), plot = NULL,
        active = new_active(use = FALSE),
        schemes = default_schemes(),
        inherit_index = inherit_index,
        inherit_panel = inherit_panel,
        inherit_nobs = inherit_nobs
    )
}

#' @importFrom ggplot2 ggproto ggproto_parent
#' @include craft-cross-.R
CrossNone <- ggproto("CrossNone", CraftCross)

# `subtract` operates at layout-level
#' @keywords internal
quad_layout_subtract <- function(object, quad, object_name) {
    UseMethod("quad_layout_subtract")
}

#' @export
quad_layout_subtract.default <- function(object, quad, object_name) {
    if (is.null(context <- quad@active)) context <- c(.TLBR, list(NULL))
    for (active in context) {
        if (is.null(active)) {
            quad <- quad_body_add(object, quad, object_name)
        } else if (!is.null(slot(quad, active))) {
            slot(quad, active) <- chain_layout_subtract(
                object, slot(quad, active), object_name
            )
        }
    }
    quad
}

# for object can set at layout level
#' @export
quad_layout_subtract.ggalign_scheme <- function(object, quad, object_name) {
    if (is.null(context <- quad@active)) {
        quad <- update_layout_scheme(object, quad, object_name)
    } else {
        slot(quad, context) <- update_layout_scheme(
            object, slot(quad, context), object_name
        )
    }
    quad
}

#' @export
quad_layout_subtract.ggalign_with_quad <- function(object, quad, object_name) {
    old <- quad@active
    context <- quad_operated_context(object, old, "-")
    object <- .subset2(object, "object")
    object_name <- .subset2(object, "object_name")
    # `subtract` operates at layout-level
    if (is.null(context)) {
        quad@active <- context
        quad <- quad_layout_subtract(object, quad, object_name)
    } else {
        for (active in context) {
            if (is.null(active)) {
                quad <- quad_body_add(object, quad, object_name)
            } else if (!is.null(slot(quad, active))) {
                slot(quad, active) <- chain_layout_subtract(
                    object, slot(quad, active), object_name
                )
            }
        }
    }
    quad@active <- old
    quad
}

###############################################################
#' @keywords internal
quad_layout_and_add <- function(object, quad, object_name) {
    UseMethod("quad_layout_and_add")
}

#' @export
quad_layout_and_add.default <- function(object, quad, object_name) {
    quad <- quad_body_add(object, quad, object_name)
    for (position in .TLBR) {
        stack <- slot(quad, position)
        if (is.null(stack)) next
        slot(quad, position) <- chain_layout_and_add(
            object, stack, object_name
        )
    }
    quad
}

#' @export
quad_layout_and_add.ggalign_with_quad <- function(object, quad, object_name) {
    object <- .subset2(object, "object")
    object_name <- .subset2(object, "object_name")
    NextMethod()
}

#' @export
quad_layout_and_add.theme <- function(object, quad, object_name) {
    ans <- NextMethod()
    # to align with `patchwork`, we also modify the layout theme
    # when using `&` to add the theme object.
    ans@theme <- ggfun("add_theme")(ans@theme, object)
    ans
}

format_object_name <- function(name, format = NULL) {
    if (is.null(format)) {
        name
    } else {
        sprintf("{.%s %s}", format, name)
    }
}

object_name <- function(object, format) UseMethod("object_name")

#' @export
object_name.StackLayout <- function(object, format = "fn") {
    ans <- format_object_name(object@name, format)
    if (!is.null(position <- .subset2(object@heatmap, "position"))) {
        ans <- sprintf("the %s annotation %s", position, ans)
    } else {
        ans <- sprintf("the %s %s", object@direction, ans)
    }
    ans
}

#' @export
object_name.CircleLayout <- function(object, format = "fn") {
    format_object_name(object@name, format)
}

#' @export
object_name.QuadLayout <- function(object, format = "fn") {
    format_object_name(object@name, format)
}

#' @export
object_name.CraftBox <- function(object, format = "fn") {
    object_name(object@craftsman, format)
}

#' @export
object_name.Craftsman <- function(object, format = "fn") {
    format_object_name(snake_class(object), format)
}

#' @export
object_name.AlignGg <- function(object, format = "fn") {
    format_object_name("ggalign", format)
}

#' @export
object_name.CrossGg <- function(object, format = "fn") {
    format_object_name("ggcross", format)
}

#' @export
object_name.FreeGg <- function(object, format = "fn") {
    format_object_name("ggfree", format)
}

#' @export
object_name.MarkGg <- function(object, format = "fn") {
    format_object_name("ggmark", format)
}

#' Split observations by k-means clustering groups.
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Aligns and groups observations based on k-means clustering, enabling
#' observation splits by cluster groups.
#'
#' @inheritDotParams stats::kmeans -x -centers
#' @param data A numeric matrix to be used by k-means. By default, it will
#' inherit from the layout matrix.
#' @inheritParams align
#' @inheritSection align Discrete Axis Alignment
#' @examples
#' ggheatmap(matrix(rnorm(81), nrow = 9)) +
#'     anno_top() +
#'     align_kmeans(3L)
#' @importFrom rlang list2
#' @export
align_kmeans <- function(..., data = NULL, active = NULL) {
    assert_active(active)
    active <- update_active(active, new_active(use = FALSE))
    align(
        align = AlignKmeans,
        params = list2(...),
        active = active,
        data = data
    )
}

#' @importFrom ggplot2 ggproto
#' @importFrom rlang inject
AlignKmeans <- ggproto("AlignKmeans", CraftAlign,
    interact_layout = function(self, layout) {
        ggproto_parent(AlignOrder2, self)$interact_layout(layout)
    },
    compute = function(self, panel, index) {
        inject(stats::kmeans(x = self$data, !!!self$params))
    },
    align = function(self, panel, index) {
        list(.subset2(self$statistics, "cluster"), index)
    },
    summary_align = function(self) c(FALSE, TRUE)
)

#' @keywords internal
"_PACKAGE"

## usethis namespace: start
#' @import vctrs
#' @importFrom lifecycle deprecated
#' @importFrom rlang .data .env
#' @importFrom cli cli_abort cli_warn cli_inform
## usethis namespace: end
NULL

# enable usage of <S7_object>@name in package code
#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
NULL

rasterise.QuadLayout <- function(input, ...) {
    input@plot <- ggrastr::rasterise(input = input@plot, ...)
    for (position in .TLBR) {
        stack <- slot(input, position)
        if (is.null(stack)) next
        slot(input, position) <- ggrastr::rasterise(input = stack, ...)
    }
    input
}

rasterise.ChainLayout <- function(input, ...) {
    input@plot_list <- lapply(input@plot_list, ggrastr::rasterise, ...)
    input
}

rasterise.CraftBox <- function(input, ...) {
    if (!is.null(plot <- input@plot)) {
        input@plot <- ggrastr::rasterise(input = plot, ...)
    }
    input
}

##########################################################
#' @export
raster_magick0.QuadLayout <- function(x, ...) {
    x@plot <- raster_magick0(x = x@plot, ...)
    for (position in .TLBR) {
        stack <- slot(x, position)
        if (is.null(stack)) next
        slot(x, position) <- raster_magick0(x = stack, ...)
    }
    x
}

#' @export
raster_magick0.ChainLayout <- function(x, ...) {
    x@plot_list <- lapply(x@plot_list, raster_magick0, ...)
    x
}

#' @export
raster_magick0.CraftBox <- function(x, ...) {
    if (!is.null(plot <- input@plot)) {
        input@plot <- raster_magick0(x = plot, ...)
    }
    input
}

#' @importFrom S7 methods_register
.onLoad <- function(libname, pkgname) {
    # register ggplot2 theme elements
    theme_elements()

    # register method for
    s3_register("ggrastr::rasterise", "CraftBox")
    s3_register("ggrastr::rasterise", "QuadLayout")
    s3_register("ggrastr::rasterise", "ChainLayout")

    methods_register()
    invisible()
}

function(data, arg = caller_arg(data),
                              call = caller_call()) {}

This code segment functions to: Validate input data against allowed types and handle functional conversions while generating appropriate error messages for non-compliant cases.

```r
[TASK_BEGIN]
check_scheme_data <- function(data, arg = caller_arg(data),
                              call = caller_call()) {
    if (!inherits(data, "scheme_data")) {
        cli_abort(
            "{.arg {arg}} must be created with {.fn scheme_data}",
            call = call
        )
    }
    data
}
[TASK_END]
```

function(data, arg = caller_arg(data),
                              call = caller_call()) {
    if (!is.waive(data) && !is.null(data) &&
        !is.function(data <- allow_lambda(data))) {
        cli_abort(paste(
            "{.arg {arg}} must be a function,",
            "{.code NULL} or {.fn waiver}"
        ), call = call)
    }
    data
}

check_scheme_data <- function(data, arg = caller_arg(data),
                              call = caller_call()) {
    if (!inherits(data, "scheme_data")) {
        cli_abort(
            "{.arg {arg}} must be created with {.fn scheme_data}",
            call = call
        )
    }
    data
}