R/create_rmd.R

In Certara.ModelResults: Generate Diagnostics for Pharmacometric Models Using 'shiny'

create_rmdFile <- function(directory){
  if(missing(directory)){
    directory <- tempdir()
  }

  directory <- gsub("\\", "/", directory, fixed = TRUE)

  if (!dir.exists(directory)) {
    stop("Cannot use ", directory, ", please ensure the path exists.")
  }

  rmdFile <- file.path(directory, "report_template.Rmd")
  file.create(rmdFile)

  return(rmdFile)

}

create_yaml <- function(title, orientation, marginLeft, marginRight, marginTop, marginBottom){ #add arguments for to create toc

  title <- paste0("title: \"", title, "\"")
  yamlBreak <- "---"
  html_theme <- "united"
  yamlHeaders <- c(title,
                   "date: '`r format(Sys.time(), \"%m-%d-%y\")`'",
                   "output:",
                   "  word_document:",
                   "    toc: true",
                   "    toc_depth: 4",
                   "    keep_md: false",
                   "    reference_docx: report_template.docx",
                   "  html_document:",
                   "    toc: true",
                   "    toc_depth: 4",
                   "    toc_float: true",
                   "    keep_md: false",
                   paste0("    theme: ", html_theme),
                   "  pdf_document:",
                   "    toc: true",
                   "    number_sections: true",
                   "    fig_caption: true",
                   "params:",
                   "  inputs: NA",
                   paste0("classoption: ", orientation),
                   paste0("geometry: ", paste0("left=", marginLeft, "cm,",
                                               "right=", marginRight, "cm,",
                                               "top=", marginTop, "cm,",
                                               "bottom=", marginBottom, "cm",
                                               collapse = ""))
  )



  yamlHead <- c(yamlBreak, yamlHeaders, yamlBreak)

  return(yamlHead)

}

create_yaml_raw <- function(title, orientation, marginLeft, marginRight, marginTop, marginBottom){

  title <- paste0("title: \"", title, "\"")
  yamlBreak <- "---"
  html_theme <- "united"
  reference_docx <- system.file(package = "Certara.ModelResults", "extdata", "report_template.docx")

  yamlHeaders <- c(title,
                   "date: '`r format(Sys.time(), \"%m-%d-%y\")`'",
                   "output:",
                   "  word_document:",
                   "    toc: true",
                   "    toc_depth: 4",
                   "    keep_md: false",
                   paste0("    reference_docx: ", reference_docx),
                   "  html_document:",
                   "    toc: true",
                   "    toc_depth: 4",
                   "    toc_float: true",
                   "    keep_md: false",
                   paste0("    theme: ", html_theme),
                   "  pdf_document:",
                   "    toc: true",
                   "    number_sections: true",
                   "    fig_caption: true",
                   "params:",
                   "  inputs: NA",
                   paste0("geometry: ", paste0("left=", marginLeft, "cm,",
                                               "right=", marginRight, "cm,",
                                               "top=", marginTop, "cm,",
                                               "bottom=", marginBottom, "cm",
                                               collapse = ""))
  )


  yamlHead <- c(yamlBreak, yamlHeaders, yamlBreak)

  return(yamlHead)

}

create_rmd <- function(title, objects, orientation, marginLeft, marginRight, marginTop, marginBottom) {

  rmdFile <- create_rmdFile()

  rmd <- create_yaml(title, orientation =  tolower(orientation), marginLeft, marginRight, marginTop, marginBottom) #need arguments for toc

  chunkNoIncl <- "\n```{r, include = FALSE}"
  chunkStart <- "\n```{r, echo = FALSE, message = FALSE, warning=FALSE}"
  chunkEnd <- "```\n"

  dep <- c("Certara.Xpose.NLME", "xpose", "flextable", "knitr")

  libs <- paste0("library(", dep, ")")
  plotDims <- "knitr::opts_chunk$set(dpi = 300, fig.width = 10, fig.height = 5, message = FALSE, warning = FALSE)"
  tinytex_opt <- "options(tinytex.verbose = TRUE)"

  rmd <- c(rmd, chunkNoIncl, libs, plotDims, tinytex_opt, chunkEnd)

  code_out <- list()
  for(obj in seq_along(objects)){
    objname <- names(objects)[[obj]]
    header <- paste0("# ", objname)
    chunk <- paste0("knit_print(params$inputs$`", objname, "`[[2]])")
    code_out[[obj]] <- c(header, chunkStart, chunk, chunkEnd)
  }

  rmd <- c(rmd, code_out)

  writeLines(unlist(rmd), con = rmdFile)

}


create_rmd_raw <- function(title, objects, orientation, marginLeft, marginRight, marginTop, marginBottom, init) {

  rmd <- create_yaml_raw(title, orientation =  tolower(orientation), marginLeft, marginRight, marginTop, marginBottom)

  chunkNoIncl <- "\n```{r, include = FALSE}"
  chunkStart <- "\n```{r, echo = FALSE, message = FALSE, warning=FALSE}"
  chunkEnd <- "```\n"

  dep <- c("Certara.ModelResults", "Certara.Xpose.NLME", "xpose", "flextable", "ggplot2", "dplyr","tidyr","magrittr")

  libs <- paste0("library(", dep, ")")
  plotDims <- "knitr::opts_chunk$set(dpi = 300, fig.width = 10, fig.height = 5, message = FALSE, warning = FALSE)"
  tinytex_opt <- "options(tinytex.verbose = TRUE)"

  rmd <- c(rmd, chunkNoIncl, libs, plotDims, tinytex_opt, chunkEnd)

  if(!is.null(init)){
    rmd <- c(rmd, chunkStart, init, chunkEnd)
  }

  code_out <- list()
  for(obj in seq_along(objects)){
    header <- paste0("# ", names(objects)[[obj]])
    chunk <-  objects[[obj]]$code

    code_out[[obj]] <- c(header, chunkStart, chunk, chunkEnd)
    }

  rmd <- c(rmd, code_out)


  return(rmd)
}

report_render <- function(type){
  if(type == "pdf"){
    render_fun <- "pdf_document"#rmarkdown::pdf_document(toc = TRUE)
  } else if (type == "docx"){
    render_fun <- "word_document"#rmarkdown::word_document(toc = TRUE, reference_docx = "report_template.docx")
  } else {
    render_fun <- "html_document"#rmarkdown::html_document(toc = TRUE)
  }
  return(render_fun)
}


gen_xpdb_code <- function(model_name, xpdb_names, init_arg_type){

  initenv <- NULL

  if(init_arg_type == "model_single"){
    modelObjects <- model_name
  } else if(init_arg_type =="model_list") {
    modelObjects <- model_name[-1]
    initenv <- paste0("list2env(",model_name[[1]], ",envir = globalenv())")
  } else {
  modelObjects <- trimws(strsplit(model_name, "[,()]")[[1]])[-1]
  }


  #stopifnot(length(modelObjects) == length(xpdb_names))

  initHeader <- c()
  for(i in seq_along(modelObjects)){
    xpdbName <- xpdb_names[[i]]
    modelObj <- modelObjects[[i]]

    xpdbInit <- paste0("`",xpdbName, "`"," = xposeNlme(dir = ", modelObj, "@modelInfo@workingDir, modelName = ",modelObj, "@modelInfo@modelName)")
     initHeader <- c(initHeader, xpdbInit)
  }


  initHeader <- paste0(initHeader, collapse = ", \n")

  xpdbCode <- paste0("xpdb <- list(", initHeader, ")\n")

  xpdbCode <-c(initenv, xpdbCode)

  return(xpdbCode)

}



gen_xpdb_list <- function(xpdb_names, xpdb_arg){

  initHeader <- paste0("xpdb <- list(`", xpdb_names, "` = ", xpdb_arg, ")")

  return(initHeader)

}


get_dir_from_script <- function(script){

  dir_pos <- script[grep("setwd", script)]

  dir <- gsub("[\\(\\)]", "", regmatches(dir_pos, gregexpr("\\(.*?\\)", dir_pos))[[1]])

  dir <- gsub("'", "", dir)

  return(dir)
}

# Separates tagged diagnostics into nested list by model



get_run_names <- function(tagged){
  runs <- NULL
  for(i in seq_along(tagged)){
    run <- tagged[[i]]$run
    runs <- c(runs, run)
  }
  return(runs)
}


parse_tagged <- function(tagged){

  runs <- unique(get_run_names(tagged))

  tagged_nested <- list()

  for(i in seq_along(runs)){
    run <- runs[[i]]
    for(j in seq_along(tagged)){
      dname <- names(tagged)[[j]]
      run_id <- tagged[[j]]$run
      if(run == run_id){
        tagged_nested[[run]][[dname]] <- tagged[[j]]
      } else {
        next
      }
    }
  }
  return(tagged_nested)
}

save_tagged_rds <- function(tagged_nested, dir_out){

  for(i in seq_along(tagged_nested)){
    run <- names(tagged_nested)[[i]]
    saveRDS(tagged_nested[[i]], file = paste0(dir_out, "/", run, "_tagged.Rds"))
    shiny::incProgress(message = paste0(run, "tagged objects saved"))
  }

}