R/qscatter.R

In ggobi/cranvas: Interactive statistical graphics based on Qt

#' Draw a scatter plot
#'
#' This function creates a scatter plot with two numeric variables. It supports
#' colors and sizes generated by \code{\link{qdata}}. When the sizes are not the
#' same, a scatter plot becomes what is called the ``bubble chart''.
#'
#' All the common interactions like brushing and deleting are documented in
#' \code{\link{common_key_press}}.
#'
#' In the identify mode, the plot will show the row id(s) of the identified
#' point(s) as well as \code{x} and \code{y} values.
#'
#' Arrow keys are used in scatter plots for interactions: without the
#' \code{Shift} key, \code{Up} and \code{Down} will increase/decrease the sizes
#' of points; with the \code{Shift} key being pressed, \code{Up}, \code{Down},
#' \code{Left} and \code{Right} will move the (background of) plot to the
#' corresponding direction.
#'
#' Mouse wheel is used to zoom in and zoom out the plot. Together with keyboard
#' interactions, this will enable us to see details in data.
#' @param x the name of the x variable
#' @param y the name of the y variable (if missing, \code{x} will be plotted
#'   against its indices, i.e., \code{y} will become \code{x} and \code{x} will
#'   be indices)
#' @param edges matrix of two columns to indicate which lines to connect
#' @inheritParams qbar
#' @param asp aspect ratio (ratio of the physical height of a plot to its width;
#'   unlike other R graphics systems, this will \emph{not} affect the ranges of
#'   axes)
#' @return A scatter plot
#' @author Heike Hofmann, Di Cook, Yihui Xie
#' @note Using more than one color (including border colors) can lead to serious
#'   speed issues; this plot is fastest when we only use a single color and a
#'   single size. As the number of unique colors increases, the plotting can be
#'   slower based on a same dataset. Using more than one size is also slower
#'   than using a single size for all points; the internal painting functions
#'   are different for the two cases (\code{\link[qtpaint]{qdrawCircle}} for the
#'   former, and \code{\link[qtpaint]{qdrawGlyph}} for the latter).
#' @export
#' @example inst/examples/qscatter-ex.R
qscatter = function(x, y, data, edges=NULL, main = '', xlim = NULL, ylim = NULL,
                    xlab = NULL, ylab = NULL, asp = 1, alpha = 1, unibrushcolor = TRUE) {

  data = check_data(data)
  b = brush(data)
  z = as.list(match.call()[-1])

  # initialize meta
  meta = Scat.meta$new(
    xvar = as.character(z$x), yvar = as.character(z$y), active = TRUE,
    xy = matrix(nrow = nrow(data), ncol = 2), alpha = alpha, main = main,
    asp = asp, minor = 'xy', samesize = near_constant(data$.size)
  )
  # set default xlab/ylab if not provided
  if (is.null(xlab)) meta$xlab = meta$xvar
  if (is.null(ylab)) meta$ylab = meta$yvar
  # users may provide expressions not in data, e.g. x = 'foo'; qscatter(x)
  if (!(meta$xvar %in% names(data))) meta$xvar = x
  if (!(meta$yvar %in% names(data))) meta$yvar = y

  # tour: color, size, transparency could be decided by proj3
  if ('proj3' %in% colnames(data)) {
    if (which(colnames(data) == 'proj3')[1] > which(colnames(data) == '.border')) {
      dim3 = c('proj1','proj2','proj3')
      meta$dim3 = dim3[! (dim3 %in% c(meta$xvar, meta$yvar))][1]
    }
  }

  ## reorder the points according to color/border for drawing speed
  compute_order = function() {
    meta$order = if (length(meta$dim3)) {
      order(data[,meta$dim3], decreasing=TRUE)
    } else {
      order(data$.color, data$.border)  # the ideal order to draw
    }
  }
  compute_order()

  update_limits = function(r) {
    # r is new range of limits - 2 by 2 matrix
    meta$limits = r
    meta$xlabels = format(meta$xat <- axis_loc(r[, 1]))
    meta$ylabels = format(meta$yat <- axis_loc(r[, 2]))
    meta$xlab = if (is.null(xlab)) meta$xvar else xlab
    meta$ylab = if (is.null(ylab)) meta$yvar else ylab
  }

  ## compute coordinates/axes-related stuff
  compute_coords = function() {
    if (is.null(z$y)) {
      meta$yvar = meta$xvar  # when y is missing, make it x
      meta$xvar = 'index'
      meta$xy[, 1] = seq(sum(idx))
    } else {
      meta$xy[, 1] = data[, meta$xvar]
    }
    meta$xy[, 2] = data[, meta$yvar]
    idx = visible(data)[meta$order]
    if (all(!idx)) idx = !idx # if you hide all the data, use original limits
    x = meta$xy[idx, 1]; meta$xlim = range(x, na.rm = TRUE, finite = TRUE)
    y = meta$xy[idx, 2]; meta$ylim = range(y, na.rm = TRUE, finite = TRUE)
    r = cbind(if (is.null(xlim)) meta$xlim else xlim,
              if (is.null(ylim)) meta$ylim else ylim)
    update_limits(extend_ranges(r))
  }
  compute_coords()

  ## aesthetics (colors)
  compute_aes = function() {
    ord = meta$order; idx = visible(data)[ord]  # reorder aesthetics according to vis
    meta$color = data$.color[ord][idx]; meta$border = data$.border[ord][idx]
    meta$size = data$.size[ord][idx]
    if (length(meta$dim3)) {
      dim3scale = rescale_range(data[ord,meta$dim3][idx], c(0.99, 0.33))
      meta$color = alpha(meta$color, dim3scale)
      meta$border = alpha(meta$border, dim3scale)
    #  meta$size = meta$size * dim3scale
    }
    if (length(unique(meta$color)) == 1) meta$color = meta$color[1]
    if (length(unique(meta$border)) == 1) meta$border = meta$border[1]
    if (meta$samesize) meta$size = meta$size[1]
  }
  compute_aes()

  ## initialize brush size (1/15 of the layer size)
  meta$brush.size = c(1, -1) * apply(meta$limits, 2, diff) / 15
  b$alpha = alpha

  ## draw points
  main_draw = function(layer, painter) {
    ord = meta$order; idx = visible(data)[ord]
    stroke = meta$border
    fill = meta$color
    if (meta$alpha < 1) {
      # adjust colors
      stroke = alpha(stroke, meta$alpha); fill = alpha(fill, meta$alpha)
    }
    if (meta$samesize) {
      qdrawGlyph(painter, qglyphCircle(r = meta$size),
                 meta$xy[ord, 1][idx], meta$xy[ord, 2][idx],
                 stroke = stroke, fill = fill)
    } else {
      qdrawCircle(painter, meta$xy[ord, 1][idx], meta$xy[ord, 2][idx], r = meta$size,
                  stroke = stroke, fill = fill)
    }
    if (!is.null(edges)) {
      qdrawSegment(painter, meta$xy[ord[edges[, 1]], 1][idx], meta$xy[ord[edges[, 1]], 2][idx], 
                   meta$xy[ord[edges[, 2]], 1][idx], meta$xy[ord[edges[, 2]], 2][idx], 
                   stroke=stroke)
    }
    if (!is.null(bd <- bound_seg(meta)))
      qdrawSegment(painter, bd[, 1], bd[, 2], bd[, 3], bd[, 4], stroke = "red")
    meta$brush.adj = one_pixel(painter) * min(meta$size)
  }

  ## draw brushed points
  brush_draw = function(layer, painter) {
    idx = selected(data) & visible(data)
    if (any(idx)) {
      if (unibrushcolor) {
        fill_color = b$color
      } else {
          fill_color = alpha('grey90',0.1)
          idx = !idx
          b$size = 1
      }
      fill_color = alpha(fill_color, b$alpha)
      if (meta$samesize) {
        qdrawGlyph(painter, qglyphCircle(r = sqrt(b$size) * meta$size),
                   meta$xy[idx, 1], meta$xy[idx, 2],
                   stroke = fill_color, fill = fill_color)
      } else {
        qdrawCircle(painter, meta$xy[idx, 1], meta$xy[idx, 2],
                    r = sqrt(b$size) * data$.size[idx],
                    stroke = fill_color, fill = fill_color)
      }
    }
    draw_brush(layer, painter, data, meta)
  }

  ## events
  brush_mouse_press = function(layer, event) {
    common_mouse_press(layer, event, data, meta)
  }

  tree = createTree(meta$xy)  # build a search tree
  brush_mouse_move = function(layer, event) {
    rect = update_brush_size(meta, event)
    rect[1, ] = rect[1, ] - meta$brush.adj
    rect[2, ] = rect[2, ] + meta$brush.adj
    if (!(b$select.only && b$draw.brush)) {
      hits = rectLookup(tree, rect[1, ], rect[2, ])
      selected(data) = mode_selection(selected(data), hits, mode = b$mode)
    } else qupdate(layer.brush)
    common_mouse_move(layer, event, data, meta)
  }
  brush_mouse_release = function(layer, event) {
    common_mouse_release(layer, event, data, meta)
    brush_mouse_move(layer, event)
  }

  key_press = function(layer, event) run_handler(meta$handlers$keypress, layer, event)
  meta$handlers$keypress = list(function(layer, event) {
    common_key_press(layer, event, data, meta)
    shift = event$modifiers() == Qt$Qt$ShiftModifier
    if (shift && length(i <- which(match_key(c('Left', 'Right', 'Up', 'Down'))))) {
      j = c(1, 1, 2, 2)[i]; k = c(1, -1, -1, 1)[i]
      meta$limits[, j] = extend_ranges(meta$limits[, j], k * c(1, -1) * 0.02)
      update_limits(meta$limits)
      qupdate(layer.grid)
    } else if (length(i <- which(match_key(c('Up', 'Down'))))) {
      ## change size
      data$.size = pmax(0.1, c(1.1, 0.9)[i] * data$.size)
    }
  })

  key_release = function(layer, event) run_handler(meta$handlers$keyrelease, layer, event)
  meta$handlers$keyrelease = list(function(layer, event) {
    common_key_release(layer, event, data, meta)
  })

  mouse_wheel = function(layer, event) {
    pos = as.numeric(event$pos())
    lim = meta$limits
    p = (pos - lim[1, ]) / (lim[2, ] - lim[1, ])  # proportions to left/bottom
    update_limits(extend_ranges(meta$limits,
                                -sign(event$delta()) * 0.1 * c(p[1], 1 - p[1], p[2], 1 - p[2])))
  }
  identify_hover = function(layer, event) {
    if (!b$identify) return()
    b$cursor = 2L
    meta$pos = as.numeric(event$pos())
    rect = as.matrix(identify_rect(meta))
    meta$identified = rectLookup(tree, rect[1, ], rect[2, ])
    qupdate(layer.identify)
  }
  identify_draw = function(layer, painter) {
    if (!b$identify || !length(idx <- meta$identified)) return()
    meta$identify.labels = sprintf(
      'row id: %s\n%s: %s\n%s: %s',
      paste(rownames(data)[idx], collapse = ', '),
      meta$xvar, paste(meta$xy[idx, 1], collapse = ', '),
      meta$yvar, paste(meta$xy[idx, 2], collapse = ', ')
    )
    draw_identify(layer, painter, data, meta)
    if (meta$samesize) {
      qdrawGlyph(painter, qglyphCircle(r = 2 * sqrt(b$size) * meta$size),
                 meta$xy[idx, 1], meta$xy[idx, 2], stroke = b$color, fill = NA)
    } else {
      qdrawCircle(painter, meta$xy[idx, 1], meta[idx, 2],
                  r = sqrt(b$size) * data$.size[idx], stroke = b$color, fill = NA)
    }
  }

  ## create layers
  scene = qscene()
  scene$setItemIndexMethod(Qt$QGraphicsScene$NoIndex)
  layer.root = qlayer(scene)
  layer.main = qlayer(
    paintFun = main_draw,
    mousePressFun = brush_mouse_press, mouseReleaseFun = brush_mouse_release,
    mouseMoveFun = brush_mouse_move, hoverMoveFun = identify_hover,
    keyPressFun = key_press, keyReleaseFun = key_release,
    wheelFun = mouse_wheel,
    focusInFun = function(layer, event) {
      common_focus_in(layer, event, data, meta)
    }, focusOutFun = function(layer, event) {
      common_focus_out(layer, event, data, meta)
    },
    limits = qrect(meta$limits), clip = TRUE, cache = TRUE)
  layer.brush = qlayer(paintFun = brush_draw, limits = qrect(meta$limits))
  layer.identify = qlayer(paintFun = identify_draw, limits = qrect(meta$limits))
  layer.title = qmtext(meta = meta, side = 3, cache = .cache())
  layer.xlab = qmtext(meta = meta, side = 1, cache = .cache())
  layer.ylab = qmtext(meta = meta, side = 2, cache = .cache())
  layer.xaxis = qaxis(meta = meta, side = 1, cache = .cache())
  layer.yaxis = qaxis(meta = meta, side = 2, cache = .cache())
  layer.grid = qgrid(meta = meta, cache = TRUE)
  layer.keys = key_layer(meta)
  layer.root[0, 2] = layer.title
  layer.root[2, 2] = layer.xaxis
  layer.root[3, 2] = layer.xlab
  layer.root[1, 1] = layer.yaxis
  layer.root[1, 0] = layer.ylab
  layer.root[1, 2] = layer.grid
  layer.root[1, 2] = layer.main
  layer.root[1, 2] = layer.brush
  layer.root[1, 2] = layer.identify
  layer.root[1, 2] = layer.keys
  layer.root[1, 3] = qlayer()

  ## set sizes of layers (arrange the layout)
  set_layout = function() {
    fix_dimension(layer.root,
                  row = list(id = c(0, 2, 3), value = c(prefer_height(meta$main),
                                                        prefer_height(meta$xlabels),
                                                        prefer_height(meta$xlab))),
                  column = list(id = c(1, 0, 3), value = c(prefer_width(meta$ylabels),
                                                           prefer_width(meta$ylab, FALSE),
                                                           10)))
  }
  set_layout()

  ## layout is dynamic (listen to changes in xlab/ylab/xlabels/ylabels...)
  meta$mainChanged$connect(set_layout)
  meta$xlabChanged$connect(set_layout); meta$ylabChanged$connect(set_layout)
  meta$xlabelsChanged$connect(set_layout); meta$ylabelsChanged$connect(set_layout)

  ## finally create the view and set window title
  view = qplotView(scene = scene)
  view$setWindowTitle(paste("Scatterplot:", meta$xvar, meta$yvar))
  meta$xvarChanged$connect(function() {
    view$setWindowTitle(paste("Scatterplot:", meta$xvar, meta$yvar))
  })
  if (!is.null(asp)) view$resize(480, 480 * asp)  # aspect ratio

  ## listeners on the data (which column updates which layer(s))
  d.idx = add_listener(data, function(i, j) {
    idx = which(j == c(meta$xvar, meta$yvar, '.brushed', '.visible', '.color', '.border'))
    if (length(idx) < 1) {
      compute_coords(); compute_aes()
      meta$samesize = near_constant(data$.size)
      qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
      qupdate(layer.main)
      return()
    } else idx = c(1, 1, 2, 3, 4, 4)[idx]
    switch(idx, {
      # update at least one of the axes
      compute_coords();
      # maybe check whether tour is on and not change tree in that case ...
      tree <<- createTree(meta$xy)
    }, qupdate(layer.brush), {
      compute_coords(); selected(data)[!visible(data)] = FALSE
    }, {
      compute_order(); compute_aes(); qupdate(layer.main)
    })
  })

  ## when layer is destroyed, remove the listener from data
  qconnect(layer.main, 'destroyed', function(x) {
    ## b$colorChanged$disconnect(b.idx)
    remove_listener(data, d.idx)
  })

  ## when b$cursor is changed, update cursor on screen
  b$cursorChanged$connect(function() {
    set_cursor(view, b$cursor)
  })

  ## these layers have the same limits from meta$limits
  sync_limits(meta, layer.main, layer.brush, layer.identify)

  ## simulate brushing
  meta$manual.brush = function(pos) {
    brush_mouse_move(layer = layer.main, event = list(pos = function() pos))
  }

  ## attach meta to the returned value (for post-processing or debugging)
  ## going to drop this line later
  attr(view, 'meta') = meta
  view
}


Scat.meta = setRefClass( "Scat_meta", contains = "CommonMeta",
  fields = properties(
    list(xvar = 'character', yvar = 'character', order = 'numeric',
         xy = 'matrix', asp = 'numeric', samesize = 'logical', dim3 = 'character')
  )
)

## order is for keeping track of the original order of data