From e31f32b502b6f4637dbfda2af4f7c3497ca42233 Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 7 Mar 2024 13:03:01 +1100 Subject: [PATCH 01/17] ellipse drawing and standardised flea data --- DESCRIPTION | 4 ++-- NEWS.md | 9 ++++++++- R/data.r | 7 ++++--- R/display-faces.r | 12 ++++++------ R/display-xy.r | 37 +++++++++++++++++++++++++++++++++++-- R/tour-radial.r | 8 ++++---- data/flea.rda | Bin 831 -> 2009 bytes data/flea_raw.rda | Bin 0 -> 842 bytes man/Flea-measurements.Rd | 8 +++++++- man/display_faces.Rd | 5 ++--- man/display_xy.Rd | 6 ++++++ man/radial_tour.Rd | 8 ++++---- 12 files changed, 78 insertions(+), 26 deletions(-) create mode 100644 data/flea_raw.rda diff --git a/DESCRIPTION b/DESCRIPTION index 598e39c8..ded28be4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tourr Title: Tour Methods for Multivariate Data Visualisation -Version: 1.1.0 +Version: 1.2.0 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")), @@ -21,7 +21,7 @@ Imports: utils, grDevices Suggests: - TeachingDemos, + aplpack, ash, energy, testthat, diff --git a/NEWS.md b/NEWS.md index 1cf3f2e0..bba978e4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,11 @@ -# tourr 1.1.0 +# tourr 1.2.0 + +* major change: rescale is now FALSE by default +* flea is now standardised measurements, and flea_raw is the original units +* TeachingDemos removed as a Suggests, and replaced with aplpack for drawing Chernoff faces +* addition of a pre-specified ellipse can be added to the 2D display + +# tourr 1.1.0 * Updated version to indicate some nice new additions for the package diff --git a/R/data.r b/R/data.r index bd9aa930..f1f1f50e 100644 --- a/R/data.r +++ b/R/data.r @@ -1,7 +1,8 @@ #' Flea beatle measurements #' #' This data is from a paper by A. A. Lubischew, "On the Use of Discriminant -#' Functions in Taxonomy", Biometrics, Dec 1962, pp.455-477. +#' Functions in Taxonomy", Biometrics, Dec 1962, pp.455-477. Data is +#' standardized, and original units are in flea_raw. #' #' \itemize{ #' \item tars1, width of the first joint of the first tarsus in microns @@ -16,7 +17,7 @@ #' } #' #' @name Flea measurements -#' @aliases flea +#' @aliases flea, flea_raw #' @docType data #' @format A 74 x 7 numeric array #' @keywords datasets @@ -25,7 +26,7 @@ #' head(flea) #' animate_xy(flea[, -7]) #' animate_xy(flea[, -7], col = flea[, 7]) -NULL +"flea" #' Turnable laser measurements from Bellcore #' diff --git a/R/display-faces.r b/R/display-faces.r index 5c72e62b..1a18e505 100644 --- a/R/display-faces.r +++ b/R/display-faces.r @@ -14,19 +14,19 @@ #' # The drawing code is fairly slow, so this animation works best with a #' # limited number of cases #' flea_s <- rescale(flea[,1:6]) -#' animate_faces(flea_s[1:2, 1:6]) -#' animate_faces(flea_s[1:4, 1:6]) +#' animate_faces(flea_s[19:24, 1:6]) #' -#' animate_faces(flea_s[1:2, 1:6], grand_tour(5)) +#' animate_faces(flea_s[19:24, 1:6], grand_tour(5)) display_faces <- function(...) { - if (!requireNamespace("TeachingDemos", quietly = TRUE)) { - stop("Please install the TeachingDemos package", call. = FALSE) + if (!requireNamespace("aplpack", quietly = TRUE)) { + stop("Please install the aplpack package", call. = FALSE) } render_data <- function(data, proj, geodesic) { x <- data %*% proj x <- (x + 2) / 4 - TeachingDemos::faces2(x, scale = "none") + aplpack::faces(x, scale = TRUE, face.type = 0, + cex = 0.1, print.info = FALSE) } list( diff --git a/R/display-xy.r b/R/display-xy.r index b3038db6..be632c70 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -13,8 +13,10 @@ #' @param pch shape of the point to be plotted, can be a factor or integer. Defaults to 20. #' @param cex size of the point to be plotted. Defaults to 1. #' @param edges.col colour of edges to be plotted, Defaults to "black" -#' @param obs_labels vector of text labels to display #' @param edges.width line width for edges, default 1 +#' @param obs_labels vector of text labels to display +#' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. Useful for +#' comparing data with some null hypothesis #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1" #' @param ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_xy}} @@ -56,10 +58,14 @@ #' flea[, 1:6], grand_tour(), #' display_xy(axes = "bottomleft", edges = edges) #' ) +#' # An ellipse can be drawn on the data using a specified var-cov +#' animate_xy(flea[, 1:6], axes = "off", ellipse=cov(flea[,1:6])) display_xy <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, edges = NULL, edges.col = "black", edges.width=1, - obs_labels = NULL, palette="Zissou 1", ...) { + obs_labels = NULL, + ellipse = NULL, + palette="Zissou 1", ...) { # Needed for CRAN checks labels <- NULL gps <- NULL @@ -140,7 +146,34 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, # Add index value if using guided tour #if (!is.na(cur_index)) # text(0, 0, labels=round(cur_index, 2)) + # Draw a pre-determined ellipse on the data + if (!is.null(ellipse)) { + if (nrow(ellipse) == nrow(proj)) { + + # Project ellipse into 2D + evc <- eigen(ellipse) + ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) + e2 <- t(proj) %*% ellinv %*% proj + evc2 <- eigen(e2) + ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) + + # Compute the points on an ellipse + sph <- geozoo::sphere.hollow(2, 200)$points + sph <- sph[order(sph[,2]),] + sph1 <- sph[sph[,2]>=0,] + sph2 <- sph[sph[,2]<0,] + sph1 <- sph1[order(sph1[,1]),] + sph2 <- sph2[order(sph2[,1], decreasing=T),] + sph <- rbind(sph1, sph2) + sph <- rbind(sph, sph[1,]) + sph2d <- sph%*%ell2d/half_range + lines(sph2d) + + } + else + message("Check the variance-covariance matrix generating the ellipse\n") + } } list( diff --git a/R/tour-radial.r b/R/tour-radial.r index 6f8af67f..685d892d 100644 --- a/R/tour-radial.r +++ b/R/tour-radial.r @@ -12,10 +12,10 @@ #' @param ... additional arguments for drawing #' @export #' @examples -#' animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = 4)) -#' animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = c(3,4))) -#' animate_dist(flea[, 1:6], radial_tour(basis_random(6, 1), mvar = 4)) -#' animate_scatmat(flea[, 1:6], radial_tour(basis_random(6, 3), mvar = 4)) +#' animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = 4), rescale=TRUE) +#' animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = c(3,4)), rescale=TRUE) +#' animate_dist(flea[, 1:6], radial_tour(basis_random(6, 1), mvar = 4), rescale=TRUE) +#' animate_scatmat(flea[, 1:6], radial_tour(basis_random(6, 3), mvar = 4), rescale=TRUE) radial_tour <- function(start, mvar = 1, ...) { first <- TRUE out <- TRUE diff --git a/data/flea.rda b/data/flea.rda index 393487df1411b7478a1953662d76457186bd53ee..6684e43000733e27eb240157bbfa2302485c10eb 100644 GIT binary patch literal 2009 zcmV;~2PXI*iwFP!000001I1W?BcT(y>vzZbsU8XT~$S56)J^C+at+dt2~KkdrjD-xp66%~q-D>yij{fXA*}IB4k>fCqNO-AdBDf=44yHz)2i z!{a5Z3kA(7M0e~@?v-hRy;$69WWT)ylRCN|_(o%%%XbZrIl~@o6fVB27iV|`<|pUk ztnW5ZF_+L}r-hn^bOMc*xbnL5^-$k6(Z=)|N5YdB4mRdl=Aj`)_GfbqC8$Hy+5By* zW2kFKtA>7sknod^ow(7&!U~OvRz^)+Pe+rPQ%_v)vQU$#B1P}d4{&eXwvMl?c0nY(F4pZbj)4o* z1FKjC>GadWEZw_n()}q6N5Sh%ZZLu=hmf$YAM+-%_IB3e#tJ2G?P%cz&GVxp{%PuZyT&TiWpq)&F_r@uw+GpE-#aJ4<8jN{@6DzlvH8ih zCJoc5&M5q#=(rc*!#Sg#@aR4S(-HK^IYZxu3b<;}9(l!vZKYglpx_`^Klk1vw&OeX zWDd}SbA}K6{L}sC2D>Vm{z;_!LtmyJGAHR40}Fp0;|n8%Lojw!QDi(dlSlr+)d2SsCH=T7IAH(CUi1^c=r9lhj3Y zC%Ae=P+#3RD37gnz!Jg9$h zM9T8+JWG7g5jXS4ufC`*MZ(@+BiwQ|Ni6fX{x10Na{MnzqgIDtBdMeN5}yq}ur>_M zT9SES4wwthp_fvhHhGTfl_IBt=*8@-oe(|hkzE4u(K0IFQ zr{Ej69QUuu^Kjg(j_Wzv+!UP-JhJ=v*SAH3crrAtP(1e$;ejsXK_B=K>A6W?z@P(o zw0OF`@co-|x)2|FAGWdj=Ta=*vns>(S{?3LYHJ~Q{*7Ecjeq~WdPhaAE5roFHvK%b zW~U+g)uHIpy^=;GN!0ExioZ|tz=LyUWa=!07pemce1@NL#cb!~f^HK$oO`p!R5(nc z#3j(R)qI5&xu4_b1s$WqK?b;QL*Uc zCEU0XMekM8NlzLHowT(@c5&3@|;^eLx;S7n`d(k*8Tq%&Sfh4=x! zH2V}k=A1LZt*Pl{Z>g4nU)guzlKJ=Q_4nd`|5ExNU5fv|>kr@7>_A==FECtor~ccg z`0MQA%^|^D|KMQGYDjG3`3LaABGy4dbsH}sbARf?FAQ{043paTan8N=8{CFI1INH+`4OGHId0hYb9`lWr<`~vg ry*Uw_bv|J-8w_iU!$P9hfxY>cOfjB%{pa-C9F+9mD{IAW#Sj1hj+q)> literal 831 zcmV-F1Hk+riwFP!000001I3n2Pg7A4h7YZZtzet@2izN5+9DE{$^tREz>lCYA=h#n z3Z*S=1K0xcp#l{F@hh5WOk5gGWMR}AHPJ+k8>1U_)V8IKq477zZ_858u$Adzw%W4ycI*MmmT0p5TY;3Iep9)Sno z6?h4rfQR5U{ZI6tf#={USOH%dlR5XnGPn(jpbRd8X)puEz!WLdE`qz@I=D*h5}0Fd zhPA)3hu>UZ#y`L>@CAHe>?imP-hy|GRXF~|=ljlQUtzAo+7&*}d(N$>{gS>ev#$$a zh)8Ub`8<1`=CfU*o#vczFb~dySw8PDHG_=jsVy-#qUIMEpHcf-;Jjt(Mc2>$&ry?N zuSMqNJ&dyNamH=!BJBV*Irfla{S3&m=Mlyvm!{tC*FF#h&9o5^1}z}Qcv$6QoD(Av zj;+2G98mea%ttu3HJViYX3lR_b;6uyX=V-G-yYS2tsPQ2t#6_Yv0jtXhn2R4fWA==c7$4)>Q?y0eQKc2+?#Q{GQ29x< zUjh0%L6ClcV@p8AYxCA`RCTt49mKC}gYtd!eaiPMd^K9X>e1RD*AJ+;?ZfsJFdO@| z`39A1teIb{w^sJ67bHOf;QPSzfjBs4s&`l3VK-w*#`@@Y(~3quTQbD@gRI-fdi})K zkk22NTB%i1`UHC$`FqHUaM@;rV}T_^q)mkZZXO zh0>PWhGGlIhl*4M#IIz@$k%duf)I<|CZj5f!4gbL(fWE_hj~u!ul02C+Gw+!* z_jGPccSm0=&=*ijd6m!WQQlfCRc&w2;pTRwd>%M8%BTFW^@)^i^*dGp+THN$KqKe^ zZ^29O2|NLh!9(yGyaG?bBk+dn&s;wTFTgXf3cfKWdmexla0e7Y8C(E!U>;0@SyHB5 z0{6fTaE;n!u)y3rYky}Czj?m+KfxOK3O+LS3w#0ZzpU1E5}RQ@$DZf-Y!_+gxMvDn1?RwJK5v1VQO0xBmY5qi_U9R&H|{mh zeJj+9ZkYG)P?KV>Mdsymm|)*ijO*G(+7W6T_TaF724vauIAfAaQ?Ku9ABcih+6V}P zHV|VxY~*9y6C)A&T94UQ2aJ3(^AY;GMvGCumHXR`I$`e9w6ccT-(I5!T{~pxOnnP& zi1k_web~^p(T^InBgTE*R_;5nOztXoR^(k;Vr)^lGb7rYYV*C3nUp!a4{k9g`RlA9 z$Q)cDGJ7+OFR*5r=PdH9GV`<4EO4L1drqfw_G>?8rhHW+I^*M4IiFz{Dt14fV9 zHu3zR5!Zd_zJh9NzdGMwL$Bh2-I(%#FvkiE+3D5sy%l{iYQudggl3%c z9v$eklf$-?59vUl)6V9tY(^qmE7rzSR!$fEcTB>H=QHx7vtBJvTO+oX*Xdy1a&i&V ziPG^6+SY(hSoVM&F`cOC#OT!JvUWTvXUM_cKUJ*-2CTdlN;qhvsx`lpDTH);GGv}< Uwei>GK8ITW3oTG$yV(f<06x8^%>V!Z literal 0 HcmV?d00001 diff --git a/man/Flea-measurements.Rd b/man/Flea-measurements.Rd index ddd85c3c..814a1eee 100644 --- a/man/Flea-measurements.Rd +++ b/man/Flea-measurements.Rd @@ -4,13 +4,19 @@ \name{Flea measurements} \alias{Flea measurements} \alias{flea} +\alias{flea,} +\alias{flea_raw} \title{Flea beatle measurements} \format{ A 74 x 7 numeric array } +\usage{ +flea +} \description{ This data is from a paper by A. A. Lubischew, "On the Use of Discriminant -Functions in Taxonomy", Biometrics, Dec 1962, pp.455-477. +Functions in Taxonomy", Biometrics, Dec 1962, pp.455-477. Data is +standardized, and original units are in flea_raw. } \details{ \itemize{ diff --git a/man/display_faces.Rd b/man/display_faces.Rd index e7e04eab..aaa2b953 100644 --- a/man/display_faces.Rd +++ b/man/display_faces.Rd @@ -28,10 +28,9 @@ Chernoff faces. See \code{\link[TeachingDemos]{faces2}} for more details. # The drawing code is fairly slow, so this animation works best with a # limited number of cases flea_s <- rescale(flea[,1:6]) -animate_faces(flea_s[1:2, 1:6]) -animate_faces(flea_s[1:4, 1:6]) +animate_faces(flea_s[19:24, 1:6]) -animate_faces(flea_s[1:2, 1:6], grand_tour(5)) +animate_faces(flea_s[19:24, 1:6], grand_tour(5)) } \seealso{ \code{\link{animate}} for options that apply to all animations diff --git a/man/display_xy.Rd b/man/display_xy.Rd index 11490182..d44ea0d8 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -16,6 +16,7 @@ display_xy( edges.col = "black", edges.width = 1, obs_labels = NULL, + ellipse = NULL, palette = "Zissou 1", ... ) @@ -46,6 +47,9 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{obs_labels}{vector of text labels to display} +\item{ellipse}{pxp variance-covariance matrix defining ellipse, default NULL. Useful for +comparing data with some null hypothesis} + \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} \item{...}{other arguments passed on to \code{\link{animate}} and @@ -94,4 +98,6 @@ animate( flea[, 1:6], grand_tour(), display_xy(axes = "bottomleft", edges = edges) ) +# An ellipse can be drawn on the data using a specified var-cov +animate_xy(flea[, 1:6], axes = "off", ellipse=cov(flea[,1:6])) } diff --git a/man/radial_tour.Rd b/man/radial_tour.Rd index 85874053..e0d824e7 100644 --- a/man/radial_tour.Rd +++ b/man/radial_tour.Rd @@ -23,8 +23,8 @@ a method that works with tour paths like \code{\link{animate}}, \code{\link{save_history}} or \code{\link{render}}. } \examples{ -animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = 4)) -animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = c(3,4))) -animate_dist(flea[, 1:6], radial_tour(basis_random(6, 1), mvar = 4)) -animate_scatmat(flea[, 1:6], radial_tour(basis_random(6, 3), mvar = 4)) +animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = 4), rescale=TRUE) +animate_xy(flea[, 1:6], radial_tour(basis_random(6, 2), mvar = c(3,4)), rescale=TRUE) +animate_dist(flea[, 1:6], radial_tour(basis_random(6, 1), mvar = 4), rescale=TRUE) +animate_scatmat(flea[, 1:6], radial_tour(basis_random(6, 3), mvar = 4), rescale=TRUE) } From 133fee9fce8cab28449aab830b9d15c06328520f Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 7 Mar 2024 14:17:55 +1100 Subject: [PATCH 02/17] palette can now be a vector of colours --- NEWS.md | 1 + R/util.r | 9 ++++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index bba978e4..6c79f173 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ * flea is now standardised measurements, and flea_raw is the original units * TeachingDemos removed as a Suggests, and replaced with aplpack for drawing Chernoff faces * addition of a pre-specified ellipse can be added to the 2D display +* palette can now be a vector of values # tourr 1.1.0 diff --git a/R/util.r b/R/util.r index c2290cd4..dce0ea12 100644 --- a/R/util.r +++ b/R/util.r @@ -122,7 +122,14 @@ areColors <- function(x) { #' @export mapColors <- function(x, palette) { n <- length(unique(x)) - pal <- grDevices::hcl.colors(n, palette=palette) + # Handle manual colour setting + if (length(palette) > 1) { + stopifnot(length(palette) == n) + pal <- palette + } + else { + pal <- grDevices::hcl.colors(n, palette=palette) + } pal[as.numeric(as.factor(x))] } From a273eb8f4f45b131f0cc27e936db1ec5211f2c8a Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 7 Mar 2024 18:04:48 +1100 Subject: [PATCH 03/17] anomaly pursuit --- NAMESPACE | 2 + R/anomaly-pursuit.r | 14 ++++++ R/display-xy.r | 14 +++++- R/tour-guided-anomaly.r | 92 ++++++++++++++++++++++++++++++++++++++ R/tour-guided-section.r | 4 +- man/display_xy.Rd | 4 ++ man/guided_section_tour.Rd | 4 +- 7 files changed, 128 insertions(+), 6 deletions(-) create mode 100644 R/anomaly-pursuit.r create mode 100644 R/tour-guided-anomaly.r diff --git a/NAMESPACE b/NAMESPACE index ad983aa3..586f7bb6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ export(animate_stars) export(animate_stereo) export(animate_trails) export(animate_xy) +export(anomaly_index) export(areColors) export(basis_init) export(basis_random) @@ -66,6 +67,7 @@ export(frozen_guided_tour) export(frozen_tour) export(geodesic_path) export(grand_tour) +export(guided_anomaly_tour) export(guided_section_tour) export(guided_tour) export(holes) diff --git a/R/anomaly-pursuit.r b/R/anomaly-pursuit.r new file mode 100644 index 00000000..5d8ce23e --- /dev/null +++ b/R/anomaly-pursuit.r @@ -0,0 +1,14 @@ +#' Anomaly index. +#' +#' Calculates an index that looks for the best projection of +#' observations that are outside a pre-determined p-D ellipse. +#' +#' @export +anomaly_index <- function() { + + function(mat, ell2d) { + + mat_tab <- mean(sqrt(mahalanobis(mat, center=c(0,0), cov=ell2d))) + } +} + diff --git a/R/display-xy.r b/R/display-xy.r index be632c70..4286589f 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -17,6 +17,8 @@ #' @param obs_labels vector of text labels to display #' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. Useful for #' comparing data with some null hypothesis +#' @param ellsize This can be considered the equivalent of a critical value, used to +#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1. #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1" #' @param ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_xy}} @@ -64,7 +66,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, edges = NULL, edges.col = "black", edges.width=1, obs_labels = NULL, - ellipse = NULL, + ellipse = NULL, ellsize = 1, palette="Zissou 1", ...) { # Needed for CRAN checks labels <- NULL @@ -151,7 +153,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, if (nrow(ellipse) == nrow(proj)) { # Project ellipse into 2D - evc <- eigen(ellipse) + evc <- eigen(ellipse*ellsize) ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) e2 <- t(proj) %*% ellinv %*% proj evc2 <- eigen(e2) @@ -170,6 +172,14 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, lines(sph2d) + # Colour points outside the pD ellipse + mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + anomalies <- which(mdst > ellsize) + cat(length(anomalies), "\n") + points(x[anomalies,], + col = "red", + pch = 4, + cex = 2) } else message("Check the variance-covariance matrix generating the ellipse\n") diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r new file mode 100644 index 00000000..a0b1c843 --- /dev/null +++ b/R/tour-guided-anomaly.r @@ -0,0 +1,92 @@ +#' A guided anomaly tour path. +#' +#' The guided anomaly tour is a variation of the guided tour that is +#' 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}}, +#' \code{\link{save_history}} or \code{\link{render}}. +#' +#' @param index_f the section pursuit index function to optimise. The function +#' needs to take two arguments, the projected data, indexes of anomalies. +#' @param d target dimensionality +#' @param alpha the initial size of the search window, in radians +#' @param cooling the amount the size of the search window should be adjusted +#' by after each step +#' @param search_f the search strategy to use +#' @param max.tries the maximum number of unsuccessful attempts to find +#' a better projection before giving up +#' @param max.i the maximum index value, stop search if a larger value is found +#' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. +#' Useful for comparing data with some hypothesized null. +#' @param ellsize This can be considered the equivalent of a critical value, used to +#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1. +#' @param ... arguments sent to the search_f +#' @seealso \code{\link{slice_index}} for an example of an index functions. +#' \code{\link{search_geodesic}}, \code{\link{search_better}}, +#' \code{\link{search_better_random}} for different search strategies +#' @export +#' @examples +#' animate_xy(flea[, 1:6], guided_anomaly_tour(anomaly_index(), +#' ellipse=cov(flea[,1:6])), ellipse=cov(flea[,1:6]), axes="off") +guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, + max.tries = 25, max.i = Inf, + ellipse, ellsize=1, + search_f = search_geodesic, ...) { + h <- NULL + + generator <- function(current, data, tries, ...) { + if (is.null(current)) { + return(basis_init(ncol(data), d)) + } + + if (is.null(h)) { + half_range <- compute_half_range(NULL, data, FALSE) + } + + index <- function(proj) { + # Check which observations are outside pD ellipse + mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + anomalies <- which(mdst > ellsize) + stopifnot(length(anomalies) > 0) + # Project ellipse into 2D + evc <- eigen(ellipse) + ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) + e2 <- t(proj) %*% ellinv %*% proj + evc2 <- eigen(e2) + ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) + index_f(as.matrix(data[anomalies,]) %*% proj, ell2d) + } + + cur_index <- index(current) + + if (cur_index > max.i) { + cat("Found index ", cur_index, ", larger than selected maximum ", max.i, ". Stopping search.\n", + sep = "" + ) + cat("Final projection: \n") + if (ncol(current) == 1) { + for (i in 1:length(current)) { + cat(sprintf("%.3f", current[i]), " ") + } + cat("\n") + } + else { + for (i in 1:nrow(current)) { + for (j in 1:ncol(current)) { + cat(sprintf("%.3f", current[i, j]), " ") + } + cat("\n") + } + } + return(NULL) + } + + basis <- search_f(current, alpha, index, tries, max.tries, cur_index = cur_index, ...) + alpha <<- alpha * cooling + + list(target = basis$target, index = index) + } + + new_geodesic_path("guided", generator) +} diff --git a/R/tour-guided-section.r b/R/tour-guided-section.r index 158e21b9..1b496a6c 100644 --- a/R/tour-guided-section.r +++ b/R/tour-guided-section.r @@ -7,7 +7,7 @@ #' a method that works with tour paths like \code{\link{animate_slice}}, #' \code{\link{save_history}} or \code{\link{render}}. #' -#' @param index_f the section purusit index function to optimise. The function +#' @param index_f the section pursuit index function to optimise. The function #' needs to take three arguments, the projected data, the vector of distances #' from the current projection plane, and the slice thickness h. #' @param d target dimensionality @@ -19,7 +19,7 @@ #' a better projection before giving up #' @param max.i the maximum index value, stop search if a larger value is found #' @param v_rel relative volume of the slice. If not set, suggested value -#' is caluclated and printed to the screen. +#' is calculated and printed to the screen. #' @param anchor A vector specifying the reference point to anchor the slice. #' If NULL (default) the slice will be anchored at the data center. #' @param ... arguments sent to the search_f diff --git a/man/display_xy.Rd b/man/display_xy.Rd index d44ea0d8..6c7096ef 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -17,6 +17,7 @@ display_xy( edges.width = 1, obs_labels = NULL, ellipse = NULL, + ellsize = 1, palette = "Zissou 1", ... ) @@ -50,6 +51,9 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{ellipse}{pxp variance-covariance matrix defining ellipse, default NULL. Useful for comparing data with some null hypothesis} +\item{ellsize}{This can be considered the equivalent of a critical value, used to +scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1.} + \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} \item{...}{other arguments passed on to \code{\link{animate}} and diff --git a/man/guided_section_tour.Rd b/man/guided_section_tour.Rd index 0f1a7d59..dc72ef58 100644 --- a/man/guided_section_tour.Rd +++ b/man/guided_section_tour.Rd @@ -18,7 +18,7 @@ guided_section_tour( ) } \arguments{ -\item{index_f}{the section purusit index function to optimise. The function +\item{index_f}{the section pursuit index function to optimise. The function needs to take three arguments, the projected data, the vector of distances from the current projection plane, and the slice thickness h.} @@ -35,7 +35,7 @@ a better projection before giving up} \item{max.i}{the maximum index value, stop search if a larger value is found} \item{v_rel}{relative volume of the slice. If not set, suggested value -is caluclated and printed to the screen.} +is calculated and printed to the screen.} \item{anchor}{A vector specifying the reference point to anchor the slice. If NULL (default) the slice will be anchored at the data center.} From 735219d15437ceccd0165d12d02f1c7318938f9b Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 7 Mar 2024 18:54:53 +1100 Subject: [PATCH 04/17] anomaly pursuit is definitely working --- NAMESPACE | 1 + R/anomaly-pursuit.r | 3 ++- R/display-xy.r | 5 +++-- R/linear-algebra.r | 22 ++++++++++++++++++++++ R/tour-guided-anomaly.r | 5 +++-- man/display_xy.Rd | 4 ++-- 6 files changed, 33 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 586f7bb6..e9235996 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -77,6 +77,7 @@ export(lda_pp) export(linear_breaks) export(little_tour) export(local_tour) +export(mahal_dist) export(manual_slice) export(mapColors) export(mapShapes) diff --git a/R/anomaly-pursuit.r b/R/anomaly-pursuit.r index 5d8ce23e..92e30216 100644 --- a/R/anomaly-pursuit.r +++ b/R/anomaly-pursuit.r @@ -8,7 +8,8 @@ anomaly_index <- function() { function(mat, ell2d) { - mat_tab <- mean(sqrt(mahalanobis(mat, center=c(0,0), cov=ell2d))) + mat_tab <- #mean(mahal_dist(mat, ell2d)) + mean(sqrt(mahalanobis(mat, center=c(0,0), cov=ell2d))) } } diff --git a/R/display-xy.r b/R/display-xy.r index 4286589f..0e95d1a9 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -18,7 +18,7 @@ #' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. Useful for #' comparing data with some null hypothesis #' @param ellsize This can be considered the equivalent of a critical value, used to -#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1. +#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3. #' @param palette name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1" #' @param ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_xy}} @@ -66,7 +66,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, edges = NULL, edges.col = "black", edges.width=1, obs_labels = NULL, - ellipse = NULL, ellsize = 1, + ellipse = NULL, ellsize = 3, palette="Zissou 1", ...) { # Needed for CRAN checks labels <- NULL @@ -174,6 +174,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, # Colour points outside the pD ellipse mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellsize) cat(length(anomalies), "\n") points(x[anomalies,], diff --git a/R/linear-algebra.r b/R/linear-algebra.r index 5b1b0236..1aa441ff 100644 --- a/R/linear-algebra.r +++ b/R/linear-algebra.r @@ -111,3 +111,25 @@ orthonormalise_by <- function(x, by) { #' @keywords algebra #' @export proj_dist <- function(x, y) sqrt(sum((x %*% t(x) - y %*% t(y))^2)) + +#' Calculate the Mahalanobis distance between points and center. +#' +#' Computes the Mahalanobis distance using a provided variance-covariance +#' matrix of observations from 0. +# +#' @param x matrix of data +#' @param vc pre-determined variance-covariance matrix +#' @keywords algebra +#' @export +mahal_dist <- function(x, vc) { + n <- dim(x)[1] + p <- dim(x)[2] + mn <- rep(0, p) + ev <- eigen(vc) + vcinv <- ev$vectors %*% diag(1/ev$values) %*% t(ev$vectors) + x <- x - matrix(rep(mn, n), ncol = p, byrow = T) + dx <- NULL + for (i in 1:n) + dx <- c(dx, x[i, ] %*% vcinv %*% as.matrix(x[i, ])) + return(dx) +} diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index a0b1c843..fd166260 100644 --- a/R/tour-guided-anomaly.r +++ b/R/tour-guided-anomaly.r @@ -20,7 +20,7 @@ #' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. #' Useful for comparing data with some hypothesized null. #' @param ellsize This can be considered the equivalent of a critical value, used to -#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1. +#' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3. #' @param ... arguments sent to the search_f #' @seealso \code{\link{slice_index}} for an example of an index functions. #' \code{\link{search_geodesic}}, \code{\link{search_better}}, @@ -31,7 +31,7 @@ #' ellipse=cov(flea[,1:6])), ellipse=cov(flea[,1:6]), axes="off") guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, max.tries = 25, max.i = Inf, - ellipse, ellsize=1, + ellipse, ellsize=3, search_f = search_geodesic, ...) { h <- NULL @@ -47,6 +47,7 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, index <- function(proj) { # Check which observations are outside pD ellipse mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellsize) stopifnot(length(anomalies) > 0) # Project ellipse into 2D diff --git a/man/display_xy.Rd b/man/display_xy.Rd index 6c7096ef..692ce629 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -17,7 +17,7 @@ display_xy( edges.width = 1, obs_labels = NULL, ellipse = NULL, - ellsize = 1, + ellsize = 3, palette = "Zissou 1", ... ) @@ -52,7 +52,7 @@ If not set, defaults to maximum distance from origin to each row of data.} comparing data with some null hypothesis} \item{ellsize}{This can be considered the equivalent of a critical value, used to -scale the ellipse larger or smaller to capture more or fewer anomalies. Default 1.} +scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} From 335541ca596a66164d961a7f3416d1f27cc3cac5 Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 7 Mar 2024 19:11:05 +1100 Subject: [PATCH 05/17] setting default size of ellipse to be 3 --- R/display-xy.r | 1 - 1 file changed, 1 deletion(-) diff --git a/R/display-xy.r b/R/display-xy.r index 0e95d1a9..bdccd7fb 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -176,7 +176,6 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellsize) - cat(length(anomalies), "\n") points(x[anomalies,], col = "red", pch = 4, From faa90ce8d22de5b8c99ca6d15c8ae53cc87437f4 Mon Sep 17 00:00:00 2001 From: dicook Date: Fri, 8 Mar 2024 08:54:16 +1100 Subject: [PATCH 06/17] think the index is working now --- NEWS.md | 2 ++ R/anomaly-pursuit.r | 2 +- R/display-xy.r | 12 +++++++++--- R/tour-guided-anomaly.r | 8 ++++++-- 4 files changed, 18 insertions(+), 6 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6c79f173..4fcb4801 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,8 @@ * TeachingDemos removed as a Suggests, and replaced with aplpack for drawing Chernoff faces * addition of a pre-specified ellipse can be added to the 2D display * palette can now be a vector of values +* a new projection pursuit index for finding anomalies relative to +a null variance-covariance matrix. # tourr 1.1.0 diff --git a/R/anomaly-pursuit.r b/R/anomaly-pursuit.r index 92e30216..c3f1ff41 100644 --- a/R/anomaly-pursuit.r +++ b/R/anomaly-pursuit.r @@ -9,7 +9,7 @@ anomaly_index <- function() { function(mat, ell2d) { mat_tab <- #mean(mahal_dist(mat, ell2d)) - mean(sqrt(mahalanobis(mat, center=c(0,0), cov=ell2d))) + mean(mahalanobis(mat, center=c(0,0), cov=ell2d)) } } diff --git a/R/display-xy.r b/R/display-xy.r index bdccd7fb..837eba8d 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -153,11 +153,15 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, if (nrow(ellipse) == nrow(proj)) { # Project ellipse into 2D + # Notation in paper: ellipse=A, ellinv=A^(-1), + # e2=P^TA^(-1)P, ell2d=B evc <- eigen(ellipse*ellsize) ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) e2 <- t(proj) %*% ellinv %*% proj evc2 <- eigen(e2) - ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) + ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values)) %*% t(evc2$vectors) + e3 <- eigen(ell2d) + ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) # Compute the points on an ellipse sph <- geozoo::sphere.hollow(2, 200)$points @@ -168,12 +172,14 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, sph2 <- sph2[order(sph2[,1], decreasing=T),] sph <- rbind(sph1, sph2) sph <- rbind(sph, sph[1,]) - sph2d <- sph%*%ell2d/half_range + sph2d <- sph%*%ell2dinv/half_range lines(sph2d) # Colour points outside the pD ellipse - mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + mdst <- mahalanobis(data, + center=rep(0, ncol(data)), + cov=ellipse) #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellsize) points(x[anomalies,], diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index fd166260..5e44a3ad 100644 --- a/R/tour-guided-anomaly.r +++ b/R/tour-guided-anomaly.r @@ -46,7 +46,9 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, index <- function(proj) { # Check which observations are outside pD ellipse - mdst <- sqrt(mahalanobis(data, center=rep(0, ncol(data)), cov=ellipse)) + mdst <- mahalanobis(data, + center=rep(0, ncol(data)), + cov=ellipse) #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellsize) stopifnot(length(anomalies) > 0) @@ -56,7 +58,9 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, e2 <- t(proj) %*% ellinv %*% proj evc2 <- eigen(e2) ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) - index_f(as.matrix(data[anomalies,]) %*% proj, ell2d) + e3 <- eigen(ell2d) + ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) + index_f(as.matrix(data[anomalies,]) %*% proj, ell2dinv) } cur_index <- index(current) From 1216e88a8d1cd34ced7309fa8775125a16e56adf Mon Sep 17 00:00:00 2001 From: dicook Date: Fri, 8 Mar 2024 09:11:14 +1100 Subject: [PATCH 07/17] point shapes can be specified like colour palettes --- NEWS.md | 1 + R/display-groupxy.r | 6 ++++-- R/display-xy.r | 6 ++++-- R/util.r | 5 +++-- man/display_groupxy.Rd | 4 ++++ man/display_xy.Rd | 4 ++++ man/mapShapes.Rd | 2 +- 7 files changed, 21 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4fcb4801..fec97da3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,7 @@ * palette can now be a vector of values * a new projection pursuit index for finding anomalies relative to a null variance-covariance matrix. +* point shapes can now be specified like palettes # tourr 1.1.0 diff --git a/R/display-groupxy.r b/R/display-groupxy.r index 3d8d283c..c72cbaaf 100644 --- a/R/display-groupxy.r +++ b/R/display-groupxy.r @@ -20,6 +20,8 @@ #' @param edges.col colour of edges to be plotted, Defaults to "black" #' @param edges.width line width for edges, default 1 #' @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 ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_groupxy}} #' @export @@ -39,7 +41,7 @@ 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", ...) { + palette = "Zissou 1", shapeset=c(15:17, 23:25), ...) { labels <- NULL # If colors are a variable, convert to colors @@ -53,7 +55,7 @@ display_groupxy <- function(centr = TRUE, axes = "center", half_range = NULL, } # If shapes are a variable, convert shapes if (is.factor(pch)) { - shapes <- mapShapes(pch) + shapes <- mapShapes(pch, shapeset) } else { shapes <- pch } diff --git a/R/display-xy.r b/R/display-xy.r index 837eba8d..0c484e48 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -20,6 +20,8 @@ #' @param ellsize This can be considered the equivalent of a critical value, used to #' scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3. #' @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 ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_xy}} #' @importFrom graphics legend @@ -67,7 +69,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, edges = NULL, edges.col = "black", edges.width=1, obs_labels = NULL, ellipse = NULL, ellsize = 3, - palette="Zissou 1", ...) { + palette="Zissou 1", shapeset=c(15:17, 23:25), ...) { # Needed for CRAN checks labels <- NULL gps <- NULL @@ -84,7 +86,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, } # If shapes are a variable, convert shapes if (is.factor(pch)) { - shapes <- mapShapes(pch) + shapes <- mapShapes(pch, shapeset) } else { shapes <- pch } diff --git a/R/util.r b/R/util.r index dce0ea12..002bd315 100644 --- a/R/util.r +++ b/R/util.r @@ -137,8 +137,9 @@ mapColors <- function(x, palette) { #' #' @param x vector #' @export -mapShapes <- function(x) { +mapShapes <- function(x, shapeset) { n <- length(unique(x)) - shapes <- c(15:17, 23:25) + stopifnot(length(shapeset) >= n) + shapes <- shapeset shapes[as.numeric(x)] } diff --git a/man/display_groupxy.Rd b/man/display_groupxy.Rd index bb873349..0db34e08 100644 --- a/man/display_groupxy.Rd +++ b/man/display_groupxy.Rd @@ -18,6 +18,7 @@ display_groupxy( group_by = NULL, plot_xgp = TRUE, palette = "Zissou 1", + shapeset = c(15:17, 23:25), ... ) @@ -51,6 +52,9 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{shapeset}{numbers corresponding to shapes in base R points, to use for mapping +categorical variable to shapes, default=c(15:17, 23:25)} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_groupxy}}} diff --git a/man/display_xy.Rd b/man/display_xy.Rd index 692ce629..7ad22e21 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -19,6 +19,7 @@ display_xy( ellipse = NULL, ellsize = 3, palette = "Zissou 1", + shapeset = c(15:17, 23:25), ... ) @@ -56,6 +57,9 @@ scale the ellipse larger or smaller to capture more or fewer anomalies. Default \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{shapeset}{numbers corresponding to shapes in base R points, to use for mapping +categorical variable to shapes, default=c(15:17, 23:25)} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_xy}}} diff --git a/man/mapShapes.Rd b/man/mapShapes.Rd index d1df54a6..7b3ab960 100644 --- a/man/mapShapes.Rd +++ b/man/mapShapes.Rd @@ -4,7 +4,7 @@ \alias{mapShapes} \title{Map vector of factors to pch} \usage{ -mapShapes(x) +mapShapes(x, shapeset) } \arguments{ \item{x}{vector} From 45f5b733aff76ca68bd38e73988680d0a400b97f Mon Sep 17 00:00:00 2001 From: dicook Date: Fri, 8 Mar 2024 09:20:44 +1100 Subject: [PATCH 08/17] axis and text colour and line width now can be set --- R/display-xy.r | 15 +++++++++++---- man/draw_tour_axes.Rd | 17 ++++++++++++++++- 2 files changed, 27 insertions(+), 5 deletions(-) diff --git a/R/display-xy.r b/R/display-xy.r index 0c484e48..30bad6ee 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -219,6 +219,9 @@ animate_xy <- function(data, tour_path = grand_tour(), ...) { #' projected data, default 1 #' @param position position of the axes: center (default), #' bottomleft or off +#' @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 ... other arguments passed #' @export #' @examples @@ -236,7 +239,8 @@ 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 <- function(proj, labels, limits=1, position="center", ...) { +draw_tour_axes <- function(proj, labels, limits=1, position="center", + axis.col= "grey50", axis.lwd=1, axis.text.col= "grey50", ...) { position <- match.arg(position, c("center", "bottomleft", "off")) if (position == "off") { return() @@ -252,13 +256,16 @@ draw_tour_axes <- function(proj, labels, limits=1, position="center", ...) { adj <- function(x) axis_pos + x * axis_scale - segments(adj(0), adj(0), adj(proj[, 1]), adj(proj[, 2]), col = "grey50") + segments(adj(0), adj(0), adj(proj[, 1]), adj(proj[, 2]), + col = axis.col, lwd = axis.lwd) # if (!is.null(mvar)) { # colour manip var # if ((mvar < (nrow(proj)+1)) & (mvar > 0)) { # segments(adj(0), adj(0), adj(proj[, 1]), adj(proj[, 2]), col = "orange") # } # } theta <- seq(0, 2 * pi, length = 50) - lines(adj(cos(theta)), adj(sin(theta)), col = "grey50") - text(adj(proj[, 1]), adj(proj[, 2]), label = labels, col = "grey50") + lines(adj(cos(theta)), adj(sin(theta)), + col = axis.col, lwd = axis.lwd) + text(adj(proj[, 1]), adj(proj[, 2]), label = labels, + col = axis.text.col) } diff --git a/man/draw_tour_axes.Rd b/man/draw_tour_axes.Rd index 3561f676..a42c5b1f 100644 --- a/man/draw_tour_axes.Rd +++ b/man/draw_tour_axes.Rd @@ -4,7 +4,16 @@ \alias{draw_tour_axes} \title{Draw tour axes on the projected data with base graphics} \usage{ -draw_tour_axes(proj, labels, limits = 1, position = "center", ...) +draw_tour_axes( + proj, + labels, + limits = 1, + position = "center", + axis.col = "grey50", + axis.lwd = 1, + axis.text.col = "grey50", + ... +) } \arguments{ \item{proj}{matrix of projection coefficients} @@ -18,6 +27,12 @@ projected data, default 1} \item{position}{position of the axes: center (default), bottomleft or off} +\item{axis.col}{colour of axes, default "grey50"} + +\item{axis.lwd}{linewidth of axes, default 1} + +\item{axis.text.col}{colour of axes text, default "grey50"} + \item{...}{other arguments passed} } \description{ From da2e575b59cf317650a8f44f83b4513474172fbd Mon Sep 17 00:00:00 2001 From: dicook Date: Tue, 12 Mar 2024 16:04:32 +1100 Subject: [PATCH 09/17] anomaly index working --- NAMESPACE | 2 ++ R/anomaly-pursuit.r | 4 +-- R/display-xy.r | 48 ++++++++++++++++++++++++++------- R/tour-guided-anomaly.r | 59 +++++++++++++++++++++++++++++------------ R/util.r | 1 + man/display_xy.Rd | 8 ++++-- man/mapShapes.Rd | 2 ++ 7 files changed, 93 insertions(+), 31 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e9235996..dfd15912 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -136,7 +136,9 @@ importFrom(graphics,rect) importFrom(graphics,segments) importFrom(graphics,stars) importFrom(graphics,text) +importFrom(stats,mahalanobis) importFrom(stats,na.omit) +importFrom(stats,qchisq) importFrom(stats,quantile) importFrom(stats,residuals) importFrom(stats,rnorm) diff --git a/R/anomaly-pursuit.r b/R/anomaly-pursuit.r index c3f1ff41..48d86aeb 100644 --- a/R/anomaly-pursuit.r +++ b/R/anomaly-pursuit.r @@ -6,10 +6,10 @@ #' @export anomaly_index <- function() { - function(mat, ell2d) { + function(mat, ell2d, ellmu2d) { mat_tab <- #mean(mahal_dist(mat, ell2d)) - mean(mahalanobis(mat, center=c(0,0), cov=ell2d)) + mean(mahalanobis(mat, center=ellmu2d, cov=ell2d)) } } diff --git a/R/display-xy.r b/R/display-xy.r index 30bad6ee..3cd3963b 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -17,14 +17,17 @@ #' @param obs_labels vector of text labels to display #' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. Useful for #' comparing data with some null hypothesis -#' @param ellsize This can be considered the equivalent of a critical value, used to +#' @param ellc This can be considered the equivalent of a critical value, used to #' 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 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 ... other arguments passed on to \code{\link{animate}} and #' \code{\link{display_xy}} #' @importFrom graphics legend +#' @importFrom stats mahalanobis qchisq #' @export #' @examples #' animate_xy(flea[, 1:6]) @@ -68,7 +71,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, col = "black", pch = 20, cex = 1, edges = NULL, edges.col = "black", edges.width=1, obs_labels = NULL, - ellipse = NULL, ellsize = 3, + ellipse = NULL, ellc = NULL, ellmu = NULL, palette="Zissou 1", shapeset=c(15:17, 23:25), ...) { # Needed for CRAN checks labels <- NULL @@ -154,19 +157,37 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, if (!is.null(ellipse)) { if (nrow(ellipse) == nrow(proj)) { + if (is.null(ellc)) + ellc <- qchisq(0.95, nrow(proj)) + else + stopifnot(ellc > 0) # Needs to be positive + if (is.null(ellmu)) + ellmu <- rep(0, nrow(proj)) + else + stopifnot(length(ellmu) == nrow(proj)) # Right dimension + message("Using ellc = ", format(ellc, digits = 2)) + # Project ellipse into 2D # Notation in paper: ellipse=A, ellinv=A^(-1), # e2=P^TA^(-1)P, ell2d=B - evc <- eigen(ellipse*ellsize) + # ellipse=var-cov of normal pop + # ellinv for defining pD ellipse, for dist calc + # e2 is projected var-cov + # ell2d is B, used to project ellipse points + evc <- eigen(ellipse) # ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) - e2 <- t(proj) %*% ellinv %*% proj + e2 <- t(proj) %*% ellipse %*% proj evc2 <- eigen(e2) - ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values)) %*% t(evc2$vectors) - e3 <- eigen(ell2d) - ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) + ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values*ellc)) %*% t(evc2$vectors) + #e3 <- eigen(ell2d) + #ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) + # Compute the points on an ellipse + # Generate points on a circle sph <- geozoo::sphere.hollow(2, 200)$points + # Organise so lines connecting consecutive + # points creates the circle sph <- sph[order(sph[,2]),] sph1 <- sph[sph[,2]>=0,] sph2 <- sph[sph[,2]<0,] @@ -174,16 +195,23 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, sph2 <- sph2[order(sph2[,1], decreasing=T),] sph <- rbind(sph1, sph2) sph <- rbind(sph, sph[1,]) - sph2d <- sph%*%ell2dinv/half_range + + # Transform circle points into an ellipse + sph2d <- sph%*%ell2d + # Centre on the given mean + ellmu2d <- t(as.matrix(ellmu)) %*% proj + sph2d <- sweep(sph2d, 2, ellmu2d, `+`) + # Scale ellipse into plot space + sph2d <- sph2d/half_range lines(sph2d) # Colour points outside the pD ellipse mdst <- mahalanobis(data, - center=rep(0, ncol(data)), + center=ellmu, cov=ellipse) #mdst <- mahal_dist(data, ellipse) - anomalies <- which(mdst > ellsize) + anomalies <- which(mdst > ellc) points(x[anomalies,], col = "red", pch = 4, diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index 5e44a3ad..11625b26 100644 --- a/R/tour-guided-anomaly.r +++ b/R/tour-guided-anomaly.r @@ -19,19 +19,22 @@ #' @param max.i the maximum index value, stop search if a larger value is found #' @param ellipse pxp variance-covariance matrix defining ellipse, default NULL. #' Useful for comparing data with some hypothesized null. -#' @param ellsize This can be considered the equivalent of a critical value, used to +#' @param ellc This can be considered the equivalent of a critical value, used to #' 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 ... arguments sent to the search_f #' @seealso \code{\link{slice_index}} for an example of an index functions. #' \code{\link{search_geodesic}}, \code{\link{search_better}}, #' \code{\link{search_better_random}} for different search strategies +#' @importFrom stats mahalanobis qchisq #' @export #' @examples #' animate_xy(flea[, 1:6], guided_anomaly_tour(anomaly_index(), #' ellipse=cov(flea[,1:6])), ellipse=cov(flea[,1:6]), axes="off") guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, max.tries = 25, max.i = Inf, - ellipse, ellsize=3, + ellipse, ellc=NULL, ellmu=NULL, search_f = search_geodesic, ...) { h <- NULL @@ -45,22 +48,44 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, } index <- function(proj) { - # Check which observations are outside pD ellipse - mdst <- mahalanobis(data, - center=rep(0, ncol(data)), - cov=ellipse) + if (nrow(ellipse) == nrow(proj)) { + + if (is.null(ellc)) + ellc <- qchisq(0.95, nrow(proj)) + else + stopifnot(ellc > 0) # Needs to be positive + if (is.null(ellmu)) + ellmu <- rep(0, nrow(proj)) + else + stopifnot(length(ellmu) == nrow(proj)) # Right dimension + message("Using ellc = ", format(ellc, digits = 2)) + + # Check which observations are outside pD ellipse + mdst <- mahalanobis(data, + center=ellmu, + cov=ellipse) #mdst <- mahal_dist(data, ellipse) - anomalies <- which(mdst > ellsize) - stopifnot(length(anomalies) > 0) - # Project ellipse into 2D - evc <- eigen(ellipse) - ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) - e2 <- t(proj) %*% ellinv %*% proj - evc2 <- eigen(e2) - ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) - e3 <- eigen(ell2d) - ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) - index_f(as.matrix(data[anomalies,]) %*% proj, ell2dinv) + anomalies <- which(mdst > ellc) + stopifnot(length(anomalies) > 0) + + # Project ellipse into 2D + evc <- eigen(ellipse) # + ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) + e2 <- t(proj) %*% ellipse %*% proj + evc2 <- eigen(e2) + ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values*ellc)) %*% t(evc2$vectors) + + ell2dinv <- (evc2$vectors) %*% diag(evc2$values*ellc) %*% t(evc2$vectors) + ellmu2d <- t(as.matrix(ellmu)) %*% proj + #evc <- eigen(ellipse) + #ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) + #e2 <- t(proj) %*% ellinv %*% proj + #evc2 <- eigen(e2) + #ell2d <- (evc2$vectors) %*% diag(sqrt(evc2$values)) %*% t(evc2$vectors) + #e3 <- eigen(ell2d) + #ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) + index_f(as.matrix(data[anomalies,]) %*% proj, e2, ellmu2d) + } } cur_index <- index(current) diff --git a/R/util.r b/R/util.r index 002bd315..c67e039e 100644 --- a/R/util.r +++ b/R/util.r @@ -136,6 +136,7 @@ mapColors <- function(x, palette) { #' Map vector of factors to pch #' #' @param x vector +#' @param shapeset vector of integers indicating point shapes #' @export mapShapes <- function(x, shapeset) { n <- length(unique(x)) diff --git a/man/display_xy.Rd b/man/display_xy.Rd index 7ad22e21..9e4f331d 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -17,7 +17,8 @@ display_xy( edges.width = 1, obs_labels = NULL, ellipse = NULL, - ellsize = 3, + ellc = NULL, + ellmu = NULL, palette = "Zissou 1", shapeset = c(15:17, 23:25), ... @@ -52,9 +53,12 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{ellipse}{pxp variance-covariance matrix defining ellipse, default NULL. Useful for comparing data with some null hypothesis} -\item{ellsize}{This can be considered the equivalent of a critical value, used to +\item{ellc}{This can be considered the equivalent of a critical value, used to scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3.} +\item{ellmu}{This is the centre of the ellipse corresponding to the mean of the +normal population. Default vector of 0's} + \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} \item{shapeset}{numbers corresponding to shapes in base R points, to use for mapping diff --git a/man/mapShapes.Rd b/man/mapShapes.Rd index 7b3ab960..f8edd1f6 100644 --- a/man/mapShapes.Rd +++ b/man/mapShapes.Rd @@ -8,6 +8,8 @@ mapShapes(x, shapeset) } \arguments{ \item{x}{vector} + +\item{shapeset}{vector of integers indicating point shapes} } \description{ Map vector of factors to pch From d888e298e362a0e6c5054e471795ced7601b07ea Mon Sep 17 00:00:00 2001 From: dicook Date: Wed, 27 Mar 2024 17:06:24 +1100 Subject: [PATCH 10/17] fixed bug induced by computing the limits once, not each projection --- R/display-xy.r | 37 ++++++++++++++++++++++++++----------- R/tour-guided-anomaly.r | 11 ++++++----- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/R/display-xy.r b/R/display-xy.r index 3cd3963b..f2e7cccd 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -97,6 +97,21 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, init <- function(data) { half_range <<- compute_half_range(half_range, data, center) labels <<- abbreviate(colnames(data), 3) + + if (!is.null(ellipse)) { + if (nrow(ellipse) == ncol(data)) { + + if (is.null(ellc)) + ellc <<- qchisq(0.95, ncol(data)) + else + stopifnot(ellc > 0) # Needs to be positive + if (is.null(ellmu)) + ellmu <<- rep(0, ncol(data)) + else + stopifnot(length(ellmu) == ncol(data)) # Right dimension + message("Using ellc = ", format(ellc, digits = 2)) + } + } } if (!is.null(edges)) { @@ -157,15 +172,15 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, if (!is.null(ellipse)) { if (nrow(ellipse) == nrow(proj)) { - if (is.null(ellc)) - ellc <- qchisq(0.95, nrow(proj)) - else - stopifnot(ellc > 0) # Needs to be positive - if (is.null(ellmu)) - ellmu <- rep(0, nrow(proj)) - else - stopifnot(length(ellmu) == nrow(proj)) # Right dimension - message("Using ellc = ", format(ellc, digits = 2)) + # if (is.null(ellc)) + # ellc <- qchisq(0.95, nrow(proj)) + # else + # stopifnot(ellc > 0) # Needs to be positive + # if (is.null(ellmu)) + # ellmu <- rep(0, nrow(proj)) + # else + # stopifnot(length(ellmu) == nrow(proj)) # Right dimension + # message("Using ellc = ", format(ellc, digits = 2)) # Project ellipse into 2D # Notation in paper: ellipse=A, ellinv=A^(-1), @@ -178,11 +193,10 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) e2 <- t(proj) %*% ellipse %*% proj evc2 <- eigen(e2) - ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values*ellc)) %*% t(evc2$vectors) + ell2d <- as.matrix((evc2$vectors)) %*% diag(sqrt(evc2$values*ellc)) %*% t(as.matrix(evc2$vectors)) #e3 <- eigen(ell2d) #ell2dinv <- (e3$vectors) %*% diag(e3$values) %*% t(e3$vectors) - # Compute the points on an ellipse # Generate points on a circle sph <- geozoo::sphere.hollow(2, 200)$points @@ -212,6 +226,7 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, cov=ellipse) #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellc) + #cat("1 ", length(anomalies), "\n") points(x[anomalies,], col = "red", pch = 4, diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index 11625b26..0271b93d 100644 --- a/R/tour-guided-anomaly.r +++ b/R/tour-guided-anomaly.r @@ -51,14 +51,14 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, if (nrow(ellipse) == nrow(proj)) { if (is.null(ellc)) - ellc <- qchisq(0.95, nrow(proj)) + ellc <<- qchisq(0.95, nrow(proj)) else stopifnot(ellc > 0) # Needs to be positive if (is.null(ellmu)) - ellmu <- rep(0, nrow(proj)) + ellmu <<- rep(0, nrow(proj)) else stopifnot(length(ellmu) == nrow(proj)) # Right dimension - message("Using ellc = ", format(ellc, digits = 2)) + #message("Using ellc = ", format(ellc, digits = 2)) # Check which observations are outside pD ellipse mdst <- mahalanobis(data, @@ -67,13 +67,14 @@ guided_anomaly_tour <- function(index_f, d = 2, alpha = 0.5, cooling = 0.99, #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellc) stopifnot(length(anomalies) > 0) + #cat(length(anomalies), "\n") # Project ellipse into 2D evc <- eigen(ellipse) # - ellinv <- (evc$vectors) %*% diag(evc$values) %*% t(evc$vectors) + ellinv <- (evc$vectors) %*% as.matrix(diag(evc$values)) %*% t(evc$vectors) e2 <- t(proj) %*% ellipse %*% proj evc2 <- eigen(e2) - ell2d <- (evc2$vectors) %*% sqrt(diag(evc2$values*ellc)) %*% t(evc2$vectors) + ell2d <- as.matrix(evc2$vectors) %*% diag(sqrt(evc2$values*ellc)) %*% t(as.matrix(evc2$vectors)) ell2dinv <- (evc2$vectors) %*% diag(evc2$values*ellc) %*% t(evc2$vectors) ellmu2d <- t(as.matrix(ellmu)) %*% proj From 20c50354445769e2c0fa688f04e5dade3556818a Mon Sep 17 00:00:00 2001 From: dicook Date: Wed, 27 Mar 2024 17:13:53 +1100 Subject: [PATCH 11/17] small fix so that outliers are not drawn, if there are none --- R/display-xy.r | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/display-xy.r b/R/display-xy.r index f2e7cccd..a4ef5075 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -227,10 +227,12 @@ display_xy <- function(center = TRUE, axes = "center", half_range = NULL, #mdst <- mahal_dist(data, ellipse) anomalies <- which(mdst > ellc) #cat("1 ", length(anomalies), "\n") - points(x[anomalies,], + if (length(anomalies) > 0) { + points(x[anomalies,], col = "red", pch = 4, cex = 2) + } } else message("Check the variance-covariance matrix generating the ellipse\n") From d0f1c7bfea7b22e0a03dd2b4560ba0c9be65a3c9 Mon Sep 17 00:00:00 2001 From: dicook Date: Fri, 19 Apr 2024 11:12:36 +1000 Subject: [PATCH 12/17] fixes for CRAN --- LICENSE | 2 +- NEWS.md | 13 ++++++----- cran-comments.md | 56 ++++++++++++++++++------------------------------ 3 files changed, 28 insertions(+), 43 deletions(-) diff --git a/LICENSE b/LICENSE index a04a547a..fd367831 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2010-2021 +YEAR: 2010-2024 COPYRIGHT HOLDER: Hadley Wickham, Di Cook diff --git a/NEWS.md b/NEWS.md index fec97da3..d9b89378 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,12 +1,11 @@ # tourr 1.2.0 -* major change: rescale is now FALSE by default -* flea is now standardised measurements, and flea_raw is the original units -* TeachingDemos removed as a Suggests, and replaced with aplpack for drawing Chernoff faces -* addition of a pre-specified ellipse can be added to the 2D display -* palette can now be a vector of values -* a new projection pursuit index for finding anomalies relative to -a null variance-covariance matrix. +* major change: rescale is now FALSE by default. +* flea is now standardised measurements, and flea_raw is the original units. +* TeachingDemos removed as a Suggests, and replaced with aplpack for drawing Chernoff faces. +* addition of a pre-specified ellipse can be added to the 2D display. +* palette can now be a vector of values. +* a new projection pursuit index for finding anomalies relative to a null variance-covariance matrix. May still need more work. * point shapes can now be specified like palettes # tourr 1.1.0 diff --git a/cran-comments.md b/cran-comments.md index a4715712..8f87ae85 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,57 +1,43 @@ ## Overview -This is a small update, with one new displayand several bug fixes. There are no major structural changes to the code, though. +The main change was removing the dependency on TeachingDemos as requested by CRAN. -\dontrun is used for example code where the method would break, and thus the code should not be run. It is important for users to be able to see these examples. +Other changes are minor, except that a different default for all animations might affect current users. -── R CMD check results ──────────────────────────── tourr 1.1.0 ──── -Duration: 1m 14.7s +── R CMD check results ──────────────── tourr 1.2.0 ──── +Duration: 1m 18.7s 0 errors ✔ | 0 warnings ✔ | 0 notes ✔ ## Test environment -* local R installation: R version 4.3.1 (2023-06-16) -* Windows Server 2022, R-devel, 64 bit -* Fedora Linux, R-devel, clang, gfortran -* Ubuntu Linux 20.04.1 LTS, R-release, GCC - -using `check_rhub()`, returns some notes: - -* checking HTML version of manual ... NOTE -Skipping checking HTML validation: no command 'tidy' found -Skipping checking math rendering: package 'V8' unavailable - -* checking for non-standard things in the check directory ... NOTE -Found the following files/directories: - ''NULL'' - -* checking for detritus in the temp directory ... NOTE -Found the following files/directories: - 'lastMiKTeXException' - -Which I understand can be ignored +* R version 4.3.3 (Angel Food Cake) +* Windows: Using https://win-builder.r-project.org/ +* Linux: Using `rhub::rc_submit()` ## Downstream dependencies All downstream dependencies have been checked. > revdepcheck::revdep_check() -── CHECK ──────────────────────────────────────── 11 packages ── -✔ cheem 0.3.0 ── E: 0 | W: 0 | N: 0 -✔ composits 0.1.1 ── E: 1 | W: 0 | N: 0 +── INIT ───────────────────────────────── Computing revdeps ── +── INSTALL ───────────────────────────────────── 2 versions ── +Installing CRAN version of tourr +Installing DEV version of tourr +── CHECK ────────────────────────────────────── 12 packages ── +✔ cheem 0.4.0.0 ── E: 0 | W: 0 | N: 0 +✔ composits 0.1.1 ── E: 0 | W: 0 | N: 0 ✔ detourr 0.1.0 ── E: 0 | W: 0 | N: 1 I diveR 0.1.2 ── E: 1 | W: 0 | N: 0 ✔ ferrn 0.0.2 ── E: 0 | W: 0 | N: 0 ✔ geozoo 0.5.1 ── E: 0 | W: 0 | N: 0 ✔ liminal 0.1.2 ── E: 0 | W: 0 | N: 0 -I loon.tourr 0.1.3 ── E: 1 | W: 0 | N: 0 -✔ mulgar 1.0.1 ── E: 0 | W: 0 | N: 0 -I REPPlab 0.9.4 ── E: 1 | W: 0 | N: 0 -✔ spinifex 0.3.6 ── E: 0 | W: 0 | N: 1 +I loon.tourr 0.1.4 ── E: 1 | W: 0 | N: 0 +✔ mulgar 1.0.2 ── E: 0 | W: 0 | N: 0 +I REPPlab 0.9.6 ── E: 1 | W: 0 | N: 0 +✔ spinifex 0.3.7.0 ── E: 0 | W: 0 | N: 0 ✔ woylier 0.0.5 ── E: 0 | W: 0 | N: 0 -OK: 12 +OK: 12 BROKEN: 0 -Total time: 13 min - -REPPlab cannot be fully checked because it uses RJava, which is difficult to install at present. REPPlab doesn't Depend, but only Suggests, the tourr package. diveR appears to be a helper package for interactive graphics but it fails to load properly for me, so I can't easily check the problems. +Total time: 12 min +── REPORT ──────────────────────────────────────────────────── From 6cad25d84158eb180c19d87c46cb887ad3d82ff3 Mon Sep 17 00:00:00 2001 From: dicook Date: Sat, 20 Apr 2024 09:34:55 +1000 Subject: [PATCH 13/17] added rhub check --- .github/workflows/rhub.yaml | 95 +++++++++++++++++++++++++++++++++++++ R/interesting-indices.r | 4 +- man/norm_bin.Rd | 4 +- 3 files changed, 99 insertions(+), 4 deletions(-) create mode 100644 .github/workflows/rhub.yaml diff --git a/.github/workflows/rhub.yaml b/.github/workflows/rhub.yaml new file mode 100644 index 00000000..74ec7b05 --- /dev/null +++ b/.github/workflows/rhub.yaml @@ -0,0 +1,95 @@ +# R-hub's generic GitHub Actions workflow file. It's canonical location is at +# https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml +# You can update this file to a newer version using the rhub2 package: +# +# rhub::rhub_setup() +# +# It is unlikely that you need to modify this file manually. + +name: R-hub +run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}" + +on: + workflow_dispatch: + inputs: + config: + description: 'A comma separated list of R-hub platforms to use.' + type: string + default: 'linux,windows,macos' + name: + description: 'Run name. You can leave this empty now.' + type: string + id: + description: 'Unique ID. You can leave this empty now.' + type: string + +jobs: + + setup: + runs-on: ubuntu-latest + outputs: + containers: ${{ steps.rhub-setup.outputs.containers }} + platforms: ${{ steps.rhub-setup.outputs.platforms }} + + steps: + # NO NEED TO CHECKOUT HERE + - uses: r-hub/actions/setup@v1 + with: + config: ${{ github.event.inputs.config }} + id: rhub-setup + + linux-containers: + needs: setup + if: ${{ needs.setup.outputs.containers != '[]' }} + runs-on: ubuntu-latest + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.containers) }} + container: + image: ${{ matrix.config.container }} + + steps: + - uses: r-hub/actions/checkout@v1 + - uses: r-hub/actions/platform-info@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/actions/setup-deps@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/actions/run-check@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + + other-platforms: + needs: setup + if: ${{ needs.setup.outputs.platforms != '[]' }} + runs-on: ${{ matrix.config.os }} + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.platforms) }} + + steps: + - uses: r-hub/actions/checkout@v1 + - uses: r-hub/actions/setup-r@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} + - uses: r-hub/actions/platform-info@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/actions/setup-deps@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} + - uses: r-hub/actions/run-check@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} diff --git a/R/interesting-indices.r b/R/interesting-indices.r index 49f6d234..3cb1997d 100644 --- a/R/interesting-indices.r +++ b/R/interesting-indices.r @@ -44,8 +44,8 @@ splines2d <- function() { #' #' Compares the similarity between the projected distribution and a normal distribution. #' \itemize{ -#' \item{norm_bin }{compares the count in 100 histogram bins} -#' \item{norm_kol }{compares the cdf based on the Kolmogorov–Smirnov test (KS test)} +#' \item norm_bin: compares the count in 100 histogram bins +#' \item norm_kol: compares the cdf based on the Kolmogorov–Smirnov test (KS test) #' } #' @param nr The number of rows in the target matrix #' diff --git a/man/norm_bin.Rd b/man/norm_bin.Rd index dcf0faac..390c2045 100644 --- a/man/norm_bin.Rd +++ b/man/norm_bin.Rd @@ -15,8 +15,8 @@ norm_kol(nr) \description{ Compares the similarity between the projected distribution and a normal distribution. \itemize{ -\item{norm_bin }{compares the count in 100 histogram bins} -\item{norm_kol }{compares the cdf based on the Kolmogorov–Smirnov test (KS test)} +\item norm_bin: compares the count in 100 histogram bins +\item norm_kol: compares the cdf based on the Kolmogorov–Smirnov test (KS test) } } \examples{ From 94b35816ba76a7885db61489fcf1c8258164dc4d Mon Sep 17 00:00:00 2001 From: dicook Date: Wed, 26 Jun 2024 00:23:45 +1000 Subject: [PATCH 14/17] only change to norm_bin docus --- man/anomaly_index.Rd | 12 +++++++ man/guided_anomaly_tour.Rd | 67 ++++++++++++++++++++++++++++++++++++++ man/mahal_dist.Rd | 18 ++++++++++ man/norm_bin.Rd | 4 +-- 4 files changed, 99 insertions(+), 2 deletions(-) create mode 100644 man/anomaly_index.Rd create mode 100644 man/guided_anomaly_tour.Rd create mode 100644 man/mahal_dist.Rd diff --git a/man/anomaly_index.Rd b/man/anomaly_index.Rd new file mode 100644 index 00000000..299c5b01 --- /dev/null +++ b/man/anomaly_index.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/anomaly-pursuit.r +\name{anomaly_index} +\alias{anomaly_index} +\title{Anomaly index.} +\usage{ +anomaly_index() +} +\description{ +Calculates an index that looks for the best projection of +observations that are outside a pre-determined p-D ellipse. +} diff --git a/man/guided_anomaly_tour.Rd b/man/guided_anomaly_tour.Rd new file mode 100644 index 00000000..a9e81f27 --- /dev/null +++ b/man/guided_anomaly_tour.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tour-guided-anomaly.r +\name{guided_anomaly_tour} +\alias{guided_anomaly_tour} +\title{A guided anomaly tour path.} +\usage{ +guided_anomaly_tour( + index_f, + d = 2, + alpha = 0.5, + cooling = 0.99, + max.tries = 25, + max.i = Inf, + ellipse, + ellc = NULL, + ellmu = NULL, + search_f = search_geodesic, + ... +) +} +\arguments{ +\item{index_f}{the section pursuit index function to optimise. The function +needs to take two arguments, the projected data, indexes of anomalies.} + +\item{d}{target dimensionality} + +\item{alpha}{the initial size of the search window, in radians} + +\item{cooling}{the amount the size of the search window should be adjusted +by after each step} + +\item{max.tries}{the maximum number of unsuccessful attempts to find +a better projection before giving up} + +\item{max.i}{the maximum index value, stop search if a larger value is found} + +\item{ellipse}{pxp variance-covariance matrix defining ellipse, default NULL. +Useful for comparing data with some hypothesized null.} + +\item{ellc}{This can be considered the equivalent of a critical value, used to +scale the ellipse larger or smaller to capture more or fewer anomalies. Default 3.} + +\item{ellmu}{This is the centre of the ellipse corresponding to the mean of the +normal population. Default vector of 0's} + +\item{search_f}{the search strategy to use} + +\item{...}{arguments sent to the search_f} +} +\description{ +The guided anomaly tour is a variation of the guided tour that is +using an ellipse to determine anomalies on which to select target planes. +} +\details{ +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}}, +\code{\link{save_history}} or \code{\link{render}}. +} +\examples{ +animate_xy(flea[, 1:6], guided_anomaly_tour(anomaly_index(), + ellipse=cov(flea[,1:6])), ellipse=cov(flea[,1:6]), axes="off") +} +\seealso{ +\code{\link{slice_index}} for an example of an index functions. +\code{\link{search_geodesic}}, \code{\link{search_better}}, + \code{\link{search_better_random}} for different search strategies +} diff --git a/man/mahal_dist.Rd b/man/mahal_dist.Rd new file mode 100644 index 00000000..7a67a42b --- /dev/null +++ b/man/mahal_dist.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linear-algebra.r +\name{mahal_dist} +\alias{mahal_dist} +\title{Calculate the Mahalanobis distance between points and center.} +\usage{ +mahal_dist(x, vc) +} +\arguments{ +\item{x}{matrix of data} + +\item{vc}{pre-determined variance-covariance matrix} +} +\description{ +Computes the Mahalanobis distance using a provided variance-covariance +matrix of observations from 0. +} +\keyword{algebra} diff --git a/man/norm_bin.Rd b/man/norm_bin.Rd index 390c2045..1a7376f9 100644 --- a/man/norm_bin.Rd +++ b/man/norm_bin.Rd @@ -14,11 +14,11 @@ norm_kol(nr) } \description{ Compares the similarity between the projected distribution and a normal distribution. -\itemize{ +} +\details{ \item norm_bin: compares the count in 100 histogram bins \item norm_kol: compares the cdf based on the Kolmogorov–Smirnov test (KS test) } -} \examples{ # manually compute the norm_kol index # create the index function From b34d651a885f2829683af5622bc4a928c7c9537f Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 4 Jul 2024 18:32:42 +1000 Subject: [PATCH 15/17] documentation changes --- DESCRIPTION | 2 +- R/tour-guided-anomaly.r | 2 +- man/guided_anomaly_tour.Rd | 2 +- man/norm_bin.Rd | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ded28be4..9f3f8ca9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,6 +39,6 @@ License: MIT + file LICENSE LazyData: true URL: https://github.com/ggobi/tourr BugReports: https://github.com/ggobi/tourr/issues -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Encoding: UTF-8 VignetteBuilder: knitr diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index 0271b93d..914806a5 100644 --- 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 diff --git a/man/guided_anomaly_tour.Rd b/man/guided_anomaly_tour.Rd index a9e81f27..4b182c51 100644 --- a/man/guided_anomaly_tour.Rd +++ b/man/guided_anomaly_tour.Rd @@ -53,7 +53,7 @@ using an ellipse to determine anomalies on which to select target planes. } \details{ 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}}. } \examples{ diff --git a/man/norm_bin.Rd b/man/norm_bin.Rd index 1a7376f9..390c2045 100644 --- a/man/norm_bin.Rd +++ b/man/norm_bin.Rd @@ -14,11 +14,11 @@ norm_kol(nr) } \description{ Compares the similarity between the projected distribution and a normal distribution. -} -\details{ +\itemize{ \item norm_bin: compares the count in 100 histogram bins \item norm_kol: compares the cdf based on the Kolmogorov–Smirnov test (KS test) } +} \examples{ # manually compute the norm_kol index # create the index function From 3822a8a45ab9d6c1b153bb361f2a143c23de0ef4 Mon Sep 17 00:00:00 2001 From: dicook Date: Thu, 4 Jul 2024 19:22:53 +1000 Subject: [PATCH 16/17] axis labels option and extreme points option --- DESCRIPTION | 2 +- NEWS.md | 5 +++++ R/display-density2d.r | 6 ++++-- R/display-groupxy.r | 6 ++++-- R/display-pca.r | 6 ++++-- R/display-sage.R | 6 ++++-- R/display-slice.r | 6 ++++-- R/display-trails.r | 5 +++-- R/display-xy.r | 21 +++++++++++++++++---- R/tour-guided-anomaly.r | 2 +- man/display_density2d.Rd | 3 +++ man/display_groupxy.Rd | 3 +++ man/display_pca.Rd | 3 +++ man/display_sage.Rd | 3 +++ man/display_slice.Rd | 3 +++ man/display_trails.Rd | 3 +++ man/display_xy.Rd | 6 ++++++ man/draw_tour_axes.Rd | 4 ++++ 18 files changed, 75 insertions(+), 18 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9f3f8ca9..acab6915 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tourr Title: Tour Methods for Multivariate Data Visualisation -Version: 1.2.0 +Version: 1.2.1 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")), diff --git a/NEWS.md b/NEWS.md index d9b89378..003b3d2c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# tourr 1.2.1 + +* anomaly tour is initialised with a random basis +* option to label only long axes + # tourr 1.2.0 * major change: rescale is now FALSE by default. diff --git a/R/display-density2d.r b/R/display-density2d.r index b2f9f90d..274668da 100644 --- 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 index c72cbaaf..d7c6d54b 100644 --- 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 index e898c2cf..abda235d 100644 --- 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 index 10c456e0..05ad631b 100644 --- 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 index 2628ede9..face3924 100644 --- 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 index 1688626c..01b24d0f 100644 --- 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 index a4ef5075..4c83afd7 100644 --- 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.3) + labels[i] <- "" + } + } text(adj(proj[, 1]), adj(proj[, 2]), label = labels, col = axis.text.col) } diff --git a/R/tour-guided-anomaly.r b/R/tour-guided-anomaly.r index 914806a5..5260c775 100644 --- a/R/tour-guided-anomaly.r +++ b/R/tour-guided-anomaly.r @@ -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 index 1f6a5ac4..1f1ca49e 100644 --- a/man/display_density2d.Rd +++ b/man/display_density2d.Rd @@ -15,6 +15,7 @@ display_density2d( contour_quartile = c(0.25, 0.5, 0.75), edges = NULL, palette = "Zissou 1", + axislablong = FALSE, ... ) @@ -42,6 +43,8 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_density2d}}} diff --git a/man/display_groupxy.Rd b/man/display_groupxy.Rd index 0db34e08..c6c15ddb 100644 --- a/man/display_groupxy.Rd +++ b/man/display_groupxy.Rd @@ -19,6 +19,7 @@ display_groupxy( plot_xgp = TRUE, palette = "Zissou 1", shapeset = c(15:17, 23:25), + axislablong = FALSE, ... ) @@ -55,6 +56,8 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{shapeset}{numbers corresponding to shapes in base R points, to use for mapping categorical variable to shapes, default=c(15:17, 23:25)} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_groupxy}}} diff --git a/man/display_pca.Rd b/man/display_pca.Rd index d6a40958..bb3f75e7 100644 --- a/man/display_pca.Rd +++ b/man/display_pca.Rd @@ -16,6 +16,7 @@ display_pca( edges = NULL, edges.col = "black", palette = "Zissou 1", + axislablong = FALSE, ... ) @@ -46,6 +47,8 @@ principal components. This is required.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_slice}}} diff --git a/man/display_sage.Rd b/man/display_sage.Rd index 66202f94..7a37b7d0 100644 --- a/man/display_sage.Rd +++ b/man/display_sage.Rd @@ -13,6 +13,7 @@ display_sage( gam = 1, R = NULL, palette = "Zissou 1", + axislablong = FALSE, ... ) @@ -35,6 +36,8 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_sage}}} diff --git a/man/display_slice.Rd b/man/display_slice.Rd index b9574c94..9b297052 100644 --- a/man/display_slice.Rd +++ b/man/display_slice.Rd @@ -20,6 +20,7 @@ display_slice( edges = NULL, edges.col = "black", palette = "Zissou 1", + axislablong = FALSE, ... ) @@ -61,6 +62,8 @@ If NULL (default) the slice will be anchored at the data center.} \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_slice}}} diff --git a/man/display_trails.Rd b/man/display_trails.Rd index 2670b56d..8130fc79 100644 --- a/man/display_trails.Rd +++ b/man/display_trails.Rd @@ -13,6 +13,7 @@ display_trails( pch = 20, cex = 1, past = 3, + axislablong = FALSE, ... ) @@ -37,6 +38,8 @@ If not set, defaults to maximum distance from origin to each row of data.} \item{past}{draw line between current projection and projection \code{past} steps ago} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_xy}}} diff --git a/man/display_xy.Rd b/man/display_xy.Rd index 9e4f331d..fb1eecc5 100644 --- a/man/display_xy.Rd +++ b/man/display_xy.Rd @@ -19,8 +19,10 @@ display_xy( ellipse = NULL, ellc = NULL, ellmu = NULL, + ellmarks = TRUE, palette = "Zissou 1", shapeset = c(15:17, 23:25), + axislablong = FALSE, ... ) @@ -59,11 +61,15 @@ scale the ellipse larger or smaller to capture more or fewer anomalies. Default \item{ellmu}{This is the centre of the ellipse corresponding to the mean of the normal population. Default vector of 0's} +\item{ellmarks}{mark the extreme points with red crosses, default TRUE} + \item{palette}{name of color palette for point colour, used by \code{\link{hcl.colors}}, default "Zissou 1"} \item{shapeset}{numbers corresponding to shapes in base R points, to use for mapping categorical variable to shapes, default=c(15:17, 23:25)} +\item{axislablong}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed on to \code{\link{animate}} and \code{\link{display_xy}}} diff --git a/man/draw_tour_axes.Rd b/man/draw_tour_axes.Rd index a42c5b1f..c73aa71b 100644 --- a/man/draw_tour_axes.Rd +++ b/man/draw_tour_axes.Rd @@ -12,6 +12,7 @@ draw_tour_axes( axis.col = "grey50", axis.lwd = 1, axis.text.col = "grey50", + longlabels, ... ) } @@ -33,6 +34,8 @@ bottomleft or off} \item{axis.text.col}{colour of axes text, default "grey50"} +\item{longlabels}{text labels only for the long axes in a projection, default FALSE} + \item{...}{other arguments passed} } \description{ @@ -53,4 +56,5 @@ plot(flea_prj$V1, flea_prj$V2, 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) } From 061708a6ea3174807b66786baeea347eb47a1ca8 Mon Sep 17 00:00:00 2001 From: dicook Date: Fri, 5 Jul 2024 00:05:06 +1000 Subject: [PATCH 17/17] smaller cutoff for long labels --- R/display-xy.r | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/display-xy.r b/R/display-xy.r index 4c83afd7..54beaa05 100644 --- a/R/display-xy.r +++ b/R/display-xy.r @@ -320,7 +320,7 @@ draw_tour_axes <- function(proj, labels, limits=1, position="center", col = axis.col, lwd = axis.lwd) if (longlabels) { for (i in 1:length(labels)) { - if ((proj[i, 1]^2 + proj[i, 2]^2) < 0.3) + if ((proj[i, 1]^2 + proj[i, 2]^2) < 0.15) labels[i] <- "" } }