R/common.R

library(RKorAPClient)
library(httr)
library(httpuv)
library(tidyverse)
library(scales)
library(idsThemeR)
library(kableExtra)
library(DT)

icc_base_url = "https://korap.ids-mannheim.de/instance/icc";

connections = list()

icc <- tibble(
  lang = c("eng", "ger", "nor"),
  app_id = c(
    "mTTTnJ6f6hGrPh6dRhbJhJ",
    "TMLPTJfP7rHb93bpFp39mL",
    "TMFtPJnbb7f4MRmd76Rb34"
  )
)


icc_token <- function(lang,  app_id, url = paste0(icc_base_url, '/', lang)) {
  token_key =  paste0("KORAP_ICC_TOKEN_", lang)
  token = Sys.getenv(token_key)
  if (token != "")
    return(token)

  korap_app <- oauth_app("icc-iclc10-contribution", key = app_id, secret = NULL)

  korap_endpoint <- oauth_endpoint(NULL,
                                   "settings/oauth/authorize",
                                   "api/v1.0/oauth2/token",
                                   base_url = url)
  token_bundle = oauth2.0_token(korap_endpoint, korap_app, scope = "search match_info", cache = T)
  token = token_bundle[["credentials"]][["access_token"]]
  do.call(Sys.setenv, as.list(setNames(token, token_key)))
  return(token)
}

icc_con <- function(lang, token = Sys.getenv(paste0("KORAP_ICC_TOKEN_", lang))) {
  if ((! lang %in% names(connections)) || is_empty(connections[[lang]])) {
    url <- paste0(icc_base_url, '/', lang)
    connections[[lang]] <<- new("KorAPConnection", KorAPUrl = url, accessToken = token, cache = T)
  }
  return(connections[[lang]])
}

icc <- icc %>%
  rowwise() %>%
  mutate(token = icc_token(lang, app_id))

genre <- c("Blog",
             "Creative:Novels_ShortStories",
             "Informational:Learned:Humanities",
             "Informational:Learned:NaturalSciences",
             "Informational:Learned:SocialSciences",
             "Informational:Learned:Technology",
             "Informational:Popular:Humanities",
             "Informational:Popular:NaturalSciences",
             "Informational:Popular:SocialSciences",
             "Informational:Popular:Technology",
             "Informational:Reportage",
             "Instructional:AdministrativeRegulatoryProse",
             "Instructional:Skills_Hobbies",
             "Persuasive"
)

wordsFromQuery <- function (query) {
  v <- str_split(query, "([! )(\uc2\uab,.:?\u201e\u201c\'\"]+|&quot;)") %>% unlist() %>%  unique()
  v <- v[str_detect(v, '^[:alnum:]+-?[:alnum:]*$')]
  v[order(nchar(v), v, decreasing = T)]
}

highliteSubstrings <- function (string, substrings) {
  what = paste0('(', paste0(substrings, collapse="|"), ')')
  with = '<b>\\1</b>'
  str_replace_all(string, what, with)
}

deleteFillers <- function (string) {
  string %>%
    str_replace_all('</b> +<b>', ' ') %>%
    str_replace_all('</b>[^<]+<b>', ' ... ') %>%
    str_replace_all('^[^<]*<b>', '') %>%
    str_replace_all('</b>[^<]*$', '')

}

show_table <- function(df, max=50) {
  df %>%
    mutate(Collocate=sprintf('<a href="%s">%s</a>', webUIRequestUrl, collocate)) %>%
    mutate(example=str_replace(example, ".*(\\W+\\w+\\W+\\w+\\W+<mark.*/mark>.*)", "\\1")) %>%
    mutate(example=str_replace(example, "(.*<mark.*/mark>\\W+\\w+\\W+\\w+).*", "\\1")) %>%
    rowwise() %>%
    mutate(Example=highliteSubstrings(example, wordsFromQuery(query))) %>%
    select(Collocate, Example, logDice, pmi, ll) %>%
    head(max) %>%
    datatable(escape = F) %>%
    formatRound(columns=~logDice + pmi + ll, digits=2)
}

show__full_table <- function(df, max=5000) {
  df %>%
    mutate(Collocate=sprintf('<a href="%s">%s</a>', webUIRequestUrl, collocate)) %>%
    mutate(example=str_replace(example, ".*(\\W+\\w+\\W+\\w+\\W+<mark.*/mark>.*)", "\\1")) %>%
    mutate(example=str_replace(example, "(.*<mark.*/mark>\\W+\\w+\\W+\\w+).*", "\\1")) %>%
    rowwise() %>%
    mutate(Example=highliteSubstrings(example, wordsFromQuery(query))) %>%
    mutate(url=paste0("=HYPERLINK('", webUIRequestUrl,"')")) %>%
    select(Collocate, Example, url, logDice, pmi, ll) %>%
    head(max) %>%
    datatable(escape = F, extensions = 'Buttons', options = list(
      paging = TRUE,
      searching = TRUE,
      fixedColumns = TRUE,
      autoWidth = TRUE,
      ordering = TRUE,
      dom = 'tB',
      buttons = c('copy', 'csv', 'excel')
    )) %>%
    formatRound(columns=~logDice + pmi + ll, digits=2)
}