Merge pull request #122 from huizezhang-sherry/master

a display for comparing index weights

NAMESPACE

@@ -22,6 +22,7 @@ export(animate_depth)
 export(animate_dist)
 export(animate_faces)
 export(animate_groupxy)
+export(animate_idx)
 export(animate_image)
 export(animate_pca)
 export(animate_pcp)
@@ -46,6 +47,7 @@ export(display_depth)
 export(display_dist)
 export(display_faces)
 export(display_groupxy)
+export(display_idx)
 export(display_image)
 export(display_pca)
 export(display_pcp)
@@ -88,6 +90,7 @@ export(path_dist)
 export(path_index)
 export(paths_index)
 export(pda_pp)
+export(planned2_tour)
 export(planned_tour)
 export(proj_dist)
 export(radial_tour)

R/display-idx.R

@@ -0,0 +1,128 @@
+#' Display 1D linear aggregation index
+#'
+#' @param center should 1d projection be centered to have mean zero (default: TRUE).
+#' This pins the centre of distribution to the same place, and makes it
+#' easier to focus on the shape of the distribution.
+#' @param half_range half range to use when calculating limits of projected.
+#' If not set, defaults to maximum distance from origin to each row of data.
+#' @param abb_vars logical, whether to abbreviate the variable name, if long
+#' @param col the color used for points, can be a vector or hexcolors or a
+#' factor, default to "red".
+#' @param cex the size used for points, default to 0.5
+#' @param panel_height_ratio input to the height argument in
+#' [graphics::layout()] for the height of data and axis panel.
+#' @param label the text label, a vector
+#' @param label_cex the size for text labels
+#' @param label_col the color for text labels
+#' @param label_x_pos the x position of text label, currently labels are
+#' positioned at a fixed x value for each observation
+#' @param frame_x_pos the x position of the frame label
+#' @param frame_y_pos the y position of the frame label
+#' @param frame_cex the size of the frame text
+#' @param frame_col the color of the frame text
+#' @param axis_bar_col,axis_bar_lwd,axis_bar_label_cex,axes_bar_label_col,
+#' the color and size/width of the axis bar and its label
+#' @param axis_var_cex,axis_var_col the color and size of the variable name
+#' to the right of the axis panel
+#' @param palette name of color palette for point colour, used by
+#' \code{\link{hcl.colors}}, default "Zissou 1"
+#' @export
+#' @rdname display_idx
+display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE,
+ col = "red", cex = 0.5, panel_height_ratio = c(6,1),
+ frame_x_pos = 0.15, frame_y_pos = 3, frame_cex = 3,
+ frame_col = "#000000", label_x_pos = 0.7, label = NULL,
+ label_cex = 1, label_col = "grey80",
+ axis_bar_col = "#000000", axis_bar_lwd = 3,
+ axis_bar_label_cex = 1, axis_bar_label_col = "#000000",
+ axis_var_cex = 3, axis_var_col = "#000000",
+ palette = "Zissou 1", ...) {
+ labels <- NULL
+ init <- function(data) {
+ half_range <<- compute_half_range(half_range, data, center)
+ if (abb_vars) {
+ labels <<- abbreviate(colnames(data), 2)
+ } else {
+ labels <<- colnames(data)
+ }
+ }
+ if (is.factor(col) | !areColors(col)) {
+ gps <- col
+ lgps <- levels(gps)
+ col <- mapColors(col, palette)
+ }
+ colrs <- unique(col)
+
+ render_frame <- function() {
+ # define the plot to have an upper & lower panel, height as 6:1
+ layout_m <- matrix(c(1, 2), nrow = 2, ncol = 1)
+ graphics::layout(mat = layout_m, heights = panel_height_ratio)
+ par(pty = "m", mar = c(1, 4, 1, 1))
+
+ }
+ render_transition <- function() {
+ rect(-1, -1.1, 1.2, 3, col = "#FFFFFFE6", border = NA)
+ }
+ render_data <- function(data, proj, geodesic, i) {
+
+ x <- data %*% proj
+ if (center) x <- center(x)
+ x <- x / half_range
+ df <- cbind(x, .y = 3/nrow(x) * (1:nrow(x)))
+ # upper panel: define the axis margin (mgp) and panel margin (mar)
+ par(mgp=c(2, 1, 0), mar = c(2, 4, 0.5, 1))
+ # initialise the plot box
+ plot(
+ x = NA, y = NA, xlim = c(0, 1.2), ylim = c(0, 3.05),
+ xlab="", ylab = "", xaxs = "i", yaxs = "i", cex = 2,
+ xaxt = "n", yaxt = "n"
+ )
+ axis(1, seq(0, 1, 0.2), cex.axis = 2.5)
+ abline(h = seq(0, 3, by = 0.5), col = "grey60")
+ text(x= frame_x_pos, y= frame_y_pos, labels= paste0("Frame ", i + 1),
+ col = frame_col, cex = frame_cex)
+ text(x=label_x_pos, y=df[,".y"], labels= label,
+ col = label_col, cex = label_cex)
+ points(df, col = col, pch = 20, cex = cex)
+
+ # lower panel: define panel margin (mar)
+ par(mgp=c(2, 1, 0), mar = c(2.5, 4, 1, 1))
+ plot(
+ x = NA, y = NA, xlim = c(0, 1.3), ylim = c(-1, 0),
+ xlab = "", ylab = "Weights", cex.lab = 2,
+ xaxt = "n", yaxt = "n"
+ )
+ lines(c(0, 0), c(-1.1, 0), col = "grey60")
+ lines(c(1, 1), c(-1.1, 0), col = "grey60")
+ axis(1, seq(0, 1, by = 0.2), cex.axis = 2.5)
+ box(col = "grey60", cex = 2)
+
+ # Render tour axes
+ ax <- seq_along(proj) / length(proj) - 0.1
+ idx_w <- proj/sum(proj)
+ segments(0, -ax, idx_w, -ax, col = axis_bar_col, lwd = axis_bar_lwd)
+ text(1.0, -ax, labels, pos = 4, cex = axis_var_cex, col = axis_var_col)
+ text(idx_w + 0.01, -ax, format(round(idx_w, 2), nsmall = 2), pos = 4, cex = axis_bar_label_cex,
+ col = axis_bar_label_col)
+ }
+
+ list(
+ init = init,
+ render_frame = render_frame,
+ render_transition = render_transition,
+ render_data = render_data,
+ render_target = nul
+ )
+}
+
+#' @rdname display_idx
+#' @inheritParams animate
+#' @export
+animate_idx <- function(data, tour_path = grand_tour(1), ...) {
+ animate(
+ data = data, tour_path = tour_path,
+ display = display_idx(...), ...
+ )
+}
+
+

R/render.r

@@ -58,7 +58,8 @@ render <- function(data, tour_path, display, dev, ..., apf = 1 / 10, frames = 50
  stop_next <- FALSE
  while (i < frames) {
  display$render_frame()
- display$render_data(data, step$proj, step$target)
+ display$render_data(data, step$proj, step$target, i = i)
+
 
  if (stop_next) {
  return(invisible())

R/tour-planned.r

@@ -15,6 +15,7 @@
 #' @keywords hplot dynamic
 #' @seealso The \code{\link{little_tour}}, a special type of planned tour
 #' which cycles between all axis parallel projections.
+#' @rdname planned-tour
 #' @export
 #' @examples
 #' twod <- save_history(flea[, 1:3], max = 5)
@@ -55,3 +56,22 @@ planned_tour <- function(basis_set, cycle = FALSE) {
 
  new_geodesic_path("planned", generator)
 }
+
+#' @rdname planned-tour
+#' @export
+planned2_tour <- function(basis_set) {
+ index <- 1
+ generator <- function(current, data, ...) {
+ if (is.null(current)) {return(as.matrix(basis_set[,,1]))}
+
+ index <<- index + 1
+ if (index > dim(basis_set)[3]) {
+ return(NULL)
+ }
+ target <- as.matrix(basis_set[,,index])
+ list(target = target)
+
+ }
+
+ new_geodesic_path("planned2", generator)
+}