0
$\begingroup$

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?

$\endgroup$
1
$\begingroup$

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]

 ## Bonferroni-adjusted p-value small enough?
 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[1]
 } 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)[1]
 ## 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)[2] <- "Gender"

myttnc <- mytree(Survived ~ Class + Age + Gender, data = ttnc)
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – gung - Reinstate Monica Mar 25 '16 at 15:47
  • $\begingroup$ Please fix the indentation and layout in your posted code. As it currently stands, it's not inviting anyone to read and understand it. $\endgroup$ – Matthew Drury Jul 1 '16 at 19:31

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.