myplot.kohcodes.r

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()
}