generate_benchmark_script.R

#===== generate_all_benchmarks (WIP) =====


#'generate_all_benchmarks
#'@description Collector function to generate benchmarks from all .prj files in
#' a directory
#'@param path Optional: A path to a benchmark directory to generate scripts
#' from (defaults to 'extdata/benchmarks' package folder)
#'@param dest_dir Optional: The directory to write the scripts to
#' (defaults to 'extdata/benchmark_scripts' package folder)
generate_all_benchmarks <- function(path = "extdata/benchmarks/",
                                    dest_dir = "extdata/benchmark_scripts/"){

    prj_files <- list.files(path = path, pattern = "\\.prj$", recursive = TRUE)

    for(i in seq_len(length(prj_files))){

        prj_file <- paste0(path, prj_files[[i]])

        skip_to_next <- FALSE

        out<- tryCatch(
            {
                xml2::read_xml(prj_file, encoding="ISO-8859-1")
            },
            error = function(cond){
                skip_to_next <<- TRUE
            }
        )

        if(skip_to_next){
            next
        }

        generate_benchmark_script(prj_file, dest_dir)
    }
}


#===== generate_benchmark_script =====

#'generate_benchmark_script
#'@description Generates a benchmark script from an existing .prj file.
#'@param prj_path The path to the project file the script will be based on
#'@param dest_dir Optional: The directory to write the script to
#'@export
generate_benchmark_script <- function(prj_path,
                                      dest_dir = "extdata/benchmark_scripts/") {

    assertthat::assert_that(assertthat::is.string(prj_path))
    assertthat::assert_that(assertthat::is.string(dest_dir))

    #Construct an object from a benchmark and then reverse engineer the call
    ogs6_obj <- OGS6$new(sim_name = "",
                         sim_id = 1,
                         sim_path = "",
                         ogs_bin_path = "",
                         test_mode = TRUE)

    read_in_prj(ogs6_obj, prj_path)

    impl_classes = get_implemented_classes()

    sim_name <- tools::file_path_sans_ext(basename(prj_path))

    script_str <- paste0("library(r2ogs6)\n\n",
                         "ogs6_obj <- OGS6$new(sim_name = \"",
                         sim_name, "\",\n",
                         "sim_id = 1,\n",
                         "sim_path = \"your_sim_path\",\n",
                         "ogs_bin_path = \"your_bin_path\")\n\n\n")

    for(i in seq_len(length(impl_classes))){
        get_component_call <- paste0("ogs6_obj$", names(impl_classes)[[i]])
        ogs6_component <- eval(parse(text = get_component_call))

        #If benchmark doesn't have components of specified name, skip
        if(is.null(ogs6_component) || length(ogs6_component) == 0){
            next
        }

        #If objects are not in wrapper list, wrap them up for seq_along()
        if(any(grepl("r2ogs6_", class(ogs6_component), fixed = TRUE))){
            ogs6_component <- list(ogs6_component)
        }

        for(j in seq_along(ogs6_component)){
            add_call_str <- paste0(construct_add_call(ogs6_component[[j]]),
                                   "\n\n")
            script_str <- paste0(script_str, add_call_str)
        }
    }

    script_str <- paste0(script_str, "run_simulation(ogs6_obj)\n")

    #If no destination file was defined, print output to console
    if(dest_dir != ""){
        if(!dir.exists(dest_dir)){
            dir.create(dest_dir, showWarnings = FALSE)
        }

        cat(script_str, file = paste0(dest_dir, sim_name, ".R"))
    }else{
        cat(script_str)
    }

    return(invisible(script_str))
}


#'construct_add_call
#'@description Constructs a call based on an OGS6 component. This is a
#' recursive function, handle with care.
#'@param object An object (numeric, character, list, NULL, or r2ogs6 class
#' object)
#'@param nested_call Optional: For recursion purposes, you should leave this as
#' it is.
#'@return A string representing the code with which the component would be added
#' to an OGS6 object
construct_add_call <- function(object, nested_call = FALSE) {

    #For values of type numeric or character, dput will give us usable output
    if(is.character(object) ||
       is.numeric(object)){
        ret_str <- paste(utils::capture.output(dput(object)), collapse="\n")
        return(invisible(ret_str))
    }

    #For NULL values we return "NULL" as string
    if(is.null(object)){
        return("NULL")
    }

    #For r2ogs6 objects we need to use recursion
    if(any(grepl("r2ogs6_", class(object), fixed = TRUE))){
        class_name <- class(object)
        tag_name <- paste(utils::tail(unlist(strsplit(class_name, "_")), -1),
                          collapse = "_")

        #Grab constructor since the helper might have coercable parameters
        param_names <- names(as.list(formals(paste0("new_", class_name))))
        param_strs <- list()

        for(i in seq_len(length(param_names))){
            get_param_call <- paste0("object$", param_names[[i]])
            param <- eval(parse(text = get_param_call))

            param_str <- construct_add_call(param, TRUE)
            param_strs <- c(param_strs, list(param_str))
        }

        content_str <- paste(param_names,
                             param_strs,
                             sep = " = ",
                             collapse = ",\n")

        #If call is nested, it's a subclass object without OGS6$add_* function
        if(nested_call){
            ret_str <- paste0(class_name, "(", content_str, ")")
            ret_str <- delete_nulls_from_str(ret_str)
            ret_str <- delete_keywords_from_str(ret_str)
            return(invisible(ret_str))
        }

        ret_str <- paste0("ogs6_obj$add_",
                          tag_name,
                          "(", class_name, "(", content_str, "))\n")
        ret_str <- delete_nulls_from_str(ret_str)
        ret_str <- delete_keywords_from_str(ret_str)
        return(invisible(ret_str))
    }

    #For tibbles we don't need recursion, but they still require extra handling
    if("tbl_df" %in% class(object)){
        tib_str <- paste(names(object), object, sep = " = ", collapse = ",\n")
        ret_str <- paste0("tibble::tibble(", tib_str, ")")
        return(invisible(ret_str))
    }

    #Positioning is important here - r2ogs6 objects are built on top of lists!
    #If is.list is checked before class, results will not be as intended!

    #For lists we need to use recursion
    if(is.list(object)){

        element_strs <- lapply(object, function(x){construct_add_call(x, TRUE)})

        if(is.null(names(object)) ||
           rlist::list.any(names(object) == "")){
            content_str <- paste(element_strs, collapse = ",\n")
        }else{
            content_str <- paste(names(object),
                                 element_strs,
                                 sep = " = ",
                                 collapse = ",\n")
        }

        ret_str <- paste0("list(", content_str, ")")
        return(invisible(ret_str))
    }
}



#'delete_nulls_from_str
#'@description Utility function to delete "param_name = NULL" from a string,
#' this isn't necessary for functionality of generate_benchmark_script but will
#' make generated scripts way more readable.
#'@param string string
delete_nulls_from_str <- function(string){

    #For single line calls
    #Match in beginning of call
    string <- stringr::str_remove_all(string, "[\\w_]* = NULL, ")

    #Match in middle or at end of call
    string <- stringr::str_remove_all(string, ", [\\w_]* = NULL")


    #For multi line calls
    #Match in beginning of call
    string <- stringr::str_remove_all(string, "[\\w_]* = NULL,\n")

    #Match in middle or at end of call
    string <- stringr::str_remove_all(string, ",\n[\\w_]* = NULL")

    return(invisible(string))
}


#'delete_keywords_from_str
#'@description Utility function to delete keywords from a string,
#' this important because there is a <repeat> tag in <time_loop> and
#' "repeat" is a reserved word in R (extend this function if you find more
#' reserved words)
#'@param string string
delete_keywords_from_str <- function(string){

    string <- stringr::str_remove_all(string, "repeat = ")

    return(invisible(string))
}