#' Plot an object of class mixture
#'
#' provides different diagnostic plots for an aggregation procedure.
#'
#' @param x an object of class mixture. If awake is provided (i.e., some experts are unactive),
#' their residuals and cumulative losses are computed by using the predictions of the mixture.
#' @param pause if set to TRUE (default) displays the plots separately, otherwise on a single page
#' @param col the color to use to represent each experts, if set to NULL (default) use R\code{RColorBrewer::brewer.pal(...,"Spectral"}
#' @param alpha \code{numeric}. Smoothing parameter for contribution plot (parameter 'f' of function \code{\link[stats]{lowess}}).
#' @param dynamic \code{boolean}. If TRUE, graphs are generated with \code{rAmCharts}, else with base R.
#' @param type \code{char}.
#' \itemize{
#' \item{'all'}{ Display all the graphs ;}
#' \item{'plot_weight', 'boxplot_weight', 'dyn_avg_loss', 'cumul_res', 'avg_loss', 'contrib'}{ Display the selected graph alone.}
#' }
#' @param max_experts \code{integer}. Maximum number of experts to be displayed (only the more influencial).
#' @param col_by_weight \code{boolean}. If TRUE (default), colors are ordered by weights of each expert, else by column
#' @param xlab \code{character}. Custom x-axis label (individual plot only)
#' @param ylab \code{character}. Custom y-axis label (individual plot only)
#' @param main \code{character}. Custom title (individual plot only)
#' @param subset \code{numeric}. Positive indices for subsetting data before plot.
#' @param ... additional plotting parameters
#'
#'
#' @return plots representing: plot of weights of each expert in function of time, boxplots of these weights,
#' cumulative loss \eqn{L_T=\sum_{t=1}^T l_{i,t}} of each expert in function of time, cumulative residuals \eqn{\sum_{t=1}^T (y_t-f_{i,t})} of each
#' expert's forecast in function of time, average loss suffered by the experts and the contribution of each expert to the aggregation
#' \eqn{p_{i,t}f_{i,t}} in function of time.
#'
#' @author Pierre Gaillard <pierre@@gaillard.me>
#' @author Yannig Goude <yannig.goude@edf.fr>
#'
#' @seealso See \code{\link{opera-package}} and opera-vignette for a brief example about how to use the package.
#'
#' @importFrom grDevices col2rgb rgb
#' @importFrom graphics axis box boxplot layout legend lines matplot mtext par plot polygon text
#' @importFrom stats lowess var
#' @importFrom htmltools browsable tagList
#'
#'
#' @export
#'
#'
plot.mixture <- function(x,
pause = FALSE,
col = NULL,
alpha = 0.01,
dynamic = T,
type = 'all',
max_experts = 50,
col_by_weight = TRUE,
xlab = NULL,
ylab = NULL,
main = NULL,
subset = NULL,
...) {
type <- tryCatch({
match.arg(type, c('all', 'plot_weight', 'boxplot_weight',
'dyn_avg_loss', 'cumul_res',
'avg_loss', 'contrib'
))
}, error = function(e){
warning("Invalid 'type' argument. Set to 'all'")
'all'
})
############# add checks on x$loss
# user label only on simple graphic
if(type == "all"){
xlab = NULL
ylab = NULL
main = NULL
}
if(x$T == 0){
message("Empty model -- nothing to plot")
return(NULL)
}
def.par <- par(no.readonly = TRUE) # save default, for resetting...
on.exit(par(def.par))
if (pause) par(ask=TRUE)
K <- ncol(x$experts)
w.order <- order(colMeans(x$weights),decreasing = FALSE)
w.min <- min(x$weights)
if (is.null(col)) {
if(!requireNamespace("RColorBrewer", quietly = TRUE)) {
print("The RColorBrewer package must be installed to get better colors\n")
col <- 2:min((K+1),7)
} else{
col <- rev(RColorBrewer::brewer.pal(n = max(min(K,11),4),name = "Spectral"))[1:min(K,11)]
}
}
if(length(col) > K){
col <- col[1:K]
} else {
col <- rep(col, length.out = K)
}
if(col_by_weight){
col <- rev(col)
} else {
my.colors <- col
col <- my.colors[w.order]
}
if (!pause && type == "all") {
layout(matrix(c(1,2,3,4,5,6),nrow = 3,ncol = 2, byrow = TRUE))
}
x$Y <- c(t(x$Y))
x$prediction <- c(t(x$prediction))
x$weights <- data.frame(x$weights, check.names = FALSE)
T <- x$T
d <- x$d
if (!is.null(x$names.experts)) {
names(x$weights) <- colnames(x$experts) <- x$names.experts
} else {
if (is.null(colnames(x$experts))) {
names(x$weights) <- colnames(x$experts) <- x$names.experts <- paste("X", 1:K,sep="")
}
}
if (ncol(x$weights) > max_experts + 2) {
l.names <- max(nchar(c(colnames(x$experts), "worst_others"))) / 3 + 1.7
col[1:ncol(x$weight) <= ncol(x$weights) - max_experts] <- "grey"
} else {
l.names <- max(nchar(colnames(x$experts))) / 3 + 1.7
}
if(is.null(subset)){
subset <- 1:nrow(x$experts)
} else {
subset <- subset[subset >= 1 & subset <= nrow(x$experts)]
}
T <- length(subset)
x$T <- length(subset)
x$weights <- x$weights[subset, w.order]
x$experts <- x$experts[subset, w.order]
x$awake <- x$awake[subset, w.order]
x$coefficients <- x$coefficients[w.order]
x$names.experts <- x$names.experts[w.order]
x$loss.experts <- x$loss.experts[w.order]
x$prediction <- x$prediction[subset]
x$Y <- x$Y[subset]
if (dynamic) {
list_plt <- list()
} else {
par(mar = c(3, 3, 1.6, 0.1), mgp = c(2, 0.5, 0))
}
if (w.min < -0.01 && (type == "all" || type == "plot_weight")) {
# Linear aggregation rule
if (! dynamic) {
if (type == "all") {
par(mar = c(3, 3, 2, l.names/2), mgp = c(1, 0.5, 0))
}
if (ncol(x$weights) > max_experts + 2) {
tmp_weights <- x$weights[, c(1, max_experts, (ncol(x$weights) - max_experts + 1):ncol(x$weights))]
names(tmp_weights)[1:2] <- c("worst_others", "best_others")
} else {
tmp_weights <- x$weights[, max(1, ncol(x$weights) - max_experts):ncol(x$weights)]
}
matplot(tmp_weights, type = "l", xlab = xlab, ylab = "", lty = 1:5,
main = ifelse(is.null(main), "Weights associated with the experts", main), col = col, ...)
mtext(side = 2, text = ifelse(is.null(ylab), "Weights", ylab), line = 1.8, cex = 1)
# mtext(side = 1, text = "Time steps", line = 1.8, cex = 1)
mtext(side = 4, text = colnames(tmp_weights), at = tmp_weights[T,], las = 2, col = col, cex= 0.5, line = 0.3)
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
plot_ridge_weights(data = x, colors = col,
max_experts = max_experts,
round = 3, xlab = xlab, ylab = ylab, main = main)
)
html_p$height <- 280 + 10 * min(K, max_experts)
html_p
}
}
} else if (type == "all" || type == "plot_weight") {
# Convex aggregation rule
if (! dynamic) {
if (type == "all") {
par(mar = c(3, 3, 2, l.names/2), mgp = c(1, 0.5, 0))
}
if (ncol(x$weights) > max_experts) {
tmp_weights <- x$weights[]
tmp_weights <- cbind(rowSums(tmp_weights[1:(ncol(tmp_weights) - max_experts)]),
tmp_weights[, (ncol(tmp_weights) - max_experts + 1):ncol(tmp_weights), drop = FALSE])
names(tmp_weights)[1] <- "others"
tmp_K <- min(K, max_experts + 1)
tmp_cols <- c(rev(col)[1:(tmp_K-1)], "grey")
} else {
tmp_weights <- x$weights
tmp_cols <- rev(col)
tmp_K <- K
}
w.summed = apply(tmp_weights,1,sum)
plot(w.summed, type = "l", col = 1:8, lwd = 2, axes = F, xlim = c(1, T),
ylim = c(0,max(w.summed)), ylab = "", xlab = xlab, main = ifelse(is.null(main), "Weights associated with the experts", main))
mtext(side = 2, text = ifelse(is.null(ylab), "Weights", ylab), line = 1.8, cex = 1)
x.idx <- c(1, 1:T, T:1)
i.remaining = rep(TRUE, tmp_K)
for (i in 1:tmp_K) {
y.idx <- c(0, w.summed, rep(0, T))
polygon(x = x.idx, y = y.idx, col = tmp_cols[i], border=NA)
w.summed.old <- w.summed
w.summed <- w.summed - tmp_weights[, rev(names(tmp_weights)), drop = FALSE][, i]
i.remaining[i] <- FALSE
writeLegend(f = w.summed.old,w.summed,name = rev(colnames(tmp_weights))[i])
}
axis(1)
axis(2)
box()
names.toWrite <- rev(colnames(tmp_weights))
names.toWrite[-(1:min(tmp_K,15))] <- ""
mtext(side = 4, text = names.toWrite,
at = (1-cumsum(c(tmp_weights[, rev(names(tmp_weights)), drop = FALSE][T,]))) +
tmp_weights[, rev(names(tmp_weights)), drop = FALSE][T,]/2, las = 2, col = tmp_cols, cex= 0.5, line = 0.3)
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
plot_weights(data = x,
colors = col,
max_experts = max_experts,
round = 3, xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 325 + 25 * (min(K, max_experts) - 3)
html_p
}
}
}
# boxplot of weights
if (!is.null(x$awake)) {
pond <- rowSums(x$awake[d*(1:T),])
normalized.weights <- x$weights * pond / (K*x$awake[d*(1:T),])
normalized.weights[x$awake[d*(1:T),] == pond] <- NaN
} else {
normalized.weights <- x$weights
}
if (type == "all" || type == "boxplot_weight") {
if (! dynamic) {
i.order <- 1:min(c(K, 15, max_experts))
if (type == "all") {
par(mar = c(l.names+2, 3, 1.6, 0.1))
}
if (ncol(x$weights) > max_experts + 2) {
if (ncol(x$weights) <= 15) {
i.order <- c(i.order, max_experts + 1, ncol(x$weights))
names(normalized.weights)[c(1, ncol(x$weights) - min(14, max_experts + 1) + 1)] <- c("worst_others", "best_others")
tmp_col <- rev(col) ; tmp_col[1:ncol(x$weight) > 13] <- "grey"
} else {
i.order <- c(i.order[1:min(13, max_experts)], min(14, max_experts + 1), ncol(x$weights))
names(normalized.weights)[c(1, ncol(x$weights) - min(14, max_experts + 1) + 1)] <- c("worst_others", "best_others")
tmp_col <- rev(col) ; tmp_col[1:ncol(x$weight) > 13] <- "grey"
}
} else {
tmp_col <- rev(col)
}
boxplot(normalized.weights[, rev(names(normalized.weights))][,i.order],
xlab = ifelse(!is.null(xlab), xlab, ""),
main = ifelse(is.null(main), "Weights associated with the experts", main),
col = tmp_col[i.order], axes = FALSE, pch='.')
mtext(side = 2, text = ifelse(is.null(ylab), "Weights", ylab), line = 1.8, cex = 1)
axis(1, at = 1:(min(c(K, 15, max_experts))), labels = FALSE)
mtext(at = 1:min(c(K, 15, max_experts + 2)), text = rev(names(normalized.weights))[i.order],
side = 1, las = 2, col = tmp_col[i.order], line = 0.8)
axis(2)
box()
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
boxplot_weights(data = x, colors = col,
max_experts = max_experts,
xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 300 + 10 * max(c(nchar(names(max_experts)), 17*(ncol(x$weights) > max_experts)))
html_p
}
}
}
# note: always pass alpha on the 0-255 scale
if (! dynamic) {
makeTransparent<-function(someColor, alpha=220)
{
newColor<-col2rgb(someColor)
apply(newColor, 2, function(curcoldata){rgb(red=curcoldata[1], green=curcoldata[2],
blue=curcoldata[3],alpha=alpha, maxColorValue=255)})
}
}
# dynamic average loss
if (type == "all" || type == "dyn_avg_loss") {
if (! dynamic) {
pred.experts <- data.frame(x$experts * x$awake + x$prediction * (1-x$awake))
cumul.losses <- apply(loss(x = pred.experts, y = x$Y, loss.type = x$loss.type), 2, cumsum)[seq(d,T*d,by=d),] / 1:T
cumul.exploss <- cumsum(loss(x = x$prediction, y = x$Y, loss.type = x$loss.type))[seq(d,T*d,by=d)] / 1:T
if (ncol(x$weights) > max_experts + 2) {
cumul.losses <- cumul.losses[, -c(2:(ncol(x$weights) - max_experts - 1))]
colnames(cumul.losses)[1:2] <- c("worst_others", "best_others")
tmp_col <- col[-c(2:(ncol(x$weights) - max_experts - 1))]
} else {
cumul.losses <- cumul.losses[, rev(max(1, ncol(cumul.losses) - max_experts + 1):ncol(cumul.losses)), drop = FALSE]
tmp_col <- rev(col)
}
if (type == "all") {
par(mar = c(1.5, 3, 2.5, l.names/2), mgp = c(1, 0.5, 0))
}
matplot(cumul.losses, type = "l", lty = 1, xlab = ifelse(!is.null(xlab), xlab, ""),
ylab = "",
main = ifelse(!is.null(main), main, "Dynamic average loss"),
col = makeTransparent(tmp_col), ylim = range(c(cumul.losses,cumul.exploss)))
lines(cumul.exploss, col = 1, lwd = 2)
mtext(side = 2, text = ifelse(!is.null(ylab), ylab, "Cumulative loss"), line = 1.8, cex = 1)
# mtext(side = 1, text = "Time steps", line = 1.8, cex = 1)
mtext(side = 4, text = colnames(cumul.losses),
at = cumul.losses[T,], las = 2,
col = makeTransparent(tmp_col[1:ncol(cumul.losses)]), cex= 0.5, line = 0.3)
legend("topleft", c("Experts", x$model), bty = "n", lty = 1, col = c("gray", 1), lwd = c(1,2))
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
plot_dyn_avg_loss(data = x, colors = col,
max_experts = max_experts, round = 2,
xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 322 + 22 * (min(K, max_experts) - 3)
html_p
}
}
}
# cumulative residuals
if (type == "all" || type == "cumul_res") {
if (! dynamic) {
pred.experts <- data.frame(x$experts * x$awake + x$prediction * (1-x$awake))
cumul.residuals <- apply(x$Y - pred.experts, 2, cumsum)[seq(d,T*d,by=d),]
cumul.expres <- cumsum(x$Y - x$prediction)[seq(d,T*d,by=d)]
if (ncol(x$weights) > max_experts + 2) {
cumul.residuals <- cumul.residuals[, -c(2:(ncol(x$weights) - max_experts - 1))]
colnames(cumul.residuals)[1:2] <- c("worst_others", "best_others")
tmp_col <- col[-c(2:(ncol(x$weights) - max_experts - 1))]
} else {
cumul.residuals <- cumul.residuals[, rev(max(1, ncol(cumul.residuals) - max_experts + 1):ncol(cumul.residuals)), drop = FALSE]
tmp_col <- rev(col)
}
if (type == "all") {
par(mar = c(1.5, 3, 2.5,l.names/2), mgp = c(1, 0.5, 0))
}
matplot(cumul.residuals, type = "l", lty = 1,
xlab = ifelse(!is.null(xlab), xlab, ""), ylab = "",
main = ifelse(!is.null(main), main, "Cumulative residuals"),
col = makeTransparent(tmp_col),
ylim = range(c(cumul.residuals,cumul.expres)))
lines(cumul.expres, col = 1, lwd = 2)
mtext(side = 2, text = ifelse(!is.null(ylab), ylab, "Cumulative residuals"), line = 1.8, cex = 1)
# mtext(side = 1, text = "Time steps", line = 1.8, cex = 1)
if (max(cumul.residuals) > abs(min(cumul.residuals))) {
place = "topleft"
} else {
place = "bottomleft"
}
mtext(side = 4, text = colnames(cumul.residuals),
at = cumul.residuals[T,], las = 2, col = tmp_col[1:ncol(cumul.residuals)], cex= 0.5, line = 0.3)
legend(place, c("Experts", x$model), bty = "n", lty = 1, col = c("gray", 1), lwd = c(1,2))
} else {
list_plt[[length(list_plt) + 1]] <- {
html_p <- rAmCharts::controlShinyPlot(
plot_cumul_res(
data = x, colors = col,
max_experts = max_experts, round = 2,
xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 322 + 22 * (min(K, max_experts) - 3)
html_p
}
}
}
# losses
if (type == "all" || type == "avg_loss") {
if (! dynamic) {
pred.experts <- data.frame(x$experts * x$awake + x$prediction * (1-x$awake))
x$loss.experts <- colMeans(matrix(unlist(loss(x = pred.experts, y = x$Y, loss.type = x$loss.type)), ncol = K))
names(x$loss.experts) <- names(pred.experts)
err.unif <- lossConv(rep(1/K, K), x$Y, x$experts, awake = x$awake, loss.type = x$loss.type)
err.mixt <- x$loss
if (ncol(x$weights) > max_experts + 2) {
x$loss.experts <- c(x$loss.experts[-c(2:(ncol(x$weight) - max_experts - 1))], "uniform" = err.unif, "mixt" = err.mixt)
names(x$loss.experts)[1:2] <- c("worst_others", "best_others")
idx.sorted <- order(x$loss.experts)
tmp_cols <- c("grey", "grey", col[-c(1:(ncol(x$weight) - max_experts))], "black", "black")[idx.sorted]
my.pch <- c(rep(20, length(x$loss.experts)-2),8,8)[idx.sorted]
} else {
x$loss.experts <- c(x$loss.experts[max(1, length(x$loss.experts) - max_experts + 1):length(x$loss.experts)], "uniform" = err.unif, "mixt" = err.mixt)
idx.sorted <- order(x$loss.experts)
tmp_cols <- c(col[max(1, col(x$weights) - max_experts + 1):ncol(x$weights)], "black", "black")[idx.sorted]
my.pch <- c(rep(20, length(x$loss.experts)-2),8,8)[idx.sorted]
}
l.names <- max(max(nchar(names(x$loss.experts))) / 3 + 1.7,4)
if (type == "all") {
par(mar = c(l.names, 3, 2.5,l.names/2), mgp = c(1, 0.5, 0))
}
loss_name <- tryCatch(paste(x$loss.type$name, "loss"), error = function(e) "loss")
plot(x$loss.experts[idx.sorted], xlab = ifelse(!is.null(xlab), xlab, ""),
ylab = "",
main = ifelse(!is.null(main), main, "Average loss suffered by the experts"),
axes = F, pch = my.pch, col = tmp_cols, lwd = 2, type='b')
mtext(side = 2, text = ifelse(!is.null(ylab), ylab, loss_name), line = 1.8, cex = 1)
axis(1, at = 1:(K + 2), labels = FALSE)
mtext(at = 1:length(x$loss.experts), text = c(names(x$loss.experts), "Uniform", x$model)[idx.sorted],
side = 1, las = 2, col = tmp_cols, line = 0.8,cex = .7)
axis(2)
box()
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
plot_avg_loss(
data = x, colors = col,
max_experts = max_experts, round = 2,
xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 300
html_p
}
}
}
# cumulative plot of the series
if (type == "all" || type == "contrib") {
if (! dynamic) {
if (x$d ==1) {
if (type == "all") {
par(mar = c(2, 3, 2.5,l.names/2), mgp = c(1, 0.5, 0))
}
cumulativePlot(W = x$weights,X = x$experts, Y = x$Y,smooth = TRUE, alpha = alpha,
plot.Y = TRUE, col.pal = col, max_experts = max_experts, xlab = xlab, ylab = ylab, main = main)
} else {
X <- apply(seriesToBlock(X = x$experts,d = x$d),c(1,3),mean)
Y <- rowMeans(seriesToBlock(x$Y,d = x$d))
colnames(X) <- names(x$weights)
if (type == "all") {
par(mar = c(2, 3, 2.5,l.names/2), mgp = c(1, 0.5, 0))
}
cumulativePlot(W = x$weights,X = X, Y = Y,smooth = TRUE,
alpha = alpha,plot.Y = TRUE, col.pal = col,
max_experts = max_experts)
}
} else {
list_plt[[length(list_plt) + 1]] <-
{
html_p <- rAmCharts::controlShinyPlot(
plot_contrib(
data = x, colors = col, alpha = alpha,
max_experts = max_experts, round = 2,
xlab = xlab, ylab = ylab, main = main
)
)
html_p$height <- 325 + 25 * (min(K, max_experts) - 3)
html_p
}
}
}
if (! dynamic) {
return(invisible(NULL))
} else {
res <- htmltools::browsable(
htmltools::tagList(
list_plt
)
)
return(res)
}
}
writeLegend <- function(f,g,name,Y.lim=c(0,1), ...) {
tau = Y.lim[2]/20
Tab = matrix(0,ncol = 2, nrow = 100)
y.seq <- seq(Y.lim[1],Y.lim[2],length.out = 100)
for (i in 1:100) {
x = y.seq[i]
sel = which(g < x & f > x + tau)
temp <- cumsum(c(1, diff(sel) - 1))
temp2 <- rle(temp)
Tab[i,1] <- max(temp2$lengths)
Tab[i,2] <- sel[which(temp == with(temp2, values[which.max(lengths)]))][1]
}
id = which.max(Tab[,1])
x <- y.seq[id]
l <- Tab[id,1]
v <- Tab[id,2]
if (l > length(f)/20){
j = max(4, floor(60 *l/length(f)))
text(v+l/2,x+tau/2,substr(name,1,j),cex = 0.8,...)
}
}
cumulativePlot<-function(W,X,Y,col.pal=NULL, smooth = FALSE, plot.Y = FALSE, alpha = 0.1, max_experts = 50, xlab = NULL, ylab = NULL, main = NULL)
{
time<-c(1:nrow(X))
active.experts<-which(colMeans(W)>0)
W<-W[,active.experts]
X<-X[, names(W)][,active.experts]
K <- ncol(X)
if(is.null(col.pal)) col.pal <- RColorBrewer::brewer.pal(n = min(K,9),name = "Spectral")
if (length(col.pal) < K) col.pal <- c(rep(col.pal[1],K-length(col.pal)),col.pal)
o<-order(colSums(W),decreasing = F)
mat<-W[,o]*X[,o]
Agg<-rowSums(mat)
colnames(mat)<-colnames(X)[o]
if (!smooth)Y.lim = range(Agg,Y,mat)
if (smooth)
{
y.lo<-lowess(x = time,y = Y,f = alpha)$y
Agg.lo<-lowess(x = time,y = Agg,f = alpha)$y
mat.lo<-apply(mat,2,function(z){lowess(x = time,y = z,f = alpha)$y})
Y.lim = range(Agg.lo,mat.lo)
}
if (ncol(mat) > max_experts) {
colnames(mat)[1:(ncol(mat)-max_experts)] <- "others"
}
plot(x = NULL,y = NULL,col=col.pal[1], type='l', xaxt='n',ylim=Y.lim,lty='dotted',
yaxt='n',xlab=ifelse(!is.null(xlab), xlab, ""),ylab=ifelse(!is.null(ylab), ylab, ""),lwd=3,xlim = range(time),
main = ifelse(!is.null(main), main, "Contribution of each expert to prediction"))
y.summed <- Agg
for(i in rev(c(1:ncol(mat))))
{
if (!smooth) addPoly(time,y.summed,col=ifelse(i <= (ncol(mat) - max_experts), "grey", col.pal[i]))
if (smooth) addPoly(time,lowess(y.summed,f = alpha)$y,col=ifelse(i <= (ncol(mat) - max_experts), "grey", col.pal[i]))
y.summed.old <- y.summed
y.summed <- y.summed - mat[,i]
if (!smooth) writeLegend(f=y.summed.old,g= y.summed,
name = colnames(mat)[i],Y.lim,col=ifelse(i <= (ncol(mat) - max_experts), "black", "black"))
if (smooth) writeLegend(f=lowess(y.summed.old,f=alpha/10)$y,g=lowess(y.summed,f=alpha/10)$y,
name = colnames(mat)[i],Y.lim,col=ifelse(i <= (ncol(mat) - max_experts), "black", "black"))
}
if (plot.Y && !smooth) lines(time,Y,col=1,lwd=2,lty='dotted')
if (plot.Y && smooth) lines(lowess(x = time,y = Y,f = alpha)$y,col=1,lwd=2,lty='dotted')
axis(1)
axis(2)
}
addPoly<-function(x,y,col)
{
xx <- c(x, rev(x))
yy <- c(rep(0, length(x)), rev(y))
polygon(xx, yy, col=col, border=NA)
}
##########
### dynamic version of the plots
#' Functions to render dynamic mixture graphs using rAmCharts
#'
#' @param data \code{mixture object}. Displays graphs.
#' @param colors \code{character}. Colors of the lines and bullets.
#' @param max_experts \code{integer}. Maximum number of experts to be displayed (only the more influencial).
#' @param round \code{integer}. Precision of the displayed values.
#' @param alpha \code{numeric}. Smoothing parameter for contribution plot (parameter 'f' of function \code{\link[stats]{lowess}}).
#' @param xlab \code{character}. Custom x-axis label (individual plot only)
#' @param ylab \code{character}. Custom y-axis label (individual plot only)
#' @param main \code{character}. Custom title (individual plot only)
#'
#' @return a \code{rAmCharts} plot
#'
#' @import pipeR
#' @importFrom rAmCharts amSerialChart addValueAxis addGraph addTitle setExport setChartCursor setChartScrollbar setLegend
#' amBoxplot setCategoryAxis controlShinyPlot
#' @importFrom htmlwidgets JS
#'
#' @rdname plot-opera-rAmCharts
#'
plot_ridge_weights <- function(data,
colors = NULL,
max_experts = 50,
round = 3,
xlab = NULL,
ylab = NULL,
main = NULL) {
K <- ncol(data$experts)
data <- data$weights
K <- ncol(data$experts)
if (is.null(colors)) {
colors <- rev(RColorBrewer::brewer.pal(n = max(min(ncol(data),11),4),name = "Spectral"))[1:min(K,11)]
}
if (ncol(data) > max_experts + 2) {
colors <- colors[-c(1:(ncol(data) - max_experts - 2))]
data <- data[, c(1, (ncol(data) - max_experts):ncol(data))]
names(data)[1:2] <- c("worst_others", "best_others")
} else {
# colors <- colors[-c(1:(ncol(data) - max_experts))]
data <- data[, max(1, ncol(data) - max_experts + 1):ncol(data)]
}
names_experts <- names(data)
data$timestamp <- 1:nrow(data)
plt <- amSerialChart(dataProvider = data,
categoryField = c("timestamp"),
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(title = ifelse(is.null(ylab), "Weights", ylab))
for (index in 1:length(names_experts)) {
plt <- plt %>>%
rAmCharts::addGraph(title = names_experts[index], id = names_experts[index],
valueField = names_experts[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index])
}
plt <- plt %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Weights associated with the experts", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
# rAmCharts::setChartScrollbar(scrollbarHeight = 10, dragIconHeight = 26, offset = 8) %>>%
rAmCharts::setLegend(useGraphSettings = F, valueText = "", position = "right", reversedOrder = T)
plt@otherProperties$zoomOutButtonImageSize <- 0
if(!is.null(xlab)){
plt <- plt %>>% rAmCharts::setCategoryAxis(title = xlab)
}
plt
}
#' @rdname plot-opera-rAmCharts
plot_weights <- function(data,
colors = NULL,
max_experts = 50,
round = 3,
xlab = NULL, ylab = NULL, main = NULL) {
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(max(3, ncol(data$experts)), 9), name = "Spectral")
}
data_weight <- data$weights
N = ncol(data_weight)
if (N > max_experts) {
data_weight <- cbind(rowSums(data_weight[1:(N - max_experts)]), data_weight[, (ncol(data_weight) - max_experts + 1):ncol(data_weight), drop = FALSE])
names(data_weight)[1] <- "others"
# colors <- colors[-c(2:(ncol(data$weights) - max_experts))]
tmp_K <- min(N, max_experts + 1)
colors <- c("grey", rev(colors)[rev(1:(tmp_K-1))])
N = ncol(data_weight)
}
names_weights <- colnames(data_weight)
data_weight <- data.frame("timestamp" = 1:data$`T`, t(apply(data_weight, 1, cumsum)), round(data_weight, round), check.names = FALSE)
max_weight = round(max(data_weight[,N+1]), 0)
plt <- amSerialChart(dataProvider = data_weight,
categoryField = c("timestamp"),
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(title = ifelse(is.null(ylab), "Weights", ylab), maximum = max_weight, minimum = 0)
for (index in 1:length(names_weights)) {
if (index == 1) {
plt <- plt %>>%
rAmCharts::addGraph(title = names_weights[index], id = names_weights[index],
valueField = names_weights[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
fillToAxis = T, fillColors = colors[index], fillAlphas = .75,
balloonText = paste0("<b>", names_weights[index], " : </b>", "[[", names_weights[index], ".1]]"))
} else {
plt <- plt %>>%
rAmCharts::addGraph(title = names_weights[index], id = names_weights[index],
valueField = names_weights[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
fillToGraph = names_weights[index-1], fillColors = colors[index], fillAlphas = .75,
balloonText = paste0("<b>", names_weights[index], " : </b>", "[[", names_weights[index], ".1]]"))
}
}
plt <- plt %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Weights associated with the experts", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
# rAmCharts::setChartScrollbar(scrollbarHeight = 10, dragIconHeight = 26, offset = 8) %>>%
rAmCharts::setLegend(useGraphSettings = F, valueText = "", position = "right", reversedOrder = T)
plt@otherProperties$zoomOutButtonImageSize <- 0
if(!is.null(xlab)){
plt <- plt %>>% rAmCharts::setCategoryAxis(title = xlab)
}
plt
}
#' @rdname plot-opera-rAmCharts
boxplot_weights <- function(data,
colors = NULL,
max_experts = 50,
xlab = NULL, ylab = NULL, main = NULL) {
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(ncol(data$experts), 9), name = "Spectral")
}
data_weight <- data$weight
if (ncol(data_weight) > max_experts + 2) {
data_weight <- data_weight[, -c(2:(ncol(data$weights) - max_experts - 1))]
names(data_weight)[1:2] <- c("worst_others", "best_others")
colors <- colors[-c(2:(ncol(data$weights) - max_experts - 1))]
} else {
data_weight <- data_weight[, max(1, ncol(data_weight) - (max_experts-1)):ncol(data_weight), drop = FALSE]
}
plt <- rAmCharts::amBoxplot(data_weight[, rev(names(data_weight)), drop = FALSE], col = rev(colors),
ylab = ifelse(is.null(ylab), "Weights", ylab), creditsPosition = "bottom-right", zoom = TRUE) %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Weights associated with the experts", main)) %>>%
rAmCharts::setCategoryAxis(autoGridCount = FALSE, gridCount = ncol(data_weight), labelRotation = 90,
labelOffset = 5, title = ifelse(!is.null(xlab), xlab, "")) %>>%
rAmCharts::setExport(position = "top-right") # %>>%
# rAmCharts::setLegend(useGraphSettings = TRUE, valueText = "", position = "right")
plt@otherProperties$zoomOutButtonImageSize <- 0
plt
}
#' @rdname plot-opera-rAmCharts
plot_dyn_avg_loss <- function(data,
colors = NULL,
max_experts = 50,
round = 3,
xlab = NULL, ylab = NULL, main = NULL) {
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(ncol(data$experts), 9), name = "Spectral")
}
pred.experts <- data.frame(data$experts * data$awake + data$prediction * (1-data$awake), check.names = FALSE)
cumul.losses <- apply(loss(x = pred.experts, y = data$Y, loss.type = data$loss.type), 2, cumsum)[seq(data$d, data$T*data$d, by = data$d), ] / 1:data$T
cumul.exploss <- cumsum(loss(x = data$prediction, y = data$Y, loss.type = data$loss.type))[seq(data$d, data$T*data$d, by = data$d)] / 1:data$T
data_loss <- data.frame(cbind(cumul.losses, cumul.exploss), check.names = FALSE)
data_loss$timestamp <- 1:nrow(data_loss)
data_loss[, c(names(data$weights), "cumul.exploss", "timestamp")]
if (ncol(data$weight) > max_experts + 2) {
data_loss <- data_loss[, -c(2:(ncol(data$weights) - max_experts - 1))]
names(data_loss)[1:2] <- c("worst_others", "best_others")
colors <- colors[-c(2:(ncol(data$weights) - max_experts - 1))]
} else {
data_loss <- data_loss[, rev(max(1, ncol(data$weights) - max_experts + 1):ncol(data_loss)), drop = FALSE]
colors <- rev(colors)
}
names_experts <- setdiff(names(data_loss), c("cumul.exploss", "timestamp"))
data_loss <- round(data_loss, round)
plt <- amSerialChart(dataProvider = data_loss,
categoryField = "timestamp",
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(title = ifelse(is.null(ylab), "Cumulative loss", ylab))
for (index in 1:length(names_experts)) {
plt <- plt %>>%
rAmCharts::addGraph(title = names_experts[index], id = names_experts[index],
valueField = names_experts[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
balloonText = paste0("<b>", names_experts[index], " : </b>", "[[value]]"))
}
plt <- plt %>>%
rAmCharts::addGraph(title = data$model, id = "cumul.exploss",
valueField = "cumul.exploss", valueAxis = "timestamp",
type = "line", lineThickness = 2, lineColor = "black",
balloonText = paste0("<b> cumul.exploss : </b>", "[[value]]"))
plt <- plt %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Dynamic average loss", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
# rAmCharts::setChartScrollbar(scrollbarHeight = 10, dragIconHeight = 26, offset = 8) %>>%
rAmCharts::setLegend(useGraphSettings = F, valueText = "", position = "right", reversedOrder = T)
plt@otherProperties$zoomOutButtonImageSize <- 0
if(!is.null(xlab)){
plt <- plt %>>% rAmCharts::setCategoryAxis(title = xlab)
}
plt
}
#' @rdname plot-opera-rAmCharts
plot_cumul_res <- function(data,
colors = NULL,
max_experts = 50,
round = 3,
xlab = NULL, ylab = NULL, main = NULL) {
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(ncol(data$experts), 9), name = "Spectral")
}
pred.experts <- data.frame(data$experts * data$awake + data$prediction * (1-data$awake), check.names = FALSE)
cumul.residuals <- apply(data$Y - pred.experts, 2, cumsum)[seq(data$d, data$T*data$d, by = data$d),]
cumul.expres <- cumsum(data$Y - data$prediction)[seq(data$d, data$T*data$d, by = data$d)]
data_res <- data.frame(cbind(cumul.residuals, cumul.expres), check.names = FALSE)
data_res$timestamp <- 1:nrow(data_res)
data_res[, c(names(data$weights), "cumul.expres", "timestamp")]
if (ncol(data$weight) > max_experts + 2) {
data_res <- data_res[, -c(2:(ncol(data$weights) - max_experts - 1))]
names(data_res)[1:2] <- c("worst_others", "best_others")
colors <- colors[-c(2:(ncol(data$weights) - max_experts - 1))]
} else {
data_res <- data_res[, rev(max(1, ncol(data$weights) - max_experts + 1):ncol(data_res)), drop = FALSE]
colors <- rev(colors)
}
names_experts <- setdiff(names(data_res), c("cumul.expres", "timestamp"))
data_res <- round(data_res, round)
plt <- amSerialChart(dataProvider = data_res,
categoryField = "timestamp",
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(title = ifelse(is.null(ylab), "Cumulative residuals", ylab))
for (index in 1:length(names_experts)) {
plt <- plt %>>%
rAmCharts::addGraph(title = names_experts[index], id = names_experts[index],
valueField = names_experts[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
balloonText = paste0("<b>", names_experts[index], " : </b>", "[[value]]"))
}
plt <- plt %>>%
rAmCharts::addGraph(title = data$model, id = "cumul.expres",
valueField = "cumul.expres", valueAxis = "timestamp",
type = "line", lineThickness = 2, lineColor = "black",
balloonText = paste0("<b> cumul.expres : </b>", "[[value]]"))
plt <- plt %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Cumulative residuals", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
# rAmCharts::setChartScrollbar(scrollbarHeight = 10, dragIconHeight = 26, offset = 8) %>>%
rAmCharts::setLegend(useGraphSettings = F, valueText = "", position = "right", reversedOrder = T)
plt@otherProperties$zoomOutButtonImageSize <- 0
if(!is.null(xlab)){
plt <- plt %>>% rAmCharts::setCategoryAxis(title = xlab)
}
plt
}
#' @rdname plot-opera-rAmCharts
plot_avg_loss <- function(data,
colors = NULL,
max_experts = 50,
round = 3,
xlab = NULL, ylab = NULL, main = NULL) {
K <- ncol(data$experts)
pred.experts <- data.frame(data$experts * data$awake + data$prediction * (1-data$awake))
data$loss.experts <- colMeans(loss(x = pred.experts, y = data$Y, loss.type = data$loss.type))
err.unif <- lossConv(rep(1/K, K), data$Y, data$experts, awake = data$awake, loss.type = data$loss.type)
err.mixt <- data$loss
data_loss <- c(data$loss.experts, "uniform" = err.unif, "mixt" = data$loss)
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(length(data_loss)-2, 9), name = "Spectral")
}
data_plot <- data.frame("values" = unname(data_loss),
"bullet" = "diamond", "size" = 10, "cols" = "black", "names" = names(data_loss))
data_plot$bullet = ifelse(data_plot$names %in% c("mixt", "uniform"), "diamond", "round")
data_plot$size = ifelse(data_plot$names %in% c("mixt", "uniform"), 10, 8)
colors_bis <- rep("black", length(data_loss)) ; colors_bis[! data_plot$names %in% c("mixt", "uniform")] <- colors
data_plot$cols = colors_bis
data_plot$names <- ifelse(data_plot$names == "mixt", data$model, data_plot$names)
if (ncol(data$weights) > max_experts + 2) {
data_plot <- data_plot[-c(2:(ncol(data$weight) - max_experts - 1)), ]
data_plot[1:2, ]$names <- c("worst_others", "best_others")
data_plot <- data_plot[order(data_plot$values), ]
} else {
data_plot <- data_plot[max(1, ncol(data$weight) - max_experts + 1):nrow(data_plot), ]
data_plot <- data_plot[order(data_loss[max(1, ncol(data$weight) - max_experts + 1):nrow(data_plot)]), ]
}
loss_name <- tryCatch(paste(data$loss.type$name, "loss"), error = function(e) "loss")
plt <- amSerialChart(dataProvider = data_plot,
categoryField = "names",
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(title = ifelse(is.null(ylab), loss_name, ylab)) %>>%
rAmCharts::addGraph(title = "lines", id = "lines",
valueField = "values", valueAxis = "names",
type = "line", lineColor = "black",
showBalloon = F) %>>%
rAmCharts::addGraph(title = "bullets", id = "bullets",
valueField = "values", valueAxis = "names",
type = "line", lineAlpha = 0,
bulletField = "bullet", bulletSizeField = "size", colorField = "cols") %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Average loss suffered by the experts", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
rAmCharts::setCategoryAxis(autoGridCount = FALSE, gridCount = nrow(data_plot),
title = ifelse(!is.null(xlab), xlab, ""),
labelRotation = 90, labelColorField = "cols", labelOffset = 5)
return(plt)
}
#' @rdname plot-opera-rAmCharts
plot_contrib <- function(data,
colors = NULL,
alpha = 0.1,
max_experts = 50,
round = 3,
xlab = NULL, ylab = NULL, main = NULL) {
W = data$weights
K = ncol(data$experts)
if (data$d == 1) {
X = data$experts
Y = data$Y
} else {
X <- apply(seriesToBlock(X = data$experts, d = data$d), c(1, 3), mean)
Y <- rowMeans(seriesToBlock(data$Y, d = data$d))
colnames(X) <- names(data$weights)
}
if (is.null(colors)) {
colors <- RColorBrewer::brewer.pal(n = min(K, 9), name = "Spectral")
}
if (length(colors) < K) colors <- c(rep(colors[1],K-length(colors)),colors)
time<-c(1:nrow(X))
active.experts<-which(colMeans(abs(W))>0)
W<-W[,active.experts]
X<-X[, names(W)]
K <- ncol(X)
o<-order(colSums(W),decreasing = F)
mat<-W[,o]*X[,o]
mat <- sapply(mat, function(x) lowess(x = 1:nrow(mat), y = x, f = alpha)$y)
colnames(mat)<-colnames(X)[o]
data_weight <- as.data.frame(mat)
N <- ncol(data_weight)
if (ncol(data_weight) > max_experts) {
data_weight <- cbind(rowSums(data_weight[1:(ncol(data_weight) - max_experts)]), data_weight[, (ncol(data_weight) - max_experts + 1):ncol(data_weight), drop = FALSE])
names(data_weight)[1] <- "others"
# colors <- colors[-c(2:(ncol(mat) - max_experts))]
tmp_K <- min(N, max_experts + 1)
colors <- c("grey", rev(colors)[rev(1:(tmp_K-1))])
}
names_weights <- colnames(data_weight)
data_weight <- data.frame("timestamp" = 1:nrow(data_weight), t(apply(data_weight, 1, cumsum)), round(data_weight, round))
data_weight$pred <- round(lowess(x = time,y = Y,f = alpha)$y, round)
balloon_fun = htmlwidgets::JS(paste0('function(item, graph) {
var result = graph.balloonText;
for (var key in item.dataContext) {
if (item.dataContext.hasOwnProperty(key) && !isNaN(item.dataContext[key])) {
var formatted = AmCharts.formatNumber(item.dataContext[key], {
precision: ', round, ',
decimalSeparator: ".",
thousandsSeparator: " "
}, 2);
result = result.replace("[[" + key + "]]", formatted);
}
}
return result;
}'))
plt <- amSerialChart(dataProvider = data_weight,
categoryField = c("timestamp"),
creditsPosition = "bottom-right",
thousandsSeparator = " ",
precision = round) %>>%
rAmCharts::addValueAxis(maximum = max(data_weight$pred), useScientificNotation = T,
title = ifelse(!is.null(ylab), ylab, ""))
for (index in 1:length(names_weights)) {
if (index == 1) {
plt <- plt %>>%
rAmCharts::addGraph(title = names_weights[index], id = names_weights[index],
valueField = names_weights[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
fillToAxis = T, fillColors = colors[index], fillAlphas = .75,
balloonText = paste0("<b>", names_weights[index], " : </b>", "[[", names_weights[index], ".1]]"),
balloonFunction = balloon_fun)
} else {
plt <- plt %>>%
rAmCharts::addGraph(title = names_weights[index], id = names_weights[index],
valueField = names_weights[index], valueAxis = "timestamp",
type = "line", lineColor = colors[index],
fillToGraph = names_weights[index-1], fillColors = colors[index], fillAlphas = .75,
balloonText = paste0("<b>", names_weights[index], " : </b>", "[[", names_weights[index], ".1]]"),
balloonFunction = balloon_fun)
}
}
plt <- plt %>>%
rAmCharts::addGraph(title = "Prediction", id = "pred",
valueField = "pred", valueAxis = "timestamp",
type = "line", dashLength = 5, lineThickness = 2, lineColor = "black",
balloonText = paste0("<b> Prediction : </b>", "[[pred]]"),
balloonFunction = balloon_fun)
plt <- plt %>>%
rAmCharts::addTitle(text = ifelse(is.null(main), "Contribution of each expert to the prediction", main)) %>>%
rAmCharts::setExport(position = "top-right") %>>%
rAmCharts::setChartCursor() %>>%
# rAmCharts::setChartScrollbar(scrollbarHeight = 10, dragIconHeight = 26, offset = 8) %>>%
rAmCharts::setLegend(useGraphSettings = F, valueText = "", position = "right", reversedOrder = T)
plt@otherProperties$zoomOutButtonImageSize <- 0
if(!is.null(xlab)){
plt <- plt %>>% rAmCharts::setCategoryAxis(title = xlab)
}
plt
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.