mouse callbacks in rgl

user-callbacks.R

library(rgl)


pan3d <- function(button, dev = rgl.cur(), subscene = currentSubscene3d(dev)) {
  start <- list()

  begin <- function(x, y) {
    activeSubscene <- par3d("activeSubscene", dev = dev)
    start$listeners <<- par3d("listeners", dev = dev, subscene = activeSubscene)
    for (sub in start$listeners) {
      init <- par3d(c("userProjection","viewport"), dev = dev, subscene = sub)
      init$pos <- c(x/init$viewport[3], 1 - y/init$viewport[4], 0.5)
      start[[as.character(sub)]] <<- init
    }
  }

  update <- function(x, y) {
    for (sub in start$listeners) {
      init <- start[[as.character(sub)]]
      xlat <- 2*(c(x/init$viewport[3], 1 - y/init$viewport[4], 0.5) - init$pos)
      mouseMatrix <- translationMatrix(xlat[1], xlat[2], xlat[3])
      par3d(userProjection = mouseMatrix %*% init$userProjection, dev = dev, subscene = sub )
    }
  }
  rgl.setMouseCallbacks(button, begin, update, dev = dev, subscene = subscene)
  cat("Callbacks set on button", button, "of rgl device", dev, "in subscene", subscene, "\n")
}

# shade3d(icosahedron3d(), col = "yellow")
# pan3d(2)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Support functions for mouseTrackball
#' Code from rgl/demo/mouseCallbacks.R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
vlen <- function(a) {
  sqrt(sum(a^2))
}

angle <- function(a,b) {
  dot <- sum(a*b)
  acos(dot/vlen(a)/vlen(b))
}

xprod <- function(a, b) {
  c(
    a[2]*b[3] - a[3]*b[2],
    a[3]*b[1] - a[1]*b[3],
    a[1]*b[2] - a[2]*b[1]
  )
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' set the mouse as a trackball
#'
#' Code adapted from rgl/demo/mouseCallbacks.R
#'
#' @param button which button does this apply to?
#' @param dev which device does this apply to?
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mouseTrackball <- function(button = 1, dev = rgl.cur() ) {
  width      <- height <- rotBase <- NULL
  userMatrix <- list()
  cur        <- rgl.cur()

  x0 <- NULL
  y0 <- NULL

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  screenToVector <- function(x, y) {
    radius <- max(width, height)/2
    # centre <- c(width, height)/2
    centre <- c(x0, y0)
    pt     <- (c(x, y) - centre)/radius
    len    <- vlen(pt)

    if (len > 1.e-6) {
      pt <- pt/len
    }

    maxlen <- sqrt(2)
    angle  <- (maxlen - len)/maxlen*pi/2
    z      <- sin(angle)
    len    <- sqrt(1 - z^2)
    pt     <- pt * len

    res <- c(pt, z)

    print(res)


    res
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  trackballBegin <- function(x, y) {

    print("Begin")

    # Save start point
    x0 <<- x
    y0 <<- y

    vp     <- par3d("viewport")
    width  <<- vp[3]
    height <<- vp[4]
    cur    <<- rgl.cur()
    for (i in dev) {
      if (inherits(try(rgl.set(i, TRUE)), "try-error")) dev <<- dev[dev != i]
      else userMatrix[[i]] <<- par3d("userMatrix")
    }
    rgl.set(cur, TRUE)
    rotBase <<- screenToVector(x, height - y)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  trackballUpdate <- function(x,y) {
    cat(x, ",", y, " ", sep='')
    rotCurrent <- screenToVector(x, height - y)
    angle      <- angle(rotBase, rotCurrent)
    axis       <- xprod(rotBase, rotCurrent)

    t_matrix <- translationMatrix(-x0, -y0, 0)
    rot_matrix <- rotationMatrix(angle, axis[1], axis[2], axis[3])
    t2_matrix <- translationMatrix(x0, y0, 0)

    mouseMatrix <- t2_matrix %*% rot_matrix %*% t_matrix

    for (i in dev) {
      if (inherits(try(rgl.set(i, TRUE)), "try-error")) dev <<- dev[dev != i]
      else par3d(userMatrix = mouseMatrix %*% userMatrix[[i]])
    }
    rgl.set(cur, TRUE)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (i in dev) {
    rgl.set(i, TRUE)
    rgl.setMouseCallbacks(button, begin = trackballBegin, update = trackballUpdate, end = NULL,
                          dev = dev)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  rgl.set(cur, TRUE)
}

rgl::rgl.close()
shade3d(icosahedron3d(), col = "yellow")
pan3d(2)
mouseTrackball(1)