Nothing
#' @export
#' @rdname setup
setCollectionDirectory <- function(collectionDirectory = file.path(getOption("qd.datadir"), "collections")) {
options(qd.collectionDirectory=collectionDirectory)
NULL
}
#' @title Installed texts
#' @description Returns a list of all ids that are installed
#' @param asDataFrame Logical value. Controls whether
#' the return value is a list (with colon-joined ids)
#' or a data.frame with two columns (corpus, drama)
#' @param dataDirectory The directory in which precompiled
#' drama data is installed
#' @return A character vector with all installed play ids
#' @export
#'
loadAllInstalledIds <- function(asDataFrame=FALSE,
dataDirectory=getOption("qd.datadir")) {
files <- list.files(path=file.path(dataDirectory),pattern=".*\\.(csv|xmi)", recursive = TRUE)
files <- strsplit(files, .Platform$file.sep, fixed=TRUE)
files <- lapply(files, function(x) {
parts <- unlist(strsplit(x[3],".",fixed=TRUE))
if (data.table::last(parts)=="xmi") {
x[3] <- paste(parts[1:(length(parts)-1)],sep=".",collapse=".")
} else if (data.table::last(parts)=="csv") {
x[3] <- paste(parts[1:(length(parts)-2)],sep=".",collapse=".")
}
x
})
files <- unique(files)
if (asDataFrame) {
data.frame(matrix(unlist(files), nrow=length(files), byrow=T))
} else {
unlist(lapply(files, function(x) { paste(x[c(1,3)],sep=":", collapse=":") }))
}
}
#' @importFrom utils read.table
loadSetsInternally <- function() {
setNames <- list.files(getOption("qd.collectionDirectory"))
sets <- lapply(setNames,
function(x) {
utils::read.table(
file.path(getOption("qd.collectionDirectory"), x),
encoding = "UTF-8",
stringsAsFactors = FALSE
)$V1
})
names(sets) <- setNames
sets
}
#' @title Load Collections
#' @description Function to load a set from collection files
#' Can optionally set the set name as a genre in the returned table.
#' \code{loadSets()} returns table of all defined collections (and the
#' number of plays in each).
#' @param setName A character vector. The name of the set(s) to retrieve.
#' @param addGenreColumn Logical. Whether to set the Genre-column in
#' the returned table to the set name. If set to FALSE (default), a vector
#' is returned. In this case, association to collections is not returned.
#' Otherwise, it's a data.frame.
#' @return A character vector with play ids that belong to the set.
#' @export
loadSet <- function(setName, addGenreColumn=FALSE) {
sets <- loadSetsInternally()
s <- sets[setName]
if (addGenreColumn == TRUE) {
Reduce(rbind,
mapply(function(x,y) { data.frame(id=x, Genre=rep(y,length(x))) },
x=s,
y=names(s),
SIMPLIFY = FALSE)
)
} else {
Reduce(c,s)
}
}
#' @export
#' @rdname loadSet
loadSets <- function() {
sets <- loadSetsInternally()
data.frame(size=unlist(lapply(sets,length)))
}
#' @title Replace corpus prefix
#' @description This function can be used to replace corpus prefixes.
#' If a list of play ids contains textgrid prefixes, for instance, this
#' function can be used to map them onto GerDraCor prefixes. Please note
#' that the function does \emph{not} check whether the play actually exists
#' in the corpus.
#' @param idList The list of ids in which we want to replace.
#' @param map A list containing the old prefix as name and the new one as
#' values.
#' @return The function returns a list of the same length of the input list, but
#' with replaced play prefixes.
#' @export
#' @examples
#'
#' # returns c("corpus2:play1", "corpus2:play2")
#' mapPrefix(c("corpus1:play1", "corpus1:play2"), list(corpus1="corpus2"))
#'
mapPrefix <- function(idList, map) {
r <- idList
for (x in names(map)) {
r <- sub(paste0(x, ":"), paste0(map[[x]], ":"), r, fixed=TRUE)
}
r
}
#' @title Create or Extend a Collection
#' @description \code{newCollection()} can be used to create new collections
#' or add dramas to existing collection files.
#' @param drama A text (or multiple texts, as data.frame or data.table), or a character
#' vector containing the drama IDs to be collected
#' @param name The name of the collection and its filename (default = concatenated drama IDs)
#' @param writeToFile = Whether to write the collection to a file (default = TRUE)
#' @param dir The directory into which the collection file will be written (default = collection directory)
#' @param append Whether to extend the collection file if it already exists.
#' If FALSE, the file will be overwritten. (default = TRUE)
#' @export
#' @return The function returns the ids that belong to the collection as a character vector.
#' @examples
#' t <- combine(rksp.0, rjmw.0)
#' newCollection(t, writeToFile=FALSE)
#' newCollection(c("rksp.0", "rjmw.0"), writeToFile=FALSE) # produces identical file
#' newCollection(c("a", "b"), name="rksp.0_rjmw.0", writeToFile=FALSE) # adds "a" and "b" to the file
newCollection <- function(drama,
name=ifelse(inherits(drama, "QDDrama"),
paste(unique(drama$meta$drama)),
paste(drama,collapse="_")),
writeToFile=TRUE,
dir=getOption("qd.collectionDirectory"),
append=TRUE) {
stopifnot(inherits(drama, "QDDrama") || is.character(drama))
fn <- paste0(dir, "/", name)
if (inherits(drama, "QDDrama")) {
t <- unique(drama$meta$drama)
} else {
t <- drama
}
if (writeToFile) {
if (append && file.exists(fn)) {
t <- unique(c(readLines(fn), t))
}
cat(t, sep="\n", file=fn)
message(name, " was written to ", dir)
}
t
}
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.