From 3dd07505c20fdf7d7f44ed58c846dcc9a29c9450 Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 10:25:58 +0100 Subject: [PATCH] Move code from kwb.rabimo and make checks pass --- .Rbuildignore | 2 + DESCRIPTION | 6 + NAMESPACE | 12 ++ R/rectangles.R | 330 ++++++++++++++++++++++++++++++++++++++++++ R/utils-pipe.R | 14 ++ R/utils.R | 8 + kwb.rect.Rproj | 5 + man/c.rects.Rd | 14 ++ man/move.rects.Rd | 41 ++++++ man/pipe.Rd | 20 +++ man/plot.rects.Rd | 23 +++ man/separate.rects.Rd | 25 ++++ 12 files changed, 500 insertions(+) create mode 100644 NAMESPACE create mode 100644 R/rectangles.R create mode 100644 R/utils-pipe.R create mode 100644 R/utils.R create mode 100644 man/c.rects.Rd create mode 100644 man/move.rects.Rd create mode 100644 man/pipe.Rd create mode 100644 man/plot.rects.Rd create mode 100644 man/separate.rects.Rd diff --git a/.Rbuildignore b/.Rbuildignore index 614cf47..8732be9 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -6,3 +6,5 @@ ^codecov\.yml$ ^index\.md$ ^README\.md$ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/DESCRIPTION b/DESCRIPTION index 14ed9c1..fd3afb3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,3 +17,9 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.1 Suggests: covr +Imports: + dplyr, + kwb.utils, + magrittr +Remotes: + github::KWB-R/kwb.utils diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..31fd6b6 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,12 @@ +# Generated by roxygen2: do not edit by hand + +S3method(c,rects) +S3method(move,rects) +S3method(plot,rects) +S3method(separate,rects) +S3method(stack,rects) +export("%>%") +importFrom(kwb.utils,defaultIfNULL) +importFrom(kwb.utils,removeColumns) +importFrom(kwb.utils,selectColumns) +importFrom(magrittr,"%>%") diff --git a/R/rectangles.R b/R/rectangles.R new file mode 100644 index 0000000..3dafed5 --- /dev/null +++ b/R/rectangles.R @@ -0,0 +1,330 @@ +# c.rects ---------------------------------------------------------------------- + +#' Combine Rectangles +#' +#' @param \dots one or more objects of class "rects" +#' @export +c.rects <- function(...) +{ + rbind(...) +} + +# check_rects ------------------------------------------------------------------ +check_rects <- function(x) +{ + stopifnot(inherits(x, "rects")) +} + +# find_lim --------------------------------------------------------------------- +find_lim <- function(r, axis = "x") +{ + check_rects(r) + coord <- select_columns(r, paste0("ll", axis)) + size <- select_columns(r, ifelse(axis == "x", "w", "h")) + c(min(coord, na.rm = TRUE), max(coord + size, na.rm = TRUE)) +} + +# get_mids --------------------------------------------------------------------- +get_mids <- function(rdf) +{ + data <- select_columns(rdf, c("llx", "lly", "w", "h")) + + data.frame( + x = data$llx + data$w/2, + y = data$lly + data$h/2 + ) +} + +# init_plot -------------------------------------------------------------------- +init_plot <- function( + width = 1, + height = 1, + xlim = c(0, width), + ylim = c(0, height), + axes = FALSE +) +{ + plot( + NA, + xlim = xlim, + ylim = ylim, + xlab = "", + ylab = "", + asp = 1, + axes = axes + ) +} + +# move ------------------------------------------------------------------------- +move <- function(x, ...) +{ + UseMethod("move") +} + +# move.rects ------------------------------------------------------------------- + +#' Move Rectangles +#' +#' @param x A "rects" object +#' @param dx delta x +#' @param dy delta y +#' @param top top position +#' @param bottom bottom position +#' @param left left position +#' @param right right position +#' @param each logical indicating whether to move each rectangle or the group of +#' rectangles +#' @param \dots additional arguments (currently not used) +#' @method move rects +#' @export +move.rects <- function( + x, + dx = 0, + dy = 0, + top = NULL, + bottom = NULL, + left = NULL, + right = NULL, + each = FALSE, + ... +) +{ + check_rects(rdf) + + #dx = 0; dy = 0; top = NULL; bottom = NULL; left = NULL; right = NULL + is_set <- !sapply(FUN = is.null, list( + top = top, + bottom = bottom, + left = left, + right = right + )) + + #rdf <- as_data_frame(r) + + if (is_set["top"]) { + upper_y <- rdf$lly + rdf$h + dy <- top - if (each) upper_y else max(upper_y) + } else if (is_set["bottom"]) { + lower_y <- rdf$lly + dy <- bottom - if (each) lower_y else min(lower_y) + } + + if (is_set["left"]) { + left_x <- rdf$llx + dx <- left - if (each) left_x else min(left_x) + } else if (is_set["right"]) { + right_x <- rdf$llx + rdf$w + dx <- right - if (each) right_x else max(right_x) + } + + rdf$llx <- rdf$llx + dx + rdf$lly <- rdf$lly + dy + + rdf +} + +# new_rects -------------------------------------------------------------------- +new_rects <- function( + w = 1, + h = 1, + llx = 0, + lly = 0, + lbl_text = NULL, + lbl_align = "centre", + density = -1, + angle = 45, + col = NA, + border = graphics::par("fg"), + lty = graphics::par("lty"), + lwd = graphics::par("lwd"), + n = NULL +) +{ + #llx = 0; lly = 0; lty = 1; lwd = 1; label = NA + #w = 2; h = 3; llx = 1:4 + + vectors <- list( + w = w, + h = h, + llx = llx, + lly = lly, + lbl_align = lbl_align, + density = density, + angle = angle, + col = col, + border = border, + lty = lty, + lwd = lwd + ) + + # length of the longest vector or length given in n + n <- default_if_null(n, max(lengths(vectors))) + + # Resize all vectors to length n + vectors <- lapply(vectors, rep, length.out = n) + + vectors[["lbl_text"]] <- if (is.null(lbl_text)) { + paste0("r", seq_len(n)) + } else { + rep(lbl_text, length.out = n) + } + + vectors <- vectors[kwb.utils::pairwise(names(vectors))] + + # Convert to data frame and add class "rects" + kwb.utils::addClass(as.data.frame(vectors), "rects") +} + +# plot.rects ------------------------------------------------------------------- + +#' Plot Rectangles +#' +#' @param x object of class "rects" +#' @param add logical indicating whether to add rectangles to an existing plot +#' or to start a new plot +#' @param cex character expansion factor +#' @param y not used. Just there to comply with the generic plot() interface. +#' @param \dots additional arguments (currently not used) +#' @export +plot.rects <- function( + x, add = !is.null(grDevices::dev.list()), cex = 1, y = NULL, ... +) +{ + check_rects(x) + + if (!add) { + init_plot( + xlim = find_lim(x, "x"), + ylim = find_lim(x, "y"), + axes = TRUE + ) + } + + args <- to_rect_args(remove_columns(x, pattern = "^lbl_")) + + do.call(graphics::rect, args) + + mids <- get_mids(x) + + labels <- kwb.utils::defaultIfNA( + select_columns(x, "lbl_text"), + seq_len(nrow(x)) + ) + + align <- select_columns(x, "lbl_align") + + is_left <- align == "left" + is_centre <- align == "centre" + + text <- function(x, y, labels, adj) { + graphics::text(x = x, y = y, labels = labels, adj = adj, cex = cex) + } + + # Left aligned labels + if (any(is_left)) { + text( + x = x$llx[is_left], + y = mids$y[is_left], + labels = labels[is_left], + adj = c(0, 0.5) + ) + } + + # Centred labels + if (any(is_centre)) { + text( + x = mids$x[is_centre], + y = mids$y[is_centre], + labels = labels[is_centre], + adj = c(0.5, 0.5) + ) + } + + invisible(x) +} + +# separate --------------------------------------------------------------------- +#' @rdname separate.rects +separate <- function(x, ...) +{ + UseMethod("separate") +} + +# separate.rects --------------------------------------------------------------- + +#' Separate Rectangles +#'#' +#' @param x "rects" object +#' @param dx space in horizontal direction to be put in between the rectangles +#' @param dy space in vertical direction to be put in between the rectangles +#' @param \dots further arguments (currently not used) +#' @rdname separate.rects +#' @export +separate.rects <- function(x, dx = 0, dy = 0, ...) +{ + check_rects(x) + mids <- get_mids(x) + x$llx <- x$llx + (order(mids$x) - 1L) * dx + x$lly <- x$lly + (order(mids$y) - 1L) * dy + x +} + +stack <- function(x, ...) +{ + UseMethod("stack") +} + +# stack.rects ------------------------------------------------------------------ +#' @export +stack.rects <- function(x, horizontal = FALSE, delta = 0, reverse = FALSE, ...) +{ + check_rects(x) + + x <- x[[ifelse(horizontal, "w", "h")]] + + positions <- stacked_positions(x, delta = delta, reverse = reverse) + + x[[ifelse(horizontal, "llx", "lly")]] <- positions[, "lower"] + + x +} + +# stacked_positions ------------------------------------------------------------ +stacked_positions <- function(x, delta = 0, reverse = FALSE) +{ + upper <- cumsum(x) + (seq_along(x) - 1L) * delta + lower <- c(0, upper[-length(upper)] + delta) + + cbind( + lower = if (reverse) -upper else lower, + upper = if (reverse) -lower else upper + ) +} + +# to_label --------------------------------------------------------------------- +to_label <- function(key, value) +{ + sprintf("%s: %0.1f", key, value) +} + +# to_rect_args ----------------------------------------------------------------- +to_rect_args <- function(rdf) +{ + cols <- c("llx", "lly", "w", "h") + data <- select_columns(rdf, cols) + + coords <- data.frame( + xleft = data$llx, + ybottom = data$lly, + xright = data$llx + data$w, + ytop = data$lly + data$h + ) + + cbind(coords, rdf[, setdiff(names(rdf), cols), drop = FALSE]) +} + +# unlabel_and_dash ------------------------------------------------------------- +unlabel_and_dash <- function(x) +{ + dplyr::mutate(x, lbl_text = "", lty = "dashed") +} diff --git a/R/utils-pipe.R b/R/utils-pipe.R new file mode 100644 index 0000000..fd0b1d1 --- /dev/null +++ b/R/utils-pipe.R @@ -0,0 +1,14 @@ +#' Pipe operator +#' +#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. +#' +#' @name %>% +#' @rdname pipe +#' @keywords internal +#' @export +#' @importFrom magrittr %>% +#' @usage lhs \%>\% rhs +#' @param lhs A value or the magrittr placeholder. +#' @param rhs A function call using the magrittr semantics. +#' @return The result of calling `rhs(lhs)`. +NULL diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..f90cca3 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,8 @@ +#' @importFrom kwb.utils defaultIfNULL +default_if_null <- kwb.utils::defaultIfNULL + +#' @importFrom kwb.utils removeColumns +remove_columns <- kwb.utils::removeColumns + +#' @importFrom kwb.utils selectColumns +select_columns <- kwb.utils::selectColumns diff --git a/kwb.rect.Rproj b/kwb.rect.Rproj index e83436a..270314b 100644 --- a/kwb.rect.Rproj +++ b/kwb.rect.Rproj @@ -14,3 +14,8 @@ LaTeX: pdfLaTeX AutoAppendNewline: Yes StripTrailingWhitespace: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace diff --git a/man/c.rects.Rd b/man/c.rects.Rd new file mode 100644 index 0000000..1c99bcf --- /dev/null +++ b/man/c.rects.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rectangles.R +\name{c.rects} +\alias{c.rects} +\title{Combine Rectangles} +\usage{ +\method{c}{rects}(...) +} +\arguments{ +\item{\dots}{one or more objects of class "rects"} +} +\description{ +Combine Rectangles +} diff --git a/man/move.rects.Rd b/man/move.rects.Rd new file mode 100644 index 0000000..66f0964 --- /dev/null +++ b/man/move.rects.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rectangles.R +\name{move.rects} +\alias{move.rects} +\title{Move Rectangles} +\usage{ +\method{move}{rects}( + x, + dx = 0, + dy = 0, + top = NULL, + bottom = NULL, + left = NULL, + right = NULL, + each = FALSE, + ... +) +} +\arguments{ +\item{x}{A "rects" object} + +\item{dx}{delta x} + +\item{dy}{delta y} + +\item{top}{top position} + +\item{bottom}{bottom position} + +\item{left}{left position} + +\item{right}{right position} + +\item{each}{logical indicating whether to move each rectangle or the group of +rectangles} + +\item{\dots}{additional arguments (currently not used)} +} +\description{ +Move Rectangles +} diff --git a/man/pipe.Rd b/man/pipe.Rd new file mode 100644 index 0000000..a648c29 --- /dev/null +++ b/man/pipe.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-pipe.R +\name{\%>\%} +\alias{\%>\%} +\title{Pipe operator} +\usage{ +lhs \%>\% rhs +} +\arguments{ +\item{lhs}{A value or the magrittr placeholder.} + +\item{rhs}{A function call using the magrittr semantics.} +} +\value{ +The result of calling \code{rhs(lhs)}. +} +\description{ +See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. +} +\keyword{internal} diff --git a/man/plot.rects.Rd b/man/plot.rects.Rd new file mode 100644 index 0000000..c7660d5 --- /dev/null +++ b/man/plot.rects.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rectangles.R +\name{plot.rects} +\alias{plot.rects} +\title{Plot Rectangles} +\usage{ +\method{plot}{rects}(x, add = !is.null(grDevices::dev.list()), cex = 1, y = NULL, ...) +} +\arguments{ +\item{x}{object of class "rects"} + +\item{add}{logical indicating whether to add rectangles to an existing plot +or to start a new plot} + +\item{cex}{character expansion factor} + +\item{y}{not used. Just there to comply with the generic plot() interface.} + +\item{\dots}{additional arguments (currently not used)} +} +\description{ +Plot Rectangles +} diff --git a/man/separate.rects.Rd b/man/separate.rects.Rd new file mode 100644 index 0000000..b4fe5b2 --- /dev/null +++ b/man/separate.rects.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rectangles.R +\name{separate} +\alias{separate} +\alias{separate.rects} +\title{Separate Rectangles +#'} +\usage{ +separate(x, ...) + +\method{separate}{rects}(x, dx = 0, dy = 0, ...) +} +\arguments{ +\item{x}{"rects" object} + +\item{\dots}{further arguments (currently not used)} + +\item{dx}{space in horizontal direction to be put in between the rectangles} + +\item{dy}{space in vertical direction to be put in between the rectangles} +} +\description{ +Separate Rectangles +#' +}