R/search.best.first.R

In FSelector: Selecting Attributes

best.first.search <- function(attributes, eval.fun, max.backtracks = 5) {
	if(length(attributes) == 0)
		stop("Attributes not specified")
	
	eval.fun = match.fun(eval.fun)
	
	attach_children <- function(states, best) {
		parent_state = states$attrs[best$idx,]
		children = create.children(parent_state, "forward", omit.func = function(...) {
			length(find.subset(states$attrs, ...)) > 0
			})
		children_len = ifelse(is.null(children), 0, dim(children)[1])
		if(children_len > 0) {
			states$attrs = rbind(states$attrs, children)
			states$open = c(states$open, rep(TRUE, children_len))
			states$results = c(states$results, rep(NA, children_len))
		}
		return(states)
	}

	states = list(
		attrs = diag(length(attributes)),
		open = rep(TRUE, length(attributes)),
		results = rep(NA, length(attributes))
	)
	colnames(states$attrs) = attributes
	
	best = list(
		result = -Inf,
		idx = NULL
	)
	
	repeat {
		# calculate merit for every open and not evaluated subset of attributes
		rows_to_eval = states$open & is.na(states$results)
		if(any(rows_to_eval)) {
			states$results[rows_to_eval] = 
				apply(states$attrs[rows_to_eval,, drop=FALSE], 1, function(vec) {
					attrs = attributes[as.logical(vec)]
					return(eval.fun(attrs))
				})
		}
		#find best
		new_best = find.best(states$results, states$open)

		#check if better
		if(is.null(new_best$result))
			break()
		states$open[new_best$idx] = FALSE
		if(new_best$result > best$result) {
			best = new_best
			states = attach_children(states, best)
		} else {
			if(max.backtracks > 0) {
				max.backtracks = max.backtracks - 1
			} else
				break
		}
	}
	return(attributes[as.logical(states$attrs[best$idx, ])])

}