R/misc.R

#' Misc functions
#'
#' @name misc-functions
NULL
#' NULL

#' Convert corpus frequency table to instances per million.
#'
#' Convenience function for converting frequency tables to instances per
#' million.
#'
#' Given a table with columns `f`, `conf.low`, and `conf.high`, `ipm` ads a `column ipm`
#' und multiplies conf.low and `conf.high` with 10^6.
#'
#' @param df table returned from [frequencyQuery()]
#'
#' @return original table with additional column `ipm` and converted columns `conf.low` and `conf.high`
#' @export
#'
#' @rdname misc-functions
#' @importFrom dplyr .data
#'
#' @examples
#' \dontrun{
#'
#' KorAPConnection() %>% frequencyQuery("Test", paste0("pubDate in ", 2000:2002)) %>% ipm()
#' }
ipm <- function(df) {
  df %>%
    mutate(ipm = .data$f * 10^6, conf.low = .data$conf.low * 10^6, conf.high = .data$conf.high * 10^6)
}

#' Convert corpus frequency table of alternatives to percent
#'
#' Convenience function for converting frequency tables of alternative variants
#' (generated with `as.alternatives=TRUE`) to percent.
#'
#' @param df table returned from [frequencyQuery()]
#'
#' @return original table with converted columns `f`, `conf.low` and `conf.high`
#' @export
#'
#' @importFrom dplyr .data
#'
#' @rdname misc-functions
#' @examples
#' \dontrun{
#'
#' KorAPConnection() %>%
#'     frequencyQuery(c("Tollpatsch", "Tolpatsch"),
#'     vc=paste0("pubDate in ", 2000:2002),
#'     as.alternatives = TRUE) %>%
#'   percent()
#' }
percent <- function(df) {
  df %>%
    mutate(f = .data$f * 10^2, conf.low = .data$conf.low * 10^2, conf.high = .data$conf.high * 10^2)
}

#' Number of characters that all given strings share as a prefix
#'
#' Replaces `PTXQC::lcpCount()`, to avoid depending on PTXQC for two small
#' string functions. The length is determined by binary search over vectorized
#' [startsWith()] calls, which needs `log2(n)` instead of `n` comparisons for a
#' common prefix of `n` characters.
#'
#' As in `PTXQC::lcpCount()`, a single string is its own prefix, and an empty
#' vector has a common prefix of length 0.
#'
#' @param strings vector of strings
#' @return number of characters common to the beginning of all `strings`
#' @noRd
longestCommonPrefixLength <- function(strings) {
  strings <- as.character(strings)
  if (length(strings) == 0) {
    return(0L)
  }
  if (length(strings) == 1) {
    return(nchar(strings[1]))
  }

  low <- 0L
  high <- min(nchar(strings))
  while (low < high) {
    middle <- (low + high + 1L) %/% 2L
    # isTRUE keeps NAs from breaking the condition, as in PTXQC, where they
    # make the character comparison fail and thus end the common prefix
    if (isTRUE(all(startsWith(strings, substr(strings[1], 1L, middle))))) {
      low <- middle
    } else {
      high <- middle - 1L
    }
  }
  low
}

#' Number of characters that all given strings share as a suffix
#'
#' Replaces `PTXQC::lcsCount()`, which reverses every string character by
#' character before looking for the common prefix. Works like
#' `longestCommonPrefixLength()`, but anchored at the end of the strings.
#'
#' @param strings vector of strings
#' @return number of characters common to the end of all `strings`
#' @noRd
longestCommonSuffixLength <- function(strings) {
  strings <- as.character(strings)
  if (length(strings) == 0) {
    return(0L)
  }
  if (length(strings) == 1) {
    return(nchar(strings[1]))
  }

  first <- strings[1]
  firstLength <- nchar(first)
  low <- 0L
  high <- min(nchar(strings))
  while (low < high) {
    middle <- (low + high + 1L) %/% 2L
    if (isTRUE(all(endsWith(strings, substr(first, firstLength - middle + 1L, firstLength))))) {
      low <- middle
    } else {
      high <- middle - 1L
    }
  }
  low
}

#' Convert query or vc strings to plot labels
#'
#' Converts a vector of query or vc strings to typically appropriate legend labels
#' by clipping off prefixes and suffixes that are common to all query strings.
#'
#' @param data string or vector of query or vc definition strings
#' @param pubDateOnly discard all but the publication date
#' @param excludePubDate discard publication date constraints
#' @return string or vector of strings with clipped off common prefixes and suffixes
#'
#' @rdname misc-functions
#'
#' @examples
#' queryStringToLabel(paste("textType = /Zeit.*/ & pubDate in", c(2010:2019)))
#' queryStringToLabel(c("[marmot/m=mood:subj]", "[marmot/m=mood:ind]"))
#' queryStringToLabel(c("wegen dem [tt/p=NN]", "wegen des [tt/p=NN]"))
#'
#' @export
queryStringToLabel <- function(data, pubDateOnly = FALSE, excludePubDate = FALSE) {
  if (pubDateOnly) {
    data <-substring(data, regexpr("(pub|creation)Date", data)+7)
  } else if(excludePubDate) {
    data <-substring(data, 1, regexpr("(pub|creation)Date", data))
  }
  leftCommon = longestCommonPrefixLength(data)
  while (leftCommon > 0 && grepl("[[:alnum:]/=.*!]", substring(data[1], leftCommon, leftCommon))) {
    leftCommon <- leftCommon - 1
  }
  rightCommon = longestCommonSuffixLength(data)
  while (rightCommon > 0 && grepl("[[:alnum:]/=.*!]", substring(data[1], 1+nchar(data[1]) - rightCommon, 1+nchar(data[1]) - rightCommon))) {
    rightCommon <- rightCommon - 1
  }
  substring(data, leftCommon + 1, nchar(data) - rightCommon)
}

#' Labels for a vector of virtual corpora
#'
#' The names of a named vector are what the caller chose to call their virtual
#' corpora, so they are what a label should say. Where a vector is named only in
#' part, [queryStringToLabel()] derives the rest from the definitions.
#'
#' @param vc character vector of virtual corpus definitions
#' @return character vector of labels, or `NULL` if `vc` carries no names at all
#' @noRd
vcLabels <- function(vc) {
  labels <- names(vc)
  if (is.null(labels)) {
    return(NULL)
  }
  unnamed <- is.na(labels) | !nzchar(labels)
  if (any(unnamed)) {
    labels[unnamed] <- queryStringToLabel(vc)[unnamed]
  }
  unname(labels)
}

#' Labels for a vector of virtual corpora, always giving one
#'
#' Like [vcLabels()], but falling back to [queryStringToLabel()] where the
#' vector carries no names, for callers that label unconditionally.
#'
#' @param vc character vector of virtual corpus definitions
#' @return character vector of labels, one per element of `vc`
#' @noRd
vcLabelsOrGuess <- function(vc) {
  labels <- vcLabels(vc)
  if (is.null(labels)) queryStringToLabel(vc) else labels
}


## Mute notes: "Undefined global functions or variables:"
globalVariables(c("conf.high", "conf.low", "onRender", "webUIRequestUrl"))


#' Experimental: Plot frequency by year graphs with confidence intervals
#'
#' Experimental convenience function for plotting typical frequency by year graphs with confidence intervals using ggplot2.
#' **Warning:** This function may be moved to a new package.
#'
#' @param mapping	Set of aesthetic mappings created by aes() or aes_(). If specified and inherit.aes = TRUE (the default), it is combined with the default mapping at the top level of the plot. You must supply mapping if there is no plot mapping.
#' @param ...	 Other arguments passed to geom_ribbon, geom_line, and geom_click_point.
#'
#' @rdname misc-functions
#'
#' @examples
#' \dontrun{
#' library(ggplot2)
#' kco <- KorAPConnection(verbose=TRUE)
#'
#' expand_grid(condition = c("textDomain = /Wirtschaft.*/", "textDomain != /Wirtschaft.*/"),
#'             year = (2005:2011)) %>%
#'   cbind(frequencyQuery(kco, "[tt/l=Heuschrecke]",
#'                             paste0(.$condition," & pubDate in ", .$year)))  %>%
#'   ipm() %>%
#'   ggplot(aes(year, ipm, fill = condition, color = condition)) +
#'   geom_freq_by_year_ci()
#' }
#' @importFrom ggplot2 ggplot aes geom_ribbon geom_line geom_point theme element_text scale_x_continuous
#'
#' @export
geom_freq_by_year_ci <- function(mapping = aes(ymin=conf.low, ymax=conf.high), ...) {
  list(
    geom_ribbon(mapping,
                alpha = .3, linetype = 0, show.legend = FALSE, ...),
    geom_line(...),
    geom_click_point(aes(url=webUIRequestUrl), ...),
    theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position.inside = c(0.8, 0.2)),
    scale_x_continuous(breaks = function(x) seq(ceiling(x[1]), floor(x[2]), by = 1 + floor(((x[2]-x[1])/30)))))
}

#'
#' @importFrom ggplot2 ggproto aes GeomPoint
#'
GeomClickPoint <- ggplot2::ggproto(
  "GeomPoint",
  ggplot2::GeomPoint,
  required_aes = c("x", "y"),
  default_aes = aes(
    shape = 19, colour = "black", size = 1.5, fill = NA,
    alpha = NA, stroke = 0.5, url = NA
  ),
  extra_params = c("na.rm", "url"),
  draw_panel = function(data, panel_params,
                        coord, na.rm = FALSE, showpoints = TRUE, url = NULL) {
    GeomPoint$draw_panel(data, panel_params, coord, na.rm = na.rm)
  }
)

#' @importFrom ggplot2 layer
geom_click_point <- function(mapping = NULL, data = NULL, stat = "identity",
                             position = "identity", na.rm = FALSE, show.legend = NA,
                             inherit.aes = TRUE, url = NA, ...) {
  layer(
    geom = GeomClickPoint, mapping = mapping,  data = data, stat = stat,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}