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