merge

Merge branch 'master' of https://github.com/huizezhang-sherry/tourr # Conflicts: # man/guided_anomaly_tour.Rd
ggobi · Sep 4, 2024 · abf0938 · abf0938
2 parents 17fd891 + 6fa03da
commit abf0938
Show file tree

Hide file tree

Showing 24 changed files with 128 additions and 24 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: tourr
 Title: Tour Methods for Multivariate Data Visualisation
-Version: 1.2.0
+Version: 1.2.3
 Authors@R: c(
  person("Hadley", "Wickham", email = "h.wickham@gmail.com", role = c("aut", "ctb"), comment = c(ORCID = "0000-0003-4757-117X")),
  person("Dianne", "Cook", email = "dicook@monash.edu", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-3813-7155")),
@@ -39,7 +39,7 @@ Suggests:
  minerva
 License: MIT + file LICENSE
 LazyData: true
-URL: https://github.com/ggobi/tourr
+URL: https://github.com/ggobi/tourr, https://ggobi.github.io/tourr/
 BugReports: https://github.com/ggobi/tourr/issues
 RoxygenNote: 7.3.2
 Encoding: UTF-8

diff --git a/NAMESPACE b/NAMESPACE
@@ -113,6 +113,7 @@ export(search_geodesic)
 export(search_jellyfish)
 export(search_polish)
 export(search_posse)
+export(skewness)
 export(slice_index)
 export(sphere_data)
 export(splines2d)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,19 @@
+# tourr 1.2.3
+
+* New optimisation routine, using the jellyfish optimiser.
+* New PP indexes from cassowaryr package, stringy, MIC and TIC.
+* Attempted fix for positron, but still not working.
+
+# tourr 1.2.2
+
+* New skewness index, as defined in original Cook, Buja, Cabrera paper.
+
+# tourr 1.2.1
+
+* anomaly tour is initialised with a random basis
+* option to label only long axes
+* bug fix for save_history with lda_pp
+
 # tourr 1.2.0 
 
 * major change: rescale is now FALSE by default.

diff --git a/R/animate.r b/R/animate.r
@@ -62,7 +62,7 @@ animate <- function(data, tour_path = grand_tour(), display = display_xy(),
  to_stop()
  }
  plat <- find_platform()
- if (rstudio_gd() && fps > 19) {
+ if ((rstudio_gd() && fps > 19) || (positron_gd() && fps > 19)) {
  warning("Rstudio graphics device supports maximum fps of 19", call. = FALSE)
  fps <- 19
  }
@@ -102,7 +102,7 @@ animate <- function(data, tour_path = grand_tour(), display = display_xy(),
  if (!is.null(start$target)){
  dev.hold()
  on.exit(dev.flush())
- if (plat$os == "win" || plat$iface == "rstudio") {
+ if (plat$os == "win" || plat$iface == "rstudio" || plat$iface == "cli") {
  display$render_frame()
  } else {
  display$render_transition()
@@ -131,5 +131,6 @@ animate <- function(data, tour_path = grand_tour(), display = display_xy(),
 }
 
 rstudio_gd <- function() identical(names(dev.cur()), "RStudioGD")
+positron_gd <- function() identical(names(dev.cur()), "Positron Graphics Device")
 
 # globalVariables("record")
diff --git a/R/display-density2d.r b/R/display-density2d.r
@@ -14,6 +14,7 @@
 #' @param cex size of the point to be plotted. Defaults to 1.
 #' @param contour_quartile Vector of quartiles to plot the contours at. Defaults to 5.
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_density2d}}
 #' @importFrom graphics contour
@@ -53,7 +54,8 @@
 display_density2d <- function(center = TRUE, axes = "center", half_range = NULL,
  col = "black", pch = 20, cex = 1,
  contour_quartile = c(.25, .5, .75), edges = NULL,
- palette = "Zissou 1", ...) {
+ palette = "Zissou 1",
+ axislablong = FALSE, ...) {
  # If colors are a variable, convert to colors
  if (is.factor(col) | !areColors(col)) {
  gps <- col
@@ -80,7 +82,7 @@ display_density2d <- function(center = TRUE, axes = "center", half_range = NULL,
  rect(-1, -1, 1, 1, col = "#FFFFFFE6", border = NA)
  }
  render_data <- function(data, proj, geodesic) {
- draw_tour_axes(proj, labels, limits = 1, axes)
+ draw_tour_axes(proj, labels, limits = 1, axes, longlabels=axislablong)
 
  # Render projected points
  x <- data %*% proj

diff --git a/R/display-groupxy.r b/R/display-groupxy.r
@@ -22,6 +22,7 @@
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
 #' @param shapeset numbers corresponding to shapes in base R points, to use for mapping
 #' categorical variable to shapes, default=c(15:17, 23:25)
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_groupxy}}
 #' @export
@@ -41,7 +42,8 @@ display_groupxy <- function(centr = TRUE, axes = "center", half_range = NULL,
  col = "black", pch = 20, cex = 1,
  edges = NULL, edges.col = "black", edges.width=1,
  group_by = NULL, plot_xgp = TRUE,
- palette = "Zissou 1", shapeset=c(15:17, 23:25), ...) {
+ palette = "Zissou 1", shapeset=c(15:17, 23:25),
+ axislablong = FALSE, ...) {
  labels <- NULL
 
  # If colors are a variable, convert to colors
@@ -95,7 +97,7 @@ display_groupxy <- function(centr = TRUE, axes = "center", half_range = NULL,
  x <- x / half_range
 
  blank_plot(xlim = c(-1, 1), ylim = c(-1, 1))
- draw_tour_axes(proj, labels, limits = 1, axes)
+ draw_tour_axes(proj, labels, limits = 1, axes, longlabels=axislablong)
  # add a legend, only if a variable was used
  if (is.factor(gps)) {
  numcol <- unique(col)

diff --git a/R/display-pca.r b/R/display-pca.r
@@ -18,6 +18,7 @@
 #' @param edges.col colour of edges to be plotted, Defaults to "black.
 #' @param rescale Default FALSE. If TRUE, rescale all variables to range [0,1].
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_slice}}
 #' @export
@@ -31,7 +32,8 @@ display_pca <- function(center = TRUE, axes = "center", half_range = NULL,
  col = "black", pch = 20, cex = 1,
  pc_coefs = NULL,
  edges = NULL, edges.col = "black",
- palette = "Zissou 1", ...) {
+ palette = "Zissou 1",
+ axislablong = FALSE, ...) {
  labels <- NULL
 
  # If colors are a variable, convert to colors
@@ -63,7 +65,7 @@ display_pca <- function(center = TRUE, axes = "center", half_range = NULL,
  render_data <- function(data, proj, geodesic) {
  # Render axes
  pc_axes <- pc_coefs %*% proj
- draw_tour_axes(pc_axes, labels, limits = 1, axes)
+ draw_tour_axes(pc_axes, labels, limits = 1, axes, longlabels=axislablong)
 
  # Render projected points
  x <- data %*% proj

diff --git a/R/display-sage.R b/R/display-sage.R
@@ -13,6 +13,7 @@
 #' @param R scale for the radial transformation.
 #' If not set, defaults to maximum distance from origin to each row of data.
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_sage}}
 #' @export
@@ -27,7 +28,8 @@
 #' animate_sage(sphere10)
 display_sage <- function(axes = "center", half_range = NULL,
  col = "black", pch = 20, gam = 1, R = NULL,
- palette = "Zissou 1", ...) {
+ palette = "Zissou 1",
+ axislablong = FALSE, ...) {
  labels <- NULL
  peff <- NULL
 
@@ -54,7 +56,7 @@ display_sage <- function(axes = "center", half_range = NULL,
  }
 
  render_data <- function(data, proj, geodesic) {
- draw_tour_axes(proj, labels, 1, axes)
+ draw_tour_axes(proj, labels, 1, axes, longlabels=axislablong)
 
  # Projecte data and center
  x <- data %*% proj

diff --git a/R/display-slice.r b/R/display-slice.r
@@ -24,6 +24,7 @@
 #' @param anchor_nav position of the anchor: center, topright or off
 #' @param rescale Default FALSE. If TRUE, rescale all variables to range [0,1].
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_slice}}
 #' @export
@@ -51,7 +52,8 @@ display_slice <- function(center = TRUE, axes = "center", half_range = NULL,
  cex_slice = 2, cex_other = 1, v_rel = NULL,
  anchor = NULL, anchor_nav = "off",
  edges = NULL, edges.col = "black",
- palette = "Zissou 1", ...) {
+ palette = "Zissou 1",
+ axislablong = FALSE, ...) {
  labels <- NULL
  h <- NULL
 
@@ -89,7 +91,7 @@ display_slice <- function(center = TRUE, axes = "center", half_range = NULL,
  }
 
  render_data <- function(data, proj, geodesic, with_anchor = anchor) {
- draw_tour_axes(proj, labels, limits = 1, axes)
+ draw_tour_axes(proj, labels, limits = 1, axes, longlabels=axislablong)
  if (!is.null(with_anchor)) {
  rng <- apply(data, 2, range)
  colnames(with_anchor) <- colnames(data)

diff --git a/R/display-trails.r b/R/display-trails.r
@@ -14,13 +14,14 @@
 #' @param past draw line between current projection and projection \code{past}
 #' steps ago
 #' @param cex magnification of plotting text relative to default. Defaults to 1.
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_xy}}
 #' @export
 #' @examples
 #' animate_trails(flea[,1:6], col=flea$species)
 #'
-display_trails <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, past = 3, ...) {
+display_trails <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, past = 3, axislablong = FALSE, ...) {
 
  # Inherit most behaviour from display_xy. This is a little hacky, but
  # the only way until tourr switch to a proper object system.
@@ -35,7 +36,7 @@ display_trails <- function(center = TRUE, axes = "center", half_range = NULL, co
 
  # Only difference is the display method
  render_data <- function(data, proj, geodesic) {
- draw_tour_axes(proj, labels, 1, axes)
+ draw_tour_axes(proj, labels, 1, axes, longlabels=axislablong)
 
  x <- data %*% proj
  if (center) x <- center(x)

diff --git a/R/display-xy.r b/R/display-xy.r
@@ -21,9 +21,11 @@
 #' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3.
 #' @param ellmu This is the centre of the ellipse corresponding to the mean of the
 #' normal population. Default vector of 0's
+#' @param ellmarks mark the extreme points with red crosses, default TRUE
 #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"
 #' @param shapeset numbers corresponding to shapes in base R points, to use for mapping
 #' categorical variable to shapes, default=c(15:17, 23:25)
+#' @param axislablong text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed on to \code{\link{animate}} and
 #' \code{\link{display_xy}}
 #' @importFrom graphics legend
@@ -72,7 +74,9 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL,
  edges = NULL, edges.col = "black", edges.width=1,
  obs_labels = NULL,
  ellipse = NULL, ellc = NULL, ellmu = NULL,
- palette="Zissou 1", shapeset=c(15:17, 23:25), ...) {
+ ellmarks = TRUE,
+ palette="Zissou 1", shapeset=c(15:17, 23:25),
+ axislablong = FALSE, ...) {
  # Needed for CRAN checks
  labels <- NULL
  gps <- NULL
@@ -128,7 +132,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL,
  rect(-1, -1, 1, 1, col = "#FFFFFFE6", border = NA)
  }
  render_data <- function(data, proj, geodesic) {
- draw_tour_axes(proj, labels, limits = 1, axes, ...)
+ draw_tour_axes(proj, labels, limits = 1, axes, longlabels=axislablong, ...)
 
  # Render projected points
  x <- data %*% proj
@@ -227,7 +231,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL,
  #mdst <- mahal_dist(data, ellipse)
  anomalies <- which(mdst > ellc)
  #cat("1 ", length(anomalies), "\n")
- if (length(anomalies) > 0) {
+ if (length(anomalies) > 0 & ellmarks) {
  points(x[anomalies,],
  col = "red",
  pch = 4,
@@ -267,6 +271,7 @@ animate_xy <- function(data, tour_path = grand_tour(), ...) {
 #' @param axis.col colour of axes, default "grey50"
 #' @param axis.lwd linewidth of axes, default 1
 #' @param axis.text.col colour of axes text, default "grey50"
+#' @param longlabels text labels only for the long axes in a projection, default FALSE
 #' @param ... other arguments passed
 #' @export
 #' @examples
@@ -284,8 +289,10 @@ animate_xy <- function(data, tour_path = grand_tour(), ...) {
 #' xlim = c(-3, 3), ylim = c(-3, 3),
 #' xlab="P1", ylab="P2")
 #' draw_tour_axes(prj, colnames(flea)[1:6], limits=3, position="bottomleft")
+#' draw_tour_axes(prj, colnames(flea)[1:6], axislablong=TRUE)
 draw_tour_axes <- function(proj, labels, limits=1, position="center",
- axis.col= "grey50", axis.lwd=1, axis.text.col= "grey50", ...) {
+ axis.col="grey50", axis.lwd=1, axis.text.col="grey50",
+ longlabels, ...) {
  position <- match.arg(position, c("center", "bottomleft", "off"))
  if (position == "off") {
  return()
@@ -311,6 +318,12 @@ draw_tour_axes <- function(proj, labels, limits=1, position="center",
  theta <- seq(0, 2 * pi, length = 50)
  lines(adj(cos(theta)), adj(sin(theta)),
  col = axis.col, lwd = axis.lwd)
+ if (longlabels) {
+ for (i in 1:length(labels)) {
+ if ((proj[i, 1]^2 + proj[i, 2]^2) < 0.15)
+ labels[i] <- ""
+ }
+ }
  text(adj(proj[, 1]), adj(proj[, 2]), label = labels,
  col = axis.text.col)
 }
diff --git a/R/interesting-indices.r b/R/interesting-indices.r
@@ -188,6 +188,25 @@ cmass <- function() {
  }
 }
 
+#' Skewness index.
+#'
+#' Calculates the skewness index. See Cook, Buja and Cabrera (1993)
+#' Projection pursuit indexes based on orthonormal function expansions
+#' for equations.
+#'
+#' @keywords hplot
+#' @export
+skewness <- function() {
+ function(mat) {
+ n <- nrow(mat)
+ d <- ncol(mat)
+
+ idx <- mean(rowSums(mat * exp(-0.5 * mat^2)))
+
+ idx
+ }
+}
+
 #' LDA projection pursuit index.
 #'
 #' Calculate the LDA projection pursuit index. See Cook and Swayne (2007)
@@ -210,7 +229,7 @@ lda_pp <- function(cl) {
 
  1 - summary(fit, test = "Wilks")$stats[[3]]
  } else {
- summary(stats::aov(mat ~ cl))[[1]][4]
+ summary(stats::aov(mat ~ cl))[[1]][1,4]
  }
  }
 }

diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r
@@ -4,7 +4,7 @@
 #' using an ellipse to determine anomalies on which to select target planes.
 #'
 #' Usually, you will not call this function directly, but will pass it to
-#' a method that works with tour paths like \code{\link{animate_slice}},
+#' a method that works with tour paths like \code{\link{animate_xy}},
 #' \code{\link{save_history}} or \code{\link{render}}.
 #'
 #' @param index_f the section pursuit index function to optimise. The function
@@ -40,7 +40,7 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99,
 
  generator <- function(current, data, tries, ...) {
  if (is.null(current)) {
- return(basis_init(ncol(data), d))
+ return(basis_random(ncol(data), d))
  }
 
  if (is.null(h)) {

diff --git a/man/display_density2d.Rd b/man/display_density2d.Rd
diff --git a/man/display_groupxy.Rd b/man/display_groupxy.Rd