R/getActivations.R

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

#' Function to calculate the activations.
#' 
#' @description Calculate the activations for all or specific outcomes 
#' on the basis of a set of cues. This function combines the various 
#' functions to calculate the activations.
#' @export
#' @import data.table
#' @param wmlist A list with weightmatrices, generated by 
#' \code{\link{RWlearning}} or \code{\link{updateWeights}}. 
#' Or, alternatively, \code{wmlist} can be a single weightmatrix.
#' @param data Data frame with columns \code{Cues} and \code{Outcomes}, 
#' specifying one learning event per row (i.e., assuming 
#' \code{Frequency=1}, as data generated with 
#' \code{\link{createTrainingData}}). 
#' Optional argument: when \code{data} is provided, the activations will 
#' be calculated for each learning event in \code{data} (i.e., for 
#' the combination of cues and outcomes). When \code{data} is set to NULL 
#' (no data frame provided), this function will use the cue sets 
#' specified in \code{cueset}. Use the argument \code{select.outcomes} 
#' to specify a set of outcomes for which to calculate the activations 
#' instead of for the observed outcome(s) only. See examples.
#' @param cueset String, specifying the cue set for which to calculate 
#' change in activation. Only will be used when \code{data} is set to NULL.
#' @param split String, separator between cues and/or outcomes.
#' @param select.outcomes Optional selection of outcomes to limit 
#' (or expand) the number of activations that are returned. See examples 
#' for how to use this argument in combination with \code{data} 
#' and \code{cueset}. 
#' When \code{data} is provided, the value of NULL (default) will only 
#' return the activations for each learning event (i.e., only for the 
#' observed cues and outcomes). 
#' When \code{data} is provided, the value TRUE will return the 
#' activations for all outcomes in \code{data} given the cues observed 
#' in the learning events. 
#' When \code{cueset} is specified, the values of NULL (default) or TRUE 
#' will return the activations for all outcomes in \code{wmlist}. 
#' Note that specified values that are not in 
#' the weightmatrix will return the initial value without error or 
#' warning. Please use \code{\link{getValues}} for returning all 
#' outcomes in the data.
#' @param init.value Value of activations for non-existing connections. 
#' Typically set to 0.
#' @param normalize Logical: whether or not the activation is normalized by 
#' dividing the total activation by the number of cues. Default is FALSE. If 
#' set to TRUE, the activation reflects the average activation per cue.
#' @return List: when \code{data} is provided, a list is returned with 
#' the outcome activations for each learning event; 
#' when \code{cueset} is provided, a list is returned with data frames 
#' of outcome activations. See examples.
#' @author Jacolien van Rij
#' @seealso \code{\link{getWeightsByCue}},
#' \code{\link{getWeightsByOutcome}}
#' @family functions for calculating activations
#' @examples
#' # load example data:
#' data(dat)
#' 
#' # add obligatory columns Cues, Outcomes, and Frequency:
#' dat <- droplevels(dat[1:3,])
#' dat$Cues <- paste("BG", dat$Shape, dat$Color, sep="_")
#' dat$Outcomes <- dat$Category
#' dat$Frequency <- dat$Frequency1
#' head(dat)
#' 
#' 
#' # now use createTrainingData to sample from the specified frequencies: 
#' train <- createTrainingData(dat)
#' head(train)
#' 
#' # this training data can actually be used train network:
#' wm <- RWlearning(train)
#' 
#' # With this data we illustrate four different 
#' # ways to retrieve activation changes.
#' 
#' # Situation I: return activations for each event 
#' act1 <- getActivations(wm, data=train)
#' head(act1)
#' # plotting activations for each event doesn't provide very 
#' # useful info:
#' plot(act1$Activation, type='l', ylim=c(0,1), col=alpha(1),
#'     ylab='Activation')
#' # these lines may be more interpretable:
#' n <- which(act1$Outcomes=="animal")
#' lines(n, act1$Activation[n], col=alpha(2), lwd=2)
#' n <- which(act1$Outcomes=="plant")
#' lines(n, act1$Activation[n], col=alpha(3), lwd=2)
#' 
#' # Situation II: return activations for each events
#' # for all outcomes
#' act2 <- getActivations(wm, data=train, select.outcomes=TRUE)
#' head(act2)
#' 
#' plot(act2$plant, type='l', ylim=c(0,1), col=alpha(1),
#'     ylab='Activation')
#' n <- which(act2$Outcomes=="plant")
#' rug(n, side=1)
#' lines(n, act2$plant[n], lwd=2, col=alpha(3))
#' n <- which(act2$Outcomes!="plant")
#' lines(n, act2$plant[n], lwd=2, col=alpha(2))
#' legend('topright', 
#'     legend=c("all events", "outcome present", "outcome absent"),
#' 	   col=c(1,alpha(3),alpha(2)), lwd=c(1,2,2),
#'     bty='n')
#' 
#' # Situation III: return activations for specific cuesets
#' # for all outcomes
#' act3 <- getActivations(wm, cueset=c("BG_cat_brown", "BG_flower_brown"))
#' str(act3) 
#' 
#' a31 <- act3[["BG_flower_brown"]] # or act3[[1]]
#' plot(a31$plant, type='l', ylim=c(0,1), col=alpha(1),
#'     main="BG_flower_brown", ylab='Activation')
#' lines(a31$animal,col=2)
#' rug(which(train$Cues == "BG_flower_brown"), side=1)
#' legend('topright', 
#'     legend=c("plant", "animal"),
#' 	   col=c(1,2), lwd=1, bty='n')
#' 
#' # Situation IV: return activations for a static weight matrix
#' # Note: only with cueset
#' (final <- getWM(wm))
#' act4 <- getActivations(final, cueset=unique(train$Cues))
#' act4
#' 

getActivations <- function(wmlist, 
	data=NULL, cueset = NULL,
	split="_", 
	select.outcomes=NULL, 
	init.value=0, normalize=FALSE){

	# check wmlist:
	if(!is.list(wmlist)){
		if(is.matrix(wmlist)){
			wmlist <- list(wmlist)
		}else{
			stop("Argument wmlist should be list of weightmatrices or a single weightmatrix.")
		}
	}

	# check data:
	if(!is.null(data)){
		cueset <- NULL
		if(length(wmlist)!=nrow(data)){
			stop("Argument wmlist should have same length as the number of rows in data.")
		}
		if(!"Cues" %in% colnames(data)){
			stop("Cannot find column 'Cues' in data.")
		}
		if(!"Outcomes" %in% colnames(data)){
			stop("Cannot find column 'Outcomes' in data.")
		}
		if(!is.null(select.outcomes)){
			if(length(select.outcomes)==1 & is.logical(select.outcomes[1])){
				if(select.outcomes[1]==TRUE){
					select.outcomes = getValues(data$Outcomes, split=split, 
					unique=TRUE)
				}else{
					warning("Argument select.outcomes=FALSE will be ignored.")
				}
			}
		}

		# calculate activations,
		# no outcomes are specified:
		if(is.null(select.outcomes)){
			activations = activationsEvents(wmlist, data=data, 
				split=split, init.value=init.value, return.list=TRUE,
				normalize=normalize)
			n <- unlist(lapply(activations, function(x){return(length(x))}))
			if(length(table(n)) > 1){
				warnings("In some events multiple outcomes were present. In these cases, the max activation will be returned. Please use function activationsEvents for more options.")
			}
			activations = as.data.frame(rbindlist( lapply(activations, function(x){
					i = which(x == max(x, na.rm=TRUE))
					return(data.frame(Activation=unlist(x[i])))
				}) ))
			activations = cbind(data[,c("Cues", "Outcomes")], activations)
			return(activations)
		# calculate activations,
		# for sepcified outcomes:
		}else{
			activations = activationsOutcomes(wmlist, data=data, 
				select.outcomes=select.outcomes,
				split=split, init.value=init.value,
				normalize=normalize)
			activations = cbind(data[,c("Cues", "Outcomes")], activations)
			return(activations)
		}
	}else{
		# check cueset:
		if(is.null(cueset)){
			stop("No cues are provided to calculate activations. Use arguments 'data' or 'cueset' to specify cues.")
		}
		if(!is.null(select.outcomes)){
			if(is.logical(select.outcomes)){
				if(select.outcomes){
					select.outcomes = NULL
				}else{
					stop("No outcomes specified. Set argument select.outcomes to NULL, TRUE, or provide outcomes as a vector of strings.")
				}
			}
		}

		# for each cue in cueset:
		out <- activationsCueSet(wmlist, cueset=cueset,
			select.outcomes=select.outcomes, split=split, 
			init.value=init.value, normalize=normalize)
		return(out)
	}
}