R/gInteraction.R

In arulesViz: Visualizing Association Rules and Frequent Itemsets

#######################################################################
# arulesViz - Visualizing Association Rules and Frequent Itemsets
# Copyright (C) 2021 Michael Hahsler
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.


## Simple Grid Interactions

## gInteraction class

gInteraction <- function(buttons = data.frame(),
  buttonCol = NULL) {
  if (is.null(buttonCol))
    buttonCol <- c("lightblue", "orange")
  
  #do some checks
  if (!is(buttons, "data.frame"))
    stop("gInteraction expects a data.frame to specify 'buttons'!")
  if (nrow(buttons) > 0) {
    if (any(is.na(match(
      c("active", "y", "x", "w", "h"),
      names(buttons)
    ))))
      stop("gInteraction: 'buttons' does not contain all required information!")
    
    for (f in c("x", "y", "w", "h"))
      if (!is(buttons[, f], "unit"))
        buttons[, f] <- I(unit(buttons[, f], "npc"))
  }
  
  ## last contains the last button pressed
  ## sel contains the current selection
  structure(list(
    buttons = buttons,
    buttonCol = buttonCol,
    lastButton = NULL,
    sel = NULL
  ),
    class = "gInteraction")
}

print.gInteraction <- function(x, ...) {
  writeLines(paste(
    "Object of class 'gInteraction' with",
    nrow(x$buttons),
    "buttons."
  ))
  
  print(t(x$buttons[, "active", drop = FALSE]))
}

## functions for buttons
drawButtons <- function(gI, which = NULL) {
  if (nrow(gI$buttons) < 1)
    return(invisible())
  
  if (!is.null(which))
    gI$buttons <- gI$buttons[which, ]
  for (i in 1:nrow(gI$buttons)) {
    b <- gI$buttons[i, ]
    
    grid.rect(
      x = b$x,
      y = b$y,
      width = b$w,
      height = b$h,
      default.units = "npc",
      gp = gpar(col = gI$buttonCol[b$active + 1L],
        fill = gI$buttonCol[b$active + 1L])
    )
    
    grid.text(
      rownames(b),
      b$x,
      y = b$y,
      default.units = "npc",
      gp = gpar(col = "black")
    )
  }
}

lastButton <- function(gI, activeOnly = TRUE) {
  if (activeOnly && !isActiveButton(gI, gI$lastButton))
    return(NULL)
  else
    return(gI$lastButton)
}

selection <- function(gI)
  gI$sel

isActiveButton <- function(gI, which = NULL) {
  ## fixme: check if button exists
  if (nrow(gI$buttons) < 1)
    return(logical(0))
  
  if (is.null(which))
    which <- rownames(gI$buttons)
  structure(gI$buttons[which, ]$active, names = which)
}

changeButton <- function(gI,
  which = NULL,
  to = NULL,
  redraw = TRUE) {
  ## fixme: check if button exists
  if (nrow(gI$buttons) < 1)
    return(gI$buttons)
  
  if (is.null(which))
    which <- rownames(gI$buttons)
  if (is.null(to))
    to <- !gI$buttons[which, ]$active
  gI$buttons[which, ]$active <- to
  if (redraw)
    drawButtons(gI, which)
  gI
}

resetButtons <- function(gI, redraw = TRUE) {
  gI <- changeButton(gI, to = FALSE, redraw = redraw)
  gI$lastButton <- NULL
  gI$sel <- NULL
  gI
}

whichButton <- function(gI, location) {
  if (nrow(gI$buttons) < 1)
    return(NULL)
  
  ## we need npc
  location$x <- convertX(location$x, "npc", valueOnly = TRUE)
  location$y <- convertY(location$y, "npc", valueOnly = TRUE)
  
  pressed <- NULL
  
  for (i in 1:nrow(gI$buttons)) {
    b <- gI$buttons[i, ]
    
    if (location$x > convertX(b$x, "npc", valueOnly = TRUE)
      - convertX(b$w, "npc", valueOnly = TRUE) / 2
      && location$x < convertX(b$x, "npc", valueOnly = TRUE)
      + convertX(b$w, "npc", valueOnly = TRUE) / 2
      && location$y > convertY(b$y, "npc", valueOnly = TRUE)
      - convertY(b$h, "npc", valueOnly = TRUE) / 2
      && location$y < convertY(b$y, "npc", valueOnly = TRUE)
      + convertY(b$h, "npc", valueOnly = TRUE) / 2) {
      pressed <- rownames(b)
      gI <- changeButton(gI, pressed)
      break
    }
  }
  
  gI$lastButton <- pressed
  
  gI
}

## Selection classes

gPointSelection <- function(loc, col = "red") {
  loc <- convertLoc(loc, "native")
  name <- paste(c("sel", unlist(loc)), collapse = "-")
  
  grid.points(
    x = loc$x,
    y = loc$y,
    pch = 3,
    gp = gpar(col = col, cex = 0.5),
    name = name
  )
  
  structure(list(loc = loc, name = name), class = "gPointSelection")
}

gBoxSelection <- function(loc1,
  loc2,
  box = TRUE ,
  col = "red") {
  if (is(loc1, "gPointSelection"))
    loc1 <- loc1$loc
  if (is(loc2, "gPointSelection"))
    loc2 <- loc2$loc
  
  loc1 <- convertLoc(loc1, "native")
  loc2 <- convertLoc(loc2, "native")
  name <-
    paste(c("sel", unlist(loc1), unlist(loc2)), collapse = "-")
  
  locs <- rbind(unlist(loc1), unlist(loc2))
  x <- sort(locs[, 1])
  y <- sort(locs[, 2])
  
  ## draw box
  if (box)
    grid.rect(
      x = x[1],
      y = y[1],
      width = diff(x),
      height = diff(y),
      default.units = "native",
      just = c("left", "bottom"),
      gp = gpar(
        col = col,
        fill = col,
        alpha = 0.1
      ),
      name = name
    )
  
  structure(list(loc = loc1, loc2 = loc2, name = name), class = "gBoxSelection")
}

## S3 dispatch for filterSelection
filterSelection <- function(sel, ...)
  UseMethod("filterSelection")

foo.default <- function(sel, ...)
  stop("Unknown gSelection type!")

filterSelection.gBoxSelection <- function(sel, x, ...) {
  locs <- rbind(unlist(convertLoc(sel$loc, "native", valueOnly = TRUE)),
    unlist(convertLoc(sel$loc2, "native", valueOnly = TRUE)))
  
  x[, 1] >= min(locs[, "x"]) & x[, 1] <= max(locs[, "x"]) &
    x[, 2] >= min(locs[, "y"]) & x[, 2] <= max(locs[, "y"])
}

filterSelection.gPointSelection <-
  function(sel, x, sensitivity = 0.01, ...) {
    loc1 <- sel$loc
    loc1$x <- loc1$x - unit(sensitivity, "npc")
    loc1$y <- loc1$y + unit(sensitivity, "npc")
    loc2 <- sel$loc
    loc2$x <- loc2$x + unit(sensitivity, "npc")
    loc2$y <- loc2$y - unit(sensitivity, "npc")
    
    filterSelection(gBoxSelection(loc1, loc2, box = FALSE), x)
  }

clearSelection <- function(sel, redraw = TRUE) {
  ## make box invisible
  ## maybe the is a way to use its own viewport for selections
  grid.edit(sel$name, gp = gpar(alpha = 0), redraw = redraw)
}

## identifyer
gIdentify <- function(gI, checkPlotBoundaries = TRUE) {
  location <- grid.locator("npc")
  if (!is.null(gI$sel)) {
    clearSelection(gI$sel)
    gI$sel <- NULL
  }
  
  if (checkPlotBoundaries && !insidePlot(location))
    return(gI)
  
  gI$sel <- gPointSelection(location)
  gI
}

## simple event loop
gGetEvent <- function(gI,
  box = TRUE,
  checkPlotBoundaries = TRUE) {
  while (TRUE) {
    location <- grid.locator("npc")
    gI <- whichButton(gI, location)
    b <- gI$lastButton
    
    if (!is.null(b)) {
      ## buttons
      if (isActiveButton(gI, b))
        return(gI)
      
    } else{
      ## selection
      if (checkPlotBoundaries && !insidePlot(location))
        next
      
      if (is(gI$sel, "gPointSelection") && !box) {
        clearSelection(gI$sel)
        gI$sel <- NULL
      }
      
      if (is(gI$sel, "gBoxSelection")) {
        clearSelection(gI$sel)
        gI$sel <- NULL
      }
      
      if (is.null(gI$sel)) {
        ## point
        gI$sel <- gPointSelection(location)
        
      } else if (is(gI$sel, "gPointSelection")) {
        ## box
        clearSelection(gI$sel, redraw = FALSE)
        gI$sel <- gBoxSelection(gI$sel, location)
      }
    }
  }
}


## location helpers
convertLoc <- function(location,
  unitTo = NULL,
  valueOnly = FALSE) {
  if (is.null(location))
    return(NULL)
  
  if (!is.null(unitTo)) {
    location$x <- convertX(location$x, unitTo)
    location$y <- convertY(location$y, unitTo)
  }
  
  if (valueOnly)
    location <- lapply(location, as.numeric)
  
  location
}

insidePlot <-
  function(location)
    all(sapply(
      convertLoc(location, "npc",
        valueOnly = TRUE),
      FUN = function(z)
        z >= 0 && z <= 1
    ))