R/getWeightsByOutcome.R

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

#' Extract the change of connection weights between all cues and a specific 
#' outcome.
#' 
#' @description Extract the change of connection weights between all cues and 
#' a specific outcome. The values are returned as data frame.
#' @export
#' @import data.table
#' @param wmlist A list with weightmatrices, generated by 
#' \code{\link{RWlearning}} or \code{\link{updateWeights}}.
#' @param outcome String: outcome for which to extract the connection weights.
#' @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 init.value Value of connection weights for non-existing connections. 
#' Typically set to 0.
#' @return Data frame.
#' @author Jacolien van Rij
#' @seealso \code{\link{plotCueWeights}}, \code{\link{plotOutcomeWeights}}, 
#' \code{\link{getWeightsByCue}}
#' @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)
#' 
#' # final weight matrix:
#' getWM(wm)
#' 
#' # Inspect the change in connection weights 
#' # for cue=car
#' outweights <- getWeightsByOutcome(wm, outcome='vehicle')
#' head(outweights)
#' emptyPlot(nrow(outweights), range(outweights), h0=0,
#'     main="Outcome='vehicle'", ylab='connection weights', xlab='learning events')
#' lines(outweights$BG)
#' lines(outweights$car, lty=4)
#' lines(outweights$bicycle, lty=2)
#' lines(outweights$cat, col=2)
#' lines(outweights$red, col='blue', lty=4)
#' lines(outweights$gray, col='blue', lty=2)
#' legend('bottomright', legend=c('BG', 'car', 'bicycle', 'cat', 'red', 'gray'),
#'     col=c(1,1,1,2,'blue', 'blue'), lty=c(1,4,2,1,4,2), lwd=1)
#' 

getWeightsByOutcome <- function(wmlist, outcome, select.cues=NULL, init.value=0){
	cues <- sort( rownames(wmlist[[length(wmlist)]]) )
	if(!is.null(select.cues)){
		cues <- select.cues
	}

	returnvalues <- function(mat, x, y){
		vals <- rep(init.value, length(x))
		names(vals) <- x
		if(y[1] %in% colnames(mat)){
			x.sub1 <- x[x %in% rownames(mat)]
			if(length(x.sub1)>0){
				vals[x.sub1] <- mat[x.sub1,y]
			}
		}
		return( as.data.frame(t(vals)) )
	}
	if(length(outcome) > 1){
		outcome <- outcome[1]
		warning(sprintf("outcome has more than one value, only the first value (%s) will be used.", outcome))
	}
	return( as.data.frame(rbindlist( lapply(wmlist, function(x){ return(returnvalues(x,cues,outcome))}) ) ) )
}