#' @include S4classes.R p_attributes.R
NULL
#' @exportMethod head
setMethod("head", "textstat", function(x, ...) head(x@stat, ...) )
#' @exportMethod tail
setMethod("tail", "textstat", function(x, ...) tail(x@stat, ...) )
#' @exportMethod dim
setMethod("dim", "textstat", function(x) dim(x@stat))
#' @exportMethod nrow
setMethod("nrow", "textstat", function(x) nrow(x@stat))
#' @exportMethod ncol
setMethod("ncol", "textstat", function(x) ncol(x@stat))
#' @param digits Number of digits.
#' @rdname textstat-class
#' @exportMethod round
#' @details The \code{round()}-method looks up all numeric columns in the
#' \code{data.table} in the \code{stat}-slot of the \code{textstat} object and
#' rounds values of these columns to the number of decimal places specified by
#' argument \code{digits}.
setMethod("round", "textstat", function(x, digits = 2L){
if (is(x@stat)[1] == "data.table"){
if (nrow(x@stat) > 1L){
column_classes <- sapply(x@stat, function(column) is(column)[1])
numeric_columns <- which(column_classes == "numeric")
for (i in numeric_columns) x@stat[, colnames(x@stat)[i] := round(x@stat[[i]], digits)]
}
}
x
})
#' @exportMethod colnames
setMethod("colnames", "textstat", function(x) colnames(x@stat))
#' @exportMethod names
setMethod("names", "textstat", function(x) x@name)
#' @exportMethod sort
#' @rdname textstat-class
setMethod("sort", "textstat", function(x, by, decreasing = TRUE){
setkeyv(x@stat, cols = by)
setorderv(x@stat, cols = by, order = ifelse(decreasing == TRUE, -1L, 1L), na.last = TRUE)
return(x)
})
#' @rdname textstat-class
#' @exportMethod as.bundle
setGeneric("as.bundle", function(object, ...) standardGeneric("as.bundle"))
setMethod("as.bundle", "textstat", function(object){
new(
paste(is(object)[1], "_bundle", sep = ""),
objects = setNames(list(object), object@name),
corpus = object@corpus,
encoding = object@encoding
)
})
#' @exportMethod +
#' @docType methods
#' @rdname textstat-class
setMethod("+", signature(e1 = "textstat", e2 = "textstat"), function(e1, e2){
if (e1@corpus != e2@corpus) warning("Please be careful - partition is from a different CWB corpus")
retval <- as.bundle(e1)
retval@objects[[length(retval@objects) + 1L]] <- e2
names(retval@objects)[length(retval@objects)] <- e2@name
retval
})
#' @exportMethod subset
#' @rdname textstat-class
#' @examples
#' sc <- partition("GERMAPARLMINI", speaker = "Angela Dorothea Merkel")
#' cnt <- count(sc, p_attribute = c("word", "pos"))
#' cnt_min <- subset(cnt, pos %in% c("NN", "ADJA"))
#' cnt_min <- subset(cnt, pos == "NE")
#' @param subset A logical expression indicating elements or rows to keep.
setMethod("subset", "textstat", function(x, subset){
expr <- substitute(subset)
x@stat <- x@stat[eval(expr, envir = x@stat)]
x
})
#' @rdname textstat-class
#' @export
#' @method as.data.table textstat
#' @examples
#' use(pkg = "RcppCWB", corpus = "REUTERS")
#'
#' # Get statistics in textstat object as data.table
#' count_dt <- corpus("REUTERS") %>%
#' subset(grep("saudi-arabia", places)) %>%
#' count(p_attribute = "word") %>%
#' as.data.table()
as.data.table.textstat <- function(x, ...){
if (length(list(...)) > 0L){
warning(
"Further arguments passed into the as.data.table method for textstat class objects ",
"or objects inheriting from the textstat class remain unused."
)
}
x@stat
}
#' @exportMethod as.data.frame
setMethod("as.data.frame", "textstat", function(x) as.data.frame(x@stat) )
#' @rdname textstat-class
setMethod("show", "textstat", function(object) {
if (Sys.getenv("RSTUDIO") == "1" && interactive() && is.na(Sys.getenv("NOT_CRAN", unset = NA))){
view(object)
} else {
message(sprintf("Object of class '%s'", is(object)[1]))
}
})
#' @exportMethod p_attributes
#' @param object a textstat object
#' @rdname textstat-class
setMethod("p_attributes", "textstat", function(.Object) .Object@p_attribute)
#' @exportMethod [[
setMethod("[[", "textstat", function(x, i){
if (nrow(x@stat) == 0){
warning("indexing is pointless because data.table is empty")
}
x@stat[[i]]
})
#' @exportMethod [
#' @importFrom data.table key
setMethod("[", "textstat", function(x, i, j){
if (nrow(x@stat) == 0L) warning("Indexing is not possible because data.table is empty.")
# Note that i cannot be a call/expression (such as word %in% c("price", "revenue"))
# in the context of a S4 method
if (is.character(i) && is.null(key(x@stat))){
if (x@p_attribute %in% colnames(x@stat)) setkeyv(x@stat, cols = x@p_attribute)
}
if (missing(j)){
x@stat <- x@stat[eval(i, envir = x@stat)]
return(x)
} else {
return( x@stat[i,j, with = FALSE] )
}
})
setAs(from = "data.table", to = "htmlwidget", def = function(from){
DT::datatable(
from,
extensions = "Buttons",
filter = "top",
options = c(list(
pageLength = getOption("polmineR.pagelength"),
lengthMenu = c(10,25,50,100,250),
lengthChange = TRUE
),
if (getOption("polmineR.buttons")){
list(
dom = "<'row'<'col-md-3'l><'col-md-6'><'col-md-3'B>><'row'<'col-md-12't>><'row'<'col-md-6'i><'col-md-6'p>>",
buttons = c('copy', 'excel', 'pdf')
)
} else NULL
),
rownames = FALSE,
selection = "single"
)
})
setAs(from = "textstat", to = "htmlwidget", def = function(from){
dt <- format(from)
colnames(dt) <- gsub("count_", "n_", colnames(dt))
as(dt, "htmlwidget")
})
#' @details The \code{knit_print} method will be called by knitr to render
#' `textstat` objects or objects inheriting from the `textstat` class as a
#' DataTable \code{htmlwidget} when rendering a R Markdown document as html.
#' It will usually be necessary to explicitly state "render = knit_print" in
#' the chunk options. The option `polmineR.pagelength` controls the number of
#' lines displayed in the resulting `htmlwidget`. Note that including
#' htmlwidgets in html documents requires that pandoc is installed. To avoid
#' an error, a formatted \code{data.table} is returned by \code{knit_print} if
#' pandoc is not available.
#' @param ... Argument that will be passed into a call of the \code{format} method
#' on the object \code{x}.
#' @importFrom knitr knit_print
#' @exportMethod knit_print
#' @rdname textstat-class
#' @param options Chunk options.
setMethod("knit_print", "textstat", function(x, options = knitr::opts_chunk, ...){
if (!requireNamespace("rmarkdown", quietly = TRUE)){
stop("package 'rmarkdown' required but not available to run knit_print()-method on a textstat object")
}
if (rmarkdown::pandoc_available()){
widget <- as(x, "htmlwidget")
y <- knit_print(widget, options = options)
} else {
y <- format(x, ...)
show(head(y, n = getOption("polmineR.pagelength")))
cat("-- RESULTS TRUNCATED --")
y <- NULL
}
y
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.