Entropy, KL Divergence, & Rcpp

kl_entropy.R

library(ggplot2)
theme_set(theme_classic())

# Visualizing entropy ---------------------------------------------------------
entropy <- function(p) -sum(p * log(p))
n <- 1e6
p <- runif(n)
q <- 1 - p
z <- matrix(c(p, q), ncol = 2)
ent <- apply(z, 1, entropy)
qplot(q, ent, geom = "line") +
  xlab("Probability") +
  ylab("Entropy") +
  ggtitle("Entropy For Two Events")

# C++
apply_entropy <- Kmisc::rcpp_apply_generator("return -sum(x * log(x));")
entropy_bm <- bench::mark(
  base = apply(z, 1, entropy),
  rcpp = apply_entropy(z, 1)
)

summary(entropy_bm)
summary(entropy_bm, relative = TRUE)

# Visualizing KL divergence ---------------------------------------------------
kld <- function(p, q) sum(p * log(p / q))
n <- 1e6
p <- c(0.6, 0.4)
q1 <- runif(n)
q2 <- 1 - q1
z <- matrix(c(q1, q2), ncol = 2)
kl <- apply(z, 1, kld, p = p)
qplot(q1, kl, geom = "line") +
  xlab("Probability") +
  ylab("KL Divergence") +
  geom_vline(xintercept = p[1], colour = "grey")

# C++
apply_kld <- Kmisc::rcpp_apply_generator('return sum(p * log(p / x));', 
  additional = '
  // [[Rcpp::plugins("cpp11")]]
  NumericVector p   {0.6, 0.4};')

kld_bm <- bench::mark(
  base = apply(z, 1, kld, p = p),
  rcpp = apply_kld(z, 1)
)

summary(kld_bm)
summary(kld_bm, relative = T)