R/plotly.R

In mhahsler/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.

# plotly interactive plots using d3.js

## Interface used by plot
scatterplot_plotly <- function(x,
  measure = measure,
  shading = shading,
  control = control,
  ...) {
  control <- c(control, list(...))
  control <- .get_parameters(
    control,
    list(
      interactive = TRUE,
      engine = "htmlwidget",
      max = 1000,
      colors = default_colors(2),
      jitter = NA,
      precision = 3,
      main = "Unused",
      marker = list()
    )
  )
  
  quality(x)[["order"]] <- size(x)
  qnames <- names(quality(x))
  measure <- qnames[pmatch(measure, qnames, duplicates.ok = TRUE)]
  if (!is.null(shading)) shading <- qnames[pmatch(shading, qnames)]
 
  .plotly_scatter(
    x,
    measure,
    shading,
    control$colors,
    control$jitter,
    control$precision,
    control$max,
    control$marker
  )
}

.plotly_scatter <- function(x,
  measure = c("support", "confidence"),
  shading = "lift",
  colors = default_colors(2),
  jitter = NA,
  precision = 3,
  max = 1000,
  marker = list(),
  ...) {
  colors <- rev(colors)
  
  quality(x)$id <- seq_along(x)
  x <- limit(x, max, shading, measure)
  
  ### reduce overplotting
  x <- rev(x)
  
  q <- quality(x)[, c(measure, shading)]
  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 (is(x, "rules"))
    l <- labels(
      x,
      itemSep = ',<BR>&nbsp;&nbsp;',
      ruleSep = '<BR>&nbsp;&nbsp; => ',
      setStart = '<B>{',
      setEnd = '}</B>'
    )
  else
    l <- labels(x,
      itemSep = ',<BR>&nbsp;&nbsp;',
      setStart = '<B>{',
      setEnd = '}</B>')
  
  txt <- paste(
    paste0('[', quality(x)$id, ']<BR>'),
    l,
    paste('<BR><BR>', measure[1], ": ", signif(q[, measure[1]], precision), sep = ""),
    paste('<BR>', measure[2], ": ", signif(q[, measure[2]], precision), sep =
        ""),
    if (!is.null(shading)) {
      paste('<BR>', shading, ": ",
        if (is.numeric(q[, shading]))
          signif(q[, shading], precision)
        else
          q[, shading], sep = "")
    } else
      ""
  )
  
  ### add x/y-jitter
  jitter <- jitter[1]
  if (is.na(jitter) && any(duplicated(q[, measure]))) {
    message("To reduce overplotting, jitter is added! Use jitter = 0 to prevent jitter.")
    jitter <- .jitter_default
  }
  
  if (!is.na(jitter) && jitter > 0)
    for (m in measure)
      q[[m]] <- jitter(q[[m]], factor = jitter, amount = 0)
  
  if (is.null(shading))
    p <-
    plotly::plot_ly(
      q,
      type = "scatter",
      x = q[, measure[1]],
      y = q[, measure[2]],
      hoverinfo = 'text',
      text = txt,
      mode = 'markers',
      marker = marker
    )
  else if (shading == "order")
    p <-
    plotly::plot_ly(
      q,
      type = "scatter",
      x = q[, measure[1]],
      y = q[, measure[2]],
      hoverinfo = 'text',
      text = txt,
      color = as.ordered(q[, shading]),
      mode = 'markers',
      marker = marker
    )
  else
    p <-
    plotly::plot_ly(
      q,
      type = "scatter",
      x = q[, measure[1]],
      y = q[, measure[2]],
      hoverinfo = 'text',
      text = txt,
      color = q[, shading],
      colors = colors,
      mode = 'markers',
      marker = marker
    )  %>% plotly::colorbar(title = shading)
  
  
  p %>%
    plotly::layout(
      hovermode = "closest",
      xaxis = list(title = measure[1]),
      yaxis = list(title = measure[2])
    )
}

matrix_plotly <- function(x, measure, shading, control, ...) {
  control <- c(control, list(...))
  control <- .get_parameters(
    control,
    list(
      interactive = TRUE,
      engine = "htmlwidget",
      max = 1000,
      colors = default_colors(2),
      reorder = "measure",
      precision = 3
    )
  )
  
  qnames <- names(quality(x))
  measure <- qnames[pmatch(measure, qnames, duplicates.ok = TRUE)]
  
  .plotly_matrix(
    x,
    measure[1],
    reorder = control$reorder,
    colors = control$colors,
    precision = control$precision,
    max = control$max
  )
}

.plotly_matrix <- function(x,
  measure = "lift",
  reorder = "none",
  colors = default_colors(2),
  precision = 3,
  max = 1000) {
  colors <- rev(colors)
 
  x <- limit(x, max, measure = measure)
  
  m <- rules2matrix(x, measure, reorder)
  m <- m[nrow(m):1, , drop = FALSE] # reverse rows
  m_s <-
    rules2matrix(x, measure = "support", reorder = "none")[rownames(m), colnames(m)]
  m_c <-
    rules2matrix(x, measure = "confidence", reorder = "none")[rownames(m), colnames(m)]
  
  txt <-
    t(outer(colnames(m), rownames(m), paste, sep = '<BR>&nbsp;&nbsp; => '))
  txt[] <- paste(
    '<B>',
    txt,
    '</B>',
    '<BR>',
    measure,
    ': ',
    signif(m, precision),
    '<BR>',
    'support',
    ': ',
    signif(m_s, precision),
    '<BR>',
    'confidence',
    ': ',
    signif(m_c, precision),
    sep = ''
  )
  txt[is.na(m)] <- NA
  
  plotly::plot_ly(
    z = m,
    x = colnames(m),
    y = rownames(m),
    type = "heatmap",
    colors = colors,
    colorbar = list(title = measure),
    hoverinfo = 'text',
    text = txt
  ) %>%
    plotly::layout(
      xaxis = list(
        title = "LHS",
        showticklabels = FALSE,
        showgrid = TRUE,
        ticks = ""
      ),
      yaxis = list(
        title = "RHS",
        showticklabels = FALSE,
        showgrid = TRUE,
        ticks = ""
      )
    )
}