mread_yaml

block_sep <- "\n//-------------------------------\n"
library(yaml)
library(purrr)

mread_yaml <- function(file, project = '.', ...) {
  mod <- yaml.load_file(file)
  eq <- imap(mod$reactions, process_reaction)
  ode <- make_ode(eq,mod)
  main <- make_main(mod)
  table <- make_table(mod)
  capture <- make_capture(mod)
  global <- make_global(mod)
  param <- make_param(mod)
  init <- make_init(mod)
  prob <- make_prob(mod)
  stem <- tools::file_path_sans_ext(basename(file))
  cpp <- paste0(stem, ".model")
  out <- file.path(project,cpp)
  message("writing model to ",cpp)
  writeLines(c(block_sep,prob,global,param,init,main,ode,table,capture),con = out)
  mread_cache(cpp, project = project, ...)
}

process_reaction <- function(x,i,width = ceiling(log10(length(x)))+1) {
  width <- max(width,2)
  flux <- paste0("J", formatC(i, width = width, flag="0"))
  rp <- sapply(x$coef,length)
  mat <- lapply(seq_along(x$coef), function(xx) {
    expand.grid(
      flux = flux,
      coef = names(x$coef)[[xx]],
      cmt = x$coef[[xx]],
      stringsAsFactors=FALSE)
  })
  mat <- bind_rows(mat)
  mat$sign <- ifelse(substr(mat$coef,1,1)=="-", "-", "+")
  mat$coef <- sub("+", "", mat$coef,fixed = TRUE)
  mat$coef <- sub("-", "", mat$coef,fixed = TRUE)
  mat$flux <- flux
  mat$term = paste0(mat$sign," ",mat$flux)
  return(list(flux = flux, rhs = x$j, mat = mat,label = x$label))
}

make_dadt <- function(x,where = "mat") {
  x <- map_df(x, where)
  x <- 
    x %>% 
    group_by(cmt) %>% 
    summarise(x = paste0(term,collapse = " ")) %>%
    ungroup() 
  x$x <- sub("^\\+ (.*)", "  \\1", x$x)
  x$dadt <- paste0("dxdt_", x$cmt)
  x$dadt <- formatC(x$dadt,width = max(nchar(x$dadt)),flag="-")
  x$x <- paste0(x$dadt, " = ", x$x, ";")
  x$dadt <- x$x
  x$x <- NULL
  x
}

make_fluxes <- function(x) {
  rhs <- map_chr(x,"rhs")
  lhs <- map_chr(x,"flux")
  paste0("double ", lhs , " = ", rhs, ";")
}

make_main <- function(x) {
  if(is.null(x$main)) {
    return(NULL)  
  }
  c("[ main ]", x$main, block_sep )
}

make_table <- function(x) {
  if(is.null(x$table)) {
    return(NULL)  
  }
  c("[ table ]", x$table, block_sep)
}

make_capture <- function(x) {
  if(is.null(x$capture)) {
    return(NULL)  
  }
  c("[ capture ]", x$capture, block_sep)
}

make_global <- function(x) {
  if(is.null(x$global)) {
    return(NULL)  
  }
  c("[ global ]", x$global, block_sep)
}
make_ode <- function(eq,mod) {
  if(is.null(eq)) return(NULL)
  ode_b <- make_dadt(eq)
  ode_a <- make_fluxes(eq)
  ode <- c(ode_a, " ", ode_b$dadt)
  c("[ ode ]",mod$ode_assignments, ode, block_sep)
}
make_param <- function(x) {
  if(is.null(x$param)) return(NULL)
  ans <- paste0(names(x$param), " = ", unlist(x$param, use.names=FALSE))
  c("[ param ]", ans, block_sep)
}
make_init <- function(x) {
  if(is.null(x$init)) return(NULL)
  ans <- paste0(names(x$init)," = ", unlist(x$init, use.names=FALSE))
  c("[ init ]", ans, block_sep)
}
make_prob <- function(x) {
  if(is.null(x$prob)) return(NULL)
  c("[ prob ]", x$prob)
}