############################################
######### PUBLIC METHODS ##################
############################################
#' Finds all items related to a set of item
#'
#' Relations are defined as in the dependency graph.
#'
#' @param names A \code{character} vector of item names.
#' @param type Can be one of "all", "to", "from". "to" recursively
#' finds items that \code{names} is attached to. "from" recursively
#' finds items that \code{names} depends on or is generated
#' by. "all" finds both (connected components including \code{names}.
#' @param excludeseed logical. If set to FALSE \code{names} will be
#' not included in the output list.
#' @return A \code{character} vector of item names.
#' @seealso dependencies
repo_related <- function(names, type="all", excludeseed=F)
{
switch(type,
"all" = {
oldset <- NULL
newset <- names
while(! all(newset %in% oldset)) {
oldset <- newset
newset <- unique(c(oldset, getRelatives(oldset, T),
getRelatives(oldset, F)))
}
set <- setdiff(newset, names)
},
"to" = set <- getRelatives(names, T),
"from" = set <- getRelatives(names, F)
)
if(excludeseed)
return(set, names)
return(c(names, set))
}
#' Build and/or plots a dependency graph
#'
#' Creates a weighted adjacency matrix, in which \code{(i,j) = x}
#' means that item \code{i} is in relation \code{x} with item
#' \code{j}. The resulting graph is plotted.
#'
#' @param tags Only show nodes matching tags
#' @param tagfun Function specifying how to match tags (by default
#' "OR": match any of \code{tags}).
#' @param depends If TRUE, show "depends on" edges.
#' @param attached If TRUE, show "attached to" edges.
#' @param generated If TRUE, show "generated by" edges.
#' @param plot If TRUE (default), plot the dependency graph.
#' @param ... Other parameters passed to the \code{plot.igraph}
#' function.
#' @details The relation between any two items \code{i} and \code{j} can have
#' values 1, 2 or 3, respectively meaning:
#' \itemize{
#' \item{depends on: }{to build item \code{i}, item \code{j} was necessary.}
#' \item{attached to: }{item \code{i} is an attachment item and is attached to
#' item \code{j}.}
#' \item{generated by: }{item \code{i} has been generated by item \code{j}. Item
#' \code{j} is usually an attachment containing the source code that
#' generated item \code{i}.}
#' }
#' @return Adjacency matrix representing the graph, with edges labeled
#' 1, 2, 3 corresponding to "depends", "attached" and "generated"
#' respectively.
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Producing some irrelevant data
#' data1 <- 1:10
#' data2 <- data1 * 2
#' data3 <- data1 + data2
#'
#' ## Putting the data in the database, specifying dependencies
#' rp$put(data1, "item1", "First item",
#' "repo_dependencies")
#' rp$put(data2, "item2", "Item dependent on item1",
#' "repo_dependencies", depends="item1")
#' rp$put(data3, "item3", "Item dependent on item1 and item2",
#' "repo_dependencies", depends=c("item1", "item2"))
#'
#' ## Creating a temporary plot and attaching it
#' fpath <- file.path(rp$root(), "temp.pdf")
#' pdf(fpath)
#' plot(data1)
#' dev.off()
#' rp$attach(fpath, "visualization of item1", "plot",
#' to="item1")
#'
#' ## Obtaining the dependency matrix
#' depmat <- rp$dependencies(plot=FALSE)
#' print(depmat)
#' ## The matrix can be plotted as a graph (requires igraph package)
#' rp$dependencies()
#' ## The following hides "generated" edges
#' rp$dependencies(generated=FALSE)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_dependencies <- function(tags=NULL, tagfun="OR", depends=T,
attached=T, generated=T, plot=T, ...)
{
pars <- list(...)
if(!"vertex.frame.color" %in% pars)
pars[["vertex.frame.color"]] <- "lightblue"
if(! "edge.arrow.size" %in% pars)
pars[["edge.arrow.size"]] <- .4
if(! "vertex.color" %in% pars)
pars[["vertex.color"]] <- "lightblue"
if(! "vertex.label.cex" %in% pars)
pars[["vertex.label.cex"]] <- .7
if(! "vertex.label.family" %in% pars)
pars[["vertex.label.family"]] <- "Helvetica"
if(! "vertex.label.color" %in% pars)
pars[["vertex.label.color"]] <- "black"
if(! "edge.label.color" %in% pars)
pars[["edge.label.color"]] <- "darkgray"
if(! "edge.label.family" %in% pars)
pars[["edge.label.family"]] <- "Helvetica"
if(! "edge.label.cex" %in% pars)
pars[["edge.label.cex"]] <- .6
deps <- depgraph(tags, tagfun, depends, attached, generated)
if(!is.null(tags))
sube <- findEntries(tags, tagfun) else sube <- 1:length(entries)
nodes <- unique(unlist(sapply(entries[sube], get, x="name")))
prjs <- sapply(nodes, isProject)
deps <- deps[!prjs,!prjs]
if(plot) {
if (requireNamespace("igraph", quietly = TRUE)) {
deps2 <- deps
rownames(deps2) <- colnames(deps2) <- basename(rownames(deps))
g <- igraph::graph.adjacency(deps2, weighted=c("type"))
pars[["x"]] <- g
pars[["edge.label"]] <-
c("depends", "attached", "generated")[igraph::get.edge.attribute(g,"type")]
do.call(igraph::plot.igraph, pars)
} else {
stop("The suggested package igraph is not installed.")
}
}
invisible(deps)
}
#' Check repository integrity.
#'
#' Checks that all indexed data are present in the repository root,
#' that files are not corrupt and that no unindexed files are present.
#'
#' @details Every time the object associated to an item is stored, an
#' MD5 checksum is saved to the repository index. \code{check}
#' will use those to verify that the object was not changed by
#' anything other than Repo itself.
#' @return Used for side effects.
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(0, "item1", "A sample item", "repo_check")
#' rp$check()
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_check <- function()
{
stopOnEmpty()
entr <- entries
for(i in 1:length(entr))
{
handleErr("CHECK_MD5_INFO_STARTING", entr[[i]]$name)
if(file.exists(getFile(entr[[i]]$name))){
md5s <- md5sum(getFile(entr[[i]]$name))
if(md5s != entr[[i]]$checksum) {
handleErr("CHECK_MD5_WARNING_FAILED")
} else handleErr("CHECK_MD5_INFO_SUCCESS")
} else {
handleErr("CHECK_WARNING_NOTFOUND")
}
}
handleErr("CHECK_EXTRA_INFO_STARTING")
allfiles <- file.path(root, list.files(root, recursive=T))
dumps <- sapply(sapply(entries, get, x="name"), getFile)
junk <- setdiff(path.expand(allfiles), path.expand(dumps))
junk <- setdiff(junk, repofile)
if(length(junk)>0){
handleErr("CHECK_EXTRA_INFO_FAILED", junk)
} else handleErr("CHECK_EXTRA_INFO_SUCCESS")
invisible()
}
#' Plots a pie chart of repository contents
#'
#' The pie chart shows all repository items as pie slices of size
#' proportional to the item sizes on disk. Items with size smaller
#' then 5% of the total are shown together as "Others".
#'
#' @param ... Other parameters passed to the \code{pie} function.
#' @return Used for side effects.
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Producing some irrelevant data of different sizes
#' data1 <- 1:10
#' data2 <- 1:length(data(1))*2
#' data3 <- 1:length(data(1))*3
#'
#' ## Putting the data in the database, specifying dependencies
#' rp$put(data1, "item1", "First item", "repo_pies")
#' rp$put(data2, "item2", "Second item", "repo_pies")
#' rp$put(data3, "item3", "Third item", "repo_pies")
#'
#' ## Showing the pie chart
#' rp$pies()
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_pies <- function(...) {
sizes = sapply(entries, get, x="size")
names(sizes) <- sapply(entries, get, x="name")
sizeperc <- sizes/sum(sizes)
toosmall <- sizeperc < .05
if(any(toosmall)) {
sizes <- c(sizes[!toosmall], sum(sizes[toosmall]))
names(sizes)[length(sizes)] <- "Others"
}
pie(sizes, ...)
}
#' Copy items to another repository
#'
#' Copies an object file from one repository to another and creates a new entry
#' in the index of the destination repository. Supports tags and multiple names.
#'
#' @param destrepo An object of class repo (will copy to it)
#' @param name The name (or list of names) of the item/s to copy
#' @param tags If not NULL, copy all items matching tags. NULL by
#' default.
#' @param replace What to do if item exists in destination repo (see
#' put). F by default.
#' @param confirm If F, don't ask for confirmation when multiple items
#' are involved. F by default.
#' @return Used for side effects.
#' @examples
#' ## Repository creation
#' rp_path1 <- file.path(tempdir(), "example_repo1")
#'
#' rp1 <- repo_open(rp_path1, TRUE)
#' rp1$put(0, "item1", "A sample item", "tag1")
#' rp_path2 <- file.path(tempdir(), "example_repo2")
#' rp2 <- repo_open(rp_path2, TRUE)
#' rp1$copy(rp2, "item1")
#'
#' ## wiping temporary repo
#' unlink(rp_path1, TRUE)
#' unlink(rp_path2, TRUE)
repo_copy <- function(destrepo, name, tags=NULL, replace=F, confirm=T)
{
if(!("repo" %in% class(destrepo)))
stop("destrepo must be an object of class repo.")
if(!xor(missing(name), is.null(tags)))
stop("You must specify either names or tags.")
if(length(name) > 1 | !is.null(tags)) {
runWithTags("copy", tags, name, replace=replace,
askconfirm=confirm, destrepo=destrepo)
} else {
if(checkName(name)) {
handleErr("ID_NOT_FOUND", name)
return(invisible())
}
e <- findEntryIndex(name)
entr <- entries[[e]]
obj <- get("this", thisEnv)$get(name)
destrepo$put(obj, name, entr$description, entr$tags,
entr$prj, entr$source,
entr$chunk, entr$depends,
replace=replace, URL=entr$URL,
asattach=isAttachment(name),
to=entr$attachedto, checkRelations=F)
}
}
#' Provides simplified access to repository items.
#'
#' Creates a list of functions, each one associated with a repository
#' item, that can be used to access items directly.
#'
#' @details Repository handlers are functions associated with
#' items. As opposed to item names, they can take advantage of IDE
#' auto-completion features and do not require quotation marks. A
#' handler to the \code{repo} object itself is provided in the
#' list.
#' @return A list of functions.
#' @examples
#'
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Putting some irrelevant data
#' rp$put(1, "item1", "Sample item 1", "repo_handlers")
#' rp$put(2, "item2", "Sample item 2", "repo_handlers")
#'
#' ## Getting item handlers
#' h <- rp$handlers()
#' ## handlers have the same names as the items in the repo (and they
#' ## include an handler to the repo itself).
#' names(h)
#'
#' ## Without arguments, function "item1" loads item named "item1".
#' i1 <- h$item1()
#'
#' ## Arguments can be used to call other repo functions on the item.
#' h$item1("info")
#'
#' ## After putting new data, the handlers must be refreshed.
#' rp$put(3, "item3", "Sample item 3", "repo_handlers")
#' h <- rp$handlers()
#' names(h)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_handlers <- function()
{
h <- list()
for(i in 1:length(entries))
{
fbody <- paste0('function(f="get", ...)',
'get("this", thisEnv)[[f]](name ="', entries[[i]]$name, '",...)')
h[[i]] <- eval(parse(text=fbody))
}
h[[length(h)+1]] <- get("this", thisEnv)
names(h) <- c(sapply(entries, get, x="name"), "repo")
return(h)
}
#' List all tags
#'
#' Shows list of all unique tags associated with any item in the
#' repository.
#'
#' @param name The name of a repository item.
#' @return Character vector of unique tags defined in the repo.
#' @seealso repo_put
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Putting two items with a few tags
#' rp$put(1, "item1", "Sample item 1",
#' c("repo_tags", "tag1"))
#' rp$put(2, "item2", "Sample item 2",
#' c("repo_tags", "tag2"))
#'
#' ## Looking up tags
#' rp$tags()
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_tags <- function(name)
{
if(missing(name)) {
entr <- entries
tagset <- unique(unlist(lapply(entr, get, x="tags")))
} else {
e <- getEntry(name)
tagset <- e$tags
}
return(tagset)
}
#' Run system call on an item
#'
#' Runs a system command passing as parameter the file name containing
#' the object associated with an item.
#'
#' @param name Name of a repo item. The path to the file that contains
#' the item will be passed to the system program.
#' @param command System command
#' @return Used for side effects.
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Creating a PDF file with a figure.
#' pdffile <- file.path(rp_path, "afigure.pdf")
#' pdf(pdffile)
#' plot(runif(30), runif(30))
#' dev.off()
#'
#' ## Attaching the PDF file to the repo
#' rp$attach(pdffile, "A plot of random numbers", "repo_sys")
#' ## don't need the original PDF file anymore
#' file.remove(pdffile)
#'
#' ## Opening the stored PDF with Evince document viewer
#' \dontrun{
#' rp$sys("afigure.pdf", "evince")
#'}
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_sys <- function(name, command)
{
stopOnNotFound(name)
e <- getEntry(name)
syscomm <-paste0(command, " ", file.path(root, e[["dump"]]))
message(paste("Running system command:", syscomm))
system(syscomm)
}
#' Match items by matching any field
#'
#' @param what Character to be matched against any field (see
#' Details).
#' @param all Show also items tagged with "hide".
#' @param show Select columns to show.
#' @return Used for side effects.
#' @details
#'
#' This function actually calls print specifying the find
#' parameters. The find parameter can be any character string to be
#' matched against any item field, including string-converted size
#' (like "10x3").
#'
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#'
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", c("tag1", "tag2"))
#' rp$put(2, "item2", "Sample item 2", c("tag1", "hide"))
#' rp$put(3, "item3", "Sample item 3", c("tag2", "tag3"))
#' rp$print()
#' rp$find("tEm2")
#' rp$find("ag2", show="t")
#'
#' ## wiping the temp repo
#' unlink(rp_path, TRUE)
#'
repo_find <- function(what, all=F, show="ds")
{
get("this", thisEnv)$print(find=what, all=all, show=show)
}
#'@export
print.repo <- function(x, tags=NULL, tagfun="OR",
find=NULL, all=F, show="ds", ...)
x$print(tags=tags, tagfun=tagfun, find=find, all=all, show=show)
#' Show a summary of the repository contents.
#'
#' @param tags A list of character tags. Only items matching all the
#' tags will be shown.
#' @param tagfun How to combine tags (see Details).
#' @param find Character to match any filed (see Details).
#' @param all Show also items tagged with "hide".
#' @param show Select columns to show.
#' @return Used for side effects.
#' @details The \code{tagfun} param specifies how to combine multiple
#' tags when matching items. It can be either a character or a
#' function. As a character, it can be one of \code{OR}, \code{AND} or
#' \code{NOT} to specify that one, all or none of the tags must be
#' matched, respectively. If it is a function, it must take two tag
#' vectors, the first of which corresponds to \code{tags}, and return
#' TRUE for a match, FALSE otherwise.
#'
#' The find param can be any character string to be matched against
#' any item field, including string-converted size (like "10x3").
#'
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", c("tag1", "tag2"))
#' rp$put(2, "item2", "Sample item 2", c("tag1", "hide"))
#' rp$put(3, "item3", "Sample item 3", c("tag2", "tag3"))
#' rp$print()
#' rp$print(all=TRUE)
#' rp$print(show="tds", all=TRUE)
#' rp$print(show="tds", all=TRUE, tags="tag1")
#' ## wiping the temp repo
#' unlink(rp_path, TRUE)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_print <- function(tags=NULL, tagfun="OR", find=NULL, all=F, show="ds")
{
if(!is.null(tags) & !is.null(find))
stop("Please provide either tags or find.")
stopOnEmpty()
entr <- entries
if(!is.null(tags) | !is.null(find)) {
w <- findEntries(tags=tags, tagfun=tagfun, find=find)
if(length(w)<1)
{
message("No matches.")
return(invisible())
} else {
entr <- entr[w]
a <- entriesToMat(w)
}
} else {
a <- entriesToMat(1:length(entr))
}
h <- rep(F,length(entr))
tagsets <- lapply(entr, get, x="tags")
hidden <- sapply(tagsets, is.element, el="hide")
if(!all)
h[hidden] <- T
if(length(entr)>1 & all(h))
{
message("All matched entries are hidden, use all=T.")
return(invisible(NULL))
}
cols <- c(T, sapply(c("f","d","t","s"), grepl, show))
a <- as.data.frame(a[!h,cols], nm="")
if(sum(!h)>1)
print(a, quote=F, row.names=F) else print(t(a), quote=F, row.names=F)
invisible(a)
}
#' Export \code{repo} items to RDS file.
#'
#' @param name Name (or list of names) of the item/s to export.
#' @param where Destination directory
#' @param tags List of tags: all items tagged with all the tags in the
#' list will be exported.
#' @param askconfirm If T ask confirmation when exporting multiple
#' items.
#' @return TRUE on success, FALSE otherwise.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "export")
#' rp$export("item1", tempdir()) # creates item1.RDS in a tempdir
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_export <- function(name, where=".", tags=NULL, askconfirm=T)
{
if(!xor(missing(name), is.null(tags)))
stop("You must specify either names or tags.")
if(!is.null(tags) | length(name)>1){
runWithTags("export", tags, name, askconfirm, where=where)
} else {
ipath <- file.path(root, getEntry(name)[["dump"]])
if(isAttachment(name))
fname <- name else fname <- paste0(name, ".RDS")
file.copy(ipath, file.path(where, fname))
}
}
#' Provides detailed information about an item.
#'
#' @param name Item name (or list of names). If both name and tags are NULL, information
#' about the whole repo will be provided.
#' @param tags List of tags: info will run on all items matching the tag list.
#' @return Used for side effects.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "info")
#' rp$info("item1")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_info <- function(name = NULL, tags = NULL)
{
stopOnEmpty()
if(!is.null(name))
stopOnNotFound(name)
if(!xor(is.null(name), is.null(tags))) {
labels <- c("Root:", "Number of items:", "Total size:")
maxw <- max(sapply(labels, nchar))
vals <- c(compressPath(root), length(entries),
hmnRead(sum(sapply(entries, get, x="size"))))
lines <- paste(format(labels, width=maxw), vals, sep=" ")
for(i in 1:length(lines))
cat(lines[[i]], "\n")
return(invisible(NULL))
}
if(!is.null(tags) | length(name)>1){
runWithTags("info", tags, name, askconfirm=F)
} else {
e <- findEntryIndex(name)
if(is.null(e))
stop("Identifier not found.")
if("#project" %in% entries[[e]]$tags)
{
sess <- get("this",thisEnv)$get(name)
cat("Project name:", name, "\n")
cat("Description:", entries[[e]]$description, "\n")
cat("Resources:", paste(sapply(entries[prjmembers(name)], get, x="name"),
collapse="\n\t"), "\n")
cat("Platform:", sess$session$platform, "\n")
cat("OS:", sess$session$running, "\n")
cat("R version:", sub("R version ", "",
sess$session$R.version$version.string), "\n")
cat("Packages:",
paste(paste(names(sess$pkg), sess$pkg, sep=" "), collapse="\n\t"),
"\n")
} else {
labels <- c("ID:", "Description:", "Tags:",
"Dimensions:", "Timestamp:",
"Size on disk:", "Provenance:",
"Attached to:", "Stored in:",
"MD5 checksum:", "URL:")
maxlen <- max(sapply(labels, nchar))
if(is.null(entries[[e]]$attachedto))
att <- "-" else att <- paste(entries[[e]]$attachedto, collapse=", ")
if(is.null(entries[[e]]$URL))
url <- "-" else url <- entries[[e]]$URL
vals <- c(entries[[e]]$name, entries[[e]]$description,
paste0(entries[[e]]$tags, collapse=", "),
paste(entries[[e]]$dims, collapse="x"),
as.character(entries[[e]]$timestamp),
hmnRead(entries[[e]]$size),
paste(entries[[e]]$source, collapse=", "), att,
file.path(get("root",thisEnv), entries[[e]]$dump),
entries[[e]] $checksum, url)
cat(paste0(format(labels, width=maxlen+1), vals, "\n"), sep="")
cat("\n")
}
}
}
#' Remove item from the repo (and the disk).
#'
#' @param name An item's name.
#' @param tags A list of tags: all items matching the list will be
#' removed.
#' @param force Don't ask for confirmation.
#' @return Used for side effects.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "info")
#' rp$put(2, "item2", "Sample item 2", "info")
#' print(rp)
#' rp$rm("item1")
#' print(rp)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_rm <- function(name = NULL, tags = NULL, force = F)
{
##:ess-bp-start::browser@nil:##
checkIndexUnchanged()
if(!xor(missing(name),missing(tags)))
stop("You must specify either a name or a set of tags.")
if(!is.null(tags) | length(name)>1){
runWithTags("rm", tags, name, !force)
} else {
e <- get("findEntryIndex",thisEnv)(name)
if(is.null(e))
return(invisible(NULL))
rmData(name, "temp")
rmData(name, "finalize")
assign("entries", entries[-e], thisEnv)
storeIndex()
}
}
#' Edit all items info using a text file.
#'
#' @details Exactly one of \code{outfile} or \code{infile} must be
#' supplied. All repository entry fields are copied to a
#' tab-separated file when using the \code{outfile} parameter. All
#' repo entries are updated reading from \code{infile} when the
#' \code{infile} parameter is used. Within the TAGS field, tags
#' must be comma-separated. The system writes a checksum to the
#' \code{outfile} that prevents from using it as \code{infile} if
#' repo has changed in the meantime.
#' @param outfile Name of a file to put entries data to.
#' @param infile Name of a file to read entries data from.
#' @return Used for side effects.
#' @seealso repo_set
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", c("tag1", "tag2"))
#'
#' items_data_file <- tempfile()
#' rp$bulkedit(items_data_file)
#' ## Manually edit items_data_file, then update items:
#' rp$bulkedit(infile=items_data_file)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_bulkedit <- function(outfile=NULL, infile=NULL)
{
if(!xor(is.null(infile), is.null(outfile)))
stop("Please provide exactly one of infile or outfile.")
if(!is.null(outfile)) {
if(file.exists(outfile))
stop("File already exists.")
outf <- file(outfile,"at")
writeLines(paste0(digest(entries),
" EDIT NEXT LINES ONLY. FIELDS MUST BE TAB-SEPARATED. ",
"TAGS MUST BE COMMA-SEPARATED."), outfile)
for(i in 1:length(entries)){
src <- entries[[i]]$source
if(is.null(src)) src <- "NULL"
line <- paste0(c(
entries[[i]]$name,
entries[[i]]$description,
paste0(entries[[i]]$tags, collapse=", "),
src,
entries[[i]]$attachedto,
entries[[i]]$depednds),
collapse="\t"
)
writeLines(line, outf)
}
close(outf)
} else {
checkIndexUnchanged()
if(!file.exists(infile))
stop("Can't find input file.")
indata <- strsplit(readLines(infile), "\t")
csum <- substr(indata[[1]],1,32)
if(csum != digest(entries))
stop(paste0("Checksum mismatch: it seems that input data were ",
"made for entries that have changed in the meantime. \n",
## "Current checksum is: ", digest(entries), "\n",
## "Checksum in input file is: ", indata[[1]], "\n",
"Overwriting could be dangerous, so I will stop here. ",
"Call bulkedit again to create a new input file.")
)
indata <- indata[-1]
rset <- get("this", thisEnv)$set
for(i in 1:length(indata)) {
src <- indata[[i]][[4]]
if(src=="NULL")
src <- NULL
entries[[i]]$name <- indata[[i]][[1]]
entries[[i]]$description <- indata[[i]][[2]]
entries[[i]]$tags <- strsplit(gsub(" ", "", entries[[i]]$tags), ",")
entries[[i]]$source <- src
}
assign("entries", entries, thisEnv)
storeIndex()
message("Entries updated.")
}
}
#' Get item attribute.
#'
#' @param name An item name.
#' @param attrib An attribute name (currently can be only "path").
#' @return The item's attribute value.
#' @seealso repo_entries, repo_get
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "tag1")
#' print(rp$attr("item1", "path"))
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_attr <- function(name, attrib)
{
okattr <- c("path", "URL", "srcfile")
if(!(attrib %in% okattr))
stop(paste("attrib must be one of:",
paste(okattr, collapse=", ")))
if(checkName(name)) {
handleErr("ID_NOT_FOUND", name)
return(invisible())
}
entry <- getEntry(name)
switch(attrib,
"path" = {res <- file.path(root, entry$dump)},
"URL" = {res <- entry$URL},
"srcfile" = {res <- get("this", thisEnv)$get(entry$source)}
)
return(res)
}
##' Shows code chunk associated with an item
##'
##' @param name Item name.
##' @return List of lines of code, invisibly.
##' @export
repo_chunk <- function(name)
{
src <- getSource(name)
##print(src)
if(is.null(src))
handleErr("CHUNK_NOSOURCE", name)
ch <- getChunk(name)
##print(ch)
if(is.null(ch))
handleErr("CHUNK_NOCHUNK", name)
cat(ch, "\n", sep="")
return(invisible(ch))
}
##' Check whether a repository has an item
##'
##' @param name Item name.
##' @return TRUE if \code{name} is in the repository, FALSE otherwise.
##' @export
repo_has <- function(name)
{
return(!is.null(getEntry(name)))
}
##' Builds a resource using the associated code chunk
##'
##' In order to be \code{build}able, a repository item must have an
##' associated source file and code chunk.
##' @param name Name of an item in the repo.
##' @param src Path to a source file containing the code block
##' associated with the resource. Not necessary if \code{name} is
##' already in the repository and has an associated source item.
##' @param recursive Build dependencies not already in the repo
##' recursively (T by default).
##' @param force Re-build dependencies recursively even if already in
##' the repo (F by default).
##' @param env Environment in which to run the code chunk associated
##' with the item to build. Parent environment by default.
##' @param built A list of items already built used for recursion (not
##' meant to be passed directly).
##' @return Nothing, used for side effects.
##' @details Code chunks are defined as in the following example: ```
##' ## chunk "item 1" {
##' x <- code_to_make_x()
##' rp$put(x, "item 1")
##' ## }
##'```
##'
##' `item 1` must be associated to the source (`src` parameter of
##' `put`) containing the chunk code.
##'
##' @export
repo_build <- function(name, src=NULL, recursive=T, force=F, env=parent.frame(), built=list())
{
if(checkName(forkedName(name)) && is.null(src))
handleErr("ID_NOT_FOUND", name)
ch <- getChunk(forkedName(name), src=src)
if(is.null(ch))
handleErr("CHUNK_NOCHUNK", name)
opt <- get("options", thisEnv)[["replace"]]
if(!is.null(opt))
if(opt == "addversion" || opt==T)
force <- T
deps <- getEntry(name)$depends
if(length(deps)>0) {
for(i in 1:length(deps)) {
if(!(deps[i] %in% built)) {
if(!get("this", thisEnv)$has(deps[i]) || force) {
handleErr("INFO_BUILDING_DEPS", deps[i])
built <- c(built, deps[i])
get("this", thisEnv)$build(deps[i], recursive=T, force=force, env=env,
built=built)
}
}
}
}
data <- eval(parse(text=ch), env)
return(invisible())
}
#' Retrieve an item from the repo.
#'
#' @param name An item's name.
#' @param enableSuggestions If set to TRUE (default), enables some
#' checks on \code{name} that are meant to gracefully handle
#' errors and provide suggestions of similar names. If FALSE, the
#' execution will be significantly faster in large repositories.
#' @return The previously stored object, or its file system path for
#' attachments.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "get")
#' print(rp$get("item1"))
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_get <- function(name, enableSuggestions=T)
{
name <- forkedName(name)
if(enableSuggestions) {
if(checkName(name)){
enames <- sapply(entries, get, x="name")
x <- agrep(name, enames)
if(length(x)>0) {
x <- x[abs(sapply(enames[x],nchar) - nchar(name))<=3]
message(paste0(
"Maybe you were looking for: ",
paste0(enames[x], collapse=", ")
))
}
handleErr("ID_NOT_FOUND", name)
return(invisible())
}
}
entry <- getEntry(name)
root <- get("root",thisEnv)
if(substr(normalizePath(entry$dump, mustWork=F), 1, nchar(root)) == root) {
newpath <- relativePath(normalizePath(entry$dump, mustWork=F))
message(paste0("This resource was indexed in a deprecated format. ",
"Now updating position from:\n", entry$dump, "\nto:\n",
newpath))
entry$dump <- newpath
setEntry(name, entry)
storeIndex()
}
f <- getFile(name)
if(!file.exists(f) && !is.null(entry$URL))
handleErr("MISS_OBJ_HAS_URL")
if(isAttachment(name))
data <- f else data <- readRDS(f)
return(data)
}
#' Low-level list of item entries.
#'
#' @return A detailed list of item entries.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "entries")
#' rp$put(2, "item2", "Sample item 2", "entries")
#' rp$put(3, "item3", "Sample item 3", "entries")
#' print(rp$entries())
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_entries <- function()
{
ent <- get("entries",thisEnv)
names(ent) <- sapply(ent, get, x="name")
return(ent)
}
#' Add tags to an item.
#'
#' @param name An item name.
#' @param newtags A list of tags that will be added to the item's tag
#' list.
#' @param tags A list of tags: newtags will be added to all items
#' matching the list.
#' @return Used for side effects.
#' @seealso repo_untag, repo_set
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", "tag1")
#' rp$print(show="t")
#' rp$tag("item1", "tag2")
#' rp$print(show="t")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_tag <- function(name = NULL, newtags, tags = NULL)
{
if(!xor(is.null(name), is.null(tags)))
stop("You must provide either name or tags.")
if(!is.null(tags) | length(name)>1)
runWithTags("tag", tags, name, F, newtags) else
get("this", thisEnv)$set(name, addtags=newtags)
}
#' Run expression with cache.
#'
#' lazydo searches the repo for previous execution of an
#' expression. If a previous execution is found, the result is loaded
#' and returned. Otherwise, the expression is executed and the result
#' stashed.
#'
#' @param expr An object of class expression (the code to run).
#' @param force If TRUE, execute expr anyway
#' @param env Environment for expr, defaults to parent.
#' @return Results of the expression (either loaded or computed on the
#' fly).
#' @details The expression results are stashed as usual. The name of
#' the resource is obtained by digesting the expression, so it will
#' look like an MD5 string in the repo. Note that the expression, and
#' not its result, will uniquely identify the item in the repo.
#'
#' The new item is automatically tagged with "stash", "hide" and
#' "lazydo".
#' @seealso repo_stash, repo_put
#'
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#'
#' ## First run
#' system.time(rp$lazydo(
#' {
#' Sys.sleep(1/10)
#' x <- 10
#' }
#' ))
#'
#' ## lazydo is building resource from code.
#' ## Cached item name is: f3c27f11f99dce20919976701d921c62
#' ## user system elapsed
#' ## 0.004 0.000 0.108
#'
#' ## Second run
#' system.time(rp$lazydo(
#' {
#' Sys.sleep(1/10)
#' x <- 10
#' }
#' ))
#'
#' ## lazydo found precomputed resource.
#' ## user system elapsed
#' ## 0.001 0.000 0.001
#'
#'
#' ## The item's name in the repo can be obtained as the name of the
#' ## last item added:
#'
#' l <- length(rp$entries())
#' resname <- rp$entries()[[l]]$name
#' cat(rp$entries()[[l]]$description)
#' ## {
#' ## Sys.sleep(1/10)
#' ## x <- 10
#' ## }
#' rp$rm(resname) ## single cached item cleared
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_lazydo <- function(expr, force=F, env=parent.frame())
{
## if(!is.expression(expr))
## handleErr("LAZY_NOT_EXPR")
src <- paste(deparse(substitute(expr)), collapse="\n")
resname <- digest(src)
if(checkName(resname) || force)
{
handleErr("LAZY_NOT_FOUND")
res <- eval(expr, envir=env)
get("this", thisEnv)$stash(res, resname)
get("this", thisEnv)$set(resname,
description=src,
addtags="lazydo")
handleErr("LAZY_NAME", resname)
return(res)
} else {
handleErr("LAZY_FOUND")
return(get("this", thisEnv)$get(resname))
}
}
#' Remove tags from an item.
#'
#' @param name An item name.
#' @param rmtags A list of tags that will be removed from the item's
#' tag list.
#' @param tags A list of tags: rmtags will be removed from all items
#' matching the list.
#' @return Used for side effects.
#' @seealso repo_tag, repo_set
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", c("tag1", "tag2"))
#' rp$print(show="t")
#' rp$untag("item1", "tag2")
#' rp$print(show="t")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_untag <- function(name = NULL, rmtags, tags = NULL)
{
if(!xor(is.null(name), is.null(tags)))
stop("You must provide either name or tags.")
if(!is.null(tags) | length(name)>1) {
runWithTags("untag", tags, name, F, rmtags)
} else {
currtags <- getEntry(name)$tags
w <- rmtags %in% currtags
if(!any(w))
warning(paste0("Tag/s ", paste0(rmtags[!w], collapse=", "),
" not present in entry ", name))
currtags <- setdiff(currtags, rmtags)
get("this", thisEnv)$set(name, tags = currtags)
}
}
#' Edit an existing item.
#'
#' @param name An item name.
#' @param obj An R object to replace the one currently associated with
#' the item.
#' @param newname Newname of the item.
#' @param description Item's description.
#' @param tags New item's tags as a list of character.
#' @param prj New item's project as a list of character.
#' @param src New item's provenance as a list of character.
#' @param chunk New item's chunk name.
#' @param depends List of item names indicating dependencies.
#' @param addtags Tags to be added to current item's tags. Can not be
#' used together with the parameter "tags".
#' @param URL A character containing an URL where the item is supposed
#' to be downloaded from.
#' @param buildURL A character containing a base URL that is completed
#' by postfixing the item's relative path. Useful to upload
#' repositories online and make their items downloadable. The
#' item's current URL is overwritten.
#' @return Used for side effects.
#' @seealso repo_put
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' rp$put(1, "item1", "Sample item 1", c("tag1", "tag2"))
#' rp$set("item1", obj=2)
#' print(rp$get("item1"))
#' rp$set("item1", description="Modified description", tags="new_tag_set")
#' rp$info("item1")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_set <- function(name, obj=NULL, newname=NULL, description=NULL,
tags=NULL, prj=NULL, src=NULL, chunk=NULL,
depends=NULL, addtags=NULL, URL=NULL,
buildURL=NULL)
{
checkIndexUnchanged()
if(missing(name) | (missing(newname) & missing(obj) & missing(description) &
missing(tags) & missing(addtags) & missing(src) &
missing(depends) & missing(URL) & missing(buildURL)))
stop("You must provide name and one of: obj, description, tags or addtags, src, depends, URL")
if(!missing(tags) & !missing(addtags))
stop("You can not specify both tags and addtags.")
if(!missing(URL) & !missing(buildURL))
stop("You can not specify both URL and buildURL.")
if(checkName(name))
handleErr("ID_NOT_FOUND", name)
w <- findEntryIndex(name)
entr <- entries[[w]]
entr$timestamp <- Sys.time()
if(!is.null(newname))
entr$name <- newname
if(!is.null(description))
entr$description <- description
if(!is.null(tags)) {
entr$tags <- checkTags(tags)
}
if(!is.null(addtags)) {
entr$tags <- unique(c(entr$tags, checkTags(addtags, name)))
}
if(!is.null(src))
entr$source <- src
if(!is.null(depends))
entr$depends <- depends
if(!missing(URL))
entr$URL <- URL
if(!missing(buildURL)) {
lastl <- substr(buildURL, nchar(buildURL), nchar(buildURL))
if(lastl=="/")
entr$URL <- paste0(buildURL, entr$dump) else {
entr$URL <- paste0(buildURL, "/", entr$dump)
}
}
if(!is.null(obj)) {
newinfo <- setData(entr$name, obj, isAttachment(entr$name))
entr$dump <- newinfo[["dump"]]
entr$size <- newinfo[["size"]]
entr$checksum <- newinfo[["checksum"]]
entr$dims <- newinfo[["dims"]]
}
entries[[w]] <- entr
assign("entries", entries, thisEnv)
storeIndex()
}
#' Create a new item from an existing file.
#'
#' @param filepath The path to the file to be stored in the repo.
#' @param description A character description of the item.
#' @param tags A list of tags to sort the item. Tags are useful for
#' selecting sets of items and run bulk actions.
#' @param src The name of the item that produced the stored
#' object. Usually a previously attached source code file.
#' @param prj The name of a \code{project} item in the repository (see
#' \code{project}). Default is no associated project item.
#' @param chunk The name of the code chunk within \code{src} that is
#' responsible for building the item. Set to \code{name} by
#' default. See \code{build}.
#' @param replace If the item exists, overwrite the specified fields.
#' @param to An existing item name to attach the file to.
#' @param URL A URL where the item contents con be downloaded from.
#' @return Used for side effects.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' \dontrun{
#' ## Creating a PDF file with a figure.
#' pdf("afigure.pdf")
#' ## Drawing a random plot in the figure
#' plot(runif(100), runif(100))
#' dev.off()
#' ## Attaching the PDF file to the repo
#' rp$attach("afigure.pdf", "A plot of random numbers", "repo_sys")
#' ## don't need the PDF file anymore
#' file.remove("afigure.pdf")
#' ## Opening the stored PDF with Evince document viewer
#' rp$sys("afigure.pdf", "evince")
#' }
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_attach <- function(filepath, description=NULL, tags=NULL,
prj=NULL, src=NULL, chunk=basename(filepath),
replace=F, to=NULL, URL=NULL)
{
get("this", thisEnv)$put(filepath, basename(filepath),
description, tags, prj, src, chunk,
replace=replace, asattach=T, to=to, URL=URL)
}
#' Quickly store temporary data
#'
#' A very simplified call to put that only requires to specify
#' a variable name.
#'
#' @details
#'
#' The \code{name} parameter is used to search the parent (or a
#' different specified) environment for the actual object to
#' store. Then it is also used as the item name. The reserved tags
#' "stash" and "hide" are set. In case a stashed item by the same
#' name already exists, it is automatically overwritten. In case a
#' non-stashed item by the same name already exists, an error is
#' raised. A different name can be specified through the rename
#' parameter in such cases.
#' @param object The object to store in the repo.
#' @param rename An optional character containing the new name for the
#' item. Otherwise the name of object is used as item's name.
#' @return Used for side effects.
#' @seealso repo_put, repo_lazydo
#' @examples
#' \dontrun{
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' tempdata <- runif(10)
#' rp$stash(tempdata)
#' rp$info("tempdata")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
#' }
repo_stash <- function(object, rename = deparse(substitute(object)))
{
name <- deparse(substitute(object))
if(!stopOnEmpty(T)){
e <- getEntry(rename)
if(!is.null(e))
if(!"stash" %in% e$tags)
stop(paste("A non-stash entry by the same name already exists,",
"try setting the rename parameter."))
}
get("this", thisEnv)$put(object, rename, "Stashed object",
c("stash", "hide"), replace=T)
}
#' Remove all stashed data
#'
#' @param force If TRUE, no confirmation is asked.
#' @return Used for side effects.
#' @seealso repo_rm, repo_stash
#' @examples
#' \dontrun{
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' tempdata <- runif(10)
#' rp$stash("tempdata")
#' rp$print(all=TRUE)
#' rp$stashclear(TRUE)
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
#' }
repo_stashclear <- function(force=F)
{
get("this", thisEnv)$rm(tags=c("stash", "hide"), force=force)
}
#' Download item remote content
#'
#' @details Repo index files can be used as pointers to remote
#' data. The pull function will download the actual data from the
#' Internet, including regular items or attachment. Another use of
#' the URL item's parameter is to attach a remote resource without
#' downloading it.
#' @param name Name of the existing item that will be updated.
#' @param replace If TRUE, existing item's object is overwritten.
#' @return Used for side effects.
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' remote_URL <- paste0("https://github.com/franapoli/repo/blob/",
#' "untested/inst/remote_sample.RDS?raw=true")
#'
#' ## The following item will have remote source
#' rp$put("Local content", "item1", "Sample item 1", "tag",
#' URL = remote_URL)
#' print(rp$get("item1"))
#'
#' ## suppressWarnings(try(rp$pull("item1"), TRUE))
#' tryCatch(rp$pull("item1"),
#' error = function(e)
#' message("There were warnings whle accessing remote content"),
#' warning = function(w)
#' message("Could not download remote content")
#' )
#' print(rp$get("item1"))
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_pull <- function(name, replace=F) {
e <- getEntry(name)
if(is.null(e$URL))
handleErr("NO_URL", name)
if(file.exists(e$dump) && !replace)
handleErr("DATA_ALREADY_THERE", name)
tf <- tempfile()
download.file(e$URL, tf)
if(isAttachment(name)) {
get("this", thisEnv)$set(name, obj=tf)
} else get("this", thisEnv)$set(name, obj=readRDS(tf))
}
#' Defines and \code{put}-s a \code{project} item.
#'
#' A \code{project} item is a special item containing session
#' information, including package dependencies. Every time a new item
#' is stored in the repository, it will automatically be assigned to
#' the current project, if one has been defined, and session
#' information will be updated.
#'
#' @param name character containing the name of the project
#' @param description character containing a longer description of the
#' project
#' @param replace logical, if T then an existing project item by the
#' same name will be overwritten.
#' @return Used for side effects.
repo_project <- function(name, description, replace=T)
{
get("this", thisEnv)$put(NULL, name, description,
c("hide", "#project"), replace=replace)
updatePrjInfo(name)
}
#' Create a new item in the repository.
#'
#' Given an R object, stores it to an RDS file in the \code{repo} root
#' and add an associated item to the \code{repo} index, including
#' object name, description, tags and more.
#'
#' @details The item \code{name} can be any string, however it should
#' be a concise identifier, possibly without special character
#' (could become mandatory soon). Some tags have a special
#' meaning, like "hide" (do not show the item by default),
#' "attachment" (the item is an attachment - this should never be
#' set manually), "stash" (the item is a stashed item, makes the
#' item over-writable by other "stash" items by default).
#' @param obj An R object to store in the repo.
#' @param name A character identifier for the new item. If NULL, the
#' name of the \code{obj} variable will be used.
#' @param description A character description of the item.
#' @param tags A list of tags to sort the item. Tags are useful for
#' selecting sets of items and run bulk actions.
#' @param prj The name of a \code{project} item in the repository (see
#' \code{project}). Default is no associated project item.
#' @param src Name of an existing item to be annotated as the
#' "generator" of the new item. Usually it is an attachment item
#' containing the source code that generated the new item. Default
#' is NULL.
#' @param chunk The name of the code chunk within \code{src} that is
#' responsible for building the item. Set to \code{name} by
#' default. See \code{build}.
#' @param depends Character vector: items that depend on this
#' item. Default is NULL.
#' @param replace One of: V, F, "addversion" to define behavior when
#' an item by the same name exists. If V, overwrite it. If F stop
#' with an error. If "addversion" the new item is stored as a new
#' version and the old item is renamed by appending a "#N"
#' suffix. Default is F.
#' @param asattach Specifies that the item is to be treated as an
#' attachment (see attach). Default is F.
#' @param to Vector of character. Specifies which item this item is
#' attached to. Default is NULL.
#' @param URL Remote URL where the \code{pull} function expects to
#' download actual item data from. Default is NULL.
#' @param checkRelations Check if items referenced by this item
#' exist. Default is T.
#' @param addversion Deprecated, use the \code{replace} parameter
#' instead.
#' @return Used for side effects.
#' @seealso get, set, attach, info
#' @examples
#' ## Repository creation
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#'
#' ## Producing some irrelevant data
#' data1 <- 1:10
#' data2 <- data1 * 2
#' data3 <- data1 / 2
#'
#' ## Putting the data in the database, specifying dependencies
#' rp$put(
#' obj = data1,
#' name = "item1",
#' description = "First item",
#' tags = c("repo_put", "a_random_tag"),
#' )
#' rp$put(data2, "item2", "Item dependent on item1",
#' "repo_dependencies", depends="item1")
#' rp$put(data3, "item3", "Item dependent on item1 and item2",
#' "repo_dependencies", depends=c("item1", "item2"))
#'
#' print(rp)
#'
#' ## Creating another version of item1
#' data1.2 <- data1 + runif(10)
#' rp$put(data1.2, name = "item1", "First item with additional noise",
#' tags = c("repo_put", "a_random_tag"), replace="addversion")
#' print(rp, all=TRUE)
#' rp$info("item1#1")
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_put <- function(obj, name=NULL, description=NULL, tags=NULL,
prj=NULL, src=NULL, chunk=name, depends=NULL,
replace=F, asattach=F, to=NULL, addversion=F,
URL=NULL, checkRelations=T)
{
checkIndexUnchanged()
## Global settings override
opt <- get("options", thisEnv)[["replace"]]
if(!is.null(opt))
replace <- opt
opt <- get("options", thisEnv)[["src"]]
if(!is.null(opt))
src <- opt
opt <- get("options", thisEnv)[["prj"]]
if(!is.null(opt))
prj <- opt
if(addversion)
stop("addversion is deprecated, use replace=\"addversion\"")
if(replace == "addversion") {
## This code is to cope with new interface after
## removing addversion parameter
addversion = T
replace = F
}
if(missing(obj))
stop("You must provide parameter: obj")
if(is.null(name))
name <- deparse(substitute(obj))
if(name == "repo")
handleErr("ID_RESERVED")
if(!is.null(to))
asattach <- T
if(asattach)
if(!file.exists(obj))
handleErr("ATTACHMENT_FILE_NOT_FOUND", obj)
##:ess-bp-start::browser@nil:##
notexist <- checkName(name)
if(!notexist & replace==F) {
entry <- getEntry(name)
if("stash" %in% entry$tags)
replace <- T
}
if(!notexist & !replace & !addversion)
handleErr("ID_EXISTING", name)
if(!asattach) {
if(!is.null(dim(obj)))
dims <- dim(obj) else
dims <- length(obj)
} else {
dims <- NULL
tags <- unique(c(tags, "attachment"))
}
if(!is.null(depends) && checkRelations)
stopOnNotFound(sapply(depends, forkedName))
if(!is.null(src) && checkRelations)
stopOnNotFound(src)
if(!is.null(to) && checkRelations)
stopOnNotFound(to)
if(!is.null(prj) && checkRelations)
stopOnNotFound(prj)
repoE <- list(name = name,
description = description,
tags = tags,
prj = prj,
class = class(obj),
dims = dims,
timestamp = Sys.time(),
dump = NULL,
size = NULL,
checksum = NULL,
source = src,
chunk = chunk,
depends = depends,
attachedto = to,
URL = URL)
if(!notexist & addversion) {
newname <- checkVersions(name)$new
get("this", thisEnv)$set(name, newname=newname)
if(!("hide" %in% get("this", thisEnv)$tags(newname))) ## avoid warning
get("this", thisEnv)$tag(newname, "hide")
}
entr <- get("entries", thisEnv)
if(!notexist & replace) {
ei <- findEntryIndex(name)
rmData(name, "temp")
oldEntr <- entr[[ei]]
} else ei <- length(entries)+1
tryCatch({
fdata <- get("storeData", thisEnv)(name, obj, asattach)
}, error = function(e) {
print(e)
if(!notexist & replace)
rmData(name, "undo")
stop("Error writing data.")
}, finally = {
repoE["size"] <- fdata[["size"]]
repoE["checksum"] <- md5sum(path.expand(fdata[["path"]]))
repoE["dump"] <- relativePath(fdata[["path"]])
## rmData must be called before overwriting the old
## entry (particularly the dump field)
if(!notexist & replace)
rmData(name, "finalize")
entr[[ei]] <- repoE
assign("entries", entr, thisEnv)
get("storeIndex", thisEnv)()
}
)
if(asattach && !("hide" %in% repoE$tags))
get("this", thisEnv)$tag(name, "hide")
if(!is.null(prj) && checkRelations) updatePrjInfo(prj)
}
## After refactoring has the same name as the globalfunction:
## repo_cpanel <- function()
## {
## repo_cpanel(get("this", thisEnv)$root())
## }
## The following has been dropped
## #' Append text to an existing item content.
## #'
## #' This feature is experimental.
## #'
## #' @param id The name of an item whose object is of class character.
## #' @param txtorfunc Text to be appended to the item's object. It can
## #' also be a on object of class function: in this case, its source is
## #' appended.
## #' @return Used for side effects.
## repo_append <- function(id, txtorfunc)
## {
## checkIndexUnchanged()
## notexist <- checkName(id)
## if(notexist)
## stop("Identifier not found.")
## if(class(txtorfunc)=="function")
## txtorfunc <- paste0("\n",
## paste(deparse(txtorfunc), collapse="\n"),
## "\n")
## if(class(txtorfunc)!="character")
## stop("txtorfunc must be an object of class function or character")
## ##e <- findEntryIndex(id)
## curobj <- this$get(id)
## this$set(id, obj=paste0(curobj, txtorfunc))
## }
#' Show path to repo root
#'
#' @return character containing the path to the root of the repo.
#' @examples
#' rp_path <- file.path(tempdir(), "example_repo")
#' rp <- repo_open(rp_path, TRUE)
#' print(rp$root())
#'
#' ## wiping temporary repo
#' unlink(rp_path, TRUE)
repo_root <- function()
{
return(get("root",thisEnv))
}
#' Returns item's dependencies
#'
#' @param name The name of a repository item.
#' @return The items on which the input item depends.
repo_depends <- function(name)
{
return(getEntry(name)$depends)
## deps <- get("dependants", thisEnv)(name)
## depnames <- sapply(entries[deps], get, x="name")
## return(depnames)
}
#' Loads an item to current workspace
#'
#' Like \code{repo_get}, returns the contents of a stored item. But,
#' unlike \code{repo_get}, loads it to the current namespace.
#'
#' @param names List or vector of repository item names.
#' @param overwrite_existing Overwrite an existing variable by the
#' same name in the current workspace. If F (defaults) throws an
#' error.
#' @param env Environment to load the variable into (parent environment
#' by default).
#' @return Nothing, used for side effects.
repo_load <- function(names, overwrite_existing=F, env=parent.frame())
{
for(i in 1:length(names)) {
obj <- get("this", thisEnv)$get(names[[i]])
assign(names[[i]], obj, envir=env)
}
return(invisible(NULL))
}
#' Set repository-wide options
#'
#' @param ... options to set
#' @return if optional parameters are not passed, the current options
#' are returned
repo_options <- function(...)
{
ls <- list(...)
curopt <- get("options", thisEnv)
if(length(ls)==0)
return(curopt)
for(i in 1:length(ls))
curopt[[names(ls)[i]]] <- ls[[i]]
assign('options', curopt, envir=thisEnv)
}
repo_methods_public <- function()
{
methods = list(
related = repo_related,
dependencies = repo_dependencies,
check = repo_check,
pies = repo_pies,
copy = repo_copy,
handlers = repo_handlers,
tags = repo_tags,
sys = repo_sys,
find = repo_find,
print = repo_print,
export = repo_export,
info = repo_info,
rm = repo_rm,
bulkedit = repo_bulkedit,
attr = repo_attr,
get = repo_get,
entries = repo_entries,
tag = repo_tag,
lazydo = repo_lazydo,
untag = repo_untag,
set = repo_set,
attach = repo_attach,
stash = repo_stash,
stashclear = repo_stashclear,
pull = repo_pull,
project = repo_project,
put = repo_put,
cpanel = repo_cpanel,
root = repo_root,
options = repo_options,
has = repo_has,
chunk = repo_chunk,
build = repo_build,
depends = repo_depends,
load = repo_load
)
return(methods)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.