R/plotCueWeights.R

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

#' Visualize the change of connection weights between a specific cue and all 
#' outcomes.
#' 
#' @description Visualize the change of connection weights between a specific 
#' cue and all outcomes.
#' @export
#' @import graphics
#' @import plotfunctions
#' @import grDevices
#' @param wmlist A list with weightmatrices, generated by 
#' \code{\link{RWlearning}} or \code{\link{updateWeights}}.
#' @param cue String: cue for which to extract the connection weights.
#' @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 outcomes from the 
#' data, and \code{\link{getValues}} for returning all outcomes in the data.
#' @param init.value Value of connection weights for non-existing connections. 
#' Typically set to 0.
#' @param add.labels Logical: whether or not to add labels for the lines. 
#' Defaults to TRUE, see examples.
#' @param add Logical: whether or not to add the lines to an existing plot. 
#' Defaults to FALSE (starting a new plot).
#' @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 Optionally a list with label specifications is returned, which 
#' allows to plot your own labels. This may be helpful for very long labels, 
#' and for overlapping lines.
#' @seealso \code{\link{plotOutcomeWeights}}, \code{\link{getWeightsByOutcome}}, 
#' \code{\link{getWeightsByCue}}
#' @author Jacolien van Rij
#' @examples
#' # load example data:
#' data(dat)
#' 
#' # add obligatory columns Cues, Outcomes, and Frequency:
#' dat$Cues <- paste("BG", dat$Shape, dat$Color, sep="_")
#' dat$Outcomes <- dat$Category
#' dat$Frequency <- dat$Frequency1
#' head(dat)
#' dim(dat)
#' 
#' # now use createTrainingData to sample from the specified frequencies: 
#' train <- createTrainingData(dat)
#' 
#' # this training data can actually be used train network:
#' wm <- RWlearning(train)
#' 
#' # plot connection weights for cue = 'car':
#' plotCueWeights(wm, cue="car")
#' 
#' # plot your own labels:
#' labels <- plotCueWeights(wm, cue="car", add.labels=FALSE)
#' legend_margin('topright', legend=labels$labels, col=labels$col, 
#'     lwd=1, bty='n')
#' 
#' # change color and select outcomes:
#' out <- getValues(train$Outcomes, unique=TRUE)
#' out <- out[out != "vehicle"]
#' labels <- plotCueWeights(wm, cue="car", add.labels=FALSE, 
#'     col=alphaPalette(c(1,2), f.seq=rep(.5,length(out))), 
#'     select.outcomes=out)
#' lab2 <- plotCueWeights(wm, cue="car", add.labels=FALSE, 
#'     select.outcomes="vehicle", add=TRUE, col=1, lwd=2)
#' legend_margin('topright', legend=c(labels$labels, "vehicle"), 
#'     col=c(labels$col, lab2$col), lwd=c(labels$lwd, lab2$lwd), 
#'     lty=c(labels$lty, lab2$lty))
#' 

plotCueWeights <- function(wmlist, cue, select.outcomes=NULL, 
	init.value=0, add.labels=TRUE, add=FALSE,
	...){
	dat <- getWeightsByCue(wmlist=wmlist, cue=cue, select.outcomes=select.outcomes, init.value=init.value)

	par <- list(...)

	xrange <- c(1, nrow(dat))
	yrange <- range(dat, na.rm=TRUE)
	col <- rainbow(ncol(dat))
	lty <- 1:ncol(dat)
	lwd <- rep(1, ncol(dat))

	if('xlim' %in% names(par)){
		xrange <- par[['xlim']]
		par[['xlim']] <- NULL
	}
	if('ylim' %in% names(par)){
		yrange <- par[['ylim']]
		par[['ylim']] <- NULL
	}
	if('col' %in% names(par)){
		col <- par[['col']]
		if(length(col)==1){
			col <- rep(col, ceiling(ncol(dat) / length(col)))[1:ncol(dat)]
		}
		par[['col']] <- NULL
	}
	if('lty' %in% names(par)){
		lty <- par[['lty']]
		if(length(lty)==1){
			lty <- rep(lty, ceiling(ncol(dat) / length(lty)))[1:ncol(dat)]
		}
		par[['lty']] <- NULL
	}
	if('lwd' %in% names(par)){
		lwd <- par[['lwd']]
		if(length(lwd)==1){
			lwd <- rep(lwd, ceiling(ncol(dat) / length(lwd)))[1:ncol(dat)]
		}
		par[['lwd']] <- NULL
	}


	if(!'main' %in% names(par)){
		par[['main']] <- sprintf("Cue: \"%s\"", cue)
	}
	if(!'xlab' %in% names(par)){
		par[['xlab']] <- "Input"
	}
	if(!'ylab' %in% names(par)){
		par[['ylab']] <- "Connection weight"
	}
	if(!'h0' %in% names(par)){
		par[['h0']] <- 0
	}


	line.par <- c("type", "pch", "bg", "cex", "lend", "ljoin", "lmitre") 
	label.par <- c("font", "adj", "pos", "offset", "vfont", "cex", "srt", 
		"family", "crt", "lheight") 

	plotspec <- list2str(x=names(par)[!names(par) %in% c(line.par, label.par)], par)
	if(plotspec != ""){
		plotspec <- paste(",", plotspec)
	}

	linespec <- list2str(line.par, par)
	if(linespec != ""){
		linespec <- paste(",", linespec)
	}

	labelspec <- list2str(label.par, par)
	if(labelspec != ""){
		labelspec <- paste(",", labelspec)
	}

	if (add == FALSE){
		eval(parse(text=sprintf("emptyPlot(xrange, yrange %s)", plotspec)))
	}
	
	for( i in 1:ncol(dat)){
		eval(parse(text=sprintf("lines(dat[,i], col=col[i], lty=lty[i], lwd=lwd[i] %s)", linespec)))
	}

	if(add.labels){
		for( i in 1:ncol(dat)){
			eval(parse(text=sprintf("text(nrow(dat), dat[nrow(dat),i], labels=names(dat)[i], col=col[i] %s, xpd=NA)", labelspec)))
		}
	}
	invisible(list(labels=names(dat), 
		x=rep(nrow(dat),ncol(dat)), y=unlist(dat[nrow(dat),]),col=col, lty=lty, lwd=lwd))
}