Add deterministic/degenerate distribution

NAMESPACE

@@ -182,6 +182,7 @@ export(colSums)
 export(cov2cor)
 export(cpu_only)
 export(destroy_greta_deps)
+export(deterministic)
 export(diag)
 export(dirichlet)
 export(dirichlet_multinomial)

R/mixture.R

@@ -56,7 +56,7 @@
 #' # check the mixing probabilities after fitting using calculate()
 #' # (you could also do this within the model)
 #' normalized_weights <- weights / sum(weights)
-#' draws_weights <- calculate(normalized_weights, draws_rates)
+#' draws_weights <- calculate(normalized_weights, values = draws_rates)
 #'
 #' # get the posterior means
 #' summary(draws_rates)$statistics[, "Mean"]

R/probability_distributions.R

@@ -1193,6 +1193,27 @@ lkj_correlation_distribution <- R6Class(
   )
 )
 
+deterministic_distribution <- R6Class(
+  "deterministic_distribution",
+  inherit = distribution_node,
+  public = list(
+    location = NA,
+    initialize = function(location, dim) {
+      location <- as.greta_array(location)
+
+      dim <- check_dims(location, target_dim = dim)
+      super$initialize("deterministic", dim)
+      self$add_parameter(location, "location")
+    },
+
+    tf_distrib = function(parameters, dag) {
+      tfp$distributions$Deterministic(
+        loc = parameters$location
+      )
+    }
+  )
+)
+
 # module for export via .internals
 distribution_classes_module <- module(
   uniform_distribution,
@@ -1222,7 +1243,8 @@ distribution_classes_module <- module(
   multinomial_distribution,
   categorical_distribution,
   dirichlet_distribution,
-  dirichlet_multinomial_distribution
+  dirichlet_multinomial_distribution,
+  deterministic_distribution
 )
 
 # export constructors
@@ -1569,3 +1591,9 @@ dirichlet_multinomial <- function(size, alpha,
     size, alpha, n_realisations, dimension
   )
 }
+
+#' @rdname distributions
+#' @export
+deterministic <- function(location, dimension = NULL) {
+  distrib("deterministic", location, dimension)
+}

tests/testthat/test_distributions.R

@@ -389,6 +389,24 @@ test_that("dirichlet-multinomial distribution has correct density", {
   )
 })
 
+ddegenerate <- function(x, location) {
+  ifelse(test = x == location,
+         yes = 1,
+         no = 0)
+}
+
+test_that("deterministic distribution has correct density", {
+  skip_if_not(check_tf_version())
+
+  compare_distribution(
+    greta::deterministic,
+    ddegenerate,
+    parameters = list(location),
+    x = sample(x = 1, size = 100, replace = TRUE)
+  )
+})
+
+
 test_that("scalar-valued distributions can be defined in models", {
   skip_if_not(check_tf_version())
 

tests/testthat/test_iid_samples.R

@@ -104,6 +104,12 @@ test_that("univariate samples are correct", {
     rf,
     parameters = list(df1 = 4, df2 = 1)
   )
+
+  # compare_iid_samples(deterministic,
+  #                     # runif, degenerate
+  #                     # parameters = list(min = -2, max = 3)
+  # )
+
 })
 
 test_that("truncated univariate samples are correct", {

tests/testthat/test_inference.R

@@ -298,6 +298,18 @@ test_that("mcmc supports slice sampler with single precision models", {
   ))
 })
 
+# test_that("mcmc works with deterministic distribution", {
+#   skip_if_not(check_tf_version())
+#   set.seed(5)
+#   x <- deterministic(0)
+#   m <- model(x, precision = "single")
+#   expect_ok(draws <- mcmc(m,
+#                           sampler = slice(),
+#                           n_samples = 100, warmup = 100,
+#                           verbose = FALSE
+#   ))
+# })
+
 test_that("initials works", {
   skip_if_not(check_tf_version())
 

tests/testthat/test_mixture.R

@@ -283,3 +283,8 @@ test_that("mixture of normals with varying weights has correct density", {
     dim = dim
   )
 })
+
+#
+# test_that("mixture of deterministic and continuous has correct density", {
+#
+# })