other misc doc

R/draw.R

@@ -264,14 +264,16 @@ add_anno <- function(dt, anno_color = "black", anno_lty = "dashed", anno_alpha =
 #' @param theo_label character; a symbol to label the theoretical point
 #' @param theo_size numeric; the size of the theoretical point
 #' @param theo_alpha numeric; the alpha of the theoretical point
+#' @param theo_color character; the colour of the theoretical point in hex
 #' @param ... other aesthetics inherent from \code{explore_space_pca()}
 #' @return a wrapper for drawing theoretical points in \code{explore_space_pca()}
 #' @family draw functions
 #' @export
-add_theo <- function(dt, theo_label = "*", theo_size = 25, theo_alpha = 0.8, ...) {
+add_theo <- function(dt, theo_label = "*", theo_size = 25, theo_alpha = 0.8,
+ theo_color = "#000000", ...) {
  ggplot2::geom_text(
  data = dt,
  ggplot2::aes(x = .data$PC1, y = .data$PC2),
- label = theo_label, size = theo_size, alpha = theo_alpha
+ label = theo_label, size = theo_size, alpha = theo_alpha, color = theo_color
  )
 }

R/explore-space-tour.R

@@ -0,0 +1,116 @@
+#' Plot the grand tour animation of the bases space in high dimension
+
+#' @rdname explore_space_tour
+#' @family main plot functions
+#' @return
+#' \describe{
+#' \item{\code{explore_space_tour()}}{an animation of the search path in the high-dimensional sphere}
+#' \item{\code{prep_space_tour()}}{a list containing various components needed for producing the animation}
+#' }
+#' @export
+explore_space_tour <- function(..., axes = "bottomleft") {
+ prep <- prep_space_tour(...)
+
+ tourr::animate_xy(prep$basis,
+ col = prep$col, cex = prep$cex, pch = prep$pch,
+ edges = prep$edges, edges.col = prep$edges_col,
+ axes = axes
+ )
+}
+
+
+#' @param dt a data object collected by the projection pursuit guided tour optimisation in \code{tourr}
+#' @param group the variable to label different runs of the optimiser(s)
+#' @param flip logical; if the sign flipping need to be performed
+#' @param n_random numeric; the number of random basis to generate
+#' @param color the variable to be coloured by
+#' @param rand_size numeric; the size of random points
+#' @param rand_color character; the color hex code for random points
+#' @param point_size numeric; the size of points searched by the optimiser(s)
+#' @param end_size numeric; the size of end points
+#' @param theo_size numeric; the size of theoretical point(s)
+#' @param theo_shape numeric; the shape symbol in the basic plot
+#' @param theo_color character; the color of theoretical point(s)
+#' @param palette the colour palette to be used
+#' @param axes see [tourr::animate_xy()]
+#' @param ... other argument passed to \code{tourr::animate_xy()} and \code{prep_space_tour()}
+#' @examples
+#' explore_space_tour(dplyr::bind_rows(holes_1d_better, holes_1d_geo),
+#' group = method, palette = botanical_palettes$fern[c(1, 6)]
+#' )
+#' @rdname explore_space_tour
+#' @export
+prep_space_tour <- function(dt, group = NULL, flip = FALSE, n_random = 2000,
+ color = NULL, rand_size = 1, rand_color = "#D3D3D3",
+ point_size = 1.5, end_size = 5, theo_size = 3,
+ theo_shape = 17, theo_color = "black",
+ palette = botanical_palettes$fern, ...) {
+ if (rlang::quo_is_null(dplyr::enquo(color))) {
+ message("map method to color")
+ color <- dplyr::sym("method")
+ }
+
+ # get start
+ dt <- dt %>%
+ dplyr::mutate(row_num = dplyr::row_number()) %>%
+ clean_method()
+
+ if (flip){
+ flip <- dt %>% flip_sign(group = {{ group }})
+ basis <- flip$basis %>% bind_random_matrix(front = TRUE)
+ } else{
+ flip = list(dt = dt)
+ basis <- dt %>%
+ get_basis_matrix() %>%
+ bind_random_matrix(n = n_random, front = TRUE)
+ }
+
+ n_rand <- nrow(basis) - nrow(dt)
+ n_end <- get_best(flip$dt, group = {{ group }}) %>% dplyr::pull(.data$row_num) + n_rand
+
+ edges_dt <- flip$dt %>%
+ dplyr::mutate(id = dplyr::row_number()) %>%
+ dplyr::filter(.data$info == "interpolation") %>%
+ dplyr::group_by(.data$method) %>%
+ dplyr::mutate(id2 = dplyr::lead(.data$id, default = NA)) %>%
+ dplyr::ungroup() %>%
+ dplyr::filter(!is.na(.data$id2))
+
+ edges <- edges_dt %>%
+ dplyr::select(.data$id, .data$id2) %>%
+ dplyr::mutate(id = .data$id + n_rand, id2 = .data$id2 + n_rand) %>%
+ as.matrix()
+
+ edges_col <- palette[as.factor(edges_dt %>% dplyr::pull({{ color }}))]
+
+ col <- c(
+ rep(rand_color, n_rand),
+ palette[as.factor(dt %>% dplyr::pull({{ color }}))]
+ )
+ cex <- c(
+ rep(rand_size, n_rand),
+ rep(point_size, nrow(dt))
+ )
+ cex[n_end] <- end_size
+
+ pch <- rep(20, nrow(basis))
+
+ if ("theoretical" %in% dt$info) {
+ theo_row_num <- dt %>%
+ dplyr::filter(.data$info == "theoretical") %>%
+ dplyr::pull(.data$row_num)
+
+ col[theo_row_num + n_rand] <- theo_color
+ cex[theo_row_num + n_rand] <- theo_size
+ pch[theo_row_num + n_rand] <- theo_shape
+ }
+
+ return(list(
+ basis = basis,
+ col = col,
+ cex = cex,
+ pch = pch,
+ edges = edges,
+ edges_col = edges_col
+ ))
+}