lasso/doodler tool for selecting points/drawing inside a plot - r

Question

Sometimes I would like to use a mouse to draw a circle or squiggly shape around my plotted points to select these points specifically. Has anyone built functionality to do this yet? Perhaps something requiring Tcl/tk?

Answer 1

You could take advantage of locator, and then use the coordinates to put into a circle drawing function like from plotrix. Then put it into a function for ease of use:
plot(rnorm(100))
click.shape('circle', border = 'red', col = NA)
click.shape <- function(shape = c('circle', 'arrow', 'rect', 'cyl', 'line', 'poly'),
corners = 3L, ...) {
shape <- match.arg(shape)
coords <- if (shape %in% 'poly')
locator(as.integer(corners)) else unlist(locator(2L))
ARROW <- function(...) {
arrows(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
CIRCLE <- function(...) {
require(plotrix)
rad <- sqrt(((coords[2L] - coords[1L]) ^ 2) + ((coords[4L] - coords[3L]) ^ 2))
draw.circle(coords[1L], coords[3L], radius = rad, ...)
}
CYL <- function(...) {
require(plotrix)
cylindrect(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
LINE <- function(...) {
segments(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
POLY <- function(...) {
polygon(coords, ...)
}
RECT <- function(...) {
rect(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
suppressWarnings(
switch(shape, arrow = ARROW(...), circle = CIRCLE(...), cyl = CYL(...),
line = LINE(...), poly = POLY(...), rect = RECT(...),
stop('Invalid shape'))
)
}
Another option which I haven't had time lately to expand
set.seed(1618)
x <- runif(10)
y <- rnorm(10, mean = 5)
par(mfrow = c(1, 2))
plot(x, y, xlab = 'mean', ylab = 'sd')
zoomin(x, y)
## ESC to quit
code for zoomin
zoomin <- function(x, y, ...) {
op <- par(no.readonly = TRUE)
on.exit(par(op))
ans <- identify(x, y, n = 1, plot = FALSE, ...)
zoom <- function (x, y, xlim, ylim, xd, yd) {
rxlim <- x + c(-1, 1) * (diff(range(xd)) / 20)
rylim <- y + c(-1, 1) * (diff(range(yd)) / 20)
par(mfrow = c(1, 2))
plot(xd, yd, xlab = 'mean', ylab = 'sd')
xext <- yext <- rxext <- ryext <- 0
if (par('xaxs') == 'r') {
xext <- diff(xlim) * 0.04
rxext <- diff(rxlim) * 0.04
}
if (par('yaxs') == 'r') {
yext <- diff(ylim) * 0.04
ryext <- diff(rylim) * 0.04
}
rect(rxlim[1] - rxext, rylim[1] - ryext, rxlim[2] + rxext, rylim[2] + ryext)
xylim <- par('usr')
xypin <- par('pin')
rxi0 <- xypin[1] * (xylim[2] - (rxlim[1] - rxext)) / diff(xylim[1:2])
rxi1 <- xypin[1] * (xylim[2] - (rxlim[2] + rxext)) / diff(xylim[1:2])
y01i <- xypin[2] * (xylim[4] - (rylim[2] + ryext)) / diff(xylim[3:4])
y02i <- xypin[2] * ((rylim[1] - ryext) - xylim[3]) / diff(xylim[3:4])
mu <- x
curve(dnorm(x, mean = mu, sd = y), from = -4 * y + mu, to = 4 * y + mu,
xlab = paste('mean:', round(mu, 2), ', sd: ', round(y, 2)), ylab = '')
xypin <- par('pin')
par(xpd = NA)
xylim <- par('usr')
xymai <- par('mai')
x0 <- xylim[1] - diff(xylim[1:2]) * (xymai[2] + xymai[4] + rxi0)/xypin[1]
x1 <- xylim[1] - diff(xylim[1:2]) * (xymai[2] + xymai[4] + rxi1)/xypin[1]
y01 <- xylim[4] - diff(xylim[3:4]) * y01i/xypin[2]
y02 <- xylim[3] + diff(xylim[3:4]) * y02i/xypin[2]
par(xpd = TRUE)
xend <- xylim[1] - diff(xylim[1:2]) * xymai[2] / (2 * xypin[1])
xprop0 <- (xylim[1] - xend) / (xylim[1] - x0)
xprop1 <- (xylim[2] - xend) / (xylim[2] - x1)
par(xpd = NA)
segments(c(x0, x0, x1, x1),
c(y01, y02, y01, y02),
c(xend, xend, xend, xend),
c(xylim[4] - (xylim[4] - y01) * xprop0,
xylim[3] + (y02 - xylim[3]) * xprop0,
xylim[4] - (xylim[4] - y01) * xprop1,
xylim[3] + (y02 - xylim[3]) * xprop1))
par(mfg = c(1, 1))
plot(xd, yd, xlab = 'mean', ylab = 'sd')
}
if(length(ans)) {
zoom(x[ans], y[ans], range(x), range(y), x, y)
points(x[ans], y[ans], pch = 19)
zoomin(x, y)
}
}