/
display-groupxy.r
172 lines (159 loc) · 6.23 KB
/
display-groupxy.r
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
#' Display 2D tour projections displayed separately by groups
#'
#' This function is designed to allow comparisons across multiple groups,
#' especially for examining things like two (or more) different models
#' on the same data. The primary display is a scatterplot, with lines or
#' contours overlaid.
#'
#' @param axes position of the axes: center, bottomleft or off
#' @param centr if TRUE, centers projected data to (0,0). This pins the
#' center of data cloud and make it easier to focus on the changing shape
#' rather than position.
#' @param half_range half range to use when calculating limits of projected.
#' If not set, defaults to maximum distance from origin to each row of data.
#' @param edges A two column integer matrix giving indices of ends of lines.
#' @param col color to use for points, can be a vector or hexcolors or a factor. Defaults to "black".
#' @param pch shape of the point to be plotted. Defaults to 20.
#' @param cex size of the point to be plotted. Defaults to 1.
#' @param group_by variable to group by. Must have less than 25 unique values.
#' @param plot_xgp if TRUE, plots points from other groups in light grey
#' @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
#' @examples
#' animate_groupxy(flea[, 1:6], col = flea$species,
#' pch = flea$species, group_by = flea$species)
#' animate_groupxy(flea[, 1:6], col = flea$species,
#' pch = flea$species, group_by = flea$species,
#' plot_xgp = FALSE)
#' # Edges example
#' x <- data.frame(x1=runif(10, -1, 1), x2=runif(10, -1, 1), x3=runif(10, -1, 1))
#' x$cl <- factor(c(rep("A", 3), rep("B", 3), rep("C", 4)))
#' x.edges <- cbind(from=c(1,2, 4,5, 7,8,9), to=c(2,3, 5,6, 8,9,10))
#' x.edges.col <- factor(c(rep("A", 2), rep("B", 2), rep("C", 3)))
#' animate_groupxy(x[,1:3], col=x$cl, group_by=x$cl, edges=x.edges, edges.col=x.edges.col)
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), ...) {
labels <- NULL
# If colors are a variable, convert to colors
if (is.factor(col) | !areColors(col)) {
gps <- col
col <- mapColors(col, palette)
}
if (is.factor(edges.col) | !areColors(edges.col)) {
edges.gps <- edges.col
edges.col <- mapColors(edges.col, palette)
}
# If shapes are a variable, convert shapes
if (is.factor(pch)) {
shapes <- mapShapes(pch, shapeset)
} else {
shapes <- pch
}
init <- function(data) {
half_range <<- compute_half_range(half_range, data, centr)
labels <<- abbreviate(colnames(data), 3)
}
if (!is.null(edges)) {
if (!is.matrix(edges) && ncol(edges) >= 2) {
stop("Edges matrix needs two columns, from and to, only.")
}
}
render_frame <- function() {
par(pty = "s", mar = rep(0.1, 4))
}
render_transition <- function() {
rect(-1, -1, 1, 1, col = "#FFFFFFE6", border = NA)
}
render_data <- function(data, proj, geodesic) {
gps <- unique(group_by)
ngps <- length(gps)
edge.gps <- unique(edges.col)
if (ngps > 24) {
stop("Please choose a group with 24 or less levels.\n")
}
grid <- ceiling(sqrt(ngps + 1))
par(mfrow = c(grid, grid))
# Render projected points
x <- data %*% proj
if (centr) x <- center(x)
x <- x / half_range
blank_plot(xlim = c(-1, 1), ylim = c(-1, 1))
draw_tour_axes(proj, labels, limits = 1, axes)
# add a legend, only if a variable was used
if (is.factor(gps)) {
numcol <- unique(col)
if (length(numcol) > 1) {
legend("topright", legend=unique(gps),
col=numcol, pch=15)
}
}
if (is.factor(pch)) {
numpch <- unique(shapes)
if (length(numpch) > 1) {
legend("bottomright", legend=unique(pch),
col="black", pch=unique(shapes))
}
}
if (ngps < 2) {
points(x, col = col, pch = shapes, cex = cex, new = FALSE)
if (!is.null(edges)) {
segments(
x[edges[, 1], 1], x[edges[, 1], 2],
x[edges[, 2], 1], x[edges[, 2], 2],
col = edges.col,
lwd = edges.width
)
}
}
else {
for (i in 1:ngps) {
x.sub <- x[group_by == gps[i], ]
col.sub <- if (length(col) == nrow(x)) col[group_by == gps[i]] else col
pch.sub <- if (length(shapes) == nrow(x)) shapes[group_by == gps[i]] else shapes
cex.sub <- if (length(cex) == nrow(x)) cex[group_by == gps[i]] else cex
blank_plot(xlim = c(-1, 1), ylim = c(-1, 1))
if (plot_xgp) {
points(x[group_by != gps[i], ],
col = "#DEDEDEDE", new = FALSE,
shapes = if (length(shapes) > 1) shapes[group_by != gps[i]] else shapes,
cex = if (length(cex) > 1) cex[group_by != gps[i]] else cex
)
}
points(x.sub, col = col.sub, pch = pch.sub, cex = cex.sub, new = FALSE)
# This is potentially fragile!
# It assumes the edge colour groups are the same as the point colour groups
if (!is.null(edges)) {
segments(
x[edges[edges.gps == gps[i], 1], 1], x[edges[edges.gps == gps[i], 1], 2],
x[edges[edges.gps == gps[i], 2], 1], x[edges[edges.gps == gps[i], 2], 2],
col = edges.col[edges.gps == gps[i]],
lwd = edges.width
)
}
}
}
}
list(
init = init,
render_frame = render_frame,
render_transition = render_transition,
render_data = render_data,
render_target = nul
)
}
#' @rdname display_groupxy
#' @inheritParams animate
#' @export
animate_groupxy <- function(data, tour_path = grand_tour(), ...) {
animate(data, tour_path, display_groupxy(...))
par(mfrow = c(1, 1))
}