R/annolite.R

In PolMine/annolite: Lightweight Fulltext Display and Annotation Tools

#' Create annolite htmlwidget
#' 
#' The HTML widget *annolite* is the core of the package and the `annolite()`
#' method is the constructor to generate it. The widget targets two basic uses:
#' 1. The widget's *annotation mode* offers a pure R workflow for basic text
#' annotation tasks. In this scenario, it is used within a Shiny Gadget called
#' via `annotate()`.
#' 2. The widget's *display mode* is designed to inspect the fulltext of a
#' document with highlighted annotations either in an interactive R session or
#' embedded in Rmarkdown documents. The widget's support of crosstalk enables
#' the interactive selection among a set of documents within an HTML document
#' generated from Rmarkdown.
#' 
#' @param x Either a `fulltexttable` object or an object that can be
#'   transformed to a `fulltexttable` using the `fulltexttable()` method.
#' @param annotations An optional `annotationstable` object. If supplied,
#'   existing annotations will be highlighted in the fulltext displayed.
#'   Defaults to an empty `annotationstable` generated by calling
#'   `annotationstable()`.
#' @param width The width of the annolite htmlwidget.
#' @param height The height of the annolite htmlwidget.
#' @param buttons To define button/color combinations for annotation mode,
#'   supply a named `list` of length-one `character` vectors to specify codes
#'   and corresponding colors for highlighting (names are codes, values colors).
#'   Colors that are assigned need to be either valid hex colors or among the
#'   color names R knows about (see `grDevices::colors()`). For display mode,
#'   set argument as `FALSE`, and there will *not*  be a pop-up menu to create
#'   an annotation if text is selected.
#' @param box Length-one `logical` value, whether draw box around HTML widget
#'   with fulltext display.
#' @param group An identifier for a Crosstalk group. HTML widgets within one
#'   Crosstalk group can communicate with each other, see documentation of the
#'   argument `group` of `crosstalk::SharedData`. Defaults to "fulltext".
#' @param layout Relevant for crosstalk mode
#' @param crosstalk \code{logical}, whether to use crosstalk
#' @param ... Further arguments
#' @importFrom htmlwidgets createWidget sizingPolicy
#' @importFrom crosstalk crosstalkLibs is.SharedData bscols
#' @importFrom utils packageVersion
#' @importFrom grDevices colors
#' @export annolite
#' @aliases annolite-package annolite
#' @docType package
#' @name annolite
#' @rdname annolite
#' @examples 
#' library(polmineR)
#' sc <- corpus("GERMAPARLMINI") %>%
#'   subset(speaker == "Volker Kauder" & date == "2009-11-10")
#' tab <- fulltexttable(sc)
#' y <- annolite(
#'   x = tab, annotations = annotationstable(),
#'   width = "100%",
#'   buttons = list(keep = "yellow", drop = "orange")
#' )
#' @author Andreas Blaette
setGeneric("annolite", function(x, ...) standardGeneric("annolite"))

setOldClass("fulltexttable")

#' @rdname annolite
setMethod("annolite", "fulltexttable", function(x, annotations = annotationstable(), buttons = list(keep = "yellow", drop = "lightgreen"), width = "100%", height = NULL,  box = TRUE, crosstalk = FALSE, layout = "filter", group = "fulltext") {
  
  # Ensure that argument 'buttons' is either FALSE or a named list of length-one
  # character vectors
  if (is.null(buttons)|| is.na(buttons)) buttons <- FALSE
  if (is.character(buttons)) buttons <- as.list(buttons)
  if (is.list(buttons)){
    if (!all(sapply(buttons, length) == 1L)){
      stop("Invalid value for argument buttons: All elements in the list are required to be length-one character vectors.")
    }
    if (
      isFALSE(
        all(as.character(unname(buttons)) %in% grDevices::colors()) ||
        all(grepl(pattern = "^#[a-fA-F0-9]{6}$", x = as.character(unname(buttons)), ignore.case = TRUE))
      )
    ){
      stop(
        "Invalid color definition in argument 'buttons': ", 
        "Values need to be either valid hex colors, or included in grDevices::colors()."
      )
    }
  }
  
  createWidget(
    "annolite",
    package = "annolite",
    x = list(
      data = list(fulltext = htmlize(x), annotations = annotations),
      settings = list(
        crosstalk = crosstalk,
        crosstalk_key = if (isTRUE(crosstalk)) "name" else NULL,
        crosstalk_group = group,
        box = box,
        buttons = buttons
      )
    ),
    width = width,
    height = height,
    dependencies = if (crosstalk) list(
      htmltools::htmlDependency(
        name = "crosstalk", 
        version = packageVersion("crosstalk"),
        package = "crosstalk",
        src = "www",
        script = "js/crosstalk.min.js",
        stylesheet = "css/crosstalk.css"
      )
    ) else NULL,
    sizingPolicy(
      browser.fill = TRUE,
      viewer.defaultHeight = 800L,
      browser.defaultHeight = 800L,
      viewer.fill = TRUE,
      knitr.figure = FALSE,
      knitr.defaultWidth = 800L,
      knitr.defaultHeight = 400L
    )
  )
})

setOldClass("SharedData")

#' @rdname annolite
#' @exportMethod annolite
setMethod("annolite", "SharedData", function(x, annotations = NULL, width = "100%", height = NULL, box = TRUE) {
  annolite(
    x = x$origData(),
    annotations = annotations, buttons = FALSE,
    width = width, height = height, box = box,
    group = x$groupName(), crosstalk = TRUE
  )
})


#' Render annolite htmlwidget in shiny apps.
#' 
#' @param outputId Output variable to read the value from.
#' @param width The width of the widget.
#' @param height The height of the widget.
#' @param expr An expression (...).
#' @param env The environment in which to evaluate expr.
#' @param quoted Is expr a quoted expression (with quote())? This is useful if
#'   you want to save an expression in a variable.
#' @export annoliteOutput
#' @importFrom htmlwidgets shinyWidgetOutput
#' @rdname shiny
annoliteOutput <- function(outputId, width = "100%", height = "100%") {
  shinyWidgetOutput(outputId, "annolite", width, height, package = "annolite")
}
#' @export renderAnnolite
#' @importFrom htmlwidgets shinyRenderWidget
#' @rdname shiny
renderAnnolite <- function(expr, env = parent.frame(), quoted = FALSE) {
  if (!quoted) { expr <- substitute(expr) } # force quoted
  shinyRenderWidget(expr, annoliteOutput, env, quoted = TRUE)
}


#' Annotated speech of Kofi Annan
#' 
#' The package includes the fulltext of Kofi Annan's speech opening the 2000
#' Millennium Summit (object `secretary_general_2000_speech`) and a sample
#' annotation of the speech (object `secretary_general_2000_annotations`).
#' 
#' @format The object `secretary_general_2000_speech` is a `fulltexttable`, see
#'   documentation object \code{\link{fulltexttable}} for an explanation of the
#'   data structure. To inspect the code that has been used to prepare the
#'   `fulltexttable`, see the file 'annan2000.R' in the data-raw subdirectory of
#'   the package.
#' @rdname sg2000
"secretary_general_2000_speech"

#' @format The object `secretary_general_2000_annotations` is a
#'   `annotationstable`, see documentation obje \code{\link{annotationstable}}
#'   for an explanation of the data structure. To inspect the code that has been
#'   used to prepare the `annotationstable`, see the file 'annan2000.R' in the
#'   data-raw subdirectory of the package.
#' @rdname sg2000
"secretary_general_2000_annotations"


#' Jane Austen's Emma
#' 
#' For explaining how a `fulltexttable` can be generated from any kind 
#' of textual data, the package includes the tokenized text of the first
#' five chapters of Jane Austen's novel *Emma*.
#' 
#' To inspect the code that has been used to prepare the object, see the file
#' 'emma.R' in the data-raw subdirectory of the package.
#' 
#' @format A list of lists of character vectors. Each list of character vectors
#'   represents a chapter of Emma.
#' @rdname emma
"emma_chapters_tokenized"

#' Speeches on migration in the UN General Assembly
#' 
#' To illustrate how the *annolite* HTML widget can be used for evaluating a
#' topic model, i.e. for inspecting documents where a topic is present among the
#' m first topics, the package includes a set of UN General Assembly speeches
#' (presumably) addressing migration affairs (object
#' `unga_migrationspeeches_fulltext`) and an `annotationstable` (object
#' `unga_migrationspeeches_anntationstable`) to highlight tokens indicative of
#' the migration topic.
#' 
#' To inspect the code that has been used to prepare the object, see the file
#' 'unga_topicmodelling.R' in the data-raw subdirectory of the package.
#' 
#' @format The object `unga_migrationspeeches_fulltext` is a `fulltexttable`,
#'   see the documentation of the function `fulltexttable` for an explanation 
#'   of the data structure of the class `fulltexttable`.
#' @rdname unga_migrationspeeches
"unga_migrationspeeches_fulltext"

#' @format The object `unga_migrationspeeches_anntationstable` is a
#'   `anntationstable`, see the documentation of the function `anntationstable`
#'   for an explanation of the data structure of the class `anntationstable`.
#' @rdname unga_migrationspeeches
"unga_migrationspeeches_anntationstable"