用于在绘图中选择点/绘图的套索/涂鸦工具

Question

有时候我想用鼠标在绘制的点周围绘制一个圆形或波浪形的形状来专门选择这些点。有没有人建立功能呢？也许是需要Tcl / tk的东西？

Answer 1

您可以利用locator，然后使用坐标放入圆形绘图功能，如plotrix。然后把它放入一个易于使用的功能：

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'))
  )
}

我最近没有时间扩展的另一种选择

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

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)
  }
}