R/spsUti.R

In systemPipeShiny: systemPipeShiny: An Interactive Framework for Workflow Management and Visualization

### Utility functions, can be run outside SPS

#' Take steps output from subsetRmd and change to a nested list structure
#' @description Data prepare for ShinyTree
#' @param t_lvl positive integers, vector, levels of all title levels in Rmd
#' @param t_text character strings, vector, text of titles
#' @param start_lvl integer, default value is 0, but default
#' level is 1 (0 + 1). level to start to create list
#' @noRd
#' @return a nested list
#'
# @examples
# library(shiny)
# library(shinyTree)
# tree = step2listTree(t_lvl, t_text)
# str(tree)
#
# tree_names = names(unlist(tree))
#
# ui = shinyUI(
#     pageWithSidebar(
#         mainPanel(
#             shinyTree("tree", stripes = TRUE,
#                       multiple = FALSE, animation = FALSE)
#         )
#     ))
# server = shinyServer(function(input, output, session) {
#     output$tree <- renderTree({
#         tree
#     })
# })
# shinyApp(ui, server)
step2listTree <- function(t_lvl, t_text, start_lvl = 0){
    if (t_lvl %>% unique() %>% length == 1){
        tmp_lst <- list()
        for (i in t_text){
            tmp_lst[[as.character(i)]] <- ""
        }
        return(tmp_lst)
    }
    start_lvl <- start_lvl + 1
    t_index <- which(t_lvl == start_lvl)
    if (!length(t_index) == 0){
        tmp_lst <- list()
        for (i in seq_along(t_index)){
            t_index <- c(t_index, length(t_lvl) + 1)
            if_children <- t_index[i]  + 1 == t_index[i+1]
            if (is.na(if_children) | if_children) {
                tmp_lst[[t_text[t_index[i]]]] <- ""
            } else {
                children_lvl <- t_lvl[(t_index[i] + 1): (t_index[i + 1] -1)]
                children_name <- t_text[(t_index[i] + 1): (t_index[i + 1] -1)]
                tmp_lst[[t_text[t_index[i]]]] <-
                    step2listTree(children_lvl, children_name, start_lvl)
            }
        }
        return(tmp_lst)
    } else {return("")}
}



#' find parent steps of from output of jsTree
#'
#' @param step_names
#'
#' @return vector strings of major and minor step numbers
#' @noRd
# @examples
# step_name <- c("1.1.1", "2.2.2")
# findTreeParent(step_name)
findTreeParent <- function(step_names){
    lapply(step_names, function(each_name){
        if (str_detect(each_name, "\\.")) {
            step_p <- str_remove(step_names, "[^0-9]+.[^.]*$")
            tmp_holder <- c(step_p, findTreeParent(step_p))
            return(c(step_names, tmp_holder))
        } else {return(each_name)}
    }) %>%
    unlist() %>%
    unique() %>% str_sort(numeric = TRUE)
}


#' Create structure for networkD3 object
#'
#' @param t_lvl title markdown heading levels, 1-5
#' @param t_text title text
#' @param start_lvl starting title level
#'
#' @return list
#' @importFrom stats na.omit
#' @noRd
# @examples
# t_lvl = c(1, 3, 1, 2, 2, 3)
# t_text = c('1', '1.1.1', '2', '2.1', '2.2', '2.2.1')
# test = step2listD3(t_lvl, t_text)
# str(test)
# diagonalNetwork(test)
step2listD3 <- function(t_lvl, t_text, start_lvl = 0){
    if (is.null(t_lvl) | is.null(t_text))
        return(list(name = "Nothing has been loaded"))
    findChildren <- function(t_lvl, t_text, start_lvl){
        start_lvl <- start_lvl + 1

        t_index <- NULL
        while (start_lvl <= max(stats::na.omit(t_lvl))) {
            t_index <- which(t_lvl == start_lvl)
            if (length(t_index) == 0) {
                start_lvl <- start_lvl + 1
            } else {
                break()
            }
        }

        if (!length(t_index) == 0) {
            tmp_lst <- lapply(seq_along(t_index), function(i){
                t_index <- c(t_index, length(t_lvl) + 1)
                children_lvl <- t_lvl[(t_index[i] + 1) : (t_index[i+1] - 1)]
                children_name <- t_text[(t_index[i] + 1) : (t_index[i+1] - 1)]
                list(name = t_text[t_index[i]],
                     children = findChildren(children_lvl,
                                             children_name,
                                             start_lvl)
                     )
            })
            return(tmp_lst)
        } else { return(list(name = ""))}
    }
    if (t_lvl %>% unique() %>% length == 1){
        tmp_lst = list()
        for (i in t_text){
            tmp_lst <- append(tmp_lst,
                              list(list(name = i, children = list(name = ""))))
        }
        return(list(name = "File", children = tmp_lst))
    }
    return(
        list(name = "File", children = findChildren(t_lvl, t_text, start_lvl))
    )
}


#' Find tab information from tabs.csv
#' If `type` is not empty, `tab_ids` will be ignored
#' @importFrom vroom vroom
#'
#' @param tab_ids vector of strings, tab names you want to get
#' @param type tab type and sub type, one of: core, wf, vs, data, plot, or
#' addition type you specific in type or type_sub column, first search type and
#' then type_sub
#' @param tab_file tab file path
#' @param force_reload bool, tab info usually stores at a variable
#' called `tab_info`. This function first look for that one, if not exists,
#' read from file. This argument forcedly read from file and ignore that
#' variable.
#' @importFrom shinyAce is.empty
#' @importFrom vroom vroom
#' @return a list contains `tab_id`, `tab_labels`, `hrefs`
#' reference, `image` path,
#' `tpye` and `tpye_sub`
#' @noRd
#'
# @examples
# tab_ids <- c("core_about", "vs_main")
# findTabInfo(tab_ids, tab_file = tab_file)
findTabInfo <- function(tab_ids=NULL, type = NULL,
                        tab_file = file.path("config", "tabs.csv"),
                        force_reload = FALSE) {
    if(is.null(type)) assert_that(is.character(tab_ids))
    tabs <- if(exists("tab_info") & !force_reload) {
        tab_info
    } else {
         suppressMessages(
             vroom::vroom(tab_file, comment = "#", na = character(),
                          altrep = FALSE))
    }
    # if(!spsOption('dev')){
    #     tabs <- tabs[!str_detect(tabs$tab_id, "_template$"), ]
    #     tab_ids <- tab_ids[!str_detect(tab_ids, "_template$")]
    #     }
    if(not_empty(type)) {
        type <- match.arg(type,
                          unique(c(tabs[['type']], tabs[['type_sub']])) %>%
                              {.[. != ""]})
        tab_nos <- tabs$type %in% type
        if (!any(tab_nos)) tab_nos <- tabs$type_sub %in% type
        if (!any(tab_nos)){
            spswarn(glue("This tab type '{type}'",
                         "contains no tab, check the type"))
            return(NULL)
        }
    } else {
        tab_nos <- vapply(tab_ids, function(x) {
            tab_no <- str_which(pattern = glue("^{x}$"), string = tabs$tab_id)
            if (shinyAce::is.empty(tab_no)){
                spserror(glue("Tab {x} is not in the tab list"))
            } else if(length(tab_no) > 1){
                glue_collapse(tabs$tab_id[duplicated(tabs$tab_id)], sep=", ")%>%
                    {spserror(glue("Find duplicated ID(s) {.}"))}
            }
            tab_no
        }, 1)
    }
    structure(
        list(
        tab_id = tabs$tab_id[tab_nos],
        tab_labels = tabs$display_label[tab_nos],
        hrefs = glue("#shiny-tab-{tabs$tab_id[tab_nos]}"),
        images = tabs$image[tab_nos],
        tpye = tabs$type[tab_nos],
        type_sub = tabs$type_sub[tab_nos]
        ),
        class = c("list", "sps-tabinfo")
    )
}

# can't import shiny internal function, gives warnings, so rewrite here
reactiveStop <- function(message = "\r              ", class = NULL){
    cond <- structure(list(message = message),
                      class = c(c("shiny.silent.error", class),
                                "error",
                                "condition")
    )
    stop(cond)
}