R/points.R

Defines functions `[<-.ggdiagram::ob_point`

pt_styles <- c("alpha", "color", "fill", "shape", "size", "stroke")

pr_place <- S7::new_property(S7::class_function, getter = function(self) {
  \(from, where = "right", sep = 1, ...) place(x = self, from = from, where = where, sep = sep, ...)
})

pt_props <- list(
  # Primary ----
  primary = list(
    x = S7::new_property(class = S7::class_numeric, default = 0),
    y = S7::new_property(class = S7::class_numeric, default = 0)
  ),
  styles = ob_style@properties[pt_styles],
  # Derived ----
  derived = list(
    auto_label = S7::new_property(getter = function(self) {
      label_object(self)
    }),
    bounding_box = S7::new_property(getter = function(self) {
      ob_rectangle(southwest = ob_point(x = min(self@x), y = min(self@y)),
                northeast = ob_point(x = max(self@x), y = max(self@y)))
    }),
    centroid = S7::new_property(getter = function(self) {
      ob_point(mean(self@x), mean(self@y), style = self[1]@style)
    }),
    length = S7::new_property(
      getter = function(self) {
        length(self@x)
      }
    ),
    r = S7::new_property(
      getter = function(self) {
        sqrt(self@x ^ 2 + self@y ^ 2)
      },
      setter = function(self, value) {
        set_props(self, x = cos(self@theta) * value, y = sin(self@theta) * value)
      }
    ),
    theta = S7::new_property(
      getter = function(self) {
        radian(radian = atan2(self@y, self@x))
      },
      setter = function(self, value) {
        set_props(self, x = cos(value) * self@r, y = sin(value) * self@r)
      }
    ),
    style = S7::new_property(
      getter = function(self) {
        pr <- purrr::map(pt_styles,
                         prop, object = self) |>
          `names<-`(pt_styles)
        rlang::inject(ob_style(!!!get_non_empty_list(pr)))
      },
      setter = function(self, value) {
        s <- self@style + value
        s_list <- get_non_empty_props(s)
        s_list <- s_list[names(s_list) %in% pt_styles]
        self <- rlang::inject(S7::set_props(self, !!!s_list))
        self
      }
    ),
    tibble = S7::new_property(getter = function(self) {
      d <- list(
        x = self@x,
        y = self@y,
        alpha = self@alpha,
        color = self@color,
        fill = self@fill,
        shape = self@shape,
        size = self@size,
        stroke = self@stroke,
        id = self@id
      )
      get_non_empty_tibble(d)
    }),
    xy = S7::new_property(
      getter = function(self) {
        cbind(x = self@x, y = self@y)
      }
    )
  ),
  # Functions ----
  funs = list(
    geom = S7::new_property(S7::class_function, getter = function(self) {
      \(...) {
        as.geom(self, ...)
      }
    }),
    label = S7::new_property(S7::class_function, getter = function(self) {
      \(label = NULL,
        accuracy = .1,
        ...
      ) {
        if (is.null(label)) {
          label = label_object(self, accuracy)

        }
        if (is.numeric(label) & !S7::S7_inherits(label)) {
          if (rlang::is_integerish(label)) {
            label <- signs::signs(label)
          } else {
            label = signs::signs(label, accuracy = accuracy, trim_leading_zeros = TRUE)
          }
        }
        ob_label(center = self, label = label, ...)
      }

    }),
    place = pr_place

  ),
  info = list(
    aesthetics = S7::new_property(getter = function(self) {
    class_aesthetics_list(
      geom = ggplot2::geom_point,
      mappable_bare = character(0),
      mappable_identity = c("shape", "color", "size", "fill", "alpha", "stroke"),
      not_mappable = character(0),
      required_aes = c("x", "y"),
      omit_names = "group",
      inherit.aes = FALSE,
      style = pt_styles
    )
  }))
)

# ob_point----

#' ob_point
#'
#' Points are specified with x and y coordinates.
#' @export
#' @param x Vector of coordinates on the x-axis (also can take a tibble/data.frame or 2-column matrix as input.)
#' @param y Vector of coordinates on the y-axis
#' @param r Radius = Distance from the origin to the ob_point
#' @param theta Angle of the vector from the origin to the [`ob_point`]
#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> properties passed to `style`
#' @slot auto_label Gets x and y coordinates and makes a label `"(x,y)"`
#' @slot geom A function that converts the object to a geom. Any additional parameters are passed to `ggplot2::geom_point`.
#' @slot length The number of points in the ob_point object
#' @param style Gets and sets the styles associated with points
#' @slot tibble Gets a [`tibble::tibble`] containing parameters and styles used by [`ggplot2::geom_point`].
#' @slot xy Gets a 2-column matrix of the x and y coordinates of the ob_point object.
#' @slot centroid ob_point at the average of the x and y values
#' @slot bounding_box ob_rectangle that contains all the points in the object
#' @slot place function to place point in relation to other objects
#' @slot label function to create ob_label for points in the object
#' @slot aesthetics returns class_aesthetics for ob_point
#' @inherit ob_style params
#' @export
#' @returns ob_point object
#' @examples
#' ggdiagram() +
#'   ob_point(1:5, 1:5) +
#'   ggplot2::theme_minimal()
#'
#' ggdiagram() +
#'   ob_polar(degree(seq(0, 330, 30)), r = 2) +
#'   ggplot2::theme_minimal()
ob_point <- S7::new_class(
  name = "ob_point",
  package = "ggdiagram",
  parent = xy,
  properties = rlang::list2(
    !!!pt_props$primary,
    !!!pt_props$styles,
    !!!pt_props$derived,
    !!!pt_props$funs,
    !!!pt_props$info),
  constructor = function(x = 0,
                         y = 0,
                         alpha = numeric(0),
                         color = character(0),
                         fill = character(0),
                         shape = numeric(0),
                         size = numeric(0),
                         stroke = numeric(0),
                         style = S7::class_missing,
                         id = character(0),
                         ...) {

    id <- as.character(id)

    if (inherits(x, "data.frame")) {
      return(rlang::inject(ob_point(!!!get_non_empty_list(x))))
    }

    if (inherits(x, "matrix")) {
      if (ncol(x) == 2) {
        y <- x[,2]
        x <- x[,1]
        # return(ob_point(x[,1], x[,2]))
      } else {
        stop(paste0("The input matrix must have 2 columns, not ", ncol(x), "."))
      }

    }

    p_style <- style +
      ob_style(
        alpha = alpha,
        color = color,
        fill = fill,
        shape = shape,
        size = size,
        stroke = stroke,
        id = id
      ) +
      ob_style(...)

    non_empty_list <- get_non_empty_props(p_style)
    d <- tibble::tibble(x = x, y = y)
    if (length(non_empty_list) > 0) {
      d <- dplyr::bind_cols(
        d,
        tibble::tibble(!!!non_empty_list))
    }



     S7::new_object(S7::S7_object(),
                 x = d$x,
                 y = d$y,
                 alpha = d[["alpha"]] %||% alpha,
                 color = d[["color"]] %||% color ,
                 fill = d[["fill"]]  %||% fill,
                 shape = d[["shape"]] %||% shape,
                 size = d[["size"]] %||% size,
                 stroke = d[["stroke"]] %||% stroke,
                 id = d[["id"]] %||% id)
  }
)


# ob_polar point class ----
#' ob_polar
#'
#' Polar points are ordinary points but are specified with an angle (theta) and a radial distance (r)
#' @rdname ob_point
#' @export
ob_polar <- S7::new_class(
  name = "ob_polar",
  parent = ob_point,
  package = "ggdiagram",
  constructor = function(theta = S7::class_missing,
                         r = numeric(0),
                         alpha = numeric(0),
                         color = character(0),
                         fill = character(0),
                         shape = numeric(0),
                         size = numeric(0),
                         stroke = numeric(0),
                        style = S7::class_missing,
                        id = character(0)) {

    id <- as.character(id)

    if (length(r) == 0) r <- 1
    if (length(theta) == 0) theta <- degree(0)
    if (is.character(theta)) theta <- degree(theta)


    p <- ob_point(x = cos(theta) * r,
               y = sin(theta) * r,
               alpha = alpha,
               color = color,
               fill = fill,
               shape = shape,
               size = size,
               stroke = stroke,
               style = style,
               id = id
              )

    S7::new_object(p)
  })


S7::method(str, ob_point) <- function(
    object,
    nest.lev = 0,
    additional = TRUE,
    omit = omit_props(object, include = c("x","y"))) {
  str_properties(object,
                 omit = omit,
                 nest.lev = nest.lev,
                additional = additional)
}

S7::method(str, ob_polar) <- function(
  object,
  nest.lev = 0,
  additional = TRUE,
  omit = omit_props(object, include = c("x","y", "r", 'theta'))) {
str_properties(object,
               omit = omit,
               nest.lev = nest.lev,
              additional = additional)
}

S7::method(get_tibble, ob_point) <- function(x) {
  x@tibble
}

S7::method(get_tibble_defaults, ob_point) <- function(x) {
  sp <- ob_style(
    alpha = replace_na(ggplot2::GeomPoint$default_aes$alpha, 1),
    color = replace_na(ggplot2::GeomPoint$default_aes$colour, "black"),
    fill = replace_na(ggplot2::GeomPoint$default_aes$fill, "black"),
    shape = replace_na(ggplot2::GeomPoint$default_aes$shape, 19),
    size = replace_na(ggplot2::GeomPoint$default_aes$size, 2),
    stroke = replace_na(ggplot2::GeomPoint$default_aes$stroke, 0.5)
  )
  get_tibble_defaults_helper(x, sp, required_aes = c("x", "y"))
}

#' Convert hjust and vjust parameters from polar coordinates
#'
#' This function is how [`ob_label`]'s `vjust` and
#' `hjust` values are recalculated automatically when the `polar_just` parameter is specified.
#' @param x angle. Can be a named direction (e.g., "north"), number (in degrees), [`degree`], [`radian`], or [`turn`]
#' @param multiplier distance
#' @param axis vertical (v) or horizontal (h)
#' @export
#' @returns ob_angle object
#' @examples
#' a <- "northwest"
#' polar2just(a, axis = "h")
#' polar2just(a, axis = "v")
polar2just <- S7::new_generic(
  name = "polar2just",
  dispatch_args = "x",
  fun = function(x, multiplier = NULL, axis = c("h", "v")) {
    S7::S7_dispatch()
  }
)
S7::method(polar2just, S7::class_numeric) <- function(x, multiplier = NULL, axis = c("h", "v")) {
  if (length(multiplier) == 0 | is.null(multiplier)) multiplier <- 1.2
  axis <- match.arg(axis)
  if (axis == "h") {
    (((cos(x + pi) + 1)/2) - 0.5) * multiplier + 0.5
  } else {
    (((sin(x + pi) + 1)/2) - 0.5) * multiplier + 0.5
  }

}

S7::method(polar2just, S7::class_character) <- function(x, multiplier = NULL, axis = c("h", "v")) {
  x <- degree(x)
  polar2just(x@radian, multiplier, axis)
}

S7::method(polar2just, ob_angle) <- function(x, multiplier = NULL, axis = c("h", "v")) {
  polar2just(x@radian, multiplier, axis)
}

S7::method(polar2just, ob_point) <- function(x, multiplier = NULL, axis = c("h", "v")) {
  if (length(multiplier) == 0 | is.null(multiplier)) multiplier <- x@r
  polar2just(x@theta, multiplier, axis)
}

S7::method(polar2just, ob_polar) <- function(x, multiplier = NULL, axis = c("h", "v")) {
  if (length(multiplier) == 0 | is.null(multiplier)) multiplier <- x@r
  polar2just(x@theta, multiplier, axis)
}

S7::method(`==`, list(ob_point, ob_point)) <- function(e1, e2) {
  (e1@x == e2@x) & (e1@y == e2@y) # nocov
}



# arithmetic ----
purrr::walk(list(`+`, `-`, `*`, `/`, `^`), \(.f) { # nocov start
  S7::method(.f, list(ob_point, ob_point)) <- function(e1, e2) {
    x <- .f(e1@x, e2@x)
    y <- .f(e1@y, e2@y)
    e2@x <- x
    e2@y <- y
    e2@style <- e1@style + e2@style
    e2
  } # nocov end

  S7::method(.f, list(ob_point, S7::class_numeric)) <- function(e1, e2) { # nocov start
    e1@x <- .f(e1@x, e2)
    e1@y <- .f(e1@y, e2)
    e1
  } # nocov end
  S7::method(.f, list(S7::class_numeric, ob_point)) <- function(e1, e2) { # nocov start
    e2@x <- .f(e1, e2@x)
    e2@y <- .f(e1, e2@y)
    e2
  } # nocov end
})

S7::method(midpoint, list(ob_point, ob_point)) <- function(x,y, position = .5, ...) {
  p <- x + ((y - x) * position)
  s <- rlang::list2(...)
  rlang::inject(set_props(p, !!!s))
}

S7::method(`%*%`, list(ob_point, ob_point)) <- function(x, y) { # nocov start
  x@xy[1, , drop = TRUE] %*% y@xy[1, , drop = TRUE]
} # nocov end

# Perpendicular ----

#' Find point perpendicular to 2 points
#'
#' @name perpendicular_point
#' @param e1 first ob_point
#' @param e2 second ob_point
#' @examples
#' x <- ob_point(0,0)
#' y <- ob_point(1,1)
#' # Find point perpendicular to x and y going vertically first
#' x %|-% y
#' # Find point perpendicular to x and y going horizontally first
#' x %-|% y
NULL

#' @name perpendicular_vertical
#' @rdname perpendicular_point
#' @aliases %|-%
#' @export
#' @returns ob_point object
`%|-%` <- S7::new_generic("%|-%", c("e1", "e2"), fun = function(e1,e2) {S7::S7_dispatch()})

S7::method(`%|-%`, list(ob_point, ob_point)) <- function(e1,e2) {
  e2@x <- e1@x
  e2
  }



#' @name perpendicular_horizontal
#' @rdname perpendicular_point
#' @aliases %-|%
#' @export
#' @returns ob_point object
`%-|%` <- S7::new_generic("%-|%", c("e1", "e2"), fun = function(e1,e2) {S7::S7_dispatch()})

S7::method(`%-|%`, list(ob_point, ob_point)) <- function(e1,e2) {
  e2@y <- e1@y
  e2
  }

S7::method(label_object, ob_point) <- function(object, accuracy = .1) {

      if (rlang::is_integerish(object@x)) {
        x <- signs::signs(object@x)
      } else {
        x = signs::signs(object@x, accuracy = accuracy, trim_leading_zeros = TRUE)
      }

      if (rlang::is_integerish(object@y)) {
        y <- signs::signs(object@y)
      } else {
        y = signs::signs(object@y, accuracy = accuracy, trim_leading_zeros = TRUE)
      }

      paste0("(", x, ",", y, ")")

}



S7::method(`[`, ob_point) <- function(x, i) {
  i <- character_index(i, x@id)
  data2shape(x@tibble[i,], ob_point)
}

#' @export
`[<-.ggdiagram::ob_point` <- function(x, i, value) {
  i <- character_index(i, x@id)
  d <- assign_data(x, i, value)
  data2shape(d, ob_point)
}

# Connect ----

S7::method(connect, list(ob_point, ob_point)) <- function(
    from,
    to,
    label = character(0),
    arc_bend = NULL,
    from_offset = NULL,
    to_offset = NULL,
    alpha = numeric(0),
    arrow_head = the$arrow_head,
    arrow_fins = list(),
    arrowhead_length = 7,
    length_head = numeric(0),
    length_fins = numeric(0),
    color = 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 = S7::class_missing,
    label_sloped = TRUE,
    id = character(0),
    ...) {
  if (is.null(from_offset) && is.null(to_offset) && (is.null(arc_bend) || all(arc_bend == 0))) {
    s <- ob_segment(from,
                    to,
                    label = label,
                    from_offset = from_offset,
                    to_offset = to_offset,
                    alpha = alpha,
                    arrow_head = arrow_head,
                    arrow_fins = arrow_fins,
                    arrowhead_length = arrowhead_length,
                    length_head = length_head,
                    length_fins = length_fins,
                    color = color,
                    lineend = lineend,
                    linejoin = linejoin,
                    linewidth = linewidth,
                    linewidth_fins = linewidth_fins,
                    linewidth_head = linewidth_head,
                    linetype = linetype,
                    resect = resect,
                    resect_fins = resect_fins,
                    resect_head = resect_head,
                    stroke_color = stroke_color,
                    stroke_width = stroke_width,
                    style = style,
                    label_sloped = label_sloped,
                    id = id, ...)
  } else if (!is.null(arc_bend)) {
    if(any(arc_bend == 0)) stop("An arc cannot have an arc_bend of 0.")
    m <- midpoint(from, to)
    chord_distance <- distance(from, to)
    theta_arc <- (m - from)@theta + sign(arc_bend) * degree(-90)
    m_arc <- ob_polar(theta_arc, r = 0.5 * chord_distance * abs(arc_bend)) + m
    sagitta_distance <- distance(m, m_arc)
    r_arc <- sagitta_distance / 2 + (chord_distance ^ 2) / (8 * sagitta_distance)
    center <- m_arc + ob_polar(theta_arc - turn(.5), r_arc)
    cc <- ob_circle(center = center,
                radius = distance(from, center))
    theta_start <- cc@angle_at(from)@positive
    theta_end <- cc@angle_at(to)@positive
    theta_end[arc_bend < 0 & theta_end > theta_start] <- theta_end[arc_bend < 0 & theta_end > theta_start] + turn(-1)


    theta_end[arc_bend > 0 & theta_end < theta_start] <- theta_end[arc_bend > 0 & theta_end < theta_start] + turn(1)
    s <- ob_arc(center = center,
                radius = cc@radius,
                label = label,
                start = theta_start,
                end = theta_end,
                alpha = alpha,
                arrow_head = arrow_head,
                arrow_fins = arrow_fins,
                arrowhead_length = arrowhead_length,
                length_head = length_head,
                length_fins = length_fins,
                color = color,
                lineend = lineend,
                linejoin = linejoin,
                linewidth = linewidth,
                linewidth_fins = linewidth_fins,
                linewidth_head = linewidth_head,
                linetype = linetype,
                resect = resect,
                resect_fins = resect_fins,
                resect_head = resect_head,
                stroke_color = stroke_color,
                stroke_width = stroke_width,
                style = style,
                label_sloped = label_sloped,
                id = id,
                ...)

  } else {
    from1 <- NULL
    to1 <- NULL
    if (is.character(from_offset)) {
      from_offset <- ob_polar(theta = degree(from_offset), r = distance(from,to))
    }

    if (is.character(to_offset)) {
      to_offset <- ob_polar(theta = degree(to_offset), r = distance(from,to))
    }

    d <- tibble::tibble(from_x = from@x,
                        from_y = from@y,
                        to_x = to@x,
                        to_y = to@y)



    if (!is.null(from_offset)) {
      from1 <- from + from_offset
      d <- d |>
        dplyr::mutate(fromoffset_x = from1@x,
                      fromoffset_y = from1@y)
    }

    if (!is.null(to_offset)) {
      to1 <- to + to_offset
      d <- d |>
        dplyr::mutate(tooffset_x = to1@x,
                      tooffset_y = to1@y)
    }



    p_control <- d |>
      dplyr::mutate(rowid = dplyr::row_number()) |>
      tidyr::pivot_longer(-rowid) |>
      tidyr::separate(name, c("control", "name")) |>
      tidyr::pivot_wider() |>
      dplyr::mutate(control = factor(
        control,
        levels = c("from", "fromoffset", "tooffset", "to"))) |>
      dplyr::arrange(rowid, control) |>
      dplyr::select(-control) |>
      tidyr::nest(.by = rowid) |>
      dplyr::pull(data) |>
      purrr::map(ob_point)

    s <- ob_bezier(p = p_control,
                   label = label,
                   from_offset = from_offset,
                   to_offset = to_offset,
                   alpha = alpha,
                   arrow_head = arrow_head,
                   arrow_fins = arrow_fins,
                   arrowhead_length = arrowhead_length,
                   length_head = length_head,
                   length_fins = length_fins,
                   color = color,
                   lineend = lineend,
                   linejoin = linejoin,
                   linewidth = linewidth,
                   linewidth_fins = linewidth_fins,
                   linewidth_head = linewidth_head,
                   linetype = linetype,
                   resect = resect,
                   resect_fins = resect_fins,
                   resect_head = resect_head,
                   stroke_color = stroke_color,
                   stroke_width = stroke_width,
                   style = style,
                   label_sloped = label_sloped,
                   id = id,
                   ...
                   )

  }

  s

}

S7::method(place, list(ob_point, ob_point)) <- function(x, from, where = "right", sep = 1) {
  where <- degree(where)
  p <- ob_polar(where, sep)
  x@x <- from@x + p@x
  x@y <- from@y + p@y
  x
}

point_or_list <- S7::new_union(ob_point, S7::class_list)

# Nudge ----

S7::method(nudge, list(ob_point, S7::class_numeric, S7::class_numeric)) <- function(object, x, y) {
  object + ob_point(x, y)
}

S7::method(nudge, list(ob_point, S7::class_numeric, S7::class_missing)) <- function(object, x, y) {
  object + ob_point(x, 0)
}

S7::method(nudge, list(ob_point, S7::class_missing, S7::class_numeric)) <- function(object, x, y) {
  object + ob_point(0, y)
}

S7::method(ob_array, ob_point) <- function(x, k = 2, sep = 1, where = "east", anchor = "center", ...) {
  s <- seq(0, sep * (k - 1), sep)
  px <- cos(degree(where)) * s
  py <- sin(degree(where)) * s
  p <- ob_point(px, py)
  bb <- p@bounding_box
  if (anchor == "center") {
    p_anchor <- bb@center
  } else {
    p_anchor <- bb@point_at(anchor)
  }
  ob_point((p - p_anchor + x)@xy, x@style, ...)
}


S7::method(ob_covariance, list(ob_point, ob_point)) <- function(
    x,
    y,
    where = NULL,
    bend = 0,
    looseness = 1,
    arrow_head = the$arrow_head,
    length_head = 7,
    length_fins = 7,
    resect = 2,
    ...) {
  if (!S7::S7_inherits(where, ob_angle) && !is.null(where)) where <- degree(where)
  if (!S7::S7_inherits(bend, ob_angle)) bend <- degree(bend)



  p <- purrr::pmap(list(xx = unbind(x), yy = unbind(y), bb = unbind(bend)), \(xx, yy, bb) {

    if (is.null(where)) {
      d_xy <- yy - xx
      x_angle <- d_xy@theta + degree(45)
      y_angle <- degree(135) + (d_xy@theta)
    } else {
      x_angle <- where
      y_angle <- degree(180) - where
    }
    s <- xx
    e <- yy
    m_dist <- looseness * (s - e)@r / 2

    bind(c(
      s,
      rotate(
        xx + ob_polar(theta = x_angle, r = m_dist),
        theta = bb,
        origin = s),
      rotate(
        yy + ob_polar(theta = y_angle, r = m_dist),
        theta = bb * -1,
        origin = e),
      e))
  })

  dots <- rlang::list2(...)

  l <- character(0)


  if (!is.null(dots$label)) {
    l <- dots$label
    if (!S7::S7_inherits(l, ob_label)) l <- ob_label(l)
    dots$label <- NULL
  }

  rlang::inject(ob_bezier(p = p,
                        label = l,
                        label_sloped = FALSE,
                        arrow_head = arrow_head,
                        arrow_fins = arrow_head,
                        length_head = length_head,
                        length_fins = length_fins,
                        resect = resect,
                        !!!dots))
}

Try the ggdiagram package in your browser

Any scripts or data that you put into this service are public.

ggdiagram documentation built on Sept. 15, 2025, 1:07 a.m.