Nothing
#' Print a display object
#'
#' @param x an object of class "displayObj"
#' @param \ldots further arguments passed to or from other methods
print.displayObj <- function(x, ...) {
cat("display object...\n")
}
#' Retrieve Display Object from VDB
#'
#' Retrieve a display object from a VDB.
#'
#' @param name the name of the display
#' @param group the group of the display
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#'
#' @details If a display is uniquely determined by its name, then group is not required.
#'
#' @return a display object
#'
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
getDisplay <- function(name, group = NULL, conn = getOption("vdbConn")) {
validateVdbConn(conn, mustHaveDisplays = TRUE)
load(file.path(conn$path, "displays", "_displayList.Rdata"))
displayInfo <- findDisplay(name = name, group = group, conn = conn)
if(is.null(displayInfo))
return(NULL)
vdbPrefix <- conn$path
load(file.path(vdbPrefix, "displays", displayInfo$group, displayInfo$name, "displayObj.Rdata"))
# if it is a local disk connection, the location can change
# this happens when we move things to a web server
if(inherits(displayObj$panelDataSource, "kvLocalDisk")) {
cn <- datadr::getAttribute(displayObj$panelDataSource, "conn")
if(!file.exists(cn$loc)) {
tmp <- file.path(conn$path, "displays", displayObj$group, displayObj$name, "panels")
if(!file.exists(tmp))
tmp <- file.path(conn$path, "data", basename(cn$loc))
if(file.exists(tmp)) {
if(inherits(displayObj$panelDataSource, "ddf")) {
displayObj$panelDataSource <- datadr::ddf(datadr::localDiskConn(tmp,
reset = TRUE, verbose = FALSE), verbose = FALSE)
} else {
displayObj$panelDataSource <- datadr::ddo(datadr::localDiskConn(tmp,
reset = TRUE, verbose = FALSE), verbose = FALSE)
}
}
}
}
displayObj
}
#' Remove a Display from a VDB
#'
#' Remove a display from a VDB.
#'
#' @param name the name of the display
#' @param group the group of the display
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#' @param autoYes should questions to proceed with display removal be automatically answered with "yes"?
#' @param verbose logical - print messages about what is being done
#'
#' @details If a display is uniquely determined by its name, then group is not required.
#'
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
removeDisplay <- function(name = NULL, group = NULL, conn = getOption("vdbConn"), autoYes = FALSE, verbose = TRUE) {
validateVdbConn(conn, mustHaveDisplays = TRUE)
load(file.path(conn$path, "displays", "_displayList.Rdata"))
displayInfo <- findDisplay(name, group, conn)
if(is.null(displayInfo))
return(invisible(NULL))
vdbPrefix <- conn$path
fileLoc <- file.path(vdbPrefix, "displays", displayInfo$group, displayInfo$name)
if(file.exists(fileLoc)) {
if(autoYes) {
ans <- "y"
} else {
ans <- readline(paste("Are you sure you want to remove ", fileLoc, "? (y = yes) ", sep = ""))
}
if(!tolower(substr(ans, 1, 1)) == "y")
return()
unlink(fileLoc, recursive = TRUE)
} else {
stop("Files associated with display not found: ", fileLoc, call. = FALSE)
}
displayList[paste(displayInfo$group, displayInfo$name, sep = "_")] <- NULL
ind <- which(
displayListDF$name == displayInfo$name
& displayListDF$group == displayInfo$group)
displayListDF <- displayListDF[-ind,]
# if there are no displays, remove the file
if(length(displayList) == 0) {
file.remove(file.path(conn$path, "displays", "_displayList.Rdata"))
} else {
save(displayList, displayListDF, displayListNames, file = file.path(conn$path, "displays", "_displayList.Rdata"))
}
if(verbose)
message("* Display removed successfully")
}
## internal
## ensures that a display exists and returns its name and group
# @return a list with the name and group of the display, if found - otherwise NULL
findDisplay <- function(name, group = NULL, conn = getOption("vdbConn")) {
load(file.path(conn$path, "displays", "_displayList.Rdata"))
errStr <- ""
if(is.null(group)) {
curDisplay <- which(displayListDF$name == name)
} else {
curDisplay <- which(displayListDF$name == name & displayListDF$group == group)
errStr <- paste(" from group \"", group, "\"", sep = "")
}
if(length(curDisplay) == 0) {
message("The display \"", name, "\"", errStr, " wasn't found.", sep = "")
return(NULL)
} else if (length(curDisplay) > 1) {
if(is.null(group)) {
message("There is more than one display of name \"", name, "\". Try specifying a group as well.", sep = "")
return(NULL)
} else {
message("There is more than one display of name \"", name, "\" from group \"", group, "\". This should not be possible")
return(NULL)
}
} else {
curDisplay <- displayListDF[curDisplay,]
return(list(name = curDisplay$name, group = curDisplay$group))
}
}
#' List Displays in a VDB
#'
#' List displays in a VDB.
#'
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#'
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
listDisplays <- function(conn = getOption("vdbConn")) {
validateVdbConn(conn, mustHaveDisplays = TRUE)
load(file.path(conn$path, "displays", "_displayList.Rdata"))
tmp <- as.matrix(displayListDF[,c("name", "group", "desc", "n", "dataClass")])
rownames(tmp) <- NULL
# tmp[,"updated"] <- substr(tmp[,"updated"], 1, 16)
tmp[is.na(tmp[,"dataClass"]),"dataClass"] <- "none (R plot)"
tmp <- tmp[order(tmp[,"group"], tmp[,"name"]),,drop = FALSE]
nc <- ncol(tmp)
sepWidth <- (nc - 1) * 3
headers <- colnames(tmp)
colWidths <- apply(tmp, 2, function(x) max(nchar(x)))
colWidths <- pmax(colWidths, nchar(headers))
totWidth <- getOption("width")
excess <- (totWidth - sepWidth) - sum(colWidths)
# (totWidth - sepWidth) - (sum(colWidths) - colWidths["desc"])
if(excess < 0) {
descCut <- excess + colWidths["desc"]
if(descCut < 3) {
tmp <- tmp[,which(colnames(tmp) != "desc")]
} else {
ell <- ifelse(tmp[,"desc"] == "", "", "...")
tmp[,"desc"] <- paste(substr(tmp[,"desc"], 1, descCut - 3), ell, sep = "")
}
}
headers <- colnames(tmp)
colWidths <- apply(tmp, 2, function(x) max(nchar(x)))
colWidths <- pmax(colWidths, nchar(headers))
nc <- length(headers)
fmtStr <- paste(paste("%", colWidths, "s", sep = ""), collapse = " | ")
cat(paste(c(
do.call(sprintf, c(list(fmt = fmtStr), as.list(headers))),
paste(sapply(colWidths, function(x) paste(rep("-", x), collapse = "")), collapse = "-+-"),
apply(tmp, 1, function(x) {
do.call(sprintf, c(list(fmt = fmtStr), as.list(x)))
})), collapse = "\n"))
}
#' Restore a Backed-Up Display Object
#'
#' @param name the name of the display
#' @param group the group the display belongs to
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#' @param autoYes should questions to proceed with display removal be automatically answered with "yes"?
#'
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
restoreDisplay <- function(name, group = NULL, conn = getOption("vdbConn"), autoYes = FALSE) {
displayInfo <- findDisplay(name = name, group = group, conn = conn)
fp <- file.path(conn$path, "displays", displayInfo$group)
ff <- list.files(fp)
bak <- paste0(name, "_bak")
cur <- name
if(bak %in% ff) {
if(autoYes) {
ans <- "y"
} else {
ans <- readline(paste("Are you sure you want to restore ", bak, "? (y = yes) ", sep = ""))
}
if(!tolower(substr(ans, 1, 1)) == "y")
return()
message("* Restoring backup display directory...", bak)
unlink(file.path(fp, cur), recursive = TRUE)
copyVerify <- copy_dir(file.path(fp, bak), file.path(fp, cur))
disp <- getDisplay(displayInfo$name, displayInfo$group)
updateDisplayList(list(
group = disp$group,
name = disp$name,
desc = disp$desc,
n = disp$n,
panelFnType = disp$panelFnType,
preRender = disp$preRender,
dataClass = utils::tail(class(disp$panelDataSource), 1),
cogClass = class(disp$cogDatConn)[1],
height = disp$height,
width = disp$width,
updated = disp$updated,
keySig = disp$keySig
), conn)
} else {
message("* No display to restore...")
}
}
#' Update a Display Object
#'
#' @param name the name of the display
#' @param group the group the display belongs to
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#' @param \ldots display parameters to update which must be one of "desc", "width", "height", "keySig", "panelFn", "state" - see \code{\link{makeDisplay}} for details on these parameters.
#'
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
updateDisplay <- function(name, ..., group = NULL, conn = getOption("vdbConn")) {
load(file.path(conn$path, "displays", "_displayList.Rdata"))
displayInfo <- findDisplay(name = name, group = group, conn = conn)
if(is.null(displayInfo)) {
message("No display to update")
return(invisible(NULL))
# message("Creating new display...")
# makeDisplay(name = name, group = group, conn = conn, ...)
} else {
args <- list(...)
nms <- names(args)
updateable <- c("panelFn", "desc", "state", "width", "height", "keySig")
notup <- setdiff(nms, updateable)
if(length(notup) > 0) {
message("note: the following attributes cannot be used to update a display and will be ignored: ", paste(notup, collapse = ", "))
}
disp <- getDisplay(name, group, conn)
noPreRend <- c("panelFn", "width", "height", "lims")
if(disp$preRender) {
if(nms %in% noPreRend)
message("note: preRender is TRUE, so the following cannot be set: ",
paste(noPreRend, collapse = ", "))
nms <- setdiff(nms, noPreRend)
}
for(cur in setdiff(updateable, c("panelFn", "state"))) {
# TODO: validate each one
if(cur %in% nms)
disp[[cur]] <- args[[cur]]
}
if("state" %in% nms)
disp$state <- validateState(args$state, disp)
if("panelFn" %in% nms) {
if(is.null(args$detectGlobals)) {
getGlobals <- TRUE
} else {
getGlobals <- as.logical(args$detectGlobals)
}
if(getGlobals) {
panelGlobals <- datadr::drGetGlobals(args$panelFn)
disp$relatedPackages <- unique(c(args$packages,
panelGlobals$packages, disp$relatedPackages))
for(nm in names(c(panelGlobals$vars, args$params))) {
disp$relatedData[[nm]] <- panelGlobals$vars[[nm]]
}
}
if(!is.null(args$params) && inherits(args$params, "list"))
environment(args$panelFn) <- list2env(args$params)
panelEx <- datadr::kvApply(datadr::kvExample(disp$panelDataSource),
args$panelFn)$value
panelFnType <- getPanelFnType(panelEx)
class(args$panelFn) <- c("function", panelFnType)
disp$panelFn <- args$panelFn
# TODO: should also update thumbnail
}
updateDisplayList(list(
group = disp$group,
name = disp$name,
desc = disp$desc,
n = disp$n,
panelFnType = disp$panelFnType,
preRender = disp$preRender,
dataClass = utils::tail(class(disp$panelDataSource), 1),
cogClass = class(disp$cogDatConn)[1],
height = disp$height,
width = disp$width,
updated = Sys.time(),
keySig = disp$keySig
), conn)
vdbPrefix <- conn$path
displayObj <- disp
save(displayObj, file = file.path(vdbPrefix, "displays",
disp$group, disp$name, "displayObj.Rdata"))
}
}
#' Remove Backed-Up Trelliscope Displays
#'
#' Remove all display directories ending with "_bak"
#' @param conn VDB connection info, typically stored in options("vdbConn") at the beginning of a session, and not necessary to specify here if a valid "vdbConn" object exists
#' @example man-roxygen/ex-displayObj.R
#' @family display_manipulation
#' @export
cleanupDisplays <- function(conn = getOption("vdbConn")) {
validateVdbConn(conn)
ff <- list.files(file.path(conn$path, "displays"),
recursive = TRUE, include.dirs = TRUE, pattern = "_bak$", full.names = TRUE)
for(f in ff) {
unlink(f, recursive = TRUE)
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.