Commit 08675db7 authored by Poppy Miller's avatar Poppy Miller
Browse files

Fixed a few little bugs in new heatmap and summary functions, and in DirichletNode.

parent fd26f038
......@@ -6,17 +6,17 @@
# Purpose: Draws a clustered heatmap #
#####################################################
are_colours <- function(x) {
sapply(x, function(X) {
are_colours <- function(object) {
sapply(object, function(x) {
tryCatch(
is.matrix(col2rgb(X)),
is.matrix(col2rgb(x)),
error = function(e)
FALSE
)
})
}
clusterHeatMap <- function(x, cols, xnames = 1:length(x), hclust_method) {
clusterHeatMap <- function(object, cols, xnames = 1:length(object), hclust_method) {
# Check colours
if (length(cols) != 2 |
......@@ -28,7 +28,7 @@ clusterHeatMap <- function(x, cols, xnames = 1:length(x), hclust_method) {
}
groups <-
as.data.frame(apply(groups, 2, function(x)
as.data.frame(apply(object, 2, function(x)
as.factor(x)))
# compute dissimilarity matrix for the type effect clusters
......
......@@ -180,10 +180,10 @@
#'
#' \item{\code{summary(alpha = 0.05, params = c("alpha", "q", "s", "r", "lambda_i",
#' "lambda_j" ,"lambda_j_prop"), times = NULL, locations = NULL, sources = NULL,
#' types = NULL, iters = NULL, flatten = FALSE, drop = TRUE, CI_type = "c-s")}}{
#' types = NULL, iters = NULL, flatten = FALSE, drop = TRUE, CI_type = "chen-shao")}}{
#' returns a list contining the
#' median and credible intervals for a subset of the parameters. The default credible
#' interval type are Chen-Shao highest posterior density intervals (alternatives
#' interval type are Chen-Shao (\code{"chen-shao"}) highest posterior density intervals (alternatives
#' are \code{"percentiles"} and \code{"spin"}).
#' See \code{extract} for details on the subsetting. \code{lambda_j_prop} returns the
#' proportion of cases attributed to each source \code{j} and is calculated by dividing
......@@ -258,7 +258,7 @@
#'
#' res$summary(params = c("alpha", "q", "lambda_i"),
#' times = "1", sources = c("ChickenA", "Bovine"),
#' iters = 10:100, flatten = TRUE, CI_type = "c-s")
#' iters = 10:100, flatten = TRUE, CI_type = "chen-shao")
#'
#' res$extract(params = c("alpha", "r", "q", "lambda_j"),
#' sources = c("ChickenB", "Ovine"),
......@@ -1164,8 +1164,8 @@ HaldDP <- R6::R6Class(
switch(
CI_type,
"chen-shao" = ci_chenShao(x),
"percentiles" = ci_percentiles(x),
"chen-shao" = ci_chenShao(x, alpha),
"percentiles" = ci_percentiles(x, alpha),
"SPIn" = ci_spin(x, alpha),
stop(
"The type of interval specified must be one of: chen-shao, percentiles, or SPIn."
......
......@@ -286,7 +286,8 @@ DirichletNode <- R6::R6Class(
self$addParent(alpha, name = 'alpha')
},
logDensity = function() {
lgamma(sum(alpha)) - sum(lgamma(alpha)) +
lgamma(sum(self$parents$alpha$getData())) -
sum(lgamma(self$parents$alpha$getData())) +
sum((self$parents$alpha$getData() - 1) * log(self$data))
}
)
......
......@@ -169,10 +169,10 @@ human cases for each type, time and location follow a Poisson likelihood.
\item{\code{summary(alpha = 0.05, params = c("alpha", "q", "s", "r", "lambda_i",
"lambda_j" ,"lambda_j_prop"), times = NULL, locations = NULL, sources = NULL,
types = NULL, iters = NULL, flatten = FALSE, drop = TRUE, CI_type = "c-s")}}{
types = NULL, iters = NULL, flatten = FALSE, drop = TRUE, CI_type = "chen-shao")}}{
returns a list contining the
median and credible intervals for a subset of the parameters. The default credible
interval type are Chen-Shao highest posterior density intervals (alternatives
interval type are Chen-Shao (\code{"chen-shao"}) highest posterior density intervals (alternatives
are \code{"percentiles"} and \code{"spin"}).
See \code{extract} for details on the subsetting. \code{lambda_j_prop} returns the
proportion of cases attributed to each source \code{j} and is calculated by dividing
......@@ -218,14 +218,14 @@ divided by the number of negative samples) \eqn{j}
\emph{Priors}
\deqn{r_{.jt}\sim Dirichlet(a_r_{1jt},..., a_r_{njt})}
\deqn{a_{tl}\sim Dirichlet(a_alpha_{1tl},..., a_alpha_{mtl})}
\deqn{q\sim DP(alpha, Gamma(a_{theta},b_{theta}))}
\deqn{q\sim DP(a_q, Gamma(a_{theta},b_{theta}))}
}
}
\examples{
data(campy)
zero_rows <- which(apply(campy[,c(2:7)], 1, sum) == 0)
campy <- campy[-zero_rows,]
prevs <- data.frame(Value = 1/c(181/ 239, 113/196, 109/127,
prevs <- data.frame(Value = c(181/ 239, 113/196, 109/127,
97/595, 165/552, 86/524),
Source = colnames(campy[, 2:7]),
Time = rep(1, 6),
......@@ -245,7 +245,7 @@ res$plot_heatmap(iters = 10:100, hclust_method = "complete")
res$summary(params = c("alpha", "q", "lambda_i"),
times = "1", sources = c("ChickenA", "Bovine"),
iters = 10:100, flatten = TRUE, CI_type = "c-s")
iters = 10:100, flatten = TRUE, CI_type = "chen-shao")
res$extract(params = c("alpha", "r", "q", "lambda_j"),
sources = c("ChickenB", "Ovine"),
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment