Implement beta-uniform-mixture likelihood

NAMESPACE

@@ -26,6 +26,7 @@ S3method(summary,group.lasso)
 S3method(summary,netReg.family)
 export(beta)
 export(binomial)
+export(bum)
 export(cv.edgenet)
 export(edgenet)
 export(family)
@@ -49,7 +50,10 @@ importFrom(tensorflow,install_tensorflow)
 importFrom(tensorflow,tf)
 importFrom(tfprobability,tfd_bernoulli)
 importFrom(tfprobability,tfd_beta)
+importFrom(tfprobability,tfd_categorical)
 importFrom(tfprobability,tfd_gamma)
 importFrom(tfprobability,tfd_inverse_gaussian)
+importFrom(tfprobability,tfd_mixture)
 importFrom(tfprobability,tfd_poisson)
+importFrom(tfprobability,tfd_uniform)
 useDynLib(netReg, .registration = TRUE)

R/family.R

@@ -161,6 +161,28 @@ beta <- function(link = c("logit", "probit", "log")) {
 }
 
 
+#' @export
+#' @rdname family-methods
+bum <- function(link = c("logit", "probit", "log")) {
+  warn.experimental("bum")
+  link <- match.arg(link)
+  linkinv <- switch(
+    link,
+    "logit" = logistic,
+    "log" = exp,
+    "probit" = gcdf,
+    stop("did not recognize link function", call. = FALSE)
+  )
+
+  .as.family(
+    "bum",
+    link,
+    linkinv,
+    bum.loss
+  )
+}
+
+
 #' @export
 #' @rdname family-methods
 inverse.gaussian <- function(link = c("1/mu^2")) {

R/likelihood.R

@@ -98,6 +98,54 @@ beta.loss <- function(y, mu.hat, ...) {
 }
 
 
+#' @noRd
+#' @importFrom tensorflow tf
+#' @importFrom tfprobability tfd_beta tfd_uniform tfd_mixture tfd_categorical
+bum.loss <- function(y, mu.hat, ...) {
+  obj <- 0
+  eps <- .Machine$double.eps * 1e9
+  N <- mu.hat$shape[[1]]
+  for (j in seq(ncol(y))) {
+    mu <- mu.hat[, j]
+    mixture_weight <- tf$constant(matrix(0.75, nrow = N, ncol = 2), dtype = tf$float32) # TODO: learn this parameter
+    phi <- 1 # TODO: replace this with tf$variable
+
+    # reparametrize
+    # concentration1 := alpha = mu * phi
+    p <- mu * phi
+    # concentration0 := beta = (1. - mu) * phi
+    q <- (1 - mu) * phi
+
+    # deal with numerical instabilities
+    p.trans <- tf$math$maximum(p, eps)
+    q.trans <- tf$math$maximum(q, eps)
+
+    # need correct batch dimensions for mixture
+    p.trans <- tf$stack(list(p.trans, p.trans), 0L)
+    q.trans <- tf$stack(list(q.trans, q.trans), 0L)
+
+    prob <- tfprobability::tfd_mixture(
+      cat = tfprobability::tfd_categorical(
+        probs = c(mixture_weight, 1 - mixture_weight)
+      ),
+      components = c(
+        tfprobability::tfd_beta(
+          concentration1 = p.trans, concentration0 = q.trans
+        ),
+        tfprobability::tfd_uniform(
+          low = tf$constant(tf$Variable(matrix(0, nrow = 2, ncol = N), dtype=tf$float32)),
+          high = tf$constant(tf$Variable(matrix(1, nrow = 2, ncol = N), dtype=tf$float32))
+        )
+      )
+    )
+
+    obj <- obj + tf$reduce_sum(prob$log_prob(y[, j]))
+  }
+
+  -obj
+}
+
+
 #' @noRd
 #' @importFrom tensorflow tf
 #' @importFrom tfprobability tfd_inverse_gaussian