[aggexp.git] / pkg / R / b_Algorithm.R

#' @include z_util.R

#' @title Algorithm
#'
#' @description Generic class to represent an algorithm
#'
#' @field H The window [t-H+1, t] considered for prediction at time step t+1
#' @field data Data frame of the last H experts forecasts + observations.
#'
Algorithm = setRefClass(
	Class = "Algorithm",

	fields = list(
		H = "numeric",
		data = "data.frame"
	),

	methods = list(
		initialize = function(...)
		{
			"Initialize (generic) Algorithm object"

			callSuper(...)
			if (length(H) == 0 || H < 1)
				H <<- Inf
		},
		inputNextForecasts = function(x)
		{
			"Obtain a new series of vectors of experts forecasts (1 to K)"

			nd = nrow(data)
			nx = nrow(x)
			indices = (nd+1):(nd+nx)

			appendedData = as.data.frame(matrix(nrow=nx, ncol=ncol(data), NA))
			names(appendedData) = names(data)
			data <<- rbind(data, appendedData)
			data[indices,names(x)] <<- x
		},
		inputNextObservations = function(y)
		{
			"Obtain the observations corresponding to last input forecasts"

			#if all experts made a large unilateral error and prediction is very bad, remove data
			n = nrow(data)
			lastTime = data[n,"Date"]
			xy = subset(data, subset=(Date == lastTime))
			xy[,"Measure"] = y
			x = xy[,names(xy) != "Measure"]
			y = xy[,"Measure"]
			ranges = apply(x-y, 1, range)
			predictableIndices = (ranges[2,] > -MAX_ERROR & ranges[1,] < MAX_ERROR)
#			predictableIndices = 1:length(y)
			data <<- data[1:(n-nrow(xy)),]
			data <<- rbind(data, xy[predictableIndices,])

			#oldest rows are removed to prevent infinitely growing memory usage,
			#or to allow a window effect (parameter H)
			delta = nrow(data) - min(H, MAX_HISTORY)
			if (delta > 0)
				data <<- data[-(1:delta),]
		},
		predict_withNA = function()
		{
			"Predict observations corresponding to the last input forecasts. Potential NAs"

			n = nrow(data)
			if (data[n,"Date"] == 1)
			{
				#no measures added so far
				return (rep(NA, n))
			}

			nx = n - nrow(subset(data, subset = (Date == data[n,"Date"])))
			x = data[(nx+1):n, !names(data) %in% c("Date","Measure","Station")]
			experts = names(x)
			prediction = c()

			#extract a maximal submatrix of data without NAs

			iy = getNoNAindices(x, 2)
			if (!any(iy))
			{
				#all columns of x have at least one NA
				return (rep(NA, n-nx))
			}

			data_noNA = data[1:nx,c(experts[iy], "Measure")]
			ix = getNoNAindices(data_noNA)
			if (!any(ix))
			{
				#no full line with NA-pattern similar to x[,iy]
				return (rep(NA, n-nx))
			}

			data_noNA = data_noNA[ix,]
			xiy = as.data.frame(x[,iy])
			names(xiy) = names(x)[iy]
			res = predict_noNA(data_noNA, xiy)
			#basic sanitization: force all values >=0
			res[res < 0.] = 0.
			return (res)
		},
		predict_noNA = function(XY, x)
		{
			"Predict observations corresponding to x. No NAs"

			#empty default implementation: to implement in inherited classes
		}
	)
)
Commit	Line	Data
a961f8a1 BA	1	#' @include z_util.R
	2
	3	#' @title Algorithm
	4	#'
	5	#' @description Generic class to represent an algorithm
	6	#'
	7	#' @field H The window [t-H+1, t] considered for prediction at time step t+1
	8	#' @field data Data frame of the last H experts forecasts + observations.
	9	#'
	10	Algorithm = setRefClass(
	11	Class = "Algorithm",
	12
	13	fields = list(
	14	H = "numeric",
	15	data = "data.frame"
	16	),
	17
	18	methods = list(
	19	initialize = function(...)
	20	{
	21	"Initialize (generic) Algorithm object"
	22
	23	callSuper(...)
	24	if (length(H) == 0 \|\| H < 1)
	25	H <<- Inf
	26	},
	27	inputNextForecasts = function(x)
	28	{
	29	"Obtain a new series of vectors of experts forecasts (1 to K)"
	30
	31	nd = nrow(data)
	32	nx = nrow(x)
	33	indices = (nd+1):(nd+nx)
	34
	35	appendedData = as.data.frame(matrix(nrow=nx, ncol=ncol(data), NA))
	36	names(appendedData) = names(data)
	37	data <<- rbind(data, appendedData)
	38	data[indices,names(x)] <<- x
	39	},
	40	inputNextObservations = function(y)
	41	{
	42	"Obtain the observations corresponding to last input forecasts"
	43
	44	#if all experts made a large unilateral error and prediction is very bad, remove data
	45	n = nrow(data)
	46	lastTime = data[n,"Date"]
	47	xy = subset(data, subset=(Date == lastTime))
	48	xy[,"Measure"] = y
	49	x = xy[,names(xy) != "Measure"]
	50	y = xy[,"Measure"]
	51	ranges = apply(x-y, 1, range)
	52	predictableIndices = (ranges[2,] > -MAX_ERROR & ranges[1,] < MAX_ERROR)
	53	# predictableIndices = 1:length(y)
	54	data <<- data[1:(n-nrow(xy)),]
	55	data <<- rbind(data, xy[predictableIndices,])
	56
	57	#oldest rows are removed to prevent infinitely growing memory usage,
	58	#or to allow a window effect (parameter H)
	59	delta = nrow(data) - min(H, MAX_HISTORY)
	60	if (delta > 0)
	61	data <<- data[-(1:delta),]
	62	},
	63	predict_withNA = function()
	64	{
65	"Predict observations corresponding to the last input forecasts. Potential NAs"
66
67	n = nrow(data)
68	if (data[n,"Date"] == 1)
69	{
70	#no measures added so far
71	return (rep(NA, n))
72	}
73
74	nx = n - nrow(subset(data, subset = (Date == data[n,"Date"])))
75	x = data[(nx+1):n, !names(data) %in% c("Date","Measure","Station")]
76	experts = names(x)
77	prediction = c()
78
79	#extract a maximal submatrix of data without NAs
80
81	iy = getNoNAindices(x, 2)
82	if (!any(iy))
83	{
84	#all columns of x have at least one NA
85	return (rep(NA, n-nx))
86	}
87
88	data_noNA = data[1:nx,c(experts[iy], "Measure")]
89	ix = getNoNAindices(data_noNA)
90	if (!any(ix))
91	{
92	#no full line with NA-pattern similar to x[,iy]
93	return (rep(NA, n-nx))
94	}
95
96	data_noNA = data_noNA[ix,]
97	xiy = as.data.frame(x[,iy])
98	names(xiy) = names(x)[iy]
99	res = predict_noNA(data_noNA, xiy)
100	#basic sanitization: force all values >=0
101	res[res < 0.] = 0.
102	return (res)
103	},
104	predict_noNA = function(XY, x)
105	{
106	"Predict observations corresponding to x. No NAs"
107
108	#empty default implementation: to implement in inherited classes
109	}
110	)
111	)