How to control Control the legend SOM codes plot - plot.kohonen - r

Question

I would like to access the legend on a kohonen SOM plot. For example this code ...
library("kohonen")
data("wines")
wines.sc <- scale(wines)
set.seed(7)
wine.som <- som(wines.sc, grid = somgrid(5, 4, "hexagonal"))
plot(wine.som, main = "Wine data",shape="straight")
... creates a nice plot with a legend of the 13 variables in a 3 column 5 row format. How do I access the legend controls on this plot to make it say 2 columns by 7 rows or perhaps 4 columns with4 rows? Perhaps I need to somehow turn the legend off (not sure how) and create my own legend in the outer margin?

Answer 1

Download the myplot.kohcodes function here and save it in your working directory as myplot.kohcodes.r.
Set the number of columns in the legend using the ncolsleg parameter.
Then, run the code:
library("kohonen")
data("wines")
wines.sc <- scale(wines)
set.seed(7)
wine.som <- som(wines.sc, grid = somgrid(5, 4, "hexagonal"))
source("myplot.kohcodes.r")
myplot.kohcodes(wine.som, main = "Wine data", keepMargins=FALSE,
palette.name=NULL, whatmap = NULL, codeRendering = NULL,
bgcol = NULL, ncolsleg=2)
A note. If the legend width is greater than the plot width, myplot.kohcodes reduces the cex parameter until the legend width is lower that the plot width.
myplot.kohcodes <- function (x, whatmap, main, palette.name, bgcol, codeRendering,
keepMargins, shape = c("round", "straight"), border = "black", ncolsleg=3,
...)
{
if (!keepMargins) {
opar <- par(c("mar"))
on.exit(par(opar))
}
if (is.null(palette.name))
palette.name <- terrain.colors
whatmap <- check.whatmap(x, whatmap)
nmaps <- length(whatmap)
if (is.list(x$codes)) {
for (i in 1:nmaps) {
huhn <- list(whatmap = 1, grid = x$grid)
huhn$codes <- getCodes(x, whatmap[i])
if (length(main) == length(x$codes)) {
main.title <- main[whatmap[i]]
}
else {
if (length(main) == nmaps) {
main.title <- main[i]
}
else {
if (length(main) == 1) {
main.title <- main
}
else {
if (is.null(main)) {
if (!is.null(names(x$codes))) {
main.title <- names(x$codes)[whatmap[i]]
}
else {
main.title <- "Codes plot"
}
}
}
}
}
if (length(codeRendering) == length(x$codes)) {
cR <- codeRendering[whatmap[i]]
}
else {
if (length(codeRendering) == nmaps) {
cR <- codeRendering[i]
}
else {
cR <- codeRendering
}
}
myplot.kohcodes(huhn, main = main.title, palette.name = palette.name,
bgcol = bgcol, whatmap = NULL, codeRendering = cR,
keepMargins = TRUE, shape = shape, border = border, ncolsleg,
...)
}
}
else {
codes <- x$codes
nvars <- ncol(codes)
maxlegendcols <- 3
ncols <- ncolsleg
print(ncolsleg)
if (is.null(codeRendering))
codeRendering <- ifelse(nvars < 15, "segments", "lines")
margins <- rep(0.6, 4)
if (!is.null(main))
margins[3] <- margins[3] + 2
par(mar = margins)
if (codeRendering == "segments" & !is.null(colnames(codes))) {
kohonen:::plot.somgrid(x$grid, ylim = c(max(x$grid$pts[, 2]) + min(x$grid$pts[,
2]), -2))
current.plot <- par("mfg")
plot.width <- diff(par("usr")[1:2])
cex <- 1
leg.result <- legend(x = mean(x$grid$pts[, 1]), xjust = 0.5,
y = 0, yjust = 1, legend = colnames(codes), cex = cex,
plot = FALSE, ncol = ncols, fill = palette.name(nvars))
while (leg.result$rect$w > plot.width) {
cex <- cex * 0.9
leg.result <- legend(x = mean(x$grid$pts[, 1]),
xjust = 0.5, y = 0, yjust = 1, legend = colnames(codes),
cex = cex, plot = FALSE, ncol = ncols, fill = palette.name(nvars))
}
leg.result <- legend(x = mean(x$grid$pts[, 1]), xjust = 0.5,
y = 0, yjust = 1, cex = cex, legend = colnames(codes),
plot = FALSE, ncol = ncols, fill = palette.name(nvars),
...)
par(mfg = current.plot)
kohonen:::plot.somgrid(x$grid, ylim = c(max(x$grid$pts[, 2]) + min(x$grid$pts[,
2]), -leg.result$rect$h))
legend(x = mean(x$grid$pts[, 1]), xjust = 0.5, y = 0,
yjust = 1, cex = cex, plot = TRUE, legend = colnames(codes),
ncol = ncols, fill = palette.name(nvars), ...)
}
else {
plot(x$grid, ...)
}
title.y <- max(x$grid$pts[, 2]) + 1.2
if (title.y > par("usr")[4] - 0.2) {
title(main)
}
else {
text(mean(range(x$grid$pts[, 1])), title.y, main,
adj = 0.5, cex = par("cex.main"), font = par("font.main"))
}
if (is.null(bgcol))
bgcol <- "transparent"
shape <- match.arg(shape)
sym <- ifelse(shape == "round", "circle", ifelse(x$grid$topo ==
"rectangular", "square", "hexagon"))
switch(sym, circle = symbols(x$grid$pts[, 1], x$grid$pts[,
2], circles = rep(0.5, nrow(x$grid$pts)), inches = FALSE,
add = TRUE, fg = border, bg = bgcol), hexagon = hexagons(x$grid$pts[,
1], x$grid$pts[, 2], unitcell = 1, col = bgcol, border = border),
square = symbols(x$grid$pts[, 1], x$grid$pts[, 2],
squares = rep(1, nrow(x$grid$pts)), inches = FALSE,
add = TRUE, fg = border, bg = bgcol))
if (codeRendering == "lines") {
yrange <- range(codes)
codes <- codes - mean(yrange)
}
else {
codemins <- apply(codes, 2, min)
codes <- sweep(codes, 2, codemins)
}
switch(codeRendering, segments = {
stars(codes, locations = x$grid$pts, labels = NULL,
len = 0.4, add = TRUE, col.segments = palette.name(nvars),
draw.segments = TRUE)
}, lines = {
for (i in 1:nrow(x$grid$pts)) {
if (yrange[1] < 0 & yrange[2] > 0) {
lines(seq(x$grid$pts[i, 1] - 0.4, x$grid$pts[i,
1] + 0.4, length = 2), rep(x$grid$pts[i,
2], 2), col = "gray")
}
lines(seq(x$grid$pts[i, 1] - 0.4, x$grid$pts[i,
1] + 0.4, length = ncol(codes)), x$grid$pts[i,
2] + codes[i, ] * 0.8/diff(yrange), col = "red")
}
}, stars = stars(codes, locations = x$grid$pts, labels = NULL,
len = 0.4, add = TRUE))
}
invisible()
}