R/sysargslist_utilities.R

Defines functions subsetRmd .prepareRmdPlot renderLogs renderReport configWF .outputTargets .outList2DF .statusPending .dirProject readSE writeSE read_SYSargsList write_SYSargsList .statusSummary output.as.df .updateAfterRunC .tryRcode runRcode status_color runWF SYSargsList SPRproject

Documented in configWF renderLogs runWF SPRproject SYSargsList write_SYSargsList

####################################################################
## Functions to construct SYSargsList objects and other utilities ##
####################################################################

##########################
## SPRproject function ##
##########################
## Detection and creation of the logs directory of the project
## This function detects an existing project or creates a project structure on the path provide
SPRproject <- function(projPath = getwd(), data = "data", param = "param", results = "results",
                       logs.dir = ".SPRproject", sys.file = "SYSargsList.yml",
                       envir = new.env(),
                       restart = FALSE, resume = FALSE,
                       load.envir = FALSE,
                       overwrite = FALSE, silent = FALSE) {
    projPath <- normalizePath(projPath)
    on.exit(options(projPath = projPath), add = TRUE)
    if (!file.exists(projPath)) stop("Provide valid 'projPath' PATH.")
    ## Main folder structure
    dirProject <- .dirProject(projPath = projPath, data = data, param = param, results = results, silent = silent)
    ## sys.file full path
    sys.file <- file.path(logs.dir, sys.file)
    ## log Folder
    logs.dir <- file.path(logs.dir)
    if (file.exists(file.path(projPath, logs.dir)) == FALSE) {
        dir.create(file.path(projPath, logs.dir), recursive = TRUE)
        if (silent != TRUE) cat("Creating directory '", file.path(projPath, logs.dir), "'", sep = "", "\n")
        ## Return SYSargsList obj - empty
        yaml::write_yaml("", file = file.path(projPath, sys.file))
        dirProject <- c(dirProject, logsDir = logs.dir, sysargslist = sys.file)
        init <- as(SYScreate("SYSargsList"), "list")
        init$projectInfo <- dirProject
        init$runInfo <- list(env = envir)
        init <- as(init, "SYSargsList")
        ## used in `importWF`
        options(linewise_importing = FALSE)
    } else if (file.exists(file.path(projPath, logs.dir)) == TRUE) {
        ## create object from sysarglist
        if (is.null(sys.file)) stop("Provide valid 'sys.file' PATH for restart/resume the project.")
        if (!file.exists(file.path(projPath, sys.file))) stop("Provide valid 'sys.file' PATH for restart/resume the project.")
        restart.sys.file <- normalizePath(file.path(projPath, sys.file))
        init <- read_SYSargsList(restart.sys.file)
        init <- as(init, "list")
        if (load.envir == TRUE) {
            if (is.null(init$projectInfo$envir)) {
                message("We could not find any environment saved...")
            } else {
                envir <- readRDS(init$projectInfo$envir)
                init$runInfo <- append(init$runInfo, envir, after = 0)
                names(init$runInfo)[[1]] <- c("env")
            }
        } else {
            init$runInfo <- append(init$runInfo, envir, after = 0)
            names(init$runInfo)[[1]] <- "env"
            init$projectInfo$envir <- NULL
        }
        init$projectInfo$project <- projPath
        init$projectInfo$logsDir <- logs.dir
        init$projectInfo$sysargslist <- sys.file
        init <- as(init, "SYSargsList")
        if (all(resume == FALSE && restart == FALSE)) {
            if (overwrite == FALSE) {
                stop(paste0(
                    file.path(projPath, logs.dir),
                    " already exists.", "\n",
                    "The Workflow can be resume where it was stopped, using the argument 'resume=TRUE'",
                    "\n", "OR ", "restart using 'restart=TRUE'."
                ))
            } else if (overwrite == TRUE) {
                ## Return SYSargsList obj - empty
                unlink(logs.dir, recursive = TRUE)
                dir.create(file.path(projPath, logs.dir), recursive = TRUE)
                if (silent != TRUE) cat("Recreating directory '", file.path(projPath, logs.dir), "'", sep = "", "\n")
                yaml::write_yaml("", file = file.path(projPath, sys.file))
                dirProject <- c(dirProject, logsDir = logs.dir, sysargslist = sys.file)
                init <- as(SYScreate("SYSargsList"), "list")
                init$projectInfo <- dirProject
                init$runInfo <- list(env = envir)
                init <- as(init, "SYSargsList")
            }
        } else if (all(resume == TRUE && restart == TRUE)) {
            stop("Please select only one action: 'resume' OR 'restart'")
        } else if (all(resume == FALSE && restart == TRUE)) {
            if (overwrite == FALSE) {
                stop(paste0(
                    file.path(projPath, logs.dir), " already exists.", "\n",
                    "The Workflow can be restart, using the argument 'restart=TRUE' and 'overwrite=TRUE'. Please use this option with caution!"
                ))
            } else if (overwrite == TRUE) {
                unlink(file.path(projPath, logs.dir), recursive = TRUE)
                dir.create(file.path(projPath, logs.dir), recursive = TRUE)
                if (silent != TRUE) cat("Creating directory '", file.path(projPath, logs.dir), "'", sep = "", "\n")
            }
        }
    }
    write_SYSargsList(init, file.path(projPath, sys.file), silent = silent)
    ## Message about the paths
    if (getwd() != projPath) {
        message(paste0(
            "Your current working directory is different from the directory chosen for the Project Workflow.",
            "\n",
            "For accurate location of the files and running the Workflow, please set the working directory to ",
            "\n",
            paste0("'setwd(", projPath, ")'")
        ))
    }
    return(init)
}

## Usage:
# sal <- SPRproject()
# sal <- SPRproject(projPath = tempdir())
# sal <- SPRproject(restart = TRUE, overwrite=TRUE)
# sal <- SPRproject(resume=TRUE)



##########################
## SYSargsList function ##
##########################
SYSargsList <- function(sysargs = NULL, step_name = "default",
                        targets = NULL, wf_file = NULL, input_file = NULL, dir_path = ".",
                        id = "SampleName",
                        inputvars = NULL,
                        rm_targets_col = NULL,
                        dir = TRUE,
                        dependency = "",
                        run_step = "mandatory",
                        run_session = "rsession",
                        silent = FALSE, projPath = getOption("projPath", getwd())) {
    ## step_name and dependency from importWF
    on.exit(options(importwf_options = NULL))
    if (!is.null(getOption("importwf_options"))) {
        step_name <- getOption("importwf_options")[[1]]
        .checkSpecialChar(step_name)
        dependency <- getOption("importwf_options")[[2]]
    }
    ## check options
    run_step <- match.arg(run_step, c("mandatory", "optional"))
    run_session <- match.arg(run_session, c("rsession", "cluster"))
    sal <- as(SYScreate("SYSargsList"), "list")
    ## Empty container
    if (all(is.null(sysargs) && is.null(wf_file) && is.null(input_file))) {
        sal <- sal ## This will not create a SPRproject.
        message("Please consider to use 'SPRproject()' function instead")
        ## sal container based on a SYSargs2 container ##
    } else if (!is.null(sysargs)) {
        if (inherits(sysargs, "SYSargs2")) {
            if (length(cmdlist(sysargs)) == 0) stop("Argument 'sysargs' needs to be assigned an object of class 'SYSargs2' after 'renderWF()'.")
            if (step_name == "default") {
                step_name <- "Step_x"
            } else {
                .checkSpecialChar(step_name)
                step_name <- step_name
            }
            sal$stepsWF <- list(sysargs)
            ## Targets
            if (length(targets(sysargs)) == 0) {
                sal$targetsWF <- list(NULL)
                sal$SE <- list()
            } else {
                sal$targetsWF <- list(as(sysargs, "DataFrame"))
                row.names(sal$targetsWF) <- sal$targetsWF[ ,sysargs$files$id]
                sal$SE <- list(SummarizedExperiment::SummarizedExperiment(
                  colData = sal$targetsWF,
                  metadata = sysargs$targetsheader))
            }
            ## Status
            if (length(status(sysargs)) == 0) {
                sal$statusWF <- list(.statusPending(sysargs))
            } else {
                sal$statusWF <- list(status(sysargs))
            }
            sal$dependency <- list(dependency)
            sal$outfiles <- list(.outList2DF(sysargs))
            sal$targets_connection <- list(NULL)
            sal$runInfo <- list(runOption = list(list(directory = dir, run_step = run_step, run_session = run_session)))
            names(sal$stepsWF) <- names(sal$targetsWF) <- names(sal$statusWF) <- names(sal$dependency) <- names(sal$outfiles) <- names(sal$targets_connection) <- names(sal$runInfo$runOption) <-  names(sal$SE) <- step_name
        } else {
            stop("Argument 'sysargs' needs to be assigned an object of class 'SYSargs2'.")
        }
      ## Build the instance from files ##
    } else if (all(!is.null(wf_file) && !is.null(input_file))) {
        ## targets
        if (is.null(targets)) {
            targets <- targets
        } else if (inherits(targets, "character")) {
            if (all(is.fullPath(targets))) {
                targets <- targets
            } else if (all(all(file.exists(file.path(projPath, targets))) && length(targets) == 1)) {
                targets <- file.path(projPath, targets)
            } else {
                targets_step <- targets
                targets <- NULL
            }
        }
        if (is.fullPath(dir_path)) {
            dir_path <- dir_path
        } else {
            dir_path <- file.path(projPath, dir_path)
        }
        WF <- loadWF(
            targets = targets, wf_file = wf_file,
            input_file = input_file,
            dir_path = dir_path, id = id
        )
        ## targets_path to projPath
        if (!is.na(WF@files$targets)) WF@files$targets <- gsub(getOption("projPath"), "", WF$files$targets)
        if (grepl("^/", WF@files$targets)) WF@files$targets <- sub("^(/|[A-Za-z]:|\\\\|~)", "", WF$files$targets)
        ## dir_path
        if (!is.na(WF@files$dir_path)) WF@files$dir_path <- gsub(getOption("projPath"), "", WF$files$dir_path)
        if (all(!is.fullPath(dir_path) && grepl("^/", WF@files$dir_path))) WF@files$dir_path <- sub("^(/|[A-Za-z]:|\\\\|~)", "", WF$files$dir_path)
        WF <- renderWF(WF, inputvars = inputvars)
        if (step_name == "default") {
            step_name <- "Step_x"
        } else {
            .checkSpecialChar(step_name)
            step_name <- step_name
        }
        sal$stepsWF <- list(WF)
        names(sal$stepsWF) <- step_name
        ## Connection to previous outfiles
        if (exists("targets_step")) {
            targets_step_list <- list(targets_step = targets_step)
            new_targets_col <- names(inputvars)
            if (is.null(new_targets_col)) {
                stop("inputvars argument need to be assigned to the output column names from the previous step specified on the targets argument")
            }
            new_col <- list(new_targets_col = new_targets_col)
            if (!is.null(rm_targets_col)) {
                rm_col <- list(rm_targets_col = rm_targets_col)
            } else {
                rm_col <- list(rm_targets_col = NULL)
            }
            sal$targets_connection <- list(list(targets_step = targets_step_list, new_targets_col = new_col, rm_targets_col = rm_col))
            names(sal$targets_connection) <- step_name
        }
        if (length(sal$targets_connection) == 0) {
            sal$targets_connection <- list(NULL)
            names(sal$targets_connection) <- step_name
        }
        sal$dependency <- list(dependency)
        sal$statusWF <- list(.statusPending(WF))
        # sal$runInfo <- list(directory=list(dir))
        sal$runInfo <- list(runOption = list(list(directory = dir, run_step = run_step, run_session = run_session)))
        ## names
        # names(sal$statusWF) <- names(sal$dependency) <- names(sal$runInfo[[1]]) <- step_name
        names(sal$statusWF) <- names(sal$dependency) <- names(sal$runInfo$runOption) <- step_name
        ## outfiles
        if (length(sal$stepsWF) > 0) {
            sal$outfiles <- .outList2DF(sal)
            ## targets
            if (length(targets(sal$stepsWF[[1]])) > 0) {
                sal$targetsWF <- list(as(sal$stepsWF[[1]], "DataFrame"))
                row.names(sal$targetsWF[[1]]) <- sal$targetsWF[[1]][ ,sal$stepsWF[[1]]$files$id]
                sal$SE <- list(SummarizedExperiment::SummarizedExperiment(
                  colData = sal$targetsWF,
                  metadata = sal$stepsWF[[1]]$targetsheader))
            } else {
                sal$targetsWF <- list(S4Vectors::DataFrame())
                sal$SE <- list(NULL)
            }
        }
        names(sal$targetsWF) <- names(sal$SE) <- step_name
    }
    sal <- as(sal, "SYSargsList")
    return(sal)
}

####################
## runWF function ##
#####################
runWF <- function(sysargs, steps = NULL, force = FALSE, saveEnv = TRUE,
                  warning.stop = FALSE, error.stop = TRUE, silent = FALSE, ...) {
    # Validations
    if (!inherits(sysargs, "SYSargsList")) stop("Argument 'sysargs' needs to be assigned an object of class 'SYSargsList'")
    if (length(sysargs) == 0) message("Workflow has no steps. Please add a step before trying to execute the workflow.")
    if (is.null(projectInfo(sysargs)$project)) stop("Project was not initialized with the 'SPRproject' function.")
    if (!dir.exists(projectInfo(sysargs)$logsDir)) stop("Project logsDir doesn't exist. Something went wrong...
        It is possible to restart the workflow saving the SYSargsList object with 'write_SYSargsList()' and restarting the project with 'SPRproject()'")
    sysproj <- projectInfo(sysargs)$logsDir
    ## check dependency
    for (i in seq_along(dependency(sysargs))) {
        if (all(!dependency(sysargs)[[i]] == "")) {
            dep_names <- unlist(dependency(sysargs)[[i]])
            if (any(!dep_names %in% names(stepsWF(sysargs)))) {
                  stop(
                      "'sysargs' has dependency on the following steps:", "\n",
                      paste0("      ", paste0(dep_names, collapse = " AND ")), "\n",
                      "Please make sure that this step is present."
                  )
              }
        }
    }
    ## Logs
    file_log <- file.path(sysproj, paste0("_logWF_", format(Sys.time(), "%b%d%Y_%H%M"), "_", paste(sample(0:9, 4), collapse = "")))
    sysargs[["projectInfo"]]$logsFile <- file_log
    ## steps loop
    args2 <- sysargs
    if (is.null(steps)) steps <- 1:length(args2)
    for (i in seq_along(stepsWF(args2))) {
        if (i %in% steps) {
            ## check single dependency
            if (all(!dependency(args2)[[i]] == "")) {
                dep_single <- sapply(dependency(args2)[[i]], function(x) args2$statusWF[[x]]$status.summary)
                if ("Pending" %in% dep_single) {
                    message("Previous steps:", "\n", paste0(names(dep_single), collapse = " AND "), "\n", "have been not executed yet.")
                    break()
                }
            }
            ## Printing step name
            single.step <- names(stepsWF(args2)[i])
            cat(crayon::bgMagenta(paste0("Running Step: ", single.step)), "\n")
            ## Printing single.step name at log files
            cat("# ", names(stepsWF(args2)[i]), "\n", file = file_log, fill = TRUE, append = TRUE)
            args.run <- stepsWF(args2)[[i]]
            ## SYSargs2 STEP
            if (inherits(args.run, "SYSargs2")) {
                ## runC arguments
                dir <- args2$runInfo$runOption[[i]]$directory
                dir.name <- single.step
                args.run <- runCommandline(args.run,
                    dir = dir, dir.name = dir.name,
                    force = force, ...
                )
                cat(readLines(args.run$files$log),
                    file = file_log, sep = "\n",
                    append = TRUE
                )
                ## update object
                step.status.summary <- status(args.run)$status.summary
                statusWF(args2, i) <- args.run$status
                stepsWF(args2, i) <- args.run
                args2[["outfiles"]][[i]] <- .outList2DF(args.run)
                args2 <- .updateAfterRunC(args2, single.step)
                assign(
                    x = as.character(as.list(match.call())$sysargs), args2,
                    envir = args2$runInfo$env
                )
                ## Stop workflow
                if (is.element("Warning", unlist(step.status.summary))) {
                    if (warning.stop == TRUE) {
                        on.exit(return(args2))
                        stop("Caught an warning, stop workflow!")
                    }
                } else if (is.element("Error", unlist(step.status.summary))) {
                    if (error.stop == TRUE) {
                        on.exit(return(args2))
                        stop("Caught an error, stop workflow!")
                    }
                }
                cat(status_color(step.status.summary)(paste0("Step Status: ", step.status.summary), "\n"))
            } else if (inherits(args.run, "LineWise")) {
                envir <- args2$runInfo$env
                assign(x = as.character(as.list(match.call())$sysargs), args2, envir = envir)
                if (!dir.exists(file.path(sysproj, "Rsteps"))) {
                    dir.create(file.path(sysproj, "Rsteps"))
                }
                file_log_Rcode <- file.path(sysproj, "Rsteps", paste0("_logRstep_", single.step, "_", format(Sys.time(), "%b%d%Y_%H%M%S")))
                args.run <- runRcode(args.run,
                    step = single.step, file_log = file_log_Rcode,
                    envir = envir, force = force
                )
                assign(
                    "args2", get(as.character(as.list(match.call())$sysargs), envir),
                    environment()
                )
                args2[["stepsWF"]][[i]] <- args.run
                args2[["statusWF"]][[i]] <- args.run$status
                cat(readLines(file_log_Rcode),
                    file = file_log, sep = "\n",
                    append = TRUE
                )
                ## Stop workflow
                if (is.element("Warning", unlist(args.run$status$status.summary))) {
                    if (warning.stop == TRUE) {
                        on.exit(return(args2))
                        stop("Caught an warning, stop workflow!")
                    }
                } else if (is.element("Error", unlist(args.run$status$status.summary))) {
                    if (error.stop == TRUE) {
                        on.exit(return(args2))
                        stop("Caught an error, stop workflow!")
                    }
                }
                cat(status_color(args.run$status$status.summary)(paste0("Step Status: ", args.run$status$status.summary), "\n"))
            }
        } else {
            ## Printing step name
            single.step <- names(stepsWF(args2)[i])
            cat(status_color("Skipping")(paste0("Skipping Step: ", single.step)), "\n")
        }
    }
    if (saveEnv == TRUE) {
        envPath <- file.path(sysproj, "sysargsEnv.rds")
        if (any(as.character(as.list(match.call())$sysargs) %in% ls(sysargs@runInfo$env, all.names = TRUE))) {
            rm(list = as.character(as.list(match.call())$sysargs), envir = sysargs@runInfo$env)
        }
        saveRDS(args2$runInfo$env, envPath)
        args2[["projectInfo"]][["envir"]] <- envPath
    }
    args2 <- .check_write_SYSargsList(args2, TRUE)
    return(args2)
}

status_color <- function(x) {
    switch(x,
        "Pending" = crayon::bgBlue,
        "Warning" = crayon::bgYellow,
        "Error" = crayon::bgRed,
        "Success" = crayon::bgGreen,
        "Skipping" = crayon::bgCyan
    )
}

# cat(status_color("Pending")("test"))
# cat(status_color("Warning")("test"))
# cat(status_color("Error")("test"))
# cat(status_color("Success")("test"))
# cat(status_color("Skipping")("test"))

#######################
## runRcode function ##
#######################
runRcode <- function(args, step = stepName(args), file_log = NULL, envir = globalenv(), force = FALSE) {
    ## Validation for 'args'
    if (!inherits(args, "LineWise")) stop("Argument 'args' needs to be assigned an object of class 'LineWise'")
    pb <- txtProgressBar(min = 0, max = length(args), style = 3)
    ## log_file
    if (is.null(file_log)) {
        file_log <- paste0("_logRcode_", format(Sys.time(), "%b%d%Y_%H%M"))
    }
    ## Print at the log_file
    cat(c(
        paste0("Time: ", paste0(format(Sys.time(), "%b%d%Y_%H%Ms%S"))), "\n",
        "## Code: ",
        "```{r, eval=FALSE} ",
        utils::capture.output(codeLine(args)),
        "```", "\n",
        "## Stdout: ",
        "```{r, eval=FALSE}"
    ), file = file_log, sep = "\n", append = TRUE)
    ## Check status of step
    if (all(args$status$status.summary == "Success" && force == FALSE)) {
        args[["status"]]$status.time$time_start <- Sys.time()
        cat("The step status is 'Success' and it was skipped.", file = file_log, fill = TRUE, append = TRUE, sep = "\n")
        args[["status"]]$status.time$time_end <- Sys.time()
    } else {
        ## Status and time register
        step_status <- list()
        time_status <- data.frame(Step = step, time_start = NA, time_end = NA)
        time_status$time_start <- Sys.time()
        ## Running the code
        stdout <- .tryRcode(args$codeLine, envir = envir)
        ## save stdout to file
        utils::capture.output(stdout$stdout, file = file_log, append = TRUE)
        ## save error and warning messages
        if (!is.null(stdout$error)) {
            cat("## Error", file = file_log, sep = "\n", append = TRUE)
            cat(stdout$error, file = file_log, sep = "\n", append = TRUE)
            step_status[["status.summary"]] <- "Error"
        } else if (!is.null(stdout$warning)) {
            cat("## Warning", file = file_log, sep = "\n", append = TRUE)
            cat(stdout$warning, file = file_log, sep = "\n", append = TRUE)
            step_status[["status.summary"]] <- "Warning"
        } else if (all(is.null(stdout$error) && is.null(stdout$warning))) {
            step_status[["status.summary"]] <- "Success"
        }
        ## Saving the new status
        step_status[["status.completed"]] <- data.frame(Step = step, Status = step_status[[1]])
        time_status$time_end <- Sys.time()
        step_status[["status.time"]] <- time_status
        args[["status"]] <- step_status
    }
    utils::setTxtProgressBar(pb, length(args))
    ## close R chunk
    cat("``` \n", file = file_log, sep = "\n", append = TRUE)
    close(pb)
    args[["files"]] <- list(log = file_log)
    return(args)
}

########################
## .tryRcode function ##
########################
.tryRcode <- function(command, envir) {
    warning <- error <- NULL
    value <- withCallingHandlers(
        tryCatch(
            eval(command, envir = envir),
            error = function(e) {
                error <<- conditionMessage(e)
                NULL
            }
        ),
        warning = function(w) {
            warning <<- append(warning, conditionMessage(w))
            invokeRestart("muffleWarning")
        }
    )
    list(stdout = value, warning = warning, error = error)
}

###############################
## .updateAfterRunC function ##
###############################
.updateAfterRunC <- function(args, step) {
    conList <- args$targets_connection[lengths(args$targets_connection) != 0]
    conList_step <- sapply(conList, "[[", 1)
    for (l in seq_along(conList_step)) {
        if (step %in% conList_step[[l]]) {
            requiredUP <- names(conList)[[l]]
            for (s in requiredUP) {
                WF <- args[s]
                WFstep <- names(stepsWF(WF))
                new_targets <- WF$targetsWF[[1]]
                col_out <- lapply(outfiles(args), function(x) colnames(x))
                col_out_l <- sapply(names(col_out), function(x) list(NULL))
                for (i in names(col_out)) {
                    col_out_l[[i]] <- col_out[[i]][col_out[[i]] %in% WF$targets_connection[[WFstep]]$new_targets_col[[1]]]
                }
                col_out_l <- col_out_l[lapply(col_out_l, length) > 0]

                if (all(sapply(col_out_l, function(x) length(x) == 1))) {
                    col_out_df <- lapply(names(col_out_l), function(x) getColumn(args, step = x, position = "outfiles", column = col_out_l[[x]]))
                    names(col_out_df) <- col_out_l
                    new_targets[as.character(col_out_l)] <- col_out_df
                } else {
                    col_out_df <- data.frame(args[step]$outfiles[[step]][, col_out_l[[1]]])
                    names(col_out_df) <- col_out_l[[1]]
                    new_targets[as.character(col_out_l[[1]])] <- col_out_df
                }
                WF2 <- stepsWF(WF)[[1]]
                WF2 <- updateWF(WF2, new_targets = targets.as.list(data.frame(new_targets)), inputvars = WF2$inputvars, write.yaml = FALSE)
                ## Preserve outfiles
                WF2[["output"]] <- WF$stepsWF[[s]]$output
                args <- sysargslist(args)
                args$stepsWF[[WFstep]] <- WF2
                args$targetsWF[[WFstep]] <- as(WF2, "DataFrame")
                args$outfiles[[WFstep]] <- output.as.df(WF2)
                args$statusWF[[WFstep]] <- WF2$status
                args <- as(args, "SYSargsList")
            }
        } else {
            do <- "donothing"
        }
    }
    return(args)
}

#############################
## output.as.df function ##
#############################
output.as.df <- function(x) {
    out_x <- output(x)
    out_x <- S4Vectors::DataFrame(matrix(unlist(out_x), nrow = length(out_x), byrow = TRUE))
    colnames(out_x) <- x$files$output_names
    return(out_x)
}

#############################
## .statusSummary function ##
#############################
.statusSummary <- function(args) {
    if (inherits(args, "SYSargs2")) {
        step.status.summary <- args$status$status
    } else if (inherits(args, "data.frame")) {
        step.status.summary <- args[5:ncol(args)]
    } else {
        stop("Argument 'args' needs to be assigned an object of class 'SYSargs2' or 'data.frame'.")
    }
    if ("Error" %in% unlist(unique(step.status.summary))) {
        step.status <- "Error"
    } else if ("Warning" %in% unlist(unique(step.status.summary))) {
        step.status <- "Warning"
    } else if ("Success" %in% unlist(unique(step.status.summary))) {
        step.status <- "Success"
    } else if ("Pending" %in% unlist(unique(step.status.summary))) {
        step.status <- "Pending"
    } else if (is.null(step.status.summary)) {
        step.status <- "Pending"
    }
    return(step.status)
}

################################
## write_SYSargsList function ##
################################
write_SYSargsList <- function(sysargs, sys.file = ".SPRproject/SYSargsList.yml", silent = TRUE) {
    ## check logDir folder
    ## TODO
    if (!inherits(sysargs, "SYSargsList")) stop("sysargs needs to be object of class 'SYSargsList'.")
    args2 <- sysargslist(sysargs)
    args_comp <- sapply(args2, function(x) list(NULL))
    steps <- names(stepsWF(sysargs))
    ## special case for "runInfo" slot
    yaml_slots <- c("runInfo")
    for (i in yaml_slots) {
        args_comp[[i]] <- yaml::as.yaml(args2[[i]]$runOption)
    }
    ## Simple yaml slots
    yaml_slots <- c("projectInfo")
    for (i in yaml_slots) {
        args_comp[[i]] <- yaml::as.yaml(args2[[i]])
    }
    ## Yaml Slots + steps
    yaml_slots_S <- c("statusWF", "dependency", "targets_connection")
    for (i in yaml_slots_S) {
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            steps_comp[j] <- yaml::as.yaml(args2[[i]][j])
        }
        args_comp[[i]] <- steps_comp
    }
    ## DataFrame Slots
    df_slots <- c("targetsWF", "outfiles")
    for (i in df_slots) {
        #  args_comp[[i]] <- yaml::as.yaml(as.data.frame(args2[[i]]$Mapping))
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            steps_comp[j] <- yaml::as.yaml(data.frame(args2[[i]][[j]], check.names = FALSE))
        }
        args_comp[[i]] <- steps_comp
    }
    ## SYSargs2 and LineWise
    steps_comp <- sapply(steps, function(x) list(NULL))
    for (j in steps) {
        if (inherits(args2[["stepsWF"]][[j]], "SYSargs2")) {
            step_obj <- sysargs2(args2[["stepsWF"]][[j]])
            steps_comp[[j]] <- yaml::as.yaml(step_obj)
        } else if (inherits(args2[["stepsWF"]][[j]], "LineWise")) {
            step_obj <- linewise(args2[["stepsWF"]][[j]])
            step_obj$codeLine <- as.character(step_obj$codeLine)
            steps_comp[[j]] <- yaml::as.yaml(step_obj)
        }
    }
    args_comp[["stepsWF"]] <- steps_comp
    ## SE slot
    path <- file.path(.getPath(sys.file), "SE")
    if(!dir.exists(path)) {
      dir.create(path, recursive = TRUE)
    }
    steps_comp <- sapply(steps, function(x) list(NULL))
    for (j in steps) {
      if(!is.null(args2[["SE"]][[j]])){
        writeSE(args2[["SE"]][[j]], dir.path = path, dir.name = j, overwrite = TRUE, silent = TRUE)
        steps_comp[[j]] <- yaml::as.yaml(list(dir.path=path, dir.name=j))
      } else {
        steps_comp[j]  <- yaml::as.yaml(args2[["SE"]][j])
      }
  }
    args_comp[["SE"]] <- steps_comp
    ## Save file
    yaml::write_yaml(args_comp, sys.file)
    if (silent != TRUE) cat("Creating file '", file.path(sys.file), "'", sep = "", "\n")
    return(sys.file)
}

# ## Usage:
# write_SYSargsList(sal, sys.file, silent=FALSE)


################################
## read_SYSargsList function ##
################################
read_SYSargsList <- function(sys.file) {
    args_comp_yml <- yaml::read_yaml(sys.file)
    args_comp <- sapply(args_comp_yml, function(x) list(NULL))
    steps <- names(args_comp_yml$stepsWF)
    ## Simple yaml slots
    yaml_slots <- c("projectInfo")
    for (i in yaml_slots) {
        args_comp[[i]] <- yaml::yaml.load(args_comp_yml[i])
    }
    ## runInfo yaml slots
    yaml_slots <- c("runInfo")
    for (i in yaml_slots) {
        args_comp[[i]] <- list(runOption = yaml::yaml.load(args_comp_yml[i]))
    }
    ## Yaml Slots + steps
    yaml_slots_S <- c("dependency", "targets_connection")
    for (i in yaml_slots_S) {
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            steps_comp[j] <- yaml::yaml.load(args_comp_yml[[i]][j])
        }
        args_comp[[i]] <- steps_comp
    }
    ## targetsWF Slots
    df_slots <- c("targetsWF", "outfiles")
    for (i in df_slots) {
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            steps_comp[[j]] <- S4Vectors::DataFrame(yaml::yaml.load(args_comp_yml[[i]][[j]]), check.names = FALSE)
        }
        args_comp[[i]] <- steps_comp
    }
    ## SYSargs2 and LineWise
    if (length(args_comp_yml$stepsWF) >= 1) {
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            if ("codeLine" %in% names(yaml::yaml.load(args_comp_yml[["stepsWF"]][[j]]))) {
                args <- yaml::yaml.load(args_comp_yml[["stepsWF"]][[j]])
                if (length(args$codeLine) >= 1) {
                    args$codeLine <- parse(text = args$codeLine)
                }
                if (length(args$codeChunkStart) == 0) args$codeChunkStart <- integer()
                if (length(args$files) == 0) args$files$rmdPath <- character()
                if (length(args$dependency) == 0) args$dependency <- character()
                args <- as(args, "LineWise")
                steps_comp[[j]] <- args
            } else {
                args <- yaml::yaml.load(args_comp_yml[["stepsWF"]][[j]])
                args[["status"]][[2]] <- data.frame(args[["status"]][[2]], check.names = FALSE)
                args[["status"]][[3]] <- data.frame(args[["status"]][[3]])
                steps_comp[[j]] <- as(args, "SYSargs2")
            }
            args_comp[["stepsWF"]] <- steps_comp
        }
    } else if (length(args_comp_yml$stepsWF) >= 0) {
        args_comp[["stepsWF"]] <- list()
    }
    ## status
    yaml_slots_Status <- c("statusWF")
    for (i in yaml_slots_Status) {
        steps_comp <- sapply(steps, function(x) list(NULL))
        for (j in steps) {
            steps_comp[j] <- yaml::yaml.load(args_comp_yml[[i]][j])
            if (length(steps_comp[[j]]$status.time) != 0) {
                steps_comp[[j]]$status.time$time_start <- .POSIXct(steps_comp[[j]]$status.time$time_start)
                steps_comp[[j]]$status.time$time_end <- .POSIXct(steps_comp[[j]]$status.time$time_end)
            }
            steps_comp[j][[1]][[2]] <- data.frame(steps_comp[j][[1]][[2]], check.names = FALSE)
            steps_comp[j][[1]][[3]] <- data.frame(steps_comp[j][[1]][[3]])
        }
        args_comp[[i]] <- steps_comp
    }
    
    
    ## SE slot
      steps_comp <- sapply(steps, function(x) list(NULL))
      for (j in steps) {
        steps_comp[[j]] <- yaml::yaml.load(args_comp_yml[["SE"]][[j]])
        if(!is.null(steps_comp[[j]][[1]])){
          dir.path <- steps_comp[[j]][[1]]
          dir.name <- steps_comp[[j]][[2]]
          SE <- readSE(dir.path = dir.path, dir.name = dir.name)
          steps_comp[[j]] <- list(SE)
          } else {
            steps_comp[[j]] <-  steps_comp[[j]]
          }
        }
      args_comp[["SE"]] <- sapply(steps_comp, function(x) x[[1]])
    return(as(args_comp, "SYSargsList"))
}

# ## Usage:
# sys.file=".SPRproject/SYSargsList.yml"
# sal3 <- read_SYSargsList(sys.file)

################################
## writeSE function ##
################################
writeSE <- function(SE, dir.path, dir.name, overwrite = FALSE, silent = FALSE){
  # Validations
  if (!inherits(SE, "SummarizedExperiment")) stop("Argument 'SE' needs to be assigned an object of class 'SummarizedExperiment'")
  if (!dir.exists(dir.path)) stop("'dir.path' doesn't exist.")
  if (all(dir.exists(file.path(dir.path, dir.name)) & overwrite == FALSE)) stop(paste("'dir.name' directory already exist. Please delete existing directory:", dir.name, "or set 'overwrite=TRUE'"))
  if(!dir.exists(file.path(dir.path, dir.name))){
    dir.create(file.path(dir.path, dir.name))
  }
  path <- file.path(dir.path, dir.name)
  ## Counts
  if(length(SummarizedExperiment::assays(SE)) > 0) {
    for (i in length(SummarizedExperiment::assays(SE))){
      write.table(SummarizedExperiment::assays(SE)[[i]], file.path(path, paste0("counts_", i, ".csv")), quote = FALSE, row.names = FALSE,
                  col.names = TRUE, sep = "\t")
    }
  }
  ## Metadata
  yaml::write_yaml(S4Vectors::metadata(SE), file.path(path, paste0("metadata.yml")))
  ## colData
  write.table(SummarizedExperiment::colData(SE), file.path(path, paste0("colData.csv")), quote = FALSE, row.names = TRUE,
              col.names = NA, sep = "\t")
  ## RowRanges
  if(!is.null(SummarizedExperiment::rowRanges(SE))){
    write.table(as.data.frame(SummarizedExperiment::rowRanges(SE)), file=file.path(path, paste0("rowRanges.csv")),
                sep="\t", quote = FALSE, row.names = FALSE)
  }
  ## Final message
  if(silent != TRUE) cat("\t", "Written content of 'SE' to directory:", path, "\n")
}

# writeSE(rse, dir.path = getwd(), dir.name = "seobj")
# 
# dir.path <- getwd()
# dir.name <- "seobj"

################################
## readSE function ##
################################
readSE <- function(dir.path, dir.name){
  path <- file.path(dir.path, dir.name)
  if (!dir.exists(path)) stop("'dir.path' doesn't exist.")
  ## Counts
  files_counts <- list.files(path, pattern = "counts")
  if(length(files_counts) > 0) {
    counts_ls <- S4Vectors::SimpleList(NULL)
    for (i in files_counts){
      counts_ls <- as.matrix(read.table(file.path(path, i), check.names = FALSE, header = TRUE))
    } 
  }  else {
    counts_ls <- S4Vectors::SimpleList()
  }
  ## Metadata
  metadata <- yaml::read_yaml(file.path(path, paste0("metadata.yml")))
  ## colData
  colData <- read.table(file.path(path, paste0("colData.csv")), check.names = FALSE, sep = "\t")
  ## rowRanges
  files_counts <- list.files(path, pattern = "rowRanges")
  if(length(files_counts) > 0) {
  rowRanges_df <- read.table(file.path(path, paste0("rowRanges.csv")), check.names = FALSE, header = TRUE)
  rowRanges <- makeGRangesFromDataFrame(rowRanges_df, keep.extra.columns=TRUE)
  } else {
    rowRanges = GRangesList()
  }
  SE <- SummarizedExperiment::SummarizedExperiment(
    assays=counts_ls,
    #rowData=NULL, 
    rowRanges=rowRanges,
    colData=colData,
    metadata=metadata)
  return(SE)
}

# nrows <- 200; ncols <- 6
# counts <- matrix(runif(nrows * ncols, 1, 1e4), nrows)
# rowRanges <- GRanges(rep(c("chr1", "chr2"), c(50, 150)),
#                      IRanges(floor(runif(200, 1e5, 1e6)), width=100),
#                      strand=sample(c("+", "-"), 200, TRUE),
#                      feature_id=sprintf("ID%03d", 1:200))
# colData <- DataFrame(Treatment=rep(c("ChIP", "Input"), 3),
#                      row.names=LETTERS[1:6])
# rse <- SummarizedExperiment::SummarizedExperiment(assays=S4Vectors::SimpleList(counts=counts),
#                             rowRanges=rowRanges, colData=colData)
# rse
# writeSE(rse, dir.path = getwd(), dir.name = "seobj")
# SE <- readSE(dir.path = getwd(), dir.name = "seobj")
# library(diffobj)
# diffPrint(target=SE, current=rse)

# writeSE(sal$SE$gzip, dir.path = getwd(), dir.name = "seobj")
# SE <- readSE(dir.path = getwd(), dir.name = "seobj")
# library(diffobj)
# diffPrint(target=SE, current=rse)

################################
## .dirProject function ##
################################
.dirProject <- function(projPath, data, param, results, silent) {
    project <- list(
        project = projPath,
        data = file.path(projPath, data),
        param = file.path(projPath, param),
        results = file.path(projPath, results)
    )
    path <- sapply(project, function(x) suppressMessages(tryPath(x)))
    create <- NULL
    for (i in seq_along(path)) {
        if (is.null(path[[i]])) create <- c(create, project[i])
    }
    ## Question
    if (!is.null(create)) {
        ## For an interactive() session
        if (interactive()) {
            dir_create <- readline(cat(
                "It is required to have the project structure in place. We can create the directories now, and you can find more information by reading the `?SPRProject` help file. ", "\n",
                "\n", "There is no directory called", "\n", paste(names(create), collapse = " OR ", sep = "\n"), "\n", "\n",
                "Would you like to create this directory now? Type a number: \n 1. Yes \n 2. No \n"
            ))
        } else {
            ## For an non-interactive session
            dir_create <- "1"
        }
        for (i in seq_along(create)) {
            if (dir_create == "1") {
                dir.create(create[[i]], recursive = TRUE)
                if (silent != TRUE) cat(paste("Creating directory:", create[[i]]), "\n")
            } else if (dir_create == 2) {
                stop("Aborting project creation. Find more information by reading the `?SPRProject` help file.", call. = FALSE)
            }
        }
    }
    project <- list(
        project = projPath,
        data = file.path(data),
        param = file.path(param),
        results = file.path(results)
    )
    return(project)
}

#############################
## .statusPending function ##
#############################
.statusPending <- function(args) {
    status.pending <- check.output(args)
    if (inherits(args, "SYSargsList")) {
        for (i in seq_along(status.pending)) {
            pending <- sapply(stepsWF(args)[[i]]$files$steps, function(x) list(x = "Pending"))
            pending <- data.frame(matrix(unlist(pending), ncol = length(pending), byrow = TRUE), stringsAsFactors = TRUE)
            colnames(pending) <- stepsWF(args)[[i]]$files$steps
            status.pending[[i]] <- cbind(status.pending[[i]], pending)
        }
    } else if (inherits(args, "SYSargs2")) {
        pending <- sapply(args$files$steps, function(x) list(x = "Pending"))
        pending <- data.frame(matrix(unlist(pending), ncol = length(pending), byrow = TRUE), stringsAsFactors = TRUE)
        colnames(pending) <- args$files$steps
        status.pending <- cbind(status.pending, pending)
    }
    status.pending[c(2:4)] <- sapply(status.pending[c(2:4)], as.numeric)
    pendingList <- list(
        status.summary = .statusSummary(status.pending),
        status.completed = status.pending, status.time = data.frame()
    )
    return(pendingList)
}

##########################
## .outList2DF function ##
##########################
.outList2DF <- function(args) {
    if (inherits(args, "list")) {
        args <- as(args, "SYSargsList")
        out <- sapply(names(stepsWF(args)), function(x) list(NULL))
        for (i in seq_along(stepsWF(args))) {
            l_out <- output(stepsWF(args)[[i]])
            out[[i]] <- S4Vectors::DataFrame(matrix(unlist(l_out), nrow = length(l_out), byrow = TRUE))
            colnames(out[[i]]) <- stepsWF(args)[[i]]$files$output_names
        }
    } else if (inherits(args, "SYSargs2")) {
        l_out <- output(args)
        out <- S4Vectors::DataFrame(matrix(unlist(l_out), nrow = length(l_out), byrow = TRUE))
        colnames(out) <- args$files$output_names
    }
    return(out)
}

#############################
## .outputTargets function ##
#############################
.outputTargets <- function(args, fromStep, index = 1, toStep, replace = c("FileName")) {
    if (!inherits(args, "SYSargsList")) stop("Argument 'args' needs to be assigned an object of class 'SYSargsList'")
    outputfiles <- outfiles(args[fromStep])[[1]]
    if (length(targetsWF(args)[[fromStep]]) > 0) {
        df <- targetsWF(args)[[fromStep]]
        df[replace] <- outputfiles
    }
    return(df)
}

########################
## ConfigWF function ##
########################
configWF <- function(x, input_steps = "ALL", exclude_steps = NULL, silent = FALSE, ...) {
    ## Validations
    if (!inherits(x, "SYSargsList")) stop("Argument 'x' needs to be assigned an object of class 'SYSargsList'")
    utils::capture.output(steps_all <- subsetRmd(Rmd = x$sysconfig$script$path), file = ".SYSproject/.NULL") ## TODO: refazer
    if ("ALL" %in% input_steps) {
        input_steps <- paste0(steps_all$t_number[1], ":", steps_all$t_number[length(steps_all$t_number)])
        save_rmd <- FALSE
        Rmd_outfile <- NULL
        Rmd_path <- x$sysconfig$script$path
    } else {
        input_steps <- input_steps
        save_rmd <- TRUE
        Rmd_outfile <- paste0(
            .getPath(x$sysconfig$script$path), "/", paste0(format(Sys.time(), "%b%d%Y")),
            "_", basename(x$sysconfig$script$path)
        )
        Rmd_path <- Rmd_outfile
    }
    utils::capture.output(steps_all <- subsetRmd(
        Rmd = x$sysconfig$script$path, input_steps = input_steps,
        exclude_steps = exclude_steps, save_Rmd = save_rmd, Rmd_outfile = Rmd_outfile
    ), file = ".NULL") ## TODO: refazer
    steps_number <- steps_all$t_number[steps_all$selected]
    ## Save input_steps in the SYSconfig.yml
    if (!any(names(x$sysconfig) %in% c("input_steps", "exclude_steps"))) {
        input_file <- x$sysconfig$SYSconfig
        param <- list(input_steps = input_steps, exclude_steps = exclude_steps)
        input <- config.param(input_file = input_file, param, file = "append", silent = TRUE)
        x <- as(x, "list")
        x$sysconfig <- input
        x <- as(x, "SYSargsList")
    }
    ## STEPS
    if (is.null(x$sysconfig$script)) {
        cat("empty list")
    } else {
        steps <- paste0(
            strrep("    ", (as.numeric(steps_all$t_lvl[steps_all$selected]) - 1)), steps_all$t_number[steps_all$selected],
            ".", steps_all$t_text[steps_all$selected]
        )
    }
    names(steps_number) <- steps
    ## CODESteps
    code <- steps_all$code[steps_all$selected]
    names(code) <- steps
    x <- as(x, "list")
    script_path <- x$sysconfig$script$path
    x$sysconfig$script[["path"]] <- Rmd_path
    x$sysconfig$script[["orginal"]] <- script_path
    x$stepsWF <- steps_number
    x$codeSteps <- code
    x$dataWF <- steps_all
    # x$sysconfig$script$path <- Rmd_outfile
    return(as(x, "SYSargsList"))
}

## Usage:
# sysargslist <- configWF(x=sysargslist)

###########################
## renderReport function ##
###########################
## type: c("pdf_document", "html_document")
renderReport <- function(sysargslist, type = c("html_document"), silent = FALSE) {
    file <- sysargslist$sysconfig$script$path
    if (!file.exists(file) == TRUE) stop("Provide valid 'sysargslist' object. Check the initialization of the project.")
    evalCode(infile = file, eval = FALSE, output = file)
    # rmarkdown::render(input = file, c(paste0("BiocStyle::", type)), quiet = TRUE, envir = new.env())
    rmarkdown::render(input = file, c(paste0(type)), quiet = TRUE, envir = new.env())
    file_path <- .getPath(file)
    file_out <- .getFileName(file)
    ext <- strsplit(basename(type), split = "\\_")[[1]][1]
    sysargslist <- as(sysargslist, "list")
    sysargslist$projectInfo[["Report"]] <- file.path(file_path, paste(file_out, ext, sep = "."))
    if (silent != TRUE) cat("\t", "Written content of 'Report' to file:", paste0(file_out, ".", ext), "\n")
    return(as(sysargslist, "SYSargsList"))
}

## Usage
# renderReport(sysargslist)

###########################
## renderLogs function ##
###########################
renderLogs <- function(sysargs,
                       type = c("html_document", "pdf_document"),
                       fileName = "default",
                       silent = FALSE,
                       open_file = TRUE) {
    if (!inherits(sysargs, "SYSargsList")) stop("`sysargs` must be a 'SYSargsList' object.")
    type <- match.arg(type, c("html_document", "pdf_document"))
    stopifnot(is.character(fileName) && length(fileName) == 1)
    stopifnot(is.logical(silent) && length(silent) == 1)
    stopifnot(is.logical(open_file) && length(open_file) == 1)

    wd <- getwd()
    if (wd != projectInfo(sysargs)$project) {
        setwd(projectInfo(sysargs)$project)
        on.exit({
            try(setwd(wd), TRUE)
        })
    }
    dir_log <- projectInfo(sysargs)$logsDir
    if (!file.exists(dir_log) == TRUE) stop("Provide valid 'SYSargsList' object. Check the initialization of the project.")
    if (is.null(projectInfo(sysargs)$logsFile)) {
        stop("Log files not found. Please run the workflow to generate some logs.")
    } else {
        file <- projectInfo(sysargs)$logsFile
    }
    if (fileName == "default") {
        fileName <- file.path(projectInfo(sysargs)$project, paste0("logs_", format(Sys.time(), "%b%d%Y_%H%M"), ".Rmd"))
    } else {
        fileName <- fileName
    }
    log <- readLines(file)
    if (type == "html_document") plot_path <- .prepareRmdPlot(sysargs, dir_log)
    writeLines(c(
        "---",
        if (type == "html_document") "title: '&nbsp;'" else "title: 'SPR Workflow Technical Report'",
        paste0("date: 'Last update: ", format(Sys.time(), "%d %B, %Y"), "'"),
        "output:",
        paste0("  ", type, ":"),
        if (type == "html_document") paste0("    includes:\n      before_body: ", plot_path),
        "    number_sections: false",
        "    theme: flatly",
        "    toc: true",
        "    toc_float:",
        "      collapsed: true",
        "package: systemPipeR",
        "fontsize: 14pt",
        "---",
        "",
        log
    ),
    con = fileName
    )
    rmarkdown::render(input = fileName, c(paste0(type)), quiet = TRUE, envir = new.env())
    # rmarkdown::render(input = fileName, c('BiocStyle::html_document'), quiet = TRUE, envir = new.env())
    file_path <- .getPath(fileName)
    file_out <- .getFileName(fileName)
    ext <- if (type == "html_document") "html" else "pdf"
    sysargs <- as(sysargs, "list")
    sysargs$projectInfo[["Report_Logs"]] <- file.path(file_path, paste(file_out, ext, sep = "."))
    if (!silent) cat("Written content of 'Report' to file:", "\n", paste(file_out, ext, sep = "."), "\n")
    if (open_file) try(utils::browseURL(file.path(file_path, paste(file_out, ext, sep = "."))), TRUE)
    return(as(sysargs, "SYSargsList"))
}

## Usage
# sal <- runWF(sal)
# sal <- renderLogs(sal)

########################
## .prepareRmdPlot ##
########################
.prepareRmdPlot <- function(sysargs, dir_log) {
    out_path <- file.path(dir_log, "log_plot.html")
    plotWF(sysargs, out_format = "html", out_path = out_path, rmarkdown = TRUE, in_log = TRUE, rstudio = TRUE)
    # modify HTML content
    if (!file.exists(out_path)) stop("Cannot create the workflow plot for logs at\n", out_path)
    plot_content <- readLines(out_path)
    writeLines(c(
        plot_content[seq(13)],
        "<h1>SPS Workflow Log Report</h1>",
        plot_content[seq(14, length(plot_content))]
    ), con = out_path)
    out_path
}

########################
## subsetRmd function ##
########################
## This function allows the user to subset the Rmarkdown and select the corresponding text and R chunk code.
## The steps definition is based on the block-level elements, defined by the `#`.
## For example: # First-level header represents step number 1;
## For example: ## Second-level header represents step number 1.1;
## For example: ### Third-level header represents step number 1.1.1
## Arguments:
# Rmd: a character vector name and path of the Rmd file
# Rmd_outfile: a character vector name and path of the output Rmd file
# input_steps: a character vector of all steps desires to preserve on the output file.
# Default is NULL. If no input_steps defined, it will return only list steps on Rmd and datagram, however, all titles are unselected (FALSE) and no output file will be saved.
# It can be used the symbol ":" to select many steps in sequence, for example, input_steps=1:5.2, from step 1 to step 5.2.
# The symbol "." represents the substeps and symbol "," is used to separate selections.
# Jump from a major step to sub-step is supported, but if a major step is selected/excluded, all sub-steps of this major step will be selected/excluded. Repeatedly selected steps will only result in a unique step.  It is recommended to put major steps in `input_steps`, like '1:4, 6:8, 10'; and unwanted sub-steps in `exclude_steps`, like '1.1, 3.1.1-3.1.3, 6.5'.
# Reverse selecting is supported e.g. '10:1'.
# exclude_steps: a character vector of all steps desires to remove on the output file.
# save_Rmd: logical, default TRUE. If set FALSE, list new selected tiles and exit.
## Value
## It returns a data frame of title levels, title numbers, title text, whether it is selected, and R code under this title.

subsetRmd <- function(Rmd, input_steps = NULL, exclude_steps = NULL, Rmd_outfile = NULL, save_Rmd = TRUE) {
    . <- NULL
    # function start, check inputs
    if (!file.exists(Rmd) == TRUE) stop("Provide valid 'Rmd' file.")
    # if (assertthat::not_empty(input_steps)) assertthat::assert_that(assertthat::is.string(input_steps))
    # if (assertthat::not_empty(Rmd_outfile)) assertthat::assert_that(file.exists(dirname(Rmd_outfile)))
    # if (assertthat::not_empty(exclude_steps)) assertthat::assert_that(assertthat::is.string(exclude_steps))
    # default out behavior, in ISO 8601 time format
    if (is.null(Rmd_outfile)) Rmd_outfile <- paste0("new", format(Sys.time(), "%Y%m%d_%H%M%S"), basename(Rmd))
    # read file
    file <- readLines(Rmd)
    # check for proper start and end
    t_start <- file %>% stringr::str_which("^#")
    if (length(t_start) == 0) stop("This Rmd does not have any '#' titles")
    # get code chunks
    chunk_start <- file %>% stringr::str_which("^```\\{.*\\}.*")
    chunk_end <- file %>% stringr::str_which("^```[[:blank:]]{0,}$")
    if (length(chunk_start) != length(chunk_end)) stop("unmatched number of code chunk starts and ends")
    for (i in seq_along(chunk_start)[-length(chunk_end)]) {
        if (chunk_start[i + 1] <= chunk_end[i]) stop(paste("A code chunk does not end: chunk line", chunk_start[i + 1]))
    }
    # remove '#' titles in code chunk
    t_start <- t_start[!unlist(lapply(t_start, function(x) any(x >= chunk_start & x <= chunk_end)))]
    # get end
    t_end <- append((t_start - 1)[c(-1)], length(file))
    # get # levels and text
    t_text <- file[t_start] %>% stringr::str_remove("^[#]+")
    t_lvl <- file[t_start] %>%
        stringr::str_extract("^[#]+") %>%
        nchar()
    # parse levels
    for (lvl in unique(t_lvl)[-length(t_lvl)]) {
        if (lvl == min(unique(t_lvl))) {
            step_main <- which(t_lvl == lvl)
            names(t_lvl)[step_main] <- names(step_main) <- seq_along(step_main)
            step_main <- append(step_main, 9999)
        }
        sub_lvl <- lvl
        while (sub_lvl <= max(t_lvl)) {
            step_sub <- which(t_lvl == sub_lvl + 1)
            if (length(step_sub) < 1) {
                sub_lvl <- sub_lvl + 1
            } else {
                break()
            }
        }
        jump_step_glue <- if (sub_lvl - lvl == 0) {
            "."
        } else {
            rep(".1.", sub_lvl - lvl) %>%
                paste0(collapse = "") %>%
                stringr::str_replace_all("\\.\\.", "\\.")
        }
        for (i in seq_along(step_main[-1])) {
            subs <- step_sub[step_sub > step_main[i] & step_sub < step_main[i + 1]]
            names(t_lvl)[subs] <- names(step_sub)[step_sub %in% subs] <- paste0(names(step_main[i]), jump_step_glue, seq_along(subs))
        }
        step_main <- append(step_sub, 9999)
    }
    # get code in lists
    code_list <- lapply(seq_along(t_start), function(t_index) {
        code_start <- chunk_start[chunk_start %in% (t_start[t_index]:t_end[t_index])]
        code_end <- chunk_end[chunk_end %in% (t_start[t_index]:t_end[t_index])]
        code_lines <- lapply(seq_along(code_start), function(code_index) {
            (code_start[code_index] + 1):(code_end[code_index] - 1)
        }) %>% unlist()
        file[code_lines]
    })
    # create a df to store everything
    rmd_df <- data.frame(
        t_lvl = t_lvl, t_number = names(t_lvl),
        t_text = t_text, selected = FALSE,
        row.names = NULL, stringsAsFactors = FALSE
    )
    rmd_df$code <- code_list
    # add sample run/success, step link cols
    rmd_df$no_run <- NA
    rmd_df$no_run <- ifelse(sapply(rmd_df$code, length) == 0, 0, NA)
    rmd_df$no_success <- NA
    rmd_df$no_success <- ifelse(sapply(rmd_df$code, length) == 0, 0, NA)
    rmd_df$link_to <- NA
    rmd_df$link_to[1:(nrow(rmd_df) - 1)] <- rmd_df$t_number[2:nrow(rmd_df)]
    # list all steps if no input_steps
    # if (!assertthat::not_empty(input_steps)) {
    if(!is.null(input_steps)) {
        cat("No input_steps is given, list all sections and exit\n")
        cat("This file contains following sections\n")
        stringr::str_replace(t_text, "^", paste0(strrep("    ", (t_lvl - 1)), names(t_lvl), " ")) %>%
            paste0(., collapse = "\n") %>%
            stringr::str_replace("$", "\n") %>%
            cat()
        return(rmd_df)
    }
    # parse steps
    index_select <- .parse_step(t_lvl, input_steps)
    index_exclude <- .parse_step(t_lvl, exclude_steps)
    index_final <- index_select[!index_select %in% index_exclude]
    rmd_df$selected[index_final] <- TRUE
    # print again what will be write in the new file
    cat("The following sections are selected\n")
    stringr::str_replace(
        t_text[index_final], "^",
        paste0(
            strrep("    ", (t_lvl[index_final] - 1)),
            names(t_lvl[index_final]), " "
        )
    ) %>%
        paste0(collapse = "\n") %>%
        stringr::str_replace("$", "\n") %>%
        cat()
    # to print new titles and return
    if (save_Rmd == FALSE) {
        return(rmd_df)
    }
    # sebset lines
    t_start[index_final]
    t_end[index_final]
    final_lines <- mapply(seq, t_start[index_final], t_end[index_final]) %>%
        unlist() %>%
        append(1:(t_start[1] - 1), .) %>%
        unique()
    writeLines(file[final_lines], Rmd_outfile)
    cat(paste("File write to", file.path(Rmd_outfile), "\n"))
    return(rmd_df)
}

# # Usage:
# Rmd <- system.file("extdata/workflows/rnaseq", "systemPipeRNAseq.Rmd", package="systemPipeRdata")
# newRmd <- subsetRmd(Rmd=Rmd, input_steps="1:2.1, 3.2:4, 4:6", exclude_steps="3.1", Rmd_outfile="test_out.Rmd", save_Rmd=TRUE)

###########################
## config.param function ##
###########################
config.param <- function(input_file = NULL, param, file = "default", silent = FALSE) {
    ## In the case of 'input_file' == character (file)
    if (class(input_file) == "character") {
        if (!file.exists(input_file)) {
            stop("Provide valid 'input_file' file. Check the file PATH.")
        }
        input <- yaml::read_yaml(file.path(input_file), eval.expr = TRUE)
        input <- out_obj <- .replace(input = input, param = param)
        path_file <- normalizePath(input_file)
        out_msg <- c("input_file")
    } else if (class(input_file) == "list") {
        if (is.null(names(param))) {
            stop("for each element of the 'param' list need to assign a name.")
        }
        input <- out_obj <- .replace(input = input_file, param = param)
        path_file <- normalizePath(file) ## TODO find a better solution!
        out_msg <- c("input_file")
    } else if (class(input_file) == "SYSargs2") {
        input <- .replace(input = yamlinput(input_file), param = param)
        dir_path <- .getPath(files(input_file)[["yml"]])
        if (is.na(files(input_file)[["targets"]])) {
            targets <- NULL
        } else {
            targets <- targets(input_file)
        }
        args1 <- loadWorkflow(
            targets = targets, wf_file = basename(files(input_file)[["cwl"]]),
            input_file = basename(files(input_file)[["yml"]]), dir_path = dir_path
        )
        args1 <- as(args1, "list")
        args1$yamlinput <- input
        if ("ModulesToLoad" %in% names(param)) {
              for (i in seq_along(param$ModulesToLoad)) {
                  args1$modules[names(param$ModulesToLoad[i])] <- param$ModulesToLoad[[i]]
              }
          }
        args1 <- out_obj <- as(args1, "SYSargs2")
        out_msg <- c("yamlinput(args1)")
        path_file <- files(input_file)[["yml"]]
    } else if (class(input_file) == "SYSargsList") { ## TODO
        input <- out_obj <- .replace(input = input_file$sysconfig, param = param)
        path_file <- input_file$projectInfo$project
        out_msg <- c("input_file")
    } else if (all(is.null(input_file))) {
        stop("'input_file' need to be defenid as '.yml' OR 'SYSargs2 class' OR 'SYSargsList class' OR 'list class' ")
    }
    ## File and Path to be written
    if (file == "default") {
        run <- dir(.getPath(path_file))
        fileName <- paste0("_run", length(grep(
            paste0(gsub("\\..*", "", basename(path_file)), "_run"),
            run
        )) + 1)
        # path <- paste0(.getPath(path_file), '/', paste(format(Sys.time(), '%b%d%Y_%H%M%S')), '_',
        # basename(path_file), collapse = '/')
        path <- paste0(.getPath(path_file), "/", gsub("\\..*", "", basename(path_file)), fileName, ".",
            gsub(".*\\.", "", basename(path_file)),
            collapse = "/"
        )
    } else if (file == "append") {
        path <- path_file
    } else {
        path <- file
    }
    ## Rename original file
    # file.rename(from = path_file, to = path)
    # if (silent != TRUE) cat("\t", "The original file was renamed to:", "\n", paste0(path), "\n")
    ## Write YML file
    yaml::write_yaml(x = input, file = path)
    if (silent != TRUE) cat("\t", "All the new param + ", out_msg, "were written to:", "\n", paste0(path), "\n")
    if (class(input_file) == "SYSargs2") {
        args1 <- as(args1, "list")
        args1$files$yml <- path
        args1 <- as(args1, "SYSargs2")
        out_obj <- args1
    }
    return(out_obj)
}

## Usage:
# Config param files
# targets <- system.file("extdata", "targets.txt", package="systemPipeR")
# input_file <- system.file("extdata", "cwl/hisat2/hisat2-se/hisat2-mapping-se.yml", package="systemPipeR")
# param <- list(thread=10, fq=list(class="File", path="./results2"))
# input <- config.param(input_file=input_file, param, file="default") # Example with 'input_file'

###############
## Utilities ##
###############

########################################################
## SYScreate ##
########################################################
SYScreate <- function(class) {
    if (class == "SYSargs2") {
        SYS.empty <- list(
            targets = data.frame(),
            targetsheader = list(),
            modules = list(),
            wf = list(),
            clt = list(),
            yamlinput = list(),
            cmdlist = list(NULL),
            input = list(),
            output = list(),
            files = list(),
            inputvars = list(),
            cmdToCwl = list(),
            status = data.frame(),
            internal_outfiles = list()
        )
        return(as(SYS.empty, "SYSargs2"))
    } else if (class == "SYSargsList") {
        SYS.empty <- list(
            stepsWF = list(),
            statusWF = list(),
            targetsWF = list(),
            outfiles = list(),
            SEobj = list(),
            dependency = list(),
            targets_connection = list(),
            projectInfo = list(),
            runInfo = list()
        )
        return(as(SYS.empty, "SYSargsList"))
    } else if (!class %in% c("SYSargs2", "SYSargsList")) {
          stop("Argument 'args' needs to be assigned an character 'SYSargs2' OR 'SYSargsList'")
      }
}
## Usage:
# list <- SYScreate("SYSargsList")
# list <- SYScreate("SYSargs2")

#########################################################################################
## Function to check if the command line / Software is installed and set in your PATH ##
#########################################################################################
tryCMD <- function(command, silent = FALSE) {
    if (command == "fastqc") command <- "fastqc --version"
    if (command == "gunzip") command <- "gunzip -h"
    if (command == "gzip") command <- "gzip -h"
    tryCatch(
        {
            system(command, ignore.stdout = TRUE, ignore.stderr = TRUE)
            if (!silent) print("All set up, proceed!")
            if (silent) (return("proceed"))
        },
        warning = function(w) {
            if (silent) invisible(return("error"))
            if (!silent) {
                  cat(paste0(
                      "ERROR: ", "\n", command, ": COMMAND NOT FOUND. ", "\n",
                      "Please make sure to configure your PATH environment variable according to the software in use."
                  ), "\n")
              }
        }
    )
}

## Usage:
# tryCMD(command="R")
# tryCMD(command="blastp")
# tryCMD(command="fastqc")
# tryCMD(command="gzip")

tryCL <- tryCMD
########################################################
## Function to check if the Path (file or dir) exists ##
########################################################
tryPath <- function(path) {
    tryCatch(normalizePath(path),
        warning = function(w) message(paste0(path, ": ", "No such file or directory")),
        error = function(e) message(paste0(path, ": ", "Please provide a valid Path"))
    )
}
## Usage:
# tryPath(path="./")

###########################################################################################
## Function to evaluate (eval=TRUE) or not evaluate (eval=FALSE) R code in the Rmarkdown ##
###########################################################################################
## infile: Name and path of the infile file, format Rmarkdown.
evalCode <- function(infile, eval = TRUE, output) {
    if (!file.exists(infile)) stop("Provide valid 'infile' file. Check the file PATH.")
    if (!"Rmd" %in% .getExt(infile)) stop("Provide Rmarkdown file. Check the file PATH.")
    file <- readLines(infile)
    Rchunk <- grep("^```[{}]", file)
    if (length(Rchunk) == 0) stop("The file does not have any R Chuck")
    for (i in Rchunk) {
        if (grepl("eval", file[i])) {
            file[i] <- sub("eval.*E", paste0("eval=", eval), file[i])
        } else {
            file[i] <- sub("[}]", paste0(", eval=", eval, "}"), file[i])
        }
    }
    writeLines(file, output)
    return(output)
}

## Usage:
# file <- system.file("extdata/workflows/rnaseq/", "systemPipeRNAseq.Rmd", package="systemPipeRdata")
# evalCode(infile=file, eval=FALSE, output="test.Rmd")

#################################
## Unexported helper functions ##
#################################

##################################
## Return the path of the file  ##
##################################
## [x] A character vector or an object containing file PATH.
.getPath <- function(x, full_path = TRUE, warning = TRUE) {
    if (warning) {
        if (!any(file.exists(x))) warning("No such file or directory. Check the file PATH.")
    }
    if (full_path) {
        x <- normalizePath(x)
    }
    for (i in seq_along(x)) {
        path_un <- unlist(strsplit(x[i], "/|\\\\"))
        path <- path_un[path_un != basename(x[i])]
        x[i] <- paste0(path, collapse = "/")
    }
    return(x)
}

## Usage:
# x <- system.file("extdata", "targets.txt", package = "systemPipeR")
# .getPath(x) ## internal fct: it will delete any suffixes up to the last slash ('/') character and return the 'path of the file'
# basename(x) ## BiocGenerics pkg: it will delete any prefix up to the last slash ('/') character and return the 'name of the file'

###############################
## Return the file extension ##
###############################
## Function to return the extension of the file. The argument 'x' is a character vector or an object containing the file PATH.
.getExt <- function(x) {
    ext <- Biostrings::strsplit(basename(x), split = "\\.")[[1]]
    ext <- ext[[length(ext)]]
    return(ext)
}

## Usage:
# x <- system.file("extdata", "targets.txt", package = "systemPipeR")
# .getExt(x) ## internal fct: it will delete any suffixes up to the last slash ('/') character and return the 'extension of the file'

##############################################
## Return the file name, without extension ##
#############################################
## [x] A character vector or an object containing file File name without extension, simmilar with 'basename'
.getFileName <- function(x) {
    #  if (!file.exists(x)) warning("No such file or directory. Check the file PATH.")
    filename <- Biostrings::strsplit(basename(x), split = "\\.")[[1]]
    filename <- filename[[-2]]
    return(filename)
}

#################################################
## Return the logical, if the path is absolute ##
#################################################
is.fullPath <- function(x) {
    grepl("^(/|[A-Za-z]:|\\\\|~)", x)
}

## Usage:
# targetspath <- system.file("extdata", "targets.txt", package="systemPipeR")
# is.fullPath(targetspath)
# is.fullPath("./results")

##########################################################
## Internal function to detect nested of the param list ##
##########################################################
.nest <- function(x) ifelse(is.list(x), 1L + max(sapply(x, .nest)), 0L)

## Usage:
# param <- list(results_new=list(class="Directory", path=8))
# nesting <- .nest(param[1])

############################################################################
## Internal function to replace or add the list values at the input file ##
############################################################################
.replace <- function(input, param) {
    for (i in seq_along(param)) {
        for (j in seq_along(param[[i]])) {
            nesting <- .nest(param[i])
            if (nesting == 1) {
                if (is.numeric(param[[i]][j][[1]])) {
                    input[names(param)[i]] <- as.integer(param[[i]][j])
                } else {
                    input[names(param)[i]] <- param[[i]][j]
                }
            } else if (nesting > 1) {
                if (is.numeric(param[[i]][j][[1]])) {
                    input[[names(param[i])]][[names(param[[i]][j])]] <- as.integer(param[[i]][[j]])
                } else {
                    input[[names(param[i])]][[names(param[[i]][j])]] <- (param[[i]][[j]])
                    input[[names(param[i])]] <- as.list(input[[names(param[i])]])
                }
            }
        }
    }
    return(input)
}

## Usage:
# input_file="param/cwl/hisat2/hisat2-se/hisat2-mapping-se.yml"
# input <- yaml::read_yaml(file.path(input_file))
# param <- list(thread=14, test="test")
# .replace(input=input, param=param)

##########################
## .parse_step function ##
##########################
## Internal parse function used in the subsetRmd function
.parse_step <- function(t_lvl, input_steps) {
    . <- NULL
    t_lvl_name <- names(t_lvl)
    input_steps <- unlist(input_steps %>% stringr::str_remove_all(" ") %>% stringr::str_split(",") %>% list())
    # single steps
    nocolon_steps <- input_steps[stringr::str_which(input_steps, "^[^:]+$")]
    lapply(nocolon_steps, function(x) if (!any(t_lvl_name %in% x)) stop(paste("Step", x, "is not found")))
    # dash linked steps
    dash_list <- NULL
    for (i in stringr::str_which(input_steps, ":")) {
        dash_step <- unlist(stringr::str_split(input_steps[i], ":"))
        dash_parse <- unlist(lapply(dash_step, function(x) {
            which(t_lvl_name %in% x) %>% ifelse(length(.) > 0, ., stop(paste("Step", x, "is not found")))
        })) %>% {
            t_lvl_name[.[1]:.[2]]
        }
        dash_list <- append(dash_list, dash_parse)
    }
    # merge
    all_step_name <- unique(append(nocolon_steps, dash_list))
    # if upper level step is selected, all sub-level steps will be added
    unlist(lapply(all_step_name, function(x) stringr::str_which(t_lvl_name, paste0("^", x, "\\..*")))) %>%
        append(which(t_lvl_name %in% all_step_name)) %>%
        unique() %>%
        sort() %>%
        return()
}

#############################
## .tryCatch function ##
#############################
.tryCatch <- function(x, file = NULL) {
    if (is.null(file)) file <- tempfile()
    tryCatch(
        expr = {
            cat("## Output", append = TRUE, file = file, "\n")
            capture.output(out <- eval(parse(text = x), envir = globalenv()), file = file, append = TRUE)
            message("DONE")
            return(out)
        },
        error = function(e) {
            print(e)
            message("ERROR")
            return("Caught an error!")
        },
        warning = function(w) {
            print(w)
            message("WARNING")
            return("Caught an warning!")
        }
    )
}

## Usage:
# .tryCatch(x=codeList[[1]])

################################
## .checkSpecialChar function ##
################################
.checkSpecialChar <- function(x) {
    chunk_names_bad <- stringr::str_detect(x, "\\W")
    if (any(chunk_names_bad)) {
        stop(
            "Only letters, numbers, and '_' allowed for step_name. Invalid name:\n",
            paste0(x[chunk_names_bad], collapse = ", "),
            call. = FALSE
        )
    }
}

## Usage:
# .checkSpecialChar("name@")
# .checkSpecialChar("name test")
tgirke/systemPipeR documentation built on Sept. 18, 2021, 12:03 p.m.