R/plotNetwork.R

In edl: Toolbox for Error-Driven Learning Simulations with Two-Layer Networks

#' Return strong weights.
#' 
#' @import plotfunctions
#' @export
#' @param wm a weightmatrix (matrix, not list) with connection 
#' weights between cues (rows) and outcomes (columns).
#' @param select.cues Optional selection of cues to limit the number of 
#' connection weights that are returned. The value of NULL (default) will 
#' return all connection weights. Note that specified values that are not in 
#' the weightmatrices will return the initial value without error or warning. 
#' Please use \code{\link{getCues}} for returning all cues from the data, and 
#' \code{\link{getValues}} for returning all cues in the data.
#' @param select.outcomes Optional selection of outcomes to limit the number 
#' of connection weights that are returned. The value of NULL (default) will 
#' return all connection weights. Note that specified values that are not in 
#' the weightmatrices will return the initial value without error or warning. 
#' Please use \code{\link{getOutcomes}} for returning all cues from the data, 
#' and \code{\link{getValues}} for returning all cues in the data.
#' @param color The color scheme to use for plots, a list of colors such as 
#' that generated by \code{\link[grDevices]{rainbow}}, 
#' \code{\link[grDevices]{heat.colors}}, 
#' \code{\link[grDevices]{colors}}, 
#' \code{\link[grDevices]{topo.colors}}, 
#' \code{\link[grDevices]{terrain.colors}} or similar functions. 
#' Alternatively a vector with some colors can be provided for a 
#' custom color palette.
#' @param zlim z-limits for the plot.
#' @param add.color.legend Logical: whether or not to add a color legend 
#' (see also \code{\link[plotfunctions]{gradientLegend}}).
#' @param ... Optional graphical arguments, as specified in 
#' \code{\link[graphics]{par}}. These parameters are forwarded to the functions 
#' \code{\link[plotfunctions]{emptyPlot}}, \code{\link[graphics]{lines}}, and 
#' \code{\link[graphics]{text}}.
#' @return No return value
#' @author Jacolien van Rij

plotNetwork <- function(wm, select.outcomes=NULL, select.cues=NULL, 
	color = NULL, zlim=NULL, 
	add.color.legend=TRUE,
	...){


	identifyLabels <- function(x, y = NULL, lab, n = length(x), 
		plot = FALSE, ...){

		message("Click with the mouse on a cell to see the label. Press ESC key to quit interactive mode.")
	    xy <- xy.coords(x, y); x <- xy$x; y <- xy$y
	    sel <- rep(FALSE, length(x))
	    while(sum(sel) < n) {
	        ans <- identify(x[!sel], y[!sel], labels = which(!sel), n = 1, plot = plot, ...)
	        if(!length(ans)) break
	        ans <- which(!sel)[ans]
	        text(x[ans], y[ans], labels=lab[ans])
	        # points(x[ans], y[ans], pch = pch)
	        sel[ans] <- TRUE
	    }
	}

	if(is.matrix(wm)){
		outcomes <- colnames(wm)
		if(!is.null(select.outcomes)){
			outcomes <- select.outcomes[select.outcomes %in% outcomes]
			if(length(select.outcomes[!select.outcomes %in% outcomes])>0){
				warning(sprintf("Outcomes %s not found in %s and will be ignored.", 
					paste(select.outcomes[!select.outcomes %in% outcomes], collapse=", "),
					deparse(substitute(wm))))
			}
		}
		cues <- rev(row.names(wm))
		if(!is.null(select.cues)){
			cues <- select.cues[select.cues %in% cues]
			if(length(select.cues[!select.cues %in% cues])>0){
				warning(sprintf("Cues %s not found in %s and will be ignored.", 
					paste(select.cues[!select.cues %in% cues], collapse=", "),
					deparse(substitute(wm))))
			}
		}

		plot.wm <- wm[cues, outcomes]

		par <- list(...)
		
		if(is.null(color)){
			color=colorRampPalette(c(rgb(.3,.3,.3), "white", rgb(.8,0,0)))(50)
		}
		main = sprintf("Weights %s", deparse(substitute(wm)))
		if("main" %in% names(par)){
			main <- par[['main']]
			par[['main']] <- NULL
		}
		xlab = ""
		if("xlab" %in% names(par)){
			xlab <- par[['xlab']]
			par[['xlab']] <- NULL
		}
		ylab = ""
		if("ylab" %in% names(par)){
			ylab <- par[['ylab']]
			par[['ylab']] <- NULL
		}
		if(is.null(zlim)){
			zlim <- range(wm)
		}

		mat <- expand.grid(x=1:ncol(plot.wm), y=1:nrow(plot.wm))
		mat$lab <- paste(row.names(plot.wm)[mat$y], colnames(plot.wm)[mat$x], sep=",")

		if(dev.interactive()) { ## use it
		  image(t(plot.wm), x=1:ncol(plot.wm), y=1:nrow(plot.wm), 
		  	col=color, axes=FALSE, zlim=zlim,
		  	xlab=xlab, ylab=ylab, main=main)
		  axis(1, at=1:ncol(plot.wm), labels=colnames(plot.wm))
		  axis(2, at=1:nrow(plot.wm), labels=row.names(plot.wm), las=1)

		  if(add.color.legend){
		  	gradientLegend(zlim, color=color, pos=.875, side=4)
		  }

		  identifyLabels(mat$x, mat$y, lab=mat$lab)
		}
	}else{
		stop(sprintf("Argument wm should be matrix, but %s is a %s.", deparse(substitute(wm)), class(wm)[1]))
	}

	
}