From 0425c6590379dfe9797c28c7b713b0cf4a07dfac Mon Sep 17 00:00:00 2001 From: huizezhang-sherry Date: Tue, 18 Jul 2023 22:16:55 +1000 Subject: [PATCH 1/4] a new display/animate_idx for visualise index weights --- NAMESPACE | 2 + R/display-idx.R | 106 +++++++++++++++++++++++++++++++++++++++++++++ man/display_idx.Rd | 57 ++++++++++++++++++++++++ 3 files changed, 165 insertions(+) create mode 100644 R/display-idx.R create mode 100644 man/display_idx.Rd diff --git a/NAMESPACE b/NAMESPACE index 7000ccc7..df8ffcee 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/display-idx.R b/R/display-idx.R new file mode 100644 index 00000000..d69ca9f4 --- /dev/null +++ b/R/display-idx.R @@ -0,0 +1,106 @@ +#' 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 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 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 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, label_x_pos = 0.7, + label = NULL, label_cex = 1, label_col = "grey80", + 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) + layout(mat = layout_m, heights = c(6,1)) + 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) { + + x <- data %*% proj + if (center) x <- center(x) + x <- x / half_range + df <- x %>% cbind(.y = 3/nrow(x) * (1:nrow(x))) + # upper panel: define the axis margin (mgp) and panel margin (mar) + par(mgp=c(1, 0.3, 0), mar = c(0.5, 4, 0.5, 1)) + # initialise the plot box + plot( + x = NA, y = NA, xlim = c(0, 1.2), ylim = c(-0.05, 3.05), + xlab="", ylab = "", xaxs = "i", yaxs = "i", + xaxt = "n", yaxt = "n" + ) + axis(1, seq(0, 1, 0.2), cex.axis = 0.8) + abline(h = seq(0, 3, by = 0.5), col = "grey80") + 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(mar = c(2, 4, 1, 1)) + plot( + x = NA, y = NA, xlim = c(0, 1.2), ylim = c(-1.1, 0), + xlab = "", ylab = "Index \n weight", cex.lab = 0.7, + xaxt = "n", yaxt = "n" + ) + lines(c(0, 0), c(-1.1, 0), col = "grey80") + lines(c(1, 1), c(-1.1, 0), col = "grey80") + axis(1, seq(0, 1, by = 0.2), cex.axis = 0.8) + box(col = "grey70") + + # Render tour axes + ax <- seq_along(proj) / length(proj) + idx_w <- proj/sum(proj) + segments(0, -ax, idx_w, -ax, col = "black", lwd = 3) + text(1.0, -ax, labels, pos = 4, cex = 0.5) + text(idx_w + 0.01, -ax, round(idx_w,2), pos = 4, cex = 0.5) + } + + 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(...), ... + ) +} diff --git a/man/display_idx.Rd b/man/display_idx.Rd new file mode 100644 index 00000000..c3d903c4 --- /dev/null +++ b/man/display_idx.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/display-idx.R +\name{display_idx} +\alias{display_idx} +\alias{animate_idx} +\title{Display 1D linear aggregation index} +\usage{ +display_idx( + center = FALSE, + half_range = NULL, + abb_vars = TRUE, + col = "red", + cex = 0.5, + label_x_pos = 0.7, + label = NULL, + label_cex = 1, + label_col = "grey80", + palette = "Zissou 1", + ... +) + +animate_idx(data, tour_path = grand_tour(1), ...) +} +\arguments{ +\item{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.} + +\item{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.} + +\item{col}{the color used for points, can be a vector or hexcolors or a +factor, default to "red".} + +\item{cex}{the size used for points, default to 0.5} + +\item{label_x_pos}{the x position of text label, currently labels are +positioned at a fixed x value for each observation} + +\item{label}{the text label, a vector} + +\item{label_cex}{the size for text labels} + +\item{label_col}{the color for text labels} + +\item{palette}{name of color palette for point colour, used by +\code{\link{hcl.colors}}, default "Zissou 1"} + +\item{...}{ignored} + +\item{data}{matrix, or data frame containing numeric columns} + +\item{tour_path}{tour path generator, defaults to 2d grand tour} +} +\description{ +Display 1D linear aggregation index +} From bf3bf4edaf647ba18f64204181b8832890b3683e Mon Sep 17 00:00:00 2001 From: huizezhang-sherry Date: Thu, 20 Jul 2023 14:13:58 +1000 Subject: [PATCH 2/4] a planned2_tour with manually inputted bases --- NAMESPACE | 1 + R/tour-planned.r | 20 ++++++++++++++++++++ man/display_idx.Rd | 2 ++ man/{planned_tour.Rd => planned-tour.Rd} | 3 +++ 4 files changed, 26 insertions(+) rename man/{planned_tour.Rd => planned-tour.Rd} (96%) diff --git a/NAMESPACE b/NAMESPACE index df8ffcee..ad983aa3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -90,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) diff --git a/R/tour-planned.r b/R/tour-planned.r index 9524ef5a..6a9ad044 100644 --- a/R/tour-planned.r +++ b/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) +} diff --git a/man/display_idx.Rd b/man/display_idx.Rd index c3d903c4..cccc38a7 100644 --- a/man/display_idx.Rd +++ b/man/display_idx.Rd @@ -29,6 +29,8 @@ easier to focus on the shape of the distribution.} \item{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.} +\item{abb_vars}{logical, whether to abbreviate the variable name, if long} + \item{col}{the color used for points, can be a vector or hexcolors or a factor, default to "red".} diff --git a/man/planned_tour.Rd b/man/planned-tour.Rd similarity index 96% rename from man/planned_tour.Rd rename to man/planned-tour.Rd index 2b09caa3..5d5206e7 100644 --- a/man/planned_tour.Rd +++ b/man/planned-tour.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/tour-planned.r \name{planned_tour} \alias{planned_tour} +\alias{planned2_tour} \title{A planned tour path.} \usage{ planned_tour(basis_set, cycle = FALSE) + +planned2_tour(basis_set) } \arguments{ \item{basis_set}{the set of bases as a list of projection matrices From 5086bba834305bec225a031bdfb57151bddfb5ed Mon Sep 17 00:00:00 2001 From: huizezhang-sherry Date: Thu, 20 Jul 2023 14:14:17 +1000 Subject: [PATCH 3/4] doc --- R/display-idx.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/display-idx.R b/R/display-idx.R index d69ca9f4..072c2d34 100644 --- a/R/display-idx.R +++ b/R/display-idx.R @@ -5,6 +5,7 @@ #' 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 @@ -40,7 +41,7 @@ display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE, 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) - layout(mat = layout_m, heights = c(6,1)) + graphics::layout(mat = layout_m, heights = c(6,1)) par(pty = "m", mar = c(1, 4, 1, 1)) } @@ -52,7 +53,7 @@ display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE, x <- data %*% proj if (center) x <- center(x) x <- x / half_range - df <- x %>% cbind(.y = 3/nrow(x) * (1:nrow(x))) + df <- cbind(x, .y = 3/nrow(x) * (1:nrow(x))) # upper panel: define the axis margin (mgp) and panel margin (mar) par(mgp=c(1, 0.3, 0), mar = c(0.5, 4, 0.5, 1)) # initialise the plot box @@ -70,7 +71,7 @@ display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE, par(mar = c(2, 4, 1, 1)) plot( x = NA, y = NA, xlim = c(0, 1.2), ylim = c(-1.1, 0), - xlab = "", ylab = "Index \n weight", cex.lab = 0.7, + xlab = "", ylab = "Weights", cex.lab = 2, xaxt = "n", yaxt = "n" ) lines(c(0, 0), c(-1.1, 0), col = "grey80") @@ -82,8 +83,8 @@ display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE, ax <- seq_along(proj) / length(proj) idx_w <- proj/sum(proj) segments(0, -ax, idx_w, -ax, col = "black", lwd = 3) - text(1.0, -ax, labels, pos = 4, cex = 0.5) - text(idx_w + 0.01, -ax, round(idx_w,2), pos = 4, cex = 0.5) + text(1.0, -ax, labels, pos = 4, cex = 2) + text(idx_w + 0.01, -ax, round(idx_w,2), pos = 4, cex = 2) } list( From 3ceda9fd38bb5b32c7c6939d04a647a2dc1095cf Mon Sep 17 00:00:00 2001 From: huizezhang-sherry Date: Mon, 21 Aug 2023 00:15:18 +1000 Subject: [PATCH 4/4] small changes on the aesthetics --- R/display-idx.R | 61 +++++++++++++++++++++++++++++++++---------------- R/render.r | 3 ++- 2 files changed, 43 insertions(+), 21 deletions(-) diff --git a/R/display-idx.R b/R/display-idx.R index 072c2d34..ba548824 100644 --- a/R/display-idx.R +++ b/R/display-idx.R @@ -9,18 +9,33 @@ #' @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, label_x_pos = 0.7, - label = NULL, label_cex = 1, label_col = "grey80", + 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) { @@ -41,50 +56,54 @@ display_idx <- function(center = FALSE, half_range = NULL, abb_vars = TRUE, 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 = c(6,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) { + 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(1, 0.3, 0), mar = c(0.5, 4, 0.5, 1)) + 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.05, 3.05), - xlab="", ylab = "", xaxs = "i", yaxs = "i", + 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 = 0.8) - abline(h = seq(0, 3, by = 0.5), col = "grey80") - text(x=label_x_pos, y=df[,".y"], labels= label, col = label_col, cex = label_cex) + 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(mar = c(2, 4, 1, 1)) + par(mgp=c(2, 1, 0), mar = c(2.5, 4, 1, 1)) plot( - x = NA, y = NA, xlim = c(0, 1.2), ylim = c(-1.1, 0), + 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 = "grey80") - lines(c(1, 1), c(-1.1, 0), col = "grey80") - axis(1, seq(0, 1, by = 0.2), cex.axis = 0.8) - box(col = "grey70") + 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) + ax <- seq_along(proj) / length(proj) - 0.1 idx_w <- proj/sum(proj) - segments(0, -ax, idx_w, -ax, col = "black", lwd = 3) - text(1.0, -ax, labels, pos = 4, cex = 2) - text(idx_w + 0.01, -ax, round(idx_w,2), pos = 4, cex = 2) + 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( @@ -105,3 +124,5 @@ animate_idx <- function(data, tour_path = grand_tour(1), ...) { display = display_idx(...), ... ) } + + diff --git a/R/render.r b/R/render.r index e2113f6b..17c70e3c 100644 --- a/R/render.r +++ b/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())