pkg_utils.R

#-----------------------------------------------------------------------
# Função para exibir diretórios em árvore ascii.

connectors <- function(x) {
    # Função que retorna em "con" os conectores para cada nó, colocados
    # na frente dos nomes de arquivos ou diretórios, sendo "`--" para os
    # nós final e "|--" para os nós intermediários. Em "pre" são
    # retornados aquilo que deve ser prefixo dos conectores para os
    # descendentes do nó caso ele seja um diretório, sendo " " para nó
    # final e "| " para nós intermediários.
    tms <- c(length(x) - 1, 1)
    list(con = rep(c("|-- ", "`-- "), tms),
         pre = rep(c("|   ", "    "), tms))
}

path2bigNestedList <- function(path, type = "none", all.files = TRUE) {
    # Tipos de ordenamento em que "none" é o que vem do list.files() e
    # "dir_last" é para ordenar deixando os diretórios para o final.
    type <- match.arg(type, choices = c("none", "dir_last"))
    # Se all.files == TRUE então diretórios é arquivos ocultos serão
    # exibidos.
    all.files <- all.files[1]
    # path: é um caminho de diretório.
    if (length(path) == 1) {
        # pre: o que antecede o contector para apropriada indentação e
        # conexão dos arquivos.
        # conn: conector que antecede o nome do arquivo/diretório.
        # path: caminho do arquivo/diretório.
        # child: o que é passado para dos descentes desse nó, caso ele
        # seja um diretório, como "pre" para haver apropriada indentação
        # e conexão entre arquivos/diretórios.
        path <- c(pre = "", conn = "", path = path, child = "")
    }
    # É diretório?
    isdir <- isTRUE(file.info(path["path"])$isdir)
    # Tem conteúdo?
    isnempty <- (length(dir(path["path"])) >= 1)
    # Só entra no if diretórios não vazios.
    if (isdir && isnempty) {
        # Retina a possível barra no do nome de diretórios para previnir
        # acidentes.
        path["path"] <- sub(x = path["path"],
                            pattern = "/$",
                            replacement = "")
        # Cria o texto do nó = pre + conn + path.
        path["text"] <- paste(basename(path[1:3]), collapse = "")
        # Lista arquivos e diretórios dentro do path informado.
        lf <- list.files(path["path"],
                         all.files = all.files,
                         no.. = TRUE,
                         include.dirs = TRUE,
                         full.names = FALSE)
        if (type == "dir_last") {
            lf <- lf[order(file.info(
                paste(path["path"], lf, sep = "/"))$isdir)]
        }
        # Diretórios vazios não retornarão nada do list.files, então
        # não correr parte do código.
        if (length(lf) >= 1) {
            # Obtém os conectores e prefixos para cada
            # arquivo/diretório.
            aux <- connectors(lf)
            # Cria matriz com os elementos necessários, em cada linha um
            # arquivo/diretório, e nas colunas os elementos do nó.
            paths <- cbind(pre = paste(path["child"], collapse = ""),
                           conn = aux$con,
                           path = paste(path["path"], lf, sep = "/"),
                           child = paste(path["child"],
                                         aux$pre,
                                         sep = ""))
            # No caso de ter apenas uma linha, que dá problema com
            # apply() que precisa de nrow > 1, trabalha como vetor para
            # obter o texto do nó = pre + conn + path.
            if (nrow(paths) == 1) {
                u <- paste(paths[1, 1:3], collapse = "")
            } else {
                u <- apply(paths[, 1:3], MARGIN = 1,
                           FUN = function(x) {
                               paste(basename(x), collapse = "")
                           })
            }
            # Transforma o que eram linhas em elementos de lista.
            paths <- split(cbind(paths, u), 1:nrow(paths))
            # Garante os nomes corretos.
            paths <- lapply(paths, "names<-", names(path))
            # Chamada recursiva com os mesmo argumentos.
            lf <- lapply(paths,
                         FUN = path2bigNestedList,
                         type = type,
                         all.files = all.files)
        }
        # Adiciona o path inicial.
        lf <- c(sprintf("%s/", path["text"]), lf)
    } else {
        # Quando não existirem mais diretórios, retorna só o texto do
        # nó. A barra no final sinaliza os diretórios.
        lf <- sprintf("%s%s",
                      path["text"],
                      ifelse(isdir, yes = "/", no = ""))
    }
    return(lf)
}

#' @name dirtree
#' @export
#' @author Walmes Zeviani, \email{walmes@@ufpr.br}.
#' @title Exibe o Diretórios como Árvores ASCII
#' @description Essa função é uma implementação em R do comando
#'     \href{http://mama.indstate.edu/users/ice/tree/}{\code{tree}} no
#'     Linux. Essa função exibe diretórios em estrutura de árvore em
#'     modo texto.
#' @param path Uma string de tamanho 1 que é caminho a partir do qual
#'     desenhar as ramificações.
#' @param type Uma string de tamanho 1 que é o critério de exibição. O
#'     default e \code{"dir_last"} que deixa para exibir diretórios no
#'     final da lista e arquivos no topo. Ordem alfabética padrão é
#'     retornada com a opção \code{"none"}.
#' @param all.files Um valor lógico de tamanho 1 onde \code{TRUE}
#'     significa exibir arquivos e diretórios ocultos.
#' @return Não retorna conteúdo, apenas exibe no console a estrutura do
#'     diretório.
#' @seealso \code{\link[base]{dir}}, \code{\link[base]{list.files}}.
#' @examples
#'
#' \donttest{
#'
#' # Tree of your currend directory.
#' getwd()
#' dirtree()
#' dirtree(type = "none")
#' dirtree(all.files = TRUE)
#'
#' # Tree of home folder.
#' dirtree("~/")
#'
#' # Tree of a installed package.
#' dirtree(system.file(package = "lattice"))
#'
#' }
dirtree <- function(path = "./",
                    type = "dir_last",
                    all.files = FALSE) {
    cat(unlist(path2bigNestedList(path = path,
                                  type = type,
                                  all.files = all.files),
               recursive = TRUE),
        sep = "\n")
}

#-----------------------------------------------------------------------
# Verifica se existe a tetra de aquivos txt, rda, R e Rd.

#' @name check4files
#' @title Verifica existência dos 4 Arquivos Associados de um Dataset
#' @description Verifica os 4 arquivos associados de um dataset: txt,
#'     rda, R e Rd.
#' @param x Um vetor com nome de um objetos.
#' @return Uma matriz de valores lógicos.
#' @author Walmes Zeviani, \email{walmes@@ufpr.br}.
#' @examples
#'
#' t(sapply(ls("package:labestData"), FUN = check4files))
#'
check4files <- function(x) {
    c(txt = file.exists(sprintf("./data-raw/%s.txt", x)),
      rda = file.exists(sprintf("./data/%s.rda", x)),
      R = file.exists(sprintf("./R/%s.R", x)),
      Rd = file.exists(sprintf("./man/%s.Rd", x)))
}

#-----------------------------------------------------------------------
# Gera código para tabelas dentro da documentação roxygen2.

# http://r-pkgs.had.co.nz/man.html#man-special
tabular <- function(df, ...) {
    stopifnot(is.data.frame(df))
    align <- function(x) {
        if (is.numeric(x)) { "r" } else { "l" }
    }
    col_align <- vapply(df, align, character(1))
    cols <- lapply(df, format, ...)
    contents <- do.call("paste",
                        c(cols,
                          list(sep = " \\tab ",
                               collapse = "\\cr\n  ")))
    paste("\\tabular{",
          paste(col_align, collapse = ""),
          "}{\n  ",
          contents,
          "\n}\n",
          sep = "")
}

#-----------------------------------------------------------------------
# Funções para gerar esqueleto de documentação.

# Função que verifica onde e com que nome criar o arquivo com o
# esqueleto da documentação.
where_save <- function(name, file, append = FALSE) {
    # Faz arquivo ter o nome do objeto.
    if (missing(file)) {
        file <- sprintf("%s.R", name)
    }
    # Onde salvar.
    if (!is.na(file)) {
        if (file.exists("DESCRIPTION")) {
            file <- sprintf("R/%s", file)
        }
        if (!append & file.exists(file)) {
            stop(sprintf(paste("File `%s` already exists.",
                               "Use append = TRUE or remove it."),
                         file))
        }
    }
    return(c(file = file))
}

# where_save("fun")
# where_save("fun", file = "as.R")
# where_save("fun", file = "func.R", append = FALSE)
# where_save("fun", file = "func.R", append = TRUE)

#' @name roxy_fun
#' @export
#' @title Gera o Esqueleto de Documentação de Funções em \code{roxygen2}
#' @description Função que recebe uma função e produz o esquelo da
#'     documentação da função em \code{roxygen2}. Opções dessa função
#'     permitem escrever o esqueleto em arquivo, adicionar campos e
#'     abrir o arquivo gerado com algum editor de texto.
#' @param object Um objeto que é uma função.
#' @param file Um nome de arquivo onde escrever a documentação e a
#'     definição da função. Quando não fornecido, o nome da função é
#'     usado como nome do arquivo. Se for usado \code{NA}, nenhum
#'     arquivo será criado e a documentação será exibida no console.
#' @param export Valor lógico que indica se deve escrever \code{@export}
#'     ou não para esta função.
#' @param author O autor da função. Este conteúdo será passado para o
#'     campo \code{@author}.
#' @param keywords Um vetor com keywords para a função que serão
#'     escritas no campo \code{@keywords}.
#' @param extra Vetor com o conteúdo de campos extras como
#'     \code{"@import lattice"}.
#' @param editor Nome do editor com o qual abrir o arquivo para fazer o
#'     preenchimento dos campos da documentação. Veja
#'     \code{\link[utils]{edit}}.
#' @param print Valor lógico que indica se deve imprimir no console o
#'     esqueleto de documentação gerado.
#' @param append Valor lógico que indica se deve escrever a documentação
#'     em arquivo que já existe.
#' @param find_file Valor lógico que indica se deve exibir no console o
#'     caminho do arquivo gerado com a documentação.
#' @return Essa função não retorna conteúdo mas cria/modifica arquivos.
#' @examples
#'
#' fun <- function(x, y, ...) {
#'     return(x + y)
#' }
#'
#' file.remove("bla.R")
#' file.remove("fun.R")
#'
#' roxy_fun(fun)
#' roxy_fun(fun, append = TRUE)
#'
#' file.remove("fun.R")
#' roxy_fun(fun, find_file = TRUE)
#'
#' file.remove("fun.R")
#' roxy_fun(fun, editor = "emacs")
#'
#' roxy_fun(fun, file = NA)
#'
#' file.remove("fun.R")
#' roxy_fun(fun, print = TRUE)
#'
#' file.remove("fun.R")
#' roxy_fun(fun, export = FALSE)
#'
#' file.remove("fun.R")
#' roxy_fun(fun, author = "Walmes Zeviani, \\email{walmes@@ufpr.br}.")
#'
#' roxy_fun(fun, file = "bla.R")
#'
#' file.remove("bla.R")
#' roxy_fun(fun, file = "bla.R", extra = "@import lattice")
#'
#' file.remove("fun.R")
#' roxy_fun(object = fun, editor = "emacs")
#'
roxy_fun <- function(object,
                     file,
                     export = TRUE,
                     author,
                     keywords,
                     extra,
                     editor,
                     print = FALSE,
                     append = FALSE,
                     find_file = FALSE) {
    # Nome da função.
    name <- deparse(substitute(object))
    file <- where_save(name, file, append)
    # Argumentos da função.
    params <- names(formals(object))
    # Conteúdo da documentação.
    ctnt <- c(sprintf("@name %s", name),
              if (!missing(author)) {
                  sprintf("@author %s", author)
              },
              if (export) {
                  "@export"
              },
              "@title",
              "@description",
              sprintf("@param %s", params),
              "@return",
              if (!missing(keywords)) {
                  paste(c("@keywords", keywords), collapse = " ")
              },
              if (!missing(extra)) {
                  extra
              },
              "@examples")
    ctnt <- paste("#\'", ctnt)
    if (is.na(file)) {
        cat(ctnt, sep = "\n")
    } else {
        # Exporta a documentação para o arquivo.
        cat(ctnt, sep = "\n", file = file, append = append)
        if (print) {
            cat(ctnt, sep = "\n")
        }
        # Exporta a função para o arquivo.
        dump(name, file = file, append = TRUE)
        # Abre arquivo no editor.
        if (!missing(editor)) {
            editor <- match.arg(arg = editor,
                                choices = c("vi",
                                            "emacs",
                                            "pico",
                                            "xemacs",
                                            "xedit"))
            do.call(editor, list(file = file))
        }
    }
    if (find_file) {
        cat(sprintf("(find-file \"%s\")",
                    paste(path.expand(getwd()), file, sep = "/")),
            "\n")
    }
    invisible()
}

#' @name roxy_data
#' @export
#' @title Gera o Esqueleto de Documentação de Datasets em
#'     \code{roxygen2}
#' @description Função que recebe uma conjunto de dados e produz o
#'     esquelo da documentação em \code{roxygen2}. Opções dessa função
#'     permitem escrever o esqueleto em arquivo, adicionar campos e
#'     abrir o arquivo gerado com algum editor de texto.
#' @param object Um objeto que armazena dados. Classes compreendidas são
#'     \code{data.frame} e vetores.
#' @param file Um nome de arquivo onde escrever a documentação do
#'     conjunto de dados. Quando não fornecido, o nome do objeto é usado
#'     como nome do arquivo. Se for usado \code{NA}, nenhum arquivo será
#'     criado e a documentação será exibida no console.
#' @param source String que é a referência bibliográfica do conjunto de
#'     dados.
#' @param keywords Um vetor com keywords para o conjunto de dados que
#'     serão escritas no campo \code{@keywords}.
#' @param author O autor do conjunto de dados. Este conteúdo será
#'     passado para o campo \code{@author}.
#' @param extra Vetor com o conteúdo de campos extras como
#'     \code{"@import lattice"}.
#' @param editor Nome do editor com o qual abrir o arquivo para fazer o
#'     preenchimento dos campos da documentação. Veja
#'     \code{\link[utils]{edit}}.
#' @param print Valor lógico que indica se deve imprimir no console o
#'     esqueleto de documentação gerado.
#' @param append Valor lógico que indica se deve escrever a documentação
#'     em arquivo que já existe.
#' @param find_file Valor lógico que indica se deve exibir no console o
#'     caminho do arquivo gerado com a documentação.
#' @return Essa função não retorna conteúdo mas cria/modifica arquivos.
#' @examples
#'
#' s <- "Smith; Sanders (1234)"
#' file.remove("iris.R")
#' roxy_data(iris,
#'          print = TRUE,
#'          source = s,
#'          editor = "emacs",
#'          keywords = c("BLA", "BLU"),
#'          find_file = TRUE,
#'          extra = c("@docType dataset",
#'                    "@details bla bla bla"))
#'
roxy_data <- function(object,
                      file,
                      source = NULL,
                      keywords,
                      author,
                      extra,
                      editor,
                      print = FALSE,
                      append = FALSE,
                      find_file = FALSE) {
    # Nome do objeto.
    name <- deparse(substitute(object))
    file <- where_save(name, file, append)
    # Determina a classe.
    cld <- class(object)[1]
    # Esqueleto do @format para cada classe.
    frmat <- switch(cld,
                    "data.frame" = {
                        f <- sprintf(paste(
                            "@format Um \\code{data.frame} com %d",
                            "observações e %d variáveis, em que"),
                            nrow(object), ncol(object))
                        f <- strwrap(f, width = 69)
                        f <- c(f[1], paste("    ", f[-1]))
                        c(f,
                          "", "\\describe{", "",
                          rbind(sprintf("\\item{\\code{%s}}{  }",
                                        names(object)), ""),
                          "}")
                    },
                    "numeric" = {
                        sprintf(
                            "@format Um vetor com %d elementos.",
                            length(object))
                    },
                    stop(paste("`object` de classe não apropriada",
                               "para a função.")))
    # Conteúdo da documentação.
    ctnt <- c(sprintf("@name %s", name),
              if (!missing(author)) {
                  sprintf("@author %s", author)
              },
              "@title",
              "@description",
              frmat,
              if (!missing(extra)) {
                  extra
              },
              if (!missing(keywords)) {
                  paste(c("@keywords", keywords), collapse = " ")
              },
              if (!is.null(source)) {
                  s <- strwrap(paste("@source", source),
                               width = 69)
                  c(s[1], paste("    ", s[-1]))
              },
              "@examples")
    # Evitar espaço no final de linhas vazias.
    ctnt <- c(paste(ifelse(ctnt == "", "#\'", "#\' "),
                    ctnt, sep = ""), "NULL")
    if (is.na(file)) {
        cat(ctnt, sep = "\n")
    } else {
        # Exporta a documentação para o arquivo.
        cat(ctnt, sep = "\n", file = file, append = append)
        if (print) {
            cat(ctnt, sep = "\n")
        }
        # Abre arquivo no editor.
        if (!missing(editor)) {
            editor <- match.arg(arg = editor,
                                choices = c("vi",
                                            "emacs",
                                            "pico",
                                            "xemacs",
                                            "xedit"))
            do.call(editor, list(file = file))
        }
    }
    if (find_file) {
        cat(sprintf("(find-file \"%s\")",
                    paste(path.expand(getwd()), file, sep = "/")),
            "\n")
    }
    invisible()
}

#-----------------------------------------------------------------------

#' @name write2txt
#' @title Cria Arquivo Texto (tsv) do Conjunto de Dados
#' @description TODO
#' @param dataset Um objeto que seja vetor ou \code{data.frame}.
#' @param overwrite Se TRUE, reescreve o arquivo se ele existir.
#' @return Não retorna nada, apenas cria arquivos.
#' @author Walmes Zeviani, \email{walmes@@ufpr.br}.
#' @examples
#'
#' write2txt(iris)
#' write2txt(precip)
#'
write2txt <- function(dataset, overwrite = FALSE) {
    if (!file.exists("DESCRIPTION")) {
        stop(paste0("Arquivo DESCRIPTION não encontrado. ",
                    "Você não está na raíz de um pacote R. ",
                    "Você está em ", getwd(), "."))
    }
    name <- deparse(substitute(dataset))
    cld <- class(dataset)[1]
    whatis <- cld == c("data.frame", "numeric", "integer")
    if (all(!whatis)) {
        stop("`dataset` de classe não reconhecida pela função.")
    }
    file <- sprintf("./data-raw/%s.txt", name)
    if (!file.exists(file) || overwrite) {
        cat(sprintf("Criando txt do dataset %s em data-raw/.",
                file),
        "Não edite na mão esse arquivo.", sep = "\n")
        switch(c(1, 2, 2)[whatis],
               "1" = {
                   write.table(x = dataset,
                               file = file,
                               quote = FALSE,
                               row.names = FALSE,
                               sep = "\t",
                               fileEncoding = "utf-8")
               },
               "2" = {
                   writeLines(text = as.character(dataset),
                              con = file)
               })
    }
}

#' @name write2rda
#' @title Cria Arquivo rda do Conjunto de Dados
#' @description Nada mais é que uma função wraper para a
#'     \code{devtools::use_data()}.
#' @param dataset Um objeto que seja vetor ou \code{data.frame}.
#' @param overwrite Se TRUE, reescreve o arquivo se ele existir.
#' @return Não retorna nada, apenas cria arquivos.
#' @author Walmes Zeviani, \email{walmes@@ufpr.br}.
#' @examples
#'
#' write2rda(iris)
#' write2rda(precip)
#'
write2rda <- function(dataset, overwrite = FALSE) {
    if (!file.exists("DESCRIPTION")) {
        stop(paste0("Arquivo DESCRIPTION não encontrado. ",
                    "Você não está na raíz na raíz de um pacote R. ",
                    "Você está em ", getwd(), "."))
    }
    cmd <- sprintf("use_data(%s, overwrite = %d)",
                   deparse(substitute(dataset)),
                   overwrite)
    eval(parse(text = cmd))
}

#-----------------------------------------------------------------------