lgb.plot.interpretation.R

#' Plot feature contribution as a bar graph
#'
#' Plot previously calculated feature contribution as a bar graph.
#'
#' @param tree_interpretation_dt a \code{data.table} returned by \code{\link{lgb.interprete}}.
#' @param top_n maximal number of top features to include into the plot.
#' @param cols the column numbers of layout, will be used only for multiclass classification feature contribution.
#' @param left_margin (base R barplot) allows to adjust the left margin size to fit feature names.
#' @param cex (base R barplot) passed as \code{cex.names} parameter to \code{barplot}.
#'
#' @details
#' The graph represents each feature as a horizontal bar of length proportional to the defined
#' contribution of a feature. Features are shown ranked in a decreasing contribution order.
#'
#' @return
#' The \code{lgb.plot.interpretation} function creates a \code{barplot}.
#'
#' @examples
#' library(lightgbm)
#' Sigmoid <- function(x) {1.0 / (1.0 + exp(-x))}
#' Logit <- function(x) {log(x / (1.0 - x))}
#' data(agaricus.train, package = "lightgbm")
#' train <- agaricus.train
#' dtrain <- lgb.Dataset(train$data, label = train$label)
#' setinfo(dtrain, "init_score", rep(Logit(mean(train$label)), length(train$label)))
#' data(agaricus.test, package = "lightgbm")
#' test <- agaricus.test
#'
#' params <- list(
#'   objective = "binary"
#'   , learning_rate = 0.01
#'   , num_leaves = 63L
#'   , max_depth = -1L
#'   , min_data_in_leaf = 1L
#'   , min_sum_hessian_in_leaf = 1.0
#' )
#' model <- lgb.train(params, dtrain, 10L)
#'
#' tree_interpretation <- lgb.interprete(model, test$data, 1L:5L)
#' lgb.plot.interpretation(tree_interpretation[[1L]], top_n = 10L)
#' @importFrom data.table setnames
#' @importFrom graphics barplot par
#' @export
lgb.plot.interpretation <- function(tree_interpretation_dt,
                                    top_n = 10L,
                                    cols = 1L,
                                    left_margin = 10L,
                                    cex = NULL) {

  # Get number of columns
  num_class <- ncol(tree_interpretation_dt) - 1L

  # Refresh plot
  op <- graphics::par(no.readonly = TRUE)
  on.exit(graphics::par(op))

  # Do some magic plotting
  bottom_margin <- 3.0
  top_margin <- 2.0
  right_margin <- op$mar[4L]

  graphics::par(
    mar = c(
      bottom_margin
      , left_margin
      , top_margin
      , right_margin
    )
  )

  # Check for number of classes
  if (num_class == 1L) {

    # Only one class, plot straight away
    multiple.tree.plot.interpretation(
      tree_interpretation_dt
      , top_n = top_n
      , title = NULL
      , cex = cex
    )

  } else {

    # More than one class, shape data first
    layout_mat <- matrix(
      seq.int(to = cols * ceiling(num_class / cols))
      , ncol = cols
      , nrow = ceiling(num_class / cols)
    )

    # Shape output
    graphics::par(mfcol = c(nrow(layout_mat), ncol(layout_mat)))

    # Loop throughout all classes
    for (i in seq_len(num_class)) {

      # Prepare interpretation, perform T, get the names, and plot straight away
      plot_dt <- tree_interpretation_dt[, c(1L, i + 1L), with = FALSE]
      data.table::setnames(
        plot_dt
        , old = names(plot_dt)
        , new = c("Feature", "Contribution")
      )
      multiple.tree.plot.interpretation(
        plot_dt
        , top_n = top_n
        , title = paste("Class", i - 1L)
        , cex = cex
      )

    }
  }
}

#' @importFrom graphics barplot
multiple.tree.plot.interpretation <- function(tree_interpretation,
                                              top_n,
                                              title,
                                              cex) {

  # Parse tree
  tree_interpretation <- tree_interpretation[order(abs(Contribution), decreasing = TRUE), ][seq_len(min(top_n, .N)), ]

  # Attempt to setup a correct cex
  if (is.null(cex)) {
    cex <- 2.5 / log2(1.0 + top_n)
  }

  # Do plot
  tree_interpretation[.N:1L,
                      graphics::barplot(
                          height = Contribution
                          , names.arg = Feature
                          , horiz = TRUE
                          , col = ifelse(Contribution > 0L, "firebrick", "steelblue")
                          , border = NA
                          , main = title
                          , cex.names = cex
                          , las = 1L
                      )]

  # Return invisibly
  return(invisible(NULL))

}