Commit 3c46f6f1 authored by Chris Jewell's avatar Chris Jewell
Browse files

Reshape2-ified initialisation of R matrix.

parent 9b57a702
......@@ -691,70 +691,30 @@ HaldDP <- R6::R6Class(
{
## r values
if (!("r" %in% names(inits))) {
## default is the source data matrix
inits$r <-
private$X + 0.000001 # Added for numeric stability -- only affects starting values for r
for (times in 1:private$nTimes) {
inits$r[, , times] <-
apply(inits$r[, , times], 2, function(x)
x / sum(x))
}
## default is the source data matrix (plus stability factor)
inits$r = apply(private$X + 1e-6, c('Source', 'Time'), function(x)
x / sum(x)) %>% aperm(c('Type', 'Source', 'Time'))
} else {
if (!is.data.frame(inits$r))
stop("inits$r must be a data frame.")
inits$r <- na.omit(inits$r)
if (!all(c("Type", "Source", "Time", "Value") %in% colnames(inits$r)))
stop("inits$r must be a data frame with columns called Type, Source, Time and Value")
inits$r$Type <- as.factor(inits$r$Type)
inits$r$Source <- as.factor(inits$r$Source)
inits$r$Time <- as.factor(inits$r$Time)
if (!setequal(unique(inits$r$Type), private$namesTypes) |
!setequal(unique(inits$r$Time), private$namesTimes) |
!setequal(unique(inits$r$Source), private$namesSources) |
dim(inits$r)[1] != (private$nTypes * private$nSources * private$nTimes))
!setequal(unique(inits$r$Source), private$namesSources))
stop(
"inits$r must be a data frame with columns called Type, Source, Time and Value with one row per combination of type, source and time."
)
if (!all(isFiniteInteger(inits$r$Value)) |
!all(inits$r$Value > 0) | !all(inits$r$Value < 1))
stop("inits$r$Value must contain only numbers between 0 and 1.")
inits_r <- array(
NA,
dim = c(private$nTypes, private$nSources, private$nTimes),
dimnames = list(
type = private$namesTypes,
source = private$namesSources,
time = private$namesTimes
)
initr_r = tryCatch(
acast(inits$r, Type ~ Source ~ Time, value.var = 'Value'),
condition=function(c) stop("inits$r must have a non-NA row for each Type/Time/Source combination.")
)
## Extract values from inits r data frame and put into arrays.
## Surely this is very slow!! TODO: find better way!
for (time in private$namesTimes) {
for (sources in private$namesSources) {
for (type in private$namesTypes) {
tmp_init_r <-
inits$r$Value[which((inits$r$Type == type) &
(inits$r$Time == time) &
(inits$r$Source == sources))]
if (length(tmp_init_r) == 0L)
stop("inits$r must have a non-NA row for each time, type and source.")
inits_r[which(private$namesTypes == type),
which(private$namesSources == sources),
which(private$namesTimes == time)] <-
tmp_init_r
}
## check the initial values sum to 1 within each time and location
if (!isTRUE(all.equal(sum(inits_r[, private$namesSources == sources, private$namesTimes == time]), 1, tol = 0.000001)))
stop("inits$r must sum to 1 within each time and source.")
}
}
names(dimnames(initr_r)) = c('Type','Source','Time')
sumToUnit = apply(initr_r, c('Type','Time'), sum)
if(!isTRUE(all.equal(sumToUnit, 1, tol=1e-5)))
stop("inits$r must sum to 1 within each time and source")
inits$r <- inits_r
}
......
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