Reshape2-ified initialisation of R matrix.

R/interface.R

@@ -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
       }