# Cost Weighted Logistic Loss

[This article was first published on

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

**R – My contRibution**, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

The problem of weighting the type 1,2 errors on binary classification came up in a forum I visit.

My solution:

# normal log-loss ll <- function(y) function(p) -(y * log(p) + (1-y)*log(1-p)) plot(ll(0),0,1,col=1,main="log loss",ylab="loss",xlab="p") plot(ll(1),0,1,col=2,add=TRUE) legend("topleft",legend = c("y=0","y=1"), lty=1, col=1:2, bty="n") # cost weighted log-loss cwll <- function(y,cost) function(p) -(cost * y * log(p) + (1-cost)*(1-y)*log(1-p)) plot(cwll(0,0.1),0,1,col=1,main="cost weighted log loss\n(cost=0.1)",ylab="loss",xlab="p") plot(cwll(1,0.1),0,1,col=2,add=TRUE) legend("topleft",legend = c("y=0","y=1"), lty=1, col=1:2, bty="n")

Here we can see the different loss behaviours

We will try to classify the Virginica species from the iris dataset

# let's take the iris data set with a species that is hard to differentiate by sepal length and petal length d <- transform(iris, y = Species == "virginica") plot(Sepal.Length~Petal.Length,data=d,col=0,pch=21,bg=rgb(0,y,0), main="is it Virginica?") legend("topleft",legend=c("virginica","others"),pch=21,col=0,pt.bg=c("green","black"),bty="n")

And now the loss functions:

# normal loss function Loss <- function(par, data) { xb <- cbind(1,d$Sepal.Length, d$Petal.Length) %*% par p <- 1 / (1 + exp(-xb)) sum(-(d$y * log(p) + (1-d$y)*log(1-p))) } # cost weighted version, cost refers to error on the virginica species cwLoss <- function(par, data, cost = 0.01) { xb <- cbind(1,d$Sepal.Length, d$Petal.Length) %*% par p <- 1 / (1 + exp(-xb)) sum(-(cost * d$y * log(p) + (1-cost)*(1-d$y)*log(1-p))) } beta <- optim(par=c(0,0,0),fn=Loss,data=d)$par cw.beta <- optim(par=c(0,0,0),fn=cwLoss,data=d)$par xRange <- range(d$Petal.Length) yRange <- range(d$Sepal.Length) X <- seq(xRange[1],xRange[2],by = 0.05) Y <- seq(yRange[1],yRange[2],by = 0.05) z <- outer(X,Y, FUN = function(x,y) -(beta[1] + x * beta[3] + y * beta[2])) cwz <- outer(X,Y, FUN = function(x,y) -(cw.beta[1] + x * cw.beta[3] + y * cw.beta[2])) contour(X,Y,z, add=TRUE,levels = 0,labels = "normal",labcex = 1) contour(X,Y,cwz, add=TRUE,levels = 0,col=4, labels = "cost-weighted",labcex = 1)

To

**leave a comment**for the author, please follow the link and comment on their blog:**R – My contRibution**.R-bloggers.com offers

**daily e-mail updates**about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.