R/shiny.R

In rainette: The Reinert Method for Textual Data Clustering

## CSS and modules for Shiny gadgets

## CSS for shiny gadgets

rainette_explor_css <- function() {
  "
#main {
  padding: 0 1em;
}
#docs {
  height: 100%;
  max-height: 100%;
  overflow-y: hidden;
  padding-left: 2em;
}
#docs_sample {
  height: 100%;
  max-height: 100%;
  overflow-y: scroll;
  padding-right: 2em;
}
#docs_sample_intro {
  color: #369;
  background-color: #F0F0F0;
  border-radius: 5px;
  padding: .6em 1em;
  margin-bottom: 20px;
}
#docs_sample hr {
  margin-top: 12px;
  margin-bottom: 12px;
}
#side {
  background-color: #EEEEEE;
  padding: 2em 3em;
  font-size: 12px;
}
.docname {
  font-size: 80%;
  color: #69B;
  margin: 0 0 .3em 0;
}
.doc {
  font-size: 100%;
  max-width: 50em;
  border-left: 3px solid #9BE;
  margin: 0;
  padding: .3em 1em .2em 1em;
}
.doc .highlight {
  background-color: #FF0;
}

/* Syntax highlighting */
span.hl.str { color: #d14;}
span.hl.kwa { color: #099;}
span.hl.num { color: #099;}
span.hl.kwd { color: #333; font-weight: bold;}
span.hl.com { color: #888; font-style: italic;}
"
}



## Cluster documents sample UI

docs_sample_ui <- function(id, res) {

    show_merged_segments <- !inherits(res, "rainette2") &&
        !is.null(res$call$min_segment_size) && res$call$min_segment_size > 1

    ns <- shiny::NS(id)
    fillRow(
        flex = c(1, 3),
        fillCol(
            flex = c(10, 1),
            id = "side",
            div(
                uiOutput(ns("group_ui")),
                numericInput(
                    ns("ndoc"), "Documents displayed",
                    value = 100, min = 1
                ),
                checkboxInput(ns("random_sample"), "Random sample", value = FALSE),
                numericInput(
                    ns("nchar"), "Maximum text length",
                    value = 1000, min = 10
                ),
                textInput(
                    ns("filter_term"), "Filter by term",
                    value = ""
                ),
                if (show_merged_segments) {
                    shiny::checkboxInput(ns("show_merged"), "Show merged segments", value = FALSE)
                }
            )
        ),
        fillCol(
            flex = c(10, 1),
            id = "docs",
            fillCol(
                flex = c(NA, 1),
                div(id = "docs_sample_intro",
                    htmlOutput(ns("docs_sample_intro"))
                ),
                div(id = "docs_sample",
                    htmlOutput(ns("docs_sample"))
                )
            )
        )
    )
}


## Cluster documents sample Server

docs_sample_server <- function(id, res, corpus_src, current_k) {
    moduleServer(
        id,
        function(input, output, session) {

            ## Cluster selection slider
            output$group_ui <- renderUI({
                ns <- session$ns
                selectInput(ns("cluster"),
                    label = "Cluster",
                    selected = 1,
                    choices = seq_len(current_k())
                )
            })

            ## Current clusters
            groups <- reactive({
                rainette::cutree(res, k = current_k())
            })

            ## Corpus from wanted cluster
            corpus_cluster <- reactive({
                if (is.null(corpus_src)) {
                    return(NULL)
                }
                ## Select only from wanted cluster
                if (!is.null(input$show_merged) && input$show_merged) {
                    corpus_src$group <- groups()
                    corpus_src$doc_name <- quanteda::docnames(corpus_src)
                    corpus_src$uc_id <- res$corresp_uce_uc$uc
                    docvars(corpus_src) <- docvars(corpus_src) %>%
                        group_by(.data$uc_id) %>%
                        mutate(doc_name = paste(.data$doc_name, collapse = " | ")) %>%
                        ungroup()
                    result <- quanteda::corpus_group(corpus_src, groups = corpus_src$doc_name)
                    sel <- quanteda::docvars(result, "group") == input$cluster &
                        !is.na(quanteda::docvars(result, "group"))
                    result <- result[sel]
                } else {
                    sel <- groups() == input$cluster & !is.na(groups())
                    result <- corpus_src[sel]
                }
                result
            })

            ## Regex for filter term input
            filter_regex <- reactive({
                stringr::regex(
                    shiny::req(input$filter_term),
                    ignore_case = TRUE, multiline = TRUE
                )
            })

            ## Corpus from cluster filtered by term
            corpus_filtered <- reactive({
                if (is.null(corpus_src)) {
                    return(NULL)
                }
                result <- corpus_cluster()
                ## Filter by terms
                filter_term <- stringr::str_trim(input$filter_term)
                if (!is.null(filter_term) && filter_term != "") {
                    keep <- stringr::str_detect(
                        as.character(corpus_cluster()),
                        filter_regex()
                    )
                    result <- result[keep]
                }
                result
            })

            highlighter <- reactive({
                filter_term <- stringr::str_trim(input$filter_term)
                if (!is.null(filter_term) && filter_term != "") {
                    fun <- function(txt) {
                        stringr::str_replace_all(
                            txt,
                            filter_regex(),
                            "<span class='highlight'>\\0</span>"
                        )
                    }
                } else {
                    fun <- I
                }
                fun
            })

            ## Maximum number of documents to display
            n_doc <- reactive({
                n_doc <- input$ndoc
                if (is.null(n_doc) || is.na(n_doc) || n_doc < 1) {
                    n_doc <- 1
                }
                n_doc
            })

            ## Maximum number of characters per document
            n_char <- reactive({
                n_char <- input$nchar
                if (is.null(n_char) || is.na(n_char) || n_char < 1) {
                    n_char <- 1
                }
                n_char
            })

            ## Sample cluster documents introducation phrase
            output$docs_sample_intro <- renderUI({

                if (is.null(corpus_src)) {
                    return(
                        HTML("<p>Can't display documents : <tt>corpus_src</tt> is null.</p><p>Please rerun <tt>rainette_explor</tt> with your quanteda corpus object as third parameter : something like <tt>rainette_explor(res, dtm, corpus)</tt>.</p>")
                    )
                }

                nb_docs_cluster <- quanteda::ndoc(corpus_filtered())
                out <- paste0(
                    "Displayed : <strong>",
                    min(n_doc(), nb_docs_cluster),
                    "</strong>"
                )
                if (quanteda::ndoc(corpus_cluster()) != quanteda::ndoc(corpus_filtered())) {
                    out <- paste0(
                        out,
                        " - Filtered documents : <strong>",
                        quanteda::ndoc(corpus_filtered()),
                        "</strong>"
                    )
                }
                out <- paste0(
                    out,
                    " - Cluster size : <strong>",
                    quanteda::ndoc(corpus_cluster()),
                    "</strong>."
                )
                shiny::HTML(out)
            })

            ## Sample cluster documents
            output$docs_sample <- renderUI({
                if (is.null(corpus_src)) {
                    return(NULL)
                }

                ## Sample docs
                size <- min(quanteda::ndoc(corpus_filtered()), n_doc())
                if (input$random_sample) {
                    corp <- quanteda::corpus_sample(corpus_filtered(), size = size)
                } else {
                    corp <- corpus_filtered()[seq_len(size)]
                }

                ## Truncate texts
                txt <- as.character(corp)
                txt <- ifelse(
                    nchar(txt) <= n_char(),
                    txt,
                    paste(stringr::str_sub(txt, 1, n_char()), "(...)")
                )

                ## Highlight texts
                txt <- highlighter()(txt)

                ## Generate output
                out <- paste(
                    "<div class='doc'>",
                    "<div class='docname'>",
                    quanteda::docnames(corp),
                    "</div>",
                    stringr::str_replace_all(txt, "\n", "<br>"),
                    "</div>",
                    "<hr>",
                    collapse = "\n"
                )
                shiny::HTML(out)
            })
        }
    )
}