R/create_rmd.R

In Certara.DarwinReporter: Data Visualization Utilities for 'pyDarwin' Machine Learning Pharmacometric Model Development

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

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

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

  return(rmdFile)

}

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

  title <- paste0("title: \"", title, "\"")
  yamlBreak <- "---"
  html_theme <- "united"
  if (!raw) {
  params <- c("params:",
  "  inputs: NA",
  "  darwin_data: NA")
  ref_doc <- "    reference_docx: report_template.docx"
  } else {
    params <- NULL
    ref_doc <- NULL
  }
  yamlHeaders <- c(title,
                   "date: '`r format(Sys.time(), \"%m-%d-%y\")`'",
                   "output:",
                   "  word_document:",
                   "    toc: true",
                   "    toc_depth: 4",
                   "    keep_md: false",
                   ref_doc,
                   "  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,
                   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_rmd <- function(darwin_data = NULL, title, objects, orientation, marginLeft, marginRight, marginTop, marginBottom, includeAppendix = TRUE, autoFormat = TRUE, customOrder = NULL, raw = FALSE, darwin_data_name = "") {

  rmdFile <- create_rmdFile()

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

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

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

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

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

  if (raw) {
    init <-
      c(
        paste0(
          darwin_data_name,
          " <- darwin_data(project_dir = '",
          darwin_data$project_dir,
          "',"
        ),
        paste0("working_dir = '", darwin_data$working_dir, "',"),
        paste0("output_dir = '", darwin_data$output_dir, "',"),
        paste0("key_models_dir = '", darwin_data$key_models_dir, "')")
      )
    init <- gsub("\\\\", "\\\\\\\\", init)

    rmd <- c(rmd, chunkStart, init, chunkEnd)
  }

  has_final_model <- FALSE

  main_header <- "## Population PK Analysis"

  search_space_header <- "### Search Space"
  search_space_text <- paste0("The search space includes the dimensions for:\n")

  search_algorithm_parameters_header <- "### Search Algorithm and Parameters"
  search_algorithm_parameters_text <- get_search_algorithm_parameters_text(darwin_data)

  fitness_function_header <- "### Fitness Function"
  fitness_function_text <- get_fitness_function_text(darwin_data)

  rmd <-
    c(
      rmd,
      main_header,
      search_space_header,
      search_space_text,
      search_algorithm_parameters_header,
      search_algorithm_parameters_text,
      fitness_function_header,
      fitness_function_text
    )

  if (autoFormat) {

  object_names <- sapply(objects, function(x) x$name)

  lookup_name <- object_names == "Penalties vs Iteration"
  if (any(lookup_name)) {
    objname <- names(object_names[lookup_name])
    text <- "\nMinimum fitness by iteration with penalty values is summarized:\n"
    if (raw) {
      chunk <- objects[[objname]]$code
    } else {
      chunk <- paste0("knit_print(params$inputs$`", objname, "`[[2]])")
    }
    rmd <- c(rmd, text, chunkStart, chunk, chunkEnd)
    #remove from objects
    objects[[objname]] <- NULL
  }

  lookup_name <- object_names == "Fitness vs Iteration"
  if (any(lookup_name)) {
    objname <- names(object_names[lookup_name])
    text <- "\nMean fitness and minimum cumulative fitness by iteration is summarized:\n"
    if (raw) {
      chunk <- objects[[objname]]$code
    } else {
      chunk <- paste0("knit_print(params$inputs$`", objname, "`[[2]])")
    }
    rmd <- c(rmd, text, chunkStart, chunk, chunkEnd)
    #remove from objects
    objects[[objname]] <- NULL
  }

  # Key Models
  header <- "### Key Models"
  text <- "Key models were defined as any improvements in fitness by generation:\n"
  # Key Models Table
  lookup_name <- object_names == "Key Models"
  if (any(lookup_name)) {
    objname <- names(object_names[lookup_name])
    if (raw) {
      chunk <- objects[[objname]]$code
    } else {
      chunk <- paste0("knit_print(params$inputs$`", objname, "`[[2]])")
    }
    rmd <- c(rmd, header, text, chunkStart, chunk, chunkEnd)
    #remove from objects
    objects[[objname]] <- NULL
  } else {
    rmd <- c(rmd, header, text)
  }

  # Get original order for key models
  key_models_complete <- names(darwin_data$key_models$xpose_data)

  key_models_obj_run <- lapply(objects, function(x) {
    x$run
  })
  key_models_obj_name <- lapply(objects, function(x) {
    x$name
  })
  key_models_obj_type <- lapply(objects, function(x) {
    x$type
  })

  key_models <- data.frame(key_model = unlist(key_models_obj_run),
                           obj_name = unlist(key_models_obj_name),
                           obj_tag = names(key_models_obj_name),
                           obs_type = unlist(key_models_obj_type),
                           row.names = NULL)

  key_models$key_model <- factor(key_models$key_model, levels = key_models_complete)
  key_models <- key_models[order(key_models$key_model), ]
  key_models$key_model <- as.character(key_models$key_model)

  code_out <- list()
  for (i in seq_len(nrow(key_models))) {
    obj_name <- key_models[i, "obj_name"]
    obj_tag <- key_models[i, "obj_tag"]
    key_model <- key_models[i, "key_model"]
    if (i == 1) {
      key_model_prev <- ""
    } else {
      key_model_prev <- key_models[i - 1, "key_model"]
    }

    key_model_number <- grep(key_model, key_models_complete)

    if (key_model != key_model_prev) {
      if (key_model_number == length(key_models_complete)) {
        header <- paste0("### Final Model")
        final_model <- names(darwin_data$key_models$run_dirs)[length(darwin_data$key_models$run_dirs)]
        final_model <- strsplit(final_model, split = "_")[[1]]
        text <-
          paste0("\nModel ",
                 final_model[3],
                 " in iteration ",
                 final_model[2],
                 " was selected as the final model.\n")
        has_final_model <- TRUE
      } else {
        header <-
          paste0("#### Key Model ", key_model_number, ": ", key_model)
        text <- NULL
      }
    } else {
      header <- NULL
      text <- NULL
    }
    if (raw) {
      chunk <- objects[[obj_tag]]$code
    } else {
      chunk <-
        paste0("knit_print(params$inputs$`", obj_tag, "`[[2]])")
    }
    code_out[[obj_tag]] <-
      c(header, text, chunkStart, chunk, chunkEnd)
  }
  } else {
    # Use tagged object name as header, given order of inputs in container
    objects <- objects[customOrder]
    code_out <- list()
    for(obj in seq_along(objects)){
      objname <- names(objects)[[obj]]
      header <- paste0("#### ", objname)
      if (raw) {
        chunk <- objects[[objname]]$code
      } else {
        chunk <- paste0("knit_print(params$inputs$`", objname, "`[[2]])")
      }
      code_out[[obj]] <- c(header, chunkStart, chunk, chunkEnd)
    }
    code_out <- c("\n### Figures\n", code_out)
  }

  rmd <- c(rmd, code_out)

  if (!has_final_model) {
    header <- paste0("### Final Model")
    final_model <- names(darwin_data$key_models$run_dirs)[length(darwin_data$key_models$run_dirs)]
    final_model <- strsplit(final_model, split = "_")[[1]]
    text <-
      paste0("\nModel ",
             final_model[3],
             " in iteration ",
             final_model[2],
             " was selected as the final model.\n")
    has_final_model <- TRUE
    code_out <- c(header, text)
    rmd <- c(rmd, code_out)
  }

  if (includeAppendix) {
    #Options, template.txt, tokens.json
    appendix_header <- "## Appendix\n"
    include_key_models_code <- TRUE
    if (include_key_models_code) {
      appendix_header <-
        c(appendix_header, "### Key Models Control File\n")
      code <- darwin_data$key_models$code
      if (raw) {
        code_out <- lapply(names(code), function(name) {
          paste0(
            "#### ",
            name,
            "\n",
            chunkStart,
            "\n",
            paste0("cat(paste0(", darwin_data_name, "$key_models$code$"),
            name,
            ", collapse = '\n'))\n",
            chunkEnd
          )
        })
      } else {
        code_out <- lapply(names(code), function(name) {
          paste0(
            "#### ",
            name,
            "\n",
            chunkStart,
            "\n",
            "cat(paste0(params$darwin_data$key_models$code$",
            name,
            ", collapse = '\n'))\n",
            chunkEnd
          )
        })
      }

      rmd <- c(rmd, appendix_header, code_out)
    }
  }


  if (raw) {
    return(rmd)
  } else {
    writeLines(unlist(rmd), con = rmdFile)
  }

}


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"))
  }

}