Skip to content

Commit

Permalink
re-design Align
Browse files Browse the repository at this point in the history
  • Loading branch information
@Yunuuuu
Yunuuuu committed Jan 7, 2025
1 parent eae13de commit 21df89f
Show file tree
Hide file tree
Showing 13 changed files with 333 additions and 468 deletions.
153 changes: 8 additions & 145 deletions R/align-.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,14 +8,11 @@
#'
#' @param align An `Align` object.
#' @param ... Additional fields passed to the `align` object.
#' @param params A list of parameters for `align`.
#' @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 check.param Logical; if `TRUE`, checks parameters and provides
#' warnings as necessary.
#' @param call The `call` used to construct the `Align` object, for reporting
#' messages.
#'
Expand All @@ -32,11 +29,9 @@
#' @importFrom ggplot2 ggproto
#' @export
#' @keywords internal
align <- function(align, data, ...,
params = list(), plot = NULL,
align <- function(align, data = NULL, ..., plot = NULL,
size = NULL, schemes = NULL, no_axes = NULL,
active = NULL, check.param = TRUE,
call = caller_call()) {
active = NULL, call = caller_call()) {
if (override_call(call)) {
call <- current_call()
}
Expand All @@ -47,18 +42,6 @@ align <- function(align, data, ...,
getOption(sprintf("%s.align_no_axes", pkg_nm()), default = TRUE)
schemes <- schemes %|w|% default_schemes(data)

# Warn about extra params or missing parameters ---------------
all <- align$parameters()
input <- names(params) %||% character()
if (isTRUE(check.param)) {
if (length(extra_param <- vec_set_difference(input, all))) { # nolint
cli_warn("Ignoring unknown parameters: {.arg {extra_param}}")
}
if (length(missing <- vec_set_difference(all, input))) { # nolint
cli_abort("missing parameters: {missing}", call = call)
}
}
input_params <- params[vec_set_intersect(input, all)]
new_ggalign_plot(
align = align,

Expand All @@ -70,18 +53,13 @@ align <- function(align, data, ...,
# and will be saved and accessed across the plot rendering process
direction = NULL,
position = NULL,
params = NULL, # `$setup_params` method
data = NULL, # $setup_data method
data = NULL, # Used to save the modified `input_data`
statistics = NULL, # `$compute` method
labels = NULL, # the original `vec_names()` of the `input_data`

# use `NULL` if this align don't require any data
# use `waiver()` to inherit from the layout data
# the input data
input_data = data,

# collect parameters
input_params = input_params,

# object slots
plot = plot,
active = active,
Expand Down Expand Up @@ -113,126 +91,27 @@ align <- function(align, data, ...,
#' @rdname align
#' @include plot-.R
Align <- ggproto("Align", AlignProto,
parameters = function(self) {
c(
align_method_params(
self$compute,
align_method_params(Align$compute)
),
align_method_params(
self$align,
align_method_params(Align$align)
),
self$extra_params
)
},
interact_layout = function(self, layout) {
layout_name <- self$layout_name
object_name <- object_name(self)
# check plot is compatible with the layout
if (is_layout_continuous(layout)) {
layout_name <- self$layout_name
# `Align` object is special for discrete variables
cli_abort(c(
sprintf("Cannot add %s to %s", object_name, layout_name),
sprintf("Cannot add %s to %s", object_name(self), layout_name),
i = sprintf("%s cannot align discrete variables", layout_name)
))
}
input_data <- self$input_data
input_params <- self$input_params
layout_data <- layout@data
design <- layout@design
layout_nobs <- .subset2(design, "nobs")
# we must have the same observations across all plots
# 1. if `Align` require data, the `nobs` should be nrow(data)
# 2. if not, we run `nobs()` method to initialize the layout nobs
if (!is.null(input_data)) { # this `Align` object require data
if (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
),
i = sprintf("no data was found in %s", 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
),
i = sprintf("no data was found in %s", layout_name)
))
}
data <- input_data(layout_data)
} else {
data <- input_data
}
}
# we always regard rows as the observations
if (is.null(layout_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
))
}

# save the labels
self$labels <- vec_names(data) %||% vec_names(layout_data)
params <- self$setup_params(layout_nobs, input_params)
self$data <- ggalign_attr_restore(
self$setup_data(params, data),
layout_data
)
} else { # this `Align` object doesn't require any data
# we keep the names from the layout data for usage
self$labels <- vec_names(layout_data)
# If `nobs` is `NULL`, it means we don't initialize the layout
# observations, we initialize `nobs` with the `Align` obect
if (is.null(layout_nobs)) {
layout_nobs <- self$nobs(input_params)
if (!(is_scalar(layout_nobs) && is.integer(layout_nobs))) {
cli_abort(c(
sprintf(
"invalid {.field nobs} defined by %s",
object_name(self)
),
i = "{.field nobs} must be a single integer"
))
}
}
params <- self$setup_params(layout_nobs, input_params)
}
design["nobs"] <- list(layout_nobs)
layout@design <- design

# save the parameters into the object ------------
self$params <- params
layout
},
setup_design = function(self, design) {
old_panel <- .subset2(design, "panel")
old_index <- .subset2(design, "index")
# prepare the data -------------------------------
# compute statistics ---------------------------------
self$statistics <- align_inject(
self$compute,
c(list(panel = old_panel, index = old_index), self$params)
)
self$statistics <- self$compute(panel = old_panel, index = old_index)

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

# check panel
layout_name <- self$layout_name
Expand Down Expand Up @@ -335,22 +214,6 @@ Align <- ggproto("Align", AlignProto,
discrete_design(panel, index, nobs)
},

# Most parameters for the `Align` are taken automatically from `compute()`,
# `align()` and `build_plot()`. However, some additional parameters may be
# removed in `setup_params`. You should put these paramters here, otherwise,
# they won't be collected.
extra_params = character(),
setup_params = function(nobs, params) params,
setup_data = function(params, data) data,

# You must provide `nobs()` function or data shouldn't be `NULL`
# If this `Align` doesn't initialize the layout observations, we should
# return `NULL`, in this way, you cannot use this `Align` object to
# initialize the layout panel or index. We always ensure the panel and index
# number is equal to `nobs`. If you want to indicates no obervations, you
# must return `0L`.
nobs = function(params) NULL,

# Following fields should be defined for the new `Align` object.
# argument name in these function doesn't matter.
compute = function(self, panel, index) NULL,
Expand Down
77 changes: 28 additions & 49 deletions R/align-dendrogram.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,33 +49,15 @@ align_dendro <- function(mapping = aes(), ...,
center = FALSE, type = "rectangle",
size = NULL, data = NULL,
no_axes = NULL, active = NULL) {
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"
)
}

assert_number_whole(k, allow_null = TRUE)
assert_number_decimal(h, allow_null = TRUE)
assert_bool(plot_cut_height, allow_null = TRUE, arg = "plot_cut_height")
assert_bool(plot_cut_height, allow_null = TRUE)
assert_bool(merge_dendrogram)
assert_bool(reorder_group)
cutree <- allow_lambda(cutree)
assert_(cutree, is.function, "a function", allow_null = TRUE)
assert_bool(plot_dendrogram)
assert_mapping(mapping)
if (is.null(data)) {
if (inherits(method, "hclust") || inherits(method, "dendrogram")) {
data <- NULL # no need for data
} else {
data <- waiver()
}
}
assert_active(active)
active <- update_active(active, new_active(use = TRUE))

# 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(
Expand All @@ -88,45 +70,41 @@ align_dendro <- function(mapping = aes(), ...,
data = function(data) ggalign_attr(data, "edge")
)
}
align(
assert_active(active)
active <- update_active(active, new_active(use = TRUE))
.align_hclust(
align = AlignDendro,
params = list(
distance = distance, method = method, use_missing = use_missing,
k = k, h = h, plot_cut_height = plot_cut_height,
center = center, type = type, root = root,
reorder_dendrogram = reorder_dendrogram,
merge_dendro = merge_dendrogram,
reorder_group = reorder_group,
cutree = cutree
),
no_axes = no_axes, active = active,
size = size,
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()),
data = data,
plot = plot
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 align-hclust.R
AlignDendro <- ggproto("AlignDendro", AlignHclust,
#' @importFrom ggplot2 aes ggplot
#' @importFrom rlang inject
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")
)
},
# other arguments
extra_params = c("plot_cut_height", "center", "type", "root"),
build_plot = function(self, plot, design, extra_design = NULL,
previous_design = NULL) {
params <- self$params
plot_cut_height <- .subset2(params, "plot_cut_height")
center <- .subset2(params, "center")
type <- .subset2(params, "type")
root <- .subset2(params, "root")
plot_cut_height <- self$plot_cut_height
center <- self$center
type <- self$type
root <- self$root
panel <- .subset2(design, "panel")
index <- .subset2(design, "index")

Expand Down Expand Up @@ -210,6 +188,7 @@ AlignDendro <- ggproto("AlignDendro", AlignHclust,
)
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_attr_set(node, list(edge = edge)))
Expand Down
32 changes: 16 additions & 16 deletions R/align-group.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,32 +16,32 @@
#' @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,
params = list(group = group),
data = NULL, active = active,
group = group,
active = active,
check.param = TRUE
)
}

#' @importFrom ggplot2 ggproto
AlignGroup <- ggproto("AlignGroup", Align,
nobs = function(self, params) {
nobs <- vec_size(.subset2(params, "group"))
if (nobs == 0L) {
cli_abort("{.arg group} cannot be empty", call = self$call)
interact_layout = function(self, layout) {
layout <- ggproto_parent(Align, 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"
)
}
nobs
layout
},
setup_params = function(self, nobs, params) {
assert_mismatch_nobs(
self, nobs, self$nobs(params),
action = "must be an atomic vector",
arg = "group"
)
params
},
align = function(self, panel, index, group) list(group, index),
align = function(self, panel, index) list(self$group, index),
summary_align = function(self) c(FALSE, TRUE)
)
Loading

0 comments on commit 21df89f

Please sign in to comment.