R/scatterplot.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.

.jitter_default <- .5

scatterplot <- function(x,
  measure = c("support", "confidence"),
  shading = "lift",
  control = NULL,
  ...) {
  engines <-
    c("default",
      "ggplot2",
      "base",
      "grid",
      "interactive",
      "plotly",
      "htmlwidget")
  if (control$engine == "help") {
    message("Available engines for this plotting method are:\n",
      paste0(engines, collapse = ", "))
    return(invisible(engines))
  }
  
  m <- pmatch(control$engine, engines, nomatch = 0)
  if (m == 0)
    stop(
      "Unknown engine: ",
      sQuote(control$engine),
      " Valid engines: ",
      paste(sQuote(engines), collapse = ", ")
    )
  control$engine <- engines[m]
  
  if (pmatch(control$engine, c("base"), nomatch = 0) > 0) {
    return(scatterplot_base(
      x,
      measure = measure,
      shading = shading,
      control = control,
      ...
    ))
  }
  
  if (pmatch(control$engine, c("grid", "interactive"), nomatch = 0) > 0) {
    return(scatterplot_grid(
      x,
      measure = measure,
      shading = shading,
      control = control,
      ...
    ))
  }
  
  if (pmatch(control$engine, c("plotly", "htmlwidget"), nomatch = 0) >
      0) {
    return(scatterplot_plotly(
      x,
      measure = measure,
      shading = shading,
      control = control,
      ...
    )) ### control has max
  }
  
  ### default is ggplot2
  return(scatterplot_ggplot2(
    x,
    measure = measure,
    shading = shading,
    control = control,
    ...
  )) ### control has max
  
}

### FIXME: specify colors for rules manually
scatterplot_base <-
  function(x,
    measure = c("support", "confidence"),
    shading = "lift",
    control = NULL,
    ...) {
    addl <- list(...)
    
    control <- .get_parameters(
      control,
      list(
        main = paste("Scatter plot for", length(x), class(x)),
        engine = "base",
        pch = 19,
        col = default_colors(100),
        jitter = NA,
        verbose = addl$verb
      )
    )
    
    ## take control parameters from ...
    o <- pmatch(names(addl), names(control))
    control[o[!is.na(o)]] <- addl[!is.na(o)]
    addl[!is.na(o)] <- NULL
    
    q <- quality(x)
    q$order <- size(x)
    col <- rev(control$col)
    
    ## shading
    if (!is.null(shading)) {
      ## reduce overplotting
      q <- q[order(q[[shading]]), ]
      
      rank <- as.integer(cut(q[[shading]], length(col)))
      col <- col[rank]
    } else
      col <- 1
    
    ## jitter
    qq <- q[measure]
    
    control$jitter <- control$jitter[1]
    if (is.na(control$jitter) && any(duplicated(qq))) {
      message("To reduce overplotting, jitter is added! Use jitter = 0 to prevent jitter or set a value for jitter to supress this message.")
      control$jitter <- .jitter_default
    }
    
    if (!is.na(control$jitter) && control$jitter > 0) {
      qq[, 1] <- jitter(qq[, 1], factor = control$jitter, amount = 0)
      qq[, 2] <- jitter(qq[, 2], factor = control$jitter, amount = 0)
    }
    
    do.call(plot, c(
      list(
        x = qq,
        pch = control$pch,
        col = col,
        main = control$main
      ),
      addl
    ))
  }


scatterplot_grid <-
  function(rules,
    measure = c("support", "confidence"),
    shading = "lift",
    control = NULL,
    ...) {
    control <- c(control, list(...))
    control <- .get_parameters(
      control,
      list(
        main = paste("Scatter plot for", length(rules), class(rules)),
        engine = "default",
        pch = 19,
        cex = .5,
        xlim = NULL,
        ylim = NULL,
        zlim = NULL,
        alpha = NULL,
        col = default_colors(100),
        newpage = TRUE,
        jitter = NA
      )
    )
    
    
    ## set zlim depending on measure...
    ## add order
    #quality(rules) <- cbind(quality(rules), order=size(rules))
    
    if (!is.null(shading)) {
      i <- pmatch(shading, colnames(quality(rules)))
      if (is.na(i))
        stop("Unknown quality measure for shading.")
      shading <- colnames(quality(rules))[i]
      
      ## fix zlim for some known measures!
      if (is.null(control$zlim)) {
        if (shading == "lift")
          control$zlim <- c(min(1, min(quality(rules)["lift"])),
            max(quality(rules)["lift"]))
      }
      
    }
    
    ## call workhorse
    scatterplot_int(rules, measure, shading, control, ...)
    
    if (control$engine != "interactive")
      return(invisible())
    
    ## interactive mode
    cat("Interactive mode.\nSelect a region with two clicks!\n")
    
    ## go to scatterplot viewport
    downViewport("scatterplot")
    
    ## add buttons
    gI <- gInteraction(data.frame(
      row.names = c("inspect", "filter", "zoom in", "zoom out", "end"),
      active = rep(FALSE, 5),
      x = c(0.1, 0.3, 0.5, 0.7, 0.9),
      y = I(rep(unit(-4.5, "lines"), 5)),
      w = I(rep(unit(3.5, "lines"), 5)),
      h = I(rep(unit(1, "lines"), 5))
    ))
    
    drawButtons(gI)
    
    q <- quality(rules)[, c(measure[1], measure[2])]
    sel_r <- rules
    
    while (TRUE) {
      gI <- gGetEvent(gI)
      
      b <- lastButton(gI)
      if (is.null(b))
        next
      
      ## actions
      if (b == "end") {
        ## fixme: is a pop missing?
        cat("Leaving interactive mode (returning selection).\n")
        return(sel_r)
      }
      
      if (b == "filter") {
        if (is.null(shading) || shading == "order") {
          cat("No filtering for order/no shading!\n")
          gI <- changeButton(gI, "filter", FALSE)
          next
        }
        
        cat("Select minimum", shading, "in colorkey.\n")
        seekViewport("colorkey")
        location <- grid.locator()
        if (insidePlot(location)) {
          colSel <- gPointSelection(location)
          sel_r <- rules[quality(rules)[, shading] >=
              convertLoc(colSel$loc, "native", valueOnly = TRUE)$y]
          
          if (length(sel_r) > 1) {
            if (is.null(control$xlim))
              control$xlim <- range(q[, 1])
            if (is.null(control$ylim))
              control$ylim <- range(q[, 2])
            
            ret <- scatterplot_grid(sel_r, measure,
              shading, control)
            if (!identical(ret, "zoom out"))
              return(ret)
            
            ## replot and reset
            scatterplot_int(rules, measure, shading, control, ...)
            downViewport("scatterplot")
            gI <- resetButtons(gI)
            #drawButton(gI)
          } else{
            cat("Not enough rules pass the filter!\n")
          }
        }
        seekViewport("scatterplot")
        gI <- changeButton(gI, "filter", FALSE)
        
      }
      
      if (b == "zoom out") {
        ## fixme: is a pop missing?
        cat("Going up.\n")
        return("zoom out")
      }
      
      ## zoom in if inside selection box
      if (b == "zoom in") {
        sel <- selection(gI)
        if (is.null(sel) || !is(sel, "gBoxSelection")) {
          ## no box selected!
          cat("Select a region first!\n")
          gI <- changeButton(gI, "zoom in", FALSE)
          next
        }
        
        sel_r <- rules[filterSelection(sel, q)]
        
        if (length(sel_r) < 2) {
          cat("Select more rules!\n")
          next
        }
        
        ## xlim, ylim for zooming makes no sense
        control$xlim <- NULL
        control$ylim <- NULL
        
        ret <- scatterplot_grid(sel_r, measure,
          shading, control)
        if (!identical(ret, "zoom out"))
          return(ret)
        
        ## replot and reset
        scatterplot_int(rules, measure, shading, control, ...)
        downViewport("scatterplot")
        
        gI <- resetButtons(gI)
        #drawButton(gI)
      }
      
      if (b == "inspect") {
        gI <- changeButton(gI, "inspect", FALSE)
        sel <- selection(gI)
        
        if (is.null(sel)) {
          cat("Nothing selected!\n")
          next
        }
        
        sel_r <- rules[filterSelection(sel, q)]
        
        if (length(sel_r) > 0) {
          cat("\nNumber of",
            class(rules),
            "selected:",
            length(sel_r),
            "\n")
          if (!is.null(shading))
            inspect(sort(sel_r, by = shading))
          else
            inspect(sel_r)
          cat("\n")
        } else
          cat("No rules selected!\n")
        
      }
      
      ## unknown button
      next
    }
  }


scatterplot_int <- function(rules, measure, shading, control, ...) {
  ## reverse colors
  colors <- rev(control$col)
  
  q <- quality(rules)[, stats::na.omit(c(measure, shading))]
  
  ## handle Inf
  for (i in 1:ncol(q)) {
    infin <- is.infinite(q[[i]])
    if (any(infin)) {
      replinfin <- signif(2 * max(q[[i]][!infin], na.rm = TRUE), 3)
      warning(
        "plot: ",
        colnames(q)[i],
        " contains infinite values! Replaced by twice the max (",
        replinfin,
        ")!",
        call. = FALSE
      )
      q[[i]][infin] <- replinfin
    }
  }
  
  if (control$newpage)
    grid.newpage()
  
  if (control$engine == "interactive")
    addspace <- 2.5
  else
    addspace <- 0
  
  ## main
  gTitle(control$main)
  
  ## colorkey
  if (!is.null(shading)) {
    pushViewport(viewport(
      x = unit(1, "npc") - unit(3 + 2, "lines"),
      y = unit(4 + addspace, "lines"),
      height = unit(1, "npc") - unit(4 + 4 + addspace, "lines"),
      width = unit(2, "lines"),
      just = c("left", "bottom")
    ))
    
    
    ## shading range
    if (is.null(control$zlim))
      range_shading <- range(q[[shading]])
    else
      range_shading <- control$zlim
    
    if (shading == "order") {
      max_size <- max(q$order)
      min_size <- min(q$order)
      steps <- (max_size - min_size) + 1
      ypos <- rev((1:steps - .5) / steps)
      col <- colors[map_int(min_size:max_size, c(1, length(colors)))]
      grid.points(
        x = rep(0, steps),
        y = ypos,
        pch = control$pch,
        gp = gpar(
          col = rev(col),
          fill = rev(col),
          alpha = control$alpha,
          cex = control$cex
        ),
        size = unit(.5, "npc")
      )
      grid.text(
        paste("order", max_size:min_size, sep = " "),
        x = rep(1, steps),
        y = ypos
      )
      
    } else {
      if (diff(range_shading) != 0) {
        gColorkey(range_shading,
          colors,
          name = "colorkey",
          label = shading)
      } else{
        grid.text(paste(shading, "=",
          round(range_shading[1], 3)), .5,
          unit(-1, "lines"))
      }
      
    }
    
    ## reduce overplotting
    o <- order(q[[shading]])
    q <- q[o, ]
    
    upViewport(1)
  }
  
  ## scatterplot
  pushViewport(viewport(
    x = unit(4, "lines"),
    y = unit(4 + addspace, "lines"),
    height = unit(1, "npc") - unit(4 + 4 + addspace, "lines"),
    width = unit(1, "npc") - unit(4 + 2 + 3 + 2, "lines"),
    just = c("left", "bottom")
  ))
  
  x <- q[, c(measure[1], measure[2])]
  
  control$jitter <- control$jitter[1]
  if (is.na(control$jitter) && any(duplicated(x))) {
    message("To reduce overplotting, jitter is added! Use jitter = 0 to prevent jitter.")
    control$jitter <- .jitter_default
  }
  
  if (!is.na(control$jitter) && control$jitter > 0) {
    x[, 1] <- jitter(x[, 1], factor = control$jitter, amount = 0)
    x[, 2] <- jitter(x[, 2], factor = control$jitter, amount = 0)
  }
  
  
  ## get colors for shading
  if (!is.null(shading)) {
    col <- colors[map_int(q[[shading]],
      c(1, length(colors)), from.range = range_shading)]
    
  } else
    col <- 1
  
  gScatterplot(
    x,
    xlim = control$xlim,
    ylim = control$ylim,
    xlab = measure[1],
    ylab = measure[2],
    col = col,
    cex = control$cex,
    alpha = control$alpha,
    pch = control$pch,
    name = "scatterplot",
    new = FALSE
  )
  
  
  upViewport(1)
}