#' List scripts
#'
#' @param folder string describing folder to search recursively in
#' @param extn character (can be regex) giving extension to limit search to
#' @param recursive by default TRUE
#' @examples
#' \dontrun{
#' ls_scripts('~/AZD6094/PK_liver4/') %>%
#' info_scripts('Description') %>%
#' filter(grepl('mod',DESCRIPTION))
#' }
#' @export
ls_scripts <- function(folder = ".", extn = "r|R|Rmd|rmd", recursive = TRUE) {
if (is.null(extn)) {
output <- dir(folder, recursive = recursive, full.names = TRUE)
} else {
file_match <- paste0("\\.(", extn, ")$")
output <- dir(folder, recursive = recursive, full.names = TRUE, pattern = file_match)
}
return(normalizePath(output, winslash = "/"))
}
#' List information about scripts
#'
#' @param files vector string of file names/paths
#' @param fields vector string of field tags to display
#' @param viewer logical indicating if Rstudio viewer should be used (default = TRUE)
#' @param silent run in quiet mode (default=FALSE)
#' @param base_dirs character vector. group files together that belong to these directory paths
#' @param shorten_paths logical. Default = TRUE. Long paths will be shortened if true in displayed output (not returned object)
#' @examples
#' \dontrun{
#' ls_scripts('~/AZD6094/PK_liver4/') %>%
#' info_scripts('Description') %>%
#' filter(grepl('mod',DESCRIPTION))
#' }
#' @export
info_scripts <- function(files, fields = c("Description"), viewer = TRUE, silent = FALSE,
base_dirs = NULL, shorten_paths = TRUE) {
if (length(fields) > 0) {
res <- lapply(files, function(file.name) {
## per file
suppressWarnings({
s <- readLines(file.name, n = 30)
field.vals <- as.data.frame(lapply(fields, function(field) {
field <- gsub(paste0("^.*",field,"s*:\\s*(.*)$"), "\\1",
s[grepl(paste0("^.*", field, "s*:\\s*"), s,ignore.case = TRUE)],
ignore.case = TRUE)
field <- field[!field %in% ""]
if (length(field) == 0)
return(as.character(NA))
field[1] ## in case multiple, take only first
}))
names(field.vals) <- fields
})
field.vals
})
res <- do.call(rbind, res)
} else res <- data.frame(row.names = seq_along(files))
d <- cbind(data.frame(FULL = normalizePath(files, winslash = "/"),
FOLDER = normalizePath(dirname(files), winslash = "/"),
NAME = basename(files), stringsAsFactors = FALSE), res)
if (!is.null(base_dirs)) {
base_dirs <- normalizePath(base_dirs, winslash = "/")
all_matches <- unlist(lapply(base_dirs, function(base_dir) {
grep(paste0("^", base_dir), d$FULL)
}))
if (length(unique(all_matches)) != length(all_matches))
stop("duplicate file matches found. Check base directories are not subsets of one another")
for (base_dir in base_dirs) {
match_base <- grepl(paste0("^", base_dir), d$FULL)
d$FOLDER[match_base] <- gsub(paste0("^(", base_dir, ").*$"), "\\1", d$FULL[match_base])
d$NAME[match_base] <- gsub(paste0("^", base_dir, .Platform$file.sep, "*(.*)$"),
"\\1", d$FULL[match_base])
}
}
d <- cbind(data.frame(NAME = d$NAME, stringsAsFactors = FALSE),
res,
data.frame(FOLDER = d$FOLDER, stringsAsFactors = FALSE))
if (shorten_paths) {
dshort <- d
dshort$FOLDER <- short_path(dshort$FOLDER)
} else {
dshort <- d
}
if (!silent) {
if (viewer)
get("View")(dshort, "available files")
}
invisible(d)
}
#' Search for files matching raw text search
#'
#' @param files vector string of file names/paths
#' @param text string (can be regex) to search for
#' @param search_title logical (default=TRUE). should matching occur in title
#' @param search_contents logical (default=TRUE). should matching occur in file contents
#'
#' @seealso \code{\link{ls_scripts}}, \code{\link{ls_code_library}}, \code{\link{stage}}
#'
#' @examples
#'
#' \dontrun{
#'
#' ls_scripts("Scripts") %>% search_raw("AUC") ## finds all scripts containing string "AUC"
#'
#' ## regex match find instances of AUC() function being used
#' ls_scripts("Scripts") %>% search_raw("AUC\\(")
#'
#' ## bring file(s) into staging area of project
#' ls_scripts("Scripts") %>% search_raw("AUC\\(") %>% stage()
#'
#' }
#'
#' @export
search_raw <- function(files, text, search_title=TRUE, search_contents=TRUE) {
res <- unlist(sapply(files, function(file.name) {
if(search_contents){
suppressWarnings(s <- readLines(file.name))
s <- grep(text, s)
} else s <- c()
if(search_title) s <- c(s,grep(text, file.name))
if (suppressWarnings(length(s) == 0))
return(NULL) else return(file.name)
}))
names(res) <- NULL
res
}
#' Search for files matching field values
#'
#' @param files vector string of file names/paths
#' @param field character. field name (can be regex) to search for
#' @param text string (can be regex) to search for
#' @export
search_field <- function(files, field, text) {
res <- unlist(sapply(files, function(file.name) {
suppressWarnings(s <- readLines(file.name,n = 10))
s <- s[grep(paste0("^.*",field,"s*:\\s*.*(",text,").*$"), s, ignore.case = TRUE)]
if(length(s)==0) return(NULL)
if(length(s)>1) stop("multiple fields detected")
return(file.name)
}))
names(res) <- NULL
res
}
#' Search for files matching key words
#'
#' @param files vector string of file names/paths
#' @param text string (can be regex) to search for
#' @export
search_keyword <- function(files, text) {
search_field(files, "key\\s*word", text)
}
#' List files in code library
#'
#' @param pattern optional character. filter the code library use regex
#'
#' @seealso \code{\link{code_library}}, \code{\link{preview}}, \code{\link{stage}}, \code{\link{import}}
#'
#' @examples
#'
#' \dontrun{
#'
#' ls_code_library("Models/ADVAN2.mod") %>%
#' stage()
#'
#' }
#'
#' @export
ls_code_library <- function(pattern = ".") {
paths <- ls_scripts(extn = ".*", folder = getOption("code_library_path"), recursive = TRUE)
paths[grepl(pattern, paths)]
}
#' Show Code Library
#'
#' @param extn vector string of extensions to include
#' @param fields character vector of fields to extract
#' @param viewer logical indicating if viewer should be used to display results
#' (default=FALSE)
#' @param silent logical indicating if messages should be silenced
#' (default=FALSE)
#' @param return_info logical (default = FALSE). Return data.frame of results
#' (FALSE= returns file paths)
#'
#' @details requires \code{getOption("code_library_path")} to be set
#'
#' @seealso \code{\link{ls_code_library}}, \code{\link{preview}}
#' @examples
#'
#' \dontrun{
#'
#' code_library()
#'
#' }
#' @export
code_library <- function(extn = NULL, fields = "Description", viewer = TRUE, silent = FALSE,
return_info = FALSE) {
if (is.null(getOption("code_library_path"))) {
if (!silent) {
message("No directories attached. To attach add the following command:")
message(" options(code_library_path=c(\"dir/of/scripts1\",\"dir/of/scripts2\",...))")
message(" 1. (for this session only) in the console")
message(" 2. (for this user) to ~/.Rprofile")
message(paste0(" 3. (for all users) to ", file.path(R.home(component = "home"),
"etc", "Rprofile.site")))
message(" 2. Attach for this user by putting command in ~/.Rprofile:")
}
return(invisible(data.frame()))
}
files <- ls_code_library()
if (!is.null(extn)) {
file_match <- paste0("\\.(", extn, ")$")
files <- files[grepl(file_match, files)]
}
if (viewer == FALSE & !return_info) {
return(files)
}
tryCatch({
info <- info_scripts(files, fields = fields, viewer = viewer, silent = silent,
base_dirs = getOption("code_library_path"))
}, error = function(e) {
if (grepl("duplicate file", e$message))
e$message <- paste0(e$message, ".\n Check getOption(\"code_library_path\") points to non-overlapping folders")
stop(e)
})
if (return_info) {
if (silent)
return_ob <- invisible(info) else return_ob <- info
} else {
return_ob <- normalizePath(files, winslash = "/")
}
if (viewer == FALSE)
return(info)
if (viewer == TRUE)
return(invisible(files))
}
#' Preview code_library file
#' @param name character indicating script in code_library to preview
#' @export
preview <- function(name) {
## preview files in code_library
if(length(name)>1) stop("can only preview one file at a time")
if (is_full_path(name)) {
if (!file.exists(name))
stop("file not found")
file.show(name)
return()
}
d <- code_library(extn = ".*", viewer = FALSE, silent = TRUE, return_info = TRUE,
fields = c())
if (!name %in% d$NAME)
stop("file not found in code_library")
if (length(which(d$NAME %in% name)) > 1)
stop("Matched more than one file with that name.\n Try preview() again with full path")
pos <- match(name, d$NAME)
path <- file.path(d$FOLDER[pos], d$NAME[pos])
file.show(path)
}
#' Display code library search path
#'
#' @export
code_library_path <- function() getOption("code_library_path")
#' Attach code library
#'
#' Attaches a path(s) to to the code library search path
#'
#' @param path character vector with paths to attach to
attach_code_library <- function(path) {
options(code_library_path = unique(c(path, getOption("code_library_path"))))
}
#' Replaces code library
#'
#' Replace code library search path with path(s)
#'
#' @param path character vector with paths to attach to
replace_code_library <- function(path) {
options(code_library_path = unique(path))
}
#' Import a project into current project
#'
#' If file isn't found will look in code_library
#'
#' @param proj_name character vector with paths to attach to
#' @export
import_project <- function(proj_name){
message("under construction")
}
#' shorten path name
#'
#' @param x character vector. Path to shorten.
short_path <- function(x) {
split_paths <- strsplit(x, .Platform$file.sep) #[[1]]
short_paths <- lapply(split_paths, function(split_path) {
if (length(split_path) > 5)
split_path.short <- c(split_path[1:3], "..", split_path[(length(split_path) -
1):length(split_path)]) else split_path.short <- split_path
do.call(file.path, as.list(split_path.short))
})
unlist(short_paths)
}
#' Download code repositor from github
#'
#' @param local_path character. Path to install repository
#' @param giturl character. URL to github repository
#' @param config_file character. Name of config file (e.g. "~/.Rprofile")
#' @export
get_github_code_library <- function(local_path,giturl,
config_file){
if(!requireNamespace("git2r", quietly = TRUE))
stop("git2r needed for this function to work. Please install it.",
call. = FALSE)
if(missing(config_file)) stop("config_file required. Use either::\n",
" ~/.Rprofile (for user installation)\n ",R.home(),"/etc/Rprofile.site (for all users - administrator access required)")
local_path <- normalizePath(local_path, winslash = "/", mustWork = FALSE)
local_path_exists <- file.exists(local_path)
tryCatch({
git2r::clone(url = giturl,local_path = local_path)
if(file.exists(config_file))
config_contents <- readLines(config_file) else {
config_contents <- ""}
if(any(grepl(local_path,config_contents))){
warning("local_path detected in config file.\n",
"Ensure the following in your config_file:\n",
" options(code_library_path=unique(c(getOption(\"code_library_path\"),\"",local_path,"\")))\n")
} else
cat("\n\noptions(code_library_path=unique(c(getOption(\"code_library_path\"),\"",local_path,"\")))\n",
file = config_file, append = TRUE , sep = "")
}, error = function(e){
if(!local_path_exists){
message("removing ",local_path)
unlink(local_path, recursive = TRUE, force = TRUE)
}
stop(e)
})
options(code_library_path=unique(c(getOption("code_library_path"),local_path)))
}
#' pull repository
#'
#' @param local_path character. Path to repository
#' @export
pull_repo <- function(local_path){
repo <- git2r::init(local_path)
if(length(git2r::remotes(repo))==0)
stop("No remotes for git repository found. Something wrong. Set up manually")
git2r::config(repo,user.name = Sys.info()["user"],user.email = getOption("user.email"))
git2r::pull(repo)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.