Nothing
#######################################################################
# 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> ",
ruleSep = "<BR> => ",
setStart = "<B>{",
setEnd = "}</B>"
)
} else {
l <- labels(x,
itemSep = ",<BR> ",
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> => "))
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 = ""
)
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.