# Loss function for Random forest

I am working on a random forest model in R and want to use a different loss function from the default. Does random forest implementation in R allow for arbitrary loss functions?

Its not easy. You will have to build your own tree and then bootstrap those trees. You will want to refer to this paper on how to build a tree.

https://cran.r-project.org/web/packages/partykit/vignettes/constparty.pdf

Their tree is built with the following code:

library(partykit)

findsplit <- function(response, data, weights, alpha = 0.01) {

## extract response values from data
y <- factor(rep(data[[response]], weights))

## perform chi-squared test of y vs. x
mychisqtest <- function(x) {
x <- factor(x)
if(length(levels(x)) < 2) return(NA)
ct <- suppressWarnings(chisq.test(table(y, x), correct = FALSE))
pchisq(ct$statistic, ct$parameter, log = TRUE, lower.tail = FALSE)
}
xselect <- which(names(data) != response)
logp <- sapply(xselect, function(i) mychisqtest(rep(data[[i]], weights)))

names(logp) <- names(data)[xselect]

if(all(is.na(logp))) return(NULL)
minp <- exp(min(logp, na.rm = TRUE))
minp <- 1 - (1 - minp)^sum(!is.na(logp))
if(minp > alpha) return(NULL)

## for selected variable, search for split minimizing p-value
xselect <- xselect[which.min(logp)]
x <- rep(data[[xselect]], weights)

## set up all possible splits in two kid nodes
lev <- levels(x[drop = TRUE])
if(length(lev) == 2) {
splitpoint <- lev
} else {
comb <- do.call("c", lapply(1:(length(lev) - 2),
function(x) combn(lev, x, simplify = FALSE)))
xlogp <- sapply(comb, function(q) mychisqtest(x %in% q))
splitpoint <- comb[[which.min(xlogp)]]
}

## split into two groups (setting groups that do not occur to NA)
splitindex <- !(levels(data[[xselect]]) %in% splitpoint)
splitindex[!(levels(data[[xselect]]) %in% lev)] <- NA_integer_
splitindex <- splitindex - min(splitindex, na.rm = TRUE) + 1L

## return split as partysplit object
return(partysplit(varid = as.integer(xselect),
index = splitindex,
info = list(p.value = 1 - (1 - exp(logp))^sum(!is.na(logp)))))
}

growtree <- function(id = 1L, response, data, weights, minbucket = 30) {

## for less than 30 observations stop here
if (sum(weights) < minbucket) return(partynode(id = id))

## find best split
sp <- findsplit(response, data, weights)
## no split found, stop here
if (is.null(sp)) return(partynode(id = id))

## actually split the data
kidids <- kidids_split(sp, data = data)

## set up all daugther nodes
kids <- vector(mode = "list", length = max(kidids, na.rm = TRUE))
for (kidid in 1:length(kids)) {
## select observations for current node
w <- weights
w[kidids != kidid] <- 0
## get next node id
if (kidid > 1) {
myid <- max(nodeids(kids[[kidid - 1]]))
} else {
myid <- id
}
## start recursion on this daugther node
kids[[kidid]] <- growtree(id = as.integer(myid + 1), response, data, w)
}

## return nodes
return(partynode(id = as.integer(id), split = sp, kids = kids,
info = list(p.value = min(info_split(sp)$p.value, na.rm = TRUE)))) } mytree <- function(formula, data, weights = NULL) { ## name of the response variable response <- all.vars(formula) ## data without missing values, response comes last data <- data[complete.cases(data), c(all.vars(formula)[-1], response)] ## data is factors only stopifnot(all(sapply(data, is.factor))) if (is.null(weights)) weights <- rep(1L, nrow(data)) ## weights are case weights, i.e., integers stopifnot(length(weights) == nrow(data) & max(abs(weights - floor(weights))) < .Machine$double.eps)

## grow tree
nodes <- growtree(id = 1L, response, data, weights)

## compute terminal node number for each observation
fitted <- fitted_node(nodes, data = data)
## return rich constparty object
ret <- party(nodes, data = data,

fitted = data.frame("(fitted)" = fitted,
"(response)" = data[[response]],
"(weights)" = weights,
check.names = FALSE),
terms = terms(formula))
as.constparty(ret)
}

data("Titanic", package = "datasets")
ttnc <- as.data.frame(Titanic)
ttnc <- ttnc[rep(1:nrow(ttnc), ttnc\$Freq), 1:4]
names(ttnc) <- "Gender"

myttnc <- mytree(Survived ~ Class + Age + Gender, data = ttnc)

• Welcome to the site. At present this is more of a comment than an answer. You could expand it, perhaps by giving a summary of the information at the link, or we can convert it into a comment for you. – gung - Reinstate Monica Mar 25 '16 at 15:47
• Please fix the indentation and layout in your posted code. As it currently stands, it's not inviting anyone to read and understand it. – Matthew Drury Jul 1 '16 at 19:31