R/concat.R

In andrewzm/MVST: Multi-variate ST modelling

#### concatenate blocks ####

#' @rdname concat
#' @aliases concat,block-method
setMethod("concat",signature = "block", function(...) { return(...) })

#' @rdname concat
#' @aliases concat,GMRF-method
setMethod("concat",signature = "GMRF",function(...) {
  l <- list(...)
  mu <- Q <- intrinsic <- n <- rep <- list()
  
  for (i in 1:length(l)) {
    mu[[i]] <- l[[i]]@mu
    Q[[i]] <- l[[i]]@Q
    intrinsic[[i]] <- l[[i]]@intrinsic
    n[[i]] <- l[[i]]@n
  }    
  mu <- Reduce("rbind",mu)
  Q <- Reduce("bdiag",Q)
  intrinsic <- Reduce("min",intrinsic)
  n <- Reduce("+",n)
  
  common_cols <- Reduce("intersect",lapply(l,function(x) {colnames(x@rep)}))
  compatible <- lapply(l,function(x) suppressWarnings(all(common_cols == colnames(x@rep))))
  if(!all(unlist(compatible))) warning("Keeping only common columns in mesh attributes when compressing")
  rep <- Reduce("rbind",lapply(l,function(x) return(subset(x@rep,select=common_cols))))
  return(new("GMRF",
             mu = mu,
             Q = Q,
             intrinsic = intrinsic,
             n = n,
             rep=rep))
})

#' @rdname concat
#' @aliases concat,GMRF_basis-method
setMethod("concat",signature = "GMRF_basis",function(...) {
  l <- list(...)
  lG <- lapply(l,function(df) {return(df@G)})
  Gconcat <- Reduce("concat",lG)
  return(Gconcat)
})

#' @rdname concat
#' @aliases concat,Obs-method
setMethod("concat",signature = "Obs",function(...) {
  l <- list(...)
  df <- n <- list()
  for (i in 1:length(l)) {
    df[[i]] <- l[[i]]@df
    n[[i]] <- l[[i]]@n
  }    
  
  common_cols <- Reduce("intersect",lapply(df,colnames))
  compatible <- lapply(df,function(x) suppressWarnings(all(common_cols == colnames(x))))
  if(!all(unlist(compatible))) warning("Keeping only common columns in data sets when compressing")
  df <- Reduce("rbind",lapply(df,function(x) return(subset(x,select=common_cols))))
  n <- Reduce("+",n)
  
  return(new("Obs",
             df = df))})


concatBasis <- function(G1,G2){
            this_basis <- new("Basis", pars=c(G1@pars,G2@pars), n=G1@n + G2@n, fn=c(G1@fn,G2@fn))
            return(this_basis)
          }