Skip to content

Commit

Permalink
elements
Browse files Browse the repository at this point in the history
  • Loading branch information
@wjschne
wjschne committed Nov 27, 2024
1 parent b8ac99b commit f40d4cd
Show file tree
Hide file tree
Showing 440 changed files with 19,665 additions and 1,227 deletions.
227 changes: 160 additions & 67 deletions R/arcs.R
View file

Large diffs are not rendered by default.

67 changes: 36 additions & 31 deletions R/bezier.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@ bz_props <- list(
rlang::inject(ob_style(!!!get_non_empty_list(pr)))
},
setter = function(self, value) {
ob_point(self@x, self@y, style = self@style + value)
ob_path(self@p, label = self@label, style = self@style + value)
}
),
tibble = new_property(getter = function(self) {
Expand Down Expand Up @@ -175,12 +175,13 @@ bz_props <- list(
#' @slot tibble Gets a tibble (data.frame) containing parameters and styles used by `ggarrow::geom_arrow`.
#' @inherit ob_style params
#' @slot geom A function that converts the object to a geom. Any additional parameters are passed to `ggarrow::geom_arrow`.
#' @slot midpoint A function that selects 1 or more midpoints of the ob_bezier. The `position` argument can be between 0 and 1. Additional arguments are passed to the ob_point's style object.
#' @slot midpoint A function that selects 1 or more midpoints of the ob_bezier. The `position` argument can be between 0 and 1. Additional arguments are passed to `ob_point`.
#' @slot aesthetics A list of information about the ob_bezier's aesthetic properties
#' @examples
#' library(ggplot2)
#' control_points <- ob_point(c(0,1,2,4), c(0,4,0,0))
#' ggplot() + coord_equal() +
#' ggplot() +
#' coord_equal() +
#' ob_bezier(control_points, color = "blue") +
#' ob_path(control_points, linetype = "dashed", linewidth = .5) +
#' control_points
Expand All @@ -198,28 +199,28 @@ ob_bezier <- new_class(
)
),
constructor = function(p = class_missing,
label = class_missing,
label = character(0),
label_sloped = TRUE,
n = 360,
alpha = class_missing,
alpha = numeric(0),
arrow_head = class_missing,
arrow_fins = class_missing,
arrowhead_length = class_missing,
length_head = class_missing,
length_fins = class_missing,
color = class_missing,
fill = class_missing,
lineend = class_missing,
linejoin = class_missing,
linewidth = class_missing,
linewidth_fins = class_missing,
linewidth_head = class_missing,
linetype = class_missing,
resect = class_missing,
resect_fins = class_missing,
resect_head = class_missing,
stroke_color = class_missing,
stroke_width = class_missing,
arrowhead_length = numeric(0),
length_head = numeric(0),
length_fins = numeric(0),
color = character(0),
fill = character(0),
lineend = numeric(0),
linejoin = numeric(0),
linewidth = numeric(0),
linewidth_fins = numeric(0),
linewidth_head = numeric(0),
linetype = numeric(0),
resect = numeric(0),
resect_fins = numeric(0),
resect_head = numeric(0),
stroke_color = character(0),
stroke_width = numeric(0),
style = class_missing,
...) {

Expand Down Expand Up @@ -331,15 +332,15 @@ method(get_tibble, ob_bezier) <- function(x) {
dplyr::mutate(p = purrr::map(p, \(x) {
x@tibble |> dplyr::select(x,y) |> as.matrix()
})) |>
dplyr::mutate(p = purrr::map2(p,n, \(pp,nn) {
dplyr::mutate(p_unnest = purrr::map2(p,n, \(pp,nn) {
bezier::bezier(t = seq(0,1, length.out = nn),
p = pp) |>
`colnames<-`(c("x", "y")) |>
tibble::as_tibble()

})) |>
tidyr::unnest(p) |>
dplyr::select(-n)
# tidyr::unnest(p) |>
dplyr::select(-n, -p)
}


Expand All @@ -350,7 +351,7 @@ method(get_tibble_defaults, ob_bezier) <- function(x) {
arrow_fins = ggarrow::arrow_fins_minimal(90),
color = replace_na(ggarrow::GeomArrow$default_aes$colour, "black"),
stroke_color = replace_na(ggarrow::GeomArrow$default_aes$colour, "black"),
stroke_width = replace_na(ggarrow::GeomArrow$default_aes$colour, 0.25),
stroke_width = replace_na(ggarrow::GeomArrow$default_aes$stroke_width, 0.25),
lineend = "butt",
linejoin = "round",
linewidth = replace_na(ggarrow::GeomArrow$default_aes$linewidth, .5),
Expand All @@ -359,7 +360,7 @@ method(get_tibble_defaults, ob_bezier) <- function(x) {
linetype = replace_na(ggarrow::GeomArrow$default_aes$linetype, 1),
n = 360
)
get_tibble_defaults_helper(x, sp,required_aes = c("x", "y", "group"))
get_tibble_defaults_helper(x, sp,required_aes = c("group", "p_unnest"))
}


Expand All @@ -386,12 +387,15 @@ method(as.geom, ob_bezier) <- function(x, ...) {

if (all(x@label_sloped)) {

d_label <- tidyr::nest(dplyr::select(d, x, y, group), .by = group) |>
dplyr::bind_cols(dplyr::select(x@label@tibble, -c(x, y))) |>
d_label <- tidyr::nest(dplyr::select(d, p_unnest, group),
.by = group) |>
dplyr::bind_cols(
dplyr::select(x@label@tibble, -c(x, y))) |>
tidyr::unnest(data)

if ("size" %in% colnames(d_label)) {
d_label <- dplyr::mutate(d_label, size = size / ggplot2::.pt)
d_label <- dplyr::mutate(d_label,
size = size / ggplot2::.pt)
}


Expand All @@ -414,13 +418,14 @@ method(as.geom, ob_bezier) <- function(x, ...) {
user_overrides = NULL)

} else {
dpos <- tibble(group = unique(d$group),
dpos <- tibble::tibble(group = unique(d$group),
pos = x@label@position)

d_l <- dplyr::select(x@label@tibble, -c(x, y))


d_label <- dplyr::select(d, x,y,group) |>
d_label <- tidyr::unnest(d, p_unnest) %>%
dplyr::select(x,y,group) |>
dplyr::left_join(dpos, by = "group") |>
dplyr::mutate(x0 = dplyr::lag(x),
y0 = dplyr::lag(y),
Expand Down
80 changes: 67 additions & 13 deletions R/circles.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,7 +58,10 @@ cr_props <- list(
rlang::inject(ob_style(!!!get_non_empty_list(pr)))
},
setter = function(self, value) {
ob_point(self@x, self@y, style = self@style + value)
ob_circle(center = self@center,
radius = self@radius,
label = self@label,
style = self@style + value)
}
),
tibble = new_property(getter = function(self) {
Expand All @@ -82,17 +85,22 @@ cr_props <- list(
as.geom(self, ...)
}
}),
arc = new_property(class_function, getter = \(self) {
\(start, end, type = "arc", ...) {
ob_arc(self@center, radius = self@radius, start = start, end = end, type = type, ...)
}
}),
angle_at = new_property(class_function, getter = function(self) {
\(point) {
dp <- point - self@center
dp@theta
}
}),
normal_at = new_property(class_function, getter = function(self) {
\(theta = degree(0), distance = 1) {
\(theta = degree(0), distance = 1, ...) {
if (S7_inherits(theta, ob_point)) theta <- projection(theta, self)@theta
if (!S7_inherits(theta, ob_angle)) theta <- degree(theta)
ob_polar(theta, self@radius + distance) + self@center
self@center + ob_polar(theta, self@radius + distance, ...)
}
}),
tangent_at = new_property(
Expand All @@ -119,7 +127,9 @@ cr_props <- list(
class_function,
getter = function(self) {
\(theta = degree(0), ...) {
if (!S7_inherits(theta, ob_angle)) theta <- degree(theta)
if (!S7_inherits(theta, ob_angle)) {
theta <- degree(theta)
}
self@center + ob_polar(theta = theta, r = self@radius, style = self@style, ...)
}
}
Expand Down Expand Up @@ -185,16 +195,16 @@ ob_circle <- new_class(
!!!cr_props$info)),
constructor = function(center = ob_point(0,0),
radius = 1,
label = class_missing,
alpha = class_missing,
color = class_missing,
fill = class_missing,
linewidth = class_missing,
linetype = class_missing,
n = class_missing,
label = character(0),
alpha = numeric(0),
color = character(0),
fill = character(0),
linewidth = numeric(0),
linetype = numeric(0),
n = numeric(0),
style = class_missing,
x0 = class_missing,
y0 = class_missing,
x0 = numeric(0),
y0 = numeric(0),
...) {
c_style <- style +
ob_style(
Expand Down Expand Up @@ -313,3 +323,47 @@ method(ob_array, ob_circle) <- function(x, k = 2, sep = 1, where = "east", ancho
style = x@style,
!!!sa$dots))
}


#' Get a circle from 3 points
#'
#' @param p1 an ob_point of length 1 or length 3
#' @param p2 an ob_point of length 1 or NULL
#' @param p3 an ob_point of length 1 or NULL
#'
#' @return ob_point
#' @export
#'
#' @examples
#' p1 <- ob_point(1,1)
#' p2 <- ob_point(2,4)
#' p3 <- ob_point(5,3)
#' circle_from_3_points(p1,p2, p3)
circle_from_3_points <- function(p1, p2 = NULL, p3 = NULL, ...) {
# from https://math.stackexchange.com/a/1460096

if (p1@length == 3 && is.null(p2) && is.null(p3)) {
p <- p1
} else if (p1@length == 1 && p2@length == 1 && p3@length == 1) {
p <- bind(c(p1, p2, p3))
} else {
stop("p1 must be of length 3 or p1, p2, and p2 must be of length 1")
}

# Minor M11
m11 <- det(cbind(p@x, p@y, rep(1,3)))
if (m11 == 0) stop("Points on the same line cannot lie on a circle.")

# Minor m12
m12 <- det(cbind(p@x ^ 2 + p@y ^ 2, p@y, rep(1,3)))
# Minor m13
m13 <- det(cbind(p@x ^ 2 + p@y ^ 2, p@x, rep(1,3)))

x0 <- 0.5 * m12 / m11
y0 <- -0.5 * m13 / m11
center <- ob_point(x0,y0)
ob_circle(center, radius = distance(center, p1), ...)
}



50 changes: 49 additions & 1 deletion R/colors.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -115,10 +115,58 @@ class_color <- new_class(
self
}
),
red = new_property(
class = class_integer,
getter = function(self) {
farver::get_channel(colour = c(self),
channel = "r",
space = "rgb")
},
setter = function(self, value) {
S7_data(self) <- farver::set_channel(c(self), value, channel = "r", space = "rgb")
self
}
),
green = new_property(
class = class_integer,
getter = function(self) {
farver::get_channel(colour = c(self),
channel = "g",
space = "rgb")
},
setter = function(self, value) {
S7_data(self) <- farver::set_channel(c(self), value, channel = "g", space = "rgb")
self
}
),
blue = new_property(
class = class_integer,
getter = function(self) {
farver::get_channel(colour = c(self),
channel = "b",
space = "rgb")
},
setter = function(self, value) {
S7_data(self) <- farver::set_channel(c(self), value, channel = "b", space = "rgb")
self
}
),
mean = new_property(getter = \(self) {
r <- mean(self@red)
g <- mean(self@green)
b <- mean(self@blue)
a <- mean(self@alpha)
x <- class_color("white")
x@red <- r
x@green <- g
x@blue <- b
x@alpha <- a
x
}),
tex = new_property(getter = function(self) {
paste0("\\color[HTML]{", substring(self@color, 2, 7), "}")
})
), constructor = function(color = class_missing, hue = NULL, saturation = NULL, brightness = NULL, alpha = NULL) {
), constructor = function(color = character(0), hue = NULL, saturation = NULL, brightness = NULL, alpha = NULL) {
decoded <- farver::decode_colour(color, alpha = TRUE)

if (!is.null(hue)) decodec <- farver::get_channel(decoded, channel = "h", space = "hsv")
Expand Down
26 changes: 12 additions & 14 deletions R/ellipses.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -300,18 +300,18 @@ ob_ellipse <- new_class(
a = 1,
b = a,
angle = 0,
m1 = class_missing,
m2 = class_missing,
label = class_missing,
alpha = class_missing,
color = class_missing,
fill = class_missing,
linewidth = class_missing,
linetype = class_missing,
n = class_missing,
m1 = numeric(0),
m2 = numeric(0),
label = character(0),
alpha = numeric(0),
color = character(0),
fill = character(0),
linewidth = numeric(0),
linetype = numeric(0),
n = numeric(0),
style = class_missing,
x0 = class_missing,
y0 = class_missing,
x0 = numeric(0),
y0 = numeric(0),
...) {
if (!S7_inherits(angle, ob_angle)) angle <- degree(angle)

Expand Down Expand Up @@ -395,11 +395,9 @@ str_properties(object,

circle_or_ellipse <- new_union(ob_circle, ob_ellipse)

method(projection, list(ob_point, circle_or_ellipse)) <- function(p,object, ...) {
method(projection, list(ob_point, centerpoint)) <- function(p,object, ...) {
d <- p - object@center
object@point_at(d@theta, ...)
# ob_point(((object@a ^ object@m1) * d@x / object@m1) ^ (1 - object@m1),
# ((object@b ^ object@m2) * d@y / object@m2) ^ (1 - object@m2),)
}

method(get_tibble, ob_ellipse) <- function(x) {
Expand Down
Loading

0 comments on commit f40d4cd

Please sign in to comment.