Nothing
#' @include S4classes.R
NULL
#' Annotation functionality
#'
#' Objects that contain analytical results (\code{kwic} objects, objects
#' inheriting from the \code{textstat} class) can be annotated by creating an
#' annotation layer using the \code{annotations}-method. The augmented object
#' can be annotated using a shiny gadget by invoking the \code{edit}-method on
#' it. Note that operations are deliberately in-place, to prevent an unwanted
#' loss of work.
#'
#' The \code{edit}-method is designed to be used in a RStudio session. It
#' generates a shiny gadget (see
#' \url{https://shiny.rstudio.com/articles/gadgets.html}) shown in the viewer
#' pane of RStudio.
#'
#' The \code{edit}-method returns the modified input object. Note however that
#' changes of annotations are deliberately in-place operations: The input object
#' is changed even if you do not close the gadget "properly" by hitting the
#' "Done" button and catch the modified object. That may be forgotten easily and
#' would be painful after the work that may have been invested.
#'
#' Consult the examples for the intended workflow.
#'
#' @param x An object to be annotated, a \code{kwic} class object, or an object
#' inheriting from the \code{textstat} class.
#' @param name An S4 object to be annotated.
#' @param value A value to assign.
#' @param viewer The viewer to use, see \code{\link[shiny]{viewer}}.
#' @return The modified input object is returned invisibly.
#' @param i The row number (single \code{integer} value) of the
#' \code{data.table} where a new value shall be assigned.
#' @param j The column number (single \code{integer} value) of the
#' \code{data.table} where a new value shall be assigned.
#' @param ... Passed into \code{rhandsontable::rhandsontable}, can be used for
#' settings such as \code{height} etc.
#' @importFrom utils menu
#' @importFrom DT dataTableProxy replaceData
#' @importFrom utils edit
#' @exportMethod edit
#' @rdname annotations
#' @aliases annotations,kwic-method
#' @examples
#' use(pkg = "RcppCWB", corpus = "REUTERS")
#'
#' a <- 2
#' # upon initializing a kwic object, there is a minimal labels object
#' # in the labels slot of the kwic object, which we can get using the
#' # annotations-method
#' o <- kwic("REUTERS", query = "oil")
#' annotations(o) # see the result (a data.table)
#'
#' # assign new annotations as follows, using the reference semantics of the
#' # data.table you get by calling the labels-method on an object
#' annotations(o) <- list(name = "class", what = factor(x = "a", levels = c("a", "b", "c")))
#' annotations(o) <- list(name = "description", what = "")
#' annotations(o) # inspect the result
#'
#' # assign values; note that is an in-place operation using the reference
#' # semantics of the data.table
#' # annotations(o, i = 77, j = 1, value = FALSE)
#' # annotations(o, i = 78, j = 1, value = FALSE)
#' annotations(o)
#'
#' \dontrun{
#' edit(o)
#' annotations(o) # to see changes made
#'
#' # maybe we want additional metadata
#' enrich(o, s_attributes = "places")
#' edit(o)
#' annotations(o)
#'
#' # to get some extra context
#' o <- enrich(o, extra = 5L, table = TRUE)
#' edit(o)
#'
#' # lineview may be better when you use a lot of extra context
#' options(polmineR.lineview = TRUE)
#' o <- kwic("REUTERS", "oil")
#' o <- enrich(o, extra = 20L)
#' edit(o)
#'
#' x <- cooccurrences("REUTERS", query = "oil")
#' annotations(x) <- list(name = "keep", what = TRUE)
#' annotations(x) <- list(name = "category", what = factor("a", levels = letters[1:10]))
#' edit(x)
#' }
#' @exportMethod annotations
setGeneric("annotations", function(x, ...) standardGeneric("annotations"))
#' @exportMethod annotations
#' @rdname annotations
setMethod("annotations", "kwic", function(x, i, j, value) callNextMethod())
#' @exportMethod annotations
#' @rdname annotations
setMethod("annotations", "textstat", function(x, i, j, value){
if (missing(i)){
return( x@stat[, c("match_id", x@annotation_cols), with = FALSE] )
} else {
x@stat[i, eval(j) := value]
return( invisible(x) )
}
})
#' @exportMethod annotations<-
#' @rdname annotations
setGeneric("annotations<-", function(x, value) standardGeneric("annotations<-"))
#' @rdname annotations
#' @exportMethod annotations<-
setReplaceMethod("annotations", signature = c(x = "kwic", value = "list"), function(x, value) callNextMethod())
#' @rdname annotations
#' @exportMethod annotations<-
setReplaceMethod("annotations", signature = c(x = "textstat", value = "list"), function(x, value){
x@stat[, (value[["name"]]) := value[["what"]]]
x@annotation_cols <- c(x@annotation_cols, value[["name"]])
x
})
.check_editing_gadget_dependencies <- function(){
for (pkg in c("shiny", "miniUI", "rhandsontable")){
if (!requireNamespace(package = pkg, quietly = TRUE)){
stop(sprintf("Package '%s' is required, but not available.", pkg))
}
}
}
.editing_gadget_ui <- function(){
miniUI::miniPage(
miniUI::gadgetTitleBar("Editing Gadget"),
miniUI::miniContentPanel(shiny::fillRow(rhandsontable::rHandsontableOutput("hot")))
)
}
#' @exportMethod edit
#' @rdname annotations
setMethod("edit", "textstat", function(name, viewer = shiny::paneViewer(minHeight = 550), ...){
.check_editing_gadget_dependencies()
dt <- format(name)
server <- function(input, output, session) {
values <- shiny::reactiveValues()
reactiveData <- shiny::reactive(dt)
.reset_values <- function(df){
values[["hot"]] <- df
for (col in name@annotation_cols) name@stat[, eval(col) := df[[col]]]
}
output$hot <- rhandsontable::renderRHandsontable({
data <- reactiveData()
# Identical result with rhandsontable:::isErrorMessage(data),
# using the ::: can be avoided thereby
if (inherits(data, "error_message")) return(NULL)
df <- if (is.null(input$hot)) data else rhandsontable::hot_to_r(input$hot)
.reset_values(df)
rht <- rhandsontable::rhandsontable(df, allowedTags = "<font><div><u>", height = 500, ...)
rht <- rhandsontable::hot_cols(rht, manualColumnResize = TRUE)
rht <- rhandsontable::hot_table(rht, highlightCol = TRUE, highlightRow = TRUE, overflow = "hidden", stretchH = "all")
if (all(c("left", "node", "right") %in% colnames(dt))){
rht <- rhandsontable::hot_col(rht, col = match(c("left", "right"), colnames(dt)), colWidths = "150")
rht <- rhandsontable::hot_col(rht, col = "left", readOnly = TRUE, renderer = htmlwidgets::JS("safeHtmlRenderer"))
rht <- rhandsontable::hot_col(rht, col = "node", readOnly = TRUE, renderer = htmlwidgets::JS("safeHtmlRenderer"))
rht <- rhandsontable::hot_col(rht, col = "right", readOnly = TRUE, halign = "htCenter", renderer = htmlwidgets::JS("safeHtmlRenderer"))
} else if ("concordance" %in% colnames(dt)){
rht <- rhandsontable::hot_col(rht, col = "concordance", colWidths = "300")
rht <- rhandsontable::hot_col(rht, col = "concordance", readOnly = TRUE, halign = "htCenter", renderer = htmlwidgets::JS("safeHtmlRenderer"))
} else {
rht <- rhandsontable::hot_col(rht, col = (1L:ncol(dt))[which(!colnames(dt) %in% name@annotation_cols)], readOnly = TRUE)
}
rht
})
shiny::observeEvent(input$done, shiny::stopApp(returnValue = name))
}
y <- shiny::runGadget(.editing_gadget_ui(), server, viewer = viewer)
invisible(y)
})
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.