inst/shiny/modules/dispersion.R

In PolMine/polmineR: Verbs and Nouns for Corpus Analysis

######################
##                  ##
##    dispersion    ##
##                  ##
######################


#' @rdname shiny_helper_functions
#' @importFrom zoo zoo
#' @export dispersionUiInput
dispersionUiInput <- function(){
  list(
    actionButton("dispersion_go", "", icon = icon("play", lib = "glyphicon")),
    code = actionButton("dispersion_code", label = "", icon = icon("code", lib = "font-awesome")),
    br(), br(),
    radioButtons("dispersion_object", "class", choices = list("corpus", "partition"), selected = "corpus", inline = TRUE),
    conditionalPanel(
      condition = "input.dispersion_object == 'corpus'",
      selectInput("dispersion_corpus", "corpus", corpus()[["corpus"]])
    ),
    radioButtons("dispersion_freq", "frequencies", choices = list("yes", "no"), selected = "no", inline = TRUE),
    radioButtons("dispersion_cqp", "CQP", choices = list("yes", "no"), selected = "no", inline = TRUE),
    conditionalPanel(
      condition = "input.dispersion_object == 'partition'",
      selectInput("dispersion_partition", "partition", choices = character())
    ),
    textInput("dispersion_query", "query", value = "Suche"),
    selectInput(
      "dispersion_p_attribute", "p_attribute",
      choices = p_attributes(corpus()[1, "corpus"])
    ),
    # radioButtons("dispersion_dims", "number of s_attributes", choices=c("1", "2"), selected="1", inline=TRUE),
    selectInput(
      "dispersion_s_attribute_1", "s_attribute",
      choices = s_attributes(corpus()[1, "corpus"]), multiple = FALSE
    ),
    radioButtons("dispersion_ts", "time series", choices = c("yes", "no"), selected = "no", inline = TRUE),
    conditionalPanel(
      condition = "input.dispersion_ts == 'yes'",
      selectInput("dispersion_ts_aggregation", "aggregation", choices=c("none", "month", "quarter", "year"), multiple = FALSE
      )
    )
  )
}


#' @rdname shiny_helper_functions
#' @export dispersionUiOutput
dispersionUiOutput <- function(){
}


#' @rdname shiny_helper_functions
#' @export dispersionServer
#' @importFrom zoo zoo
#' @importFrom data.table copy
dispersionServer <- function(input, output, session){
  
  observe({
    x <- input$dispersion_partition
    if (x != "" && length(values$partitions) > 0 && x %in% names(values$partitions)){
      new_sAttr <- s_attributes(values$partitions[[x]]@corpus)
      new_pAttr <- p_attributes(values$partitions[[x]]@corpus)
      updateSelectInput(session, "dispersion_p_attribute", choices = new_pAttr, selected = NULL)
      updateSelectInput(session, "dispersion_s_attribute_1", choices = new_sAttr, selected = NULL)
    }
  })
  
  observe({
    new_sAttr <- s_attributes(input$dispersion_corpus)
    new_pAttr <- p_attributes(input$dispersion_corpus)
    updateSelectInput(session, "dispersion_p_attribute", choices = new_pAttr, selected = NULL)
    updateSelectInput(session, "dispersion_s_attribute_1", choices = new_sAttr, selected = NULL)
  })
  
  observeEvent(input$dispersion_code, {
    snippet <- sprintf(
      'dispersion(\n  %s,\n  query = "%s",\n  freq = %s,\n  cqp = %s,\n  p_attribute = "%s",\n  s_attribute = "%s"\n)',
      if (input$dispersion_object == "corpus") sprintf('"%s"', input$dispersion_corpus)  else input$dispersion_partition,
      input$dispersion_query,
      if (input$dispersion_freq == "yes") "TRUE" else "FALSE", 
      if (input$dispersion_cqp == "yes") "TRUE" else "FALSE", 
      input$dispersion_p_attribute,
      input$dispersion_s_attribute_1
    )
    snippet_html <- highlight::highlight(
      parse.output = parse(text = snippet),
      renderer = highlight::renderer_html(document = TRUE),
      output = NULL
    )
    showModal(modalDialog(title = "Code", HTML(paste(snippet_html, collapse = ""))))
  })

  observeEvent(
    input$dispersion_go,
    isolate({
      
      obj <- if (input$dispersion_object == "partition")
        values$partitions[[input$dispersion_partition]]
      else 
        input$dispersion_corpus

      tab <- dispersion(
        obj,
        query = rectifySpecialChars(input$dispersion_query),
        s_attribute = input$dispersion_s_attribute_1,
        p_attribute = input$dispersion_p_attribute,
        cqp = if (input$dispersion_cqp == "yes") TRUE else FALSE,
        freq = if (input$dispersion_freq == "yes") TRUE else FALSE
      )
      
      if ("freq" %in% colnames(tab)) tab[, "freq" := round(tab[["freq"]] * 100000, 7)]

      if (input$dispersion_ts == "yes"){
        dates <- tab[[input$dispersion_s_attribute_1]]
        dt <- data.table::copy(tab)
        dt[, eval(input$dispersion_s_attribute_1) := NULL]
        if ("query" %in% colnames(dt)) dt[, "query" := NULL]
        print(head(dt))
        zoo_obj <- zoo::zoo(as.matrix(dt), order.by = as.Date(dates))

        if (input$dispersion_ts_aggregation != "none"){
          zoo_obj <- switch(
            input$dispersion_ts_aggregation,
            month = aggregate(zoo_obj, zoo::as.Date(zoo::as.yearmon(zoo::index(zoo_obj)))),
            quarter = aggregate(zoo_obj, zoo::as.Date(zoo::as.yearqtr(zoo::index(zoo_obj)))),
            year = aggregate(zoo_obj, as.Date(paste(gsub("^(\\d{4}).*?$", "\\1", zoo::index(zoo_obj)), "-01-01", sep="")))
          )
          # rework data.frame
          tab <- data.frame(date = zoo::index(zoo_obj), zoo_obj)
          colnames(tab)[1] <- input$dispersion_s_attribute_1
          rownames(tab) <- NULL
          output$dispersion_plot <- renderPlot(zoo::plot.zoo(zoo_obj, main = ""))
        }
      } else {
        output$dispersion_plot <- renderPlot(
          barplot(
            height = if (input$dispersion_freq == "yes") tab[["freq"]] else tab[["count"]],
            names.arg = tab[[input$dispersion_s_attribute_1]]
          )
        )
      }
      
      output$dispersion_table <- DT::renderDataTable(as(as.data.table(tab), "htmlwidget"))
      
    })
  )
  
}