regexplain/R/regex_gadget.R

#' regexplain_addin
#'
#' @keywords internal
regexplain_addin <- function() {
  # Get the document context.
  context <- rstudioapi::getActiveDocumentContext()

  # Get context text
  ctx_text <- context$selection[[1]]$text

  # If it is one line and evaluates to something, use that
  # Otherwise treat as text
  obj <- tryCatch({
    if (grepl("\n", ctx_text)) {
      ctx_text[1:min(length(ctx_text), 100)]
    } else {
      x <- eval(parse(text = ctx_text))
      x <- as.character(x)
      if (length(x) == 1 && grepl("\n", x))
        x <- strsplit(x, "\n")[[1]]
      if (length(x) > 10) {
        message(ctx_text, " gave ", length(x), " lines, limiting to first 10 unique lines.")
        x <- unique(x)
        x[1:min(length(x), 10)]
      } else x
    }
  },
  error = function(e) {as.character(ctx_text[1:min(length(ctx_text), 100)])})

  regex_gadget(if (length(obj) && obj != "") obj)

}

#' regexplain gadget
#'
#' @import miniUI
#' @import shiny
#' @param text Text to explore in gadget (editable using interface)
#' @param start_page Open gadget to this tab, one of `"Text"`, `"Regex"`,
#'   `"Output"`, or `"Help"`
#' @export
regex_gadget <- function(text = NULL,
                         start_page = if (is.null(text)) "Text" else "Regex") {
  stopifnot(requireNamespace("miniUI"), requireNamespace("shiny"))

  ui <- miniPage(
    shiny::includeCSS(system.file("style.css", package = "regexplain")),
    shiny::includeCSS(system.file("gadget.css", package = "regexplain")),
    gadgetTitleBar(
      "regexplain",
      right = miniTitleBarButton("done", "Send Regex To Console", TRUE)
    ),
    miniTabstripPanel(
      selected = match.arg(start_page, c("Text", "Regex", "Output", "Help")),
      miniTabPanel(
        "Text", icon = icon('file-text-o'),
        miniContentPanel(
          fillCol(
            textAreaInputAlt('text',
                             label = "Text to search or parse",
                             value = paste(text, collapse = "\n"),
                             resize = "both",
                             width = "100%",
                             height="90%",
                             placeholder = "Paste, enter, or edit your sample text here.")
          )
        )
      ),
      miniTabPanel(
        "Regex", icon = icon('terminal'),
        miniContentPanel(
          fillCol(
            flex = c(1, 3),
            fillCol(
              flex = c(1, 1),
              textInputCode('pattern', 'Regex', width = "100%",
                            placeholder = "Enter regex, single \\ okay"),
              checkboxGroupInput(
                'regex_options',
                label = "",
                inline = TRUE,
                width = "90%",
                choices = c("Break Lines" = "text_break_lines",
                            "Ignore Case" = "ignore.case",
                            "Perl Style" = "perl",
                            "Fixed" = "fixed",
                            "Use Bytes" = "useBytes"
                            # , "Invert" = "invert"
                ),
                selected = c('text_break_lines')
              )
            ),
            tags$div(
              class = "gadget-result",
              style = "overflow-y: scroll; height: 100%;",
              htmlOutput('result')
            )
          )
        )
      ),
      miniTabPanel(
        "Output", icon = icon("table"),
        miniContentPanel(
          fillCol(
            flex = c(1, 3),
            inputPanel(
              width = "100%;",
              selectInput('regexFn', label = 'Apply Function',
                          choices = regexFn_choices)
            ),
            # verbatimTextOutput('output_result', placeholder = TRUE)
            tags$pre(
              id = "output_result",
              class = "shiny-text-output",
              style = "overflow-y: scroll; height: 100%;"
            )
          )
        )
      ),
      miniTabPanel(
        "Help", icon = icon("support"),
        miniContentPanel(
          fillRow(
            flex = c(1, 4),
            tagList(
              # selectInput("help_category", "Category", c("", unique(cheatsheet$category))),
              # uiOutput("help_group"),
              tags$ul(
                id = "help-sidebar",
                tags$li("Character Classes", class = "header"),
                tags$ul(
                  class = "subgroup",
                  tags$li(actionLink("help_cat_character_classes_regular", "Regular")),
                  tags$li(actionLink("help_cat_character_classes_prebuilt", "Pre-Built"))
                ),
                tags$li(actionLink("help_cat_anchors", "Anchors")),
                tags$li("Escaped Characters", class = "header"),
                tags$ul(
                  class = "subgroup",
                  tags$li(actionLink("help_cat_escaped_general", "General")),
                  tags$li(actionLink("help_cat_escaped_hex", "Hex")),
                  tags$li(actionLink("help_cat_escaped_control", "Control Characters"))
                ),
                tags$li(actionLink("help_cat_groups", "Groups")),
                tags$li(actionLink("help_cat_quantifiers", "Quantifiers"))
              )
            ),
            tags$div(
              style = "width: 100%; padding-left: 10px;",
              uiOutput('help_text_selected')
            )
          )
        )
      )
    )
  )

  server <- function(input, output, session) {
    rtext <- reactive({
      x <- if ('text_break_lines' %in% input$regex_options) {
        strsplit(input$text, "\n")[[1]]
      } else input$text
      x
    })

    pattern <- reactive({
      sanitize_text_input(input$pattern)
    })

    alert_result <- function(msg, type = "danger") {
      msg <- gsub("\n", "<br>", msg)
      msg <- gsub("\t", "&nbsp;&nbsp;", msg)
      paste0("<pre class='alert alert-", type, "' ",
             "style='padding: 4px; margin-top: 1px; margin-bottom: 4px;'>",
             paste(msg, collapse = "<br>"),
             "</pre>")
    }

    output$result <- renderUI({
      if (is.null(rtext())) return(NULL)
      if (pattern() == "") {
        return(toHTML(paste('<p class="results">', escape_html(rtext()), "</p>", collapse = "")))
      }
      res <- NULL
      error_message <- NULL
      warning_message <- NULL
      tryCatch({
        res <- paste(
          view_regex(
            rtext(),
            pattern(),
            ignore.case = 'ignore.case' %in% input$regex_options,
            perl = 'perl' %in% input$regex_options,
            fixed = 'fixed' %in% input$regex_options,
            useBytes = 'useBytes' %in% input$regex_options,
            # invert = 'invert' %in% input$regex_options,
            render = FALSE,
            escape = TRUE),
          collapse = ""
        )
      },
      error = function(e) {
        error_message <<- alert_result(e$message, "danger")
      },
      warning = function(w) {
        warning_message <<- alert_result(w$message, "warning")
      })

      if (is.null(res)) res <- toHTML(
        paste('<p class="results">', escape_html(rtext()), "</p>", collapse = "")
      )

      toHTML(paste(error_message, warning_message, res))
    })

    output$output_result <- renderPrint({
      req(input$regexFn)
      regexPkg <- get_pkg_namespace(input$regexFn)
      regexFn <- getFromNamespace(input$regexFn, regexPkg)
      x <- if (regexPkg == "base") {
        regexFn(pattern(), rtext())
      } else if (regexPkg == "stringr") {
        regexFn(rtext(), pattern())
      } else {
        "Um. Not sure how I got here."
      }

      # if (inherits(x, 'logical') || inherits(x, 'character')) {
      #   if (length(x) < 25) print(x) else print(head(x, 25))
      # } else if (inherits(x, 'matrix') | inherits(x, "data.frame")) {
      #   if (nrow(x) < 15) { print(x)
      #   } else glimpse(x)
      # } else {
      #   str(x, max.level = 3)
      # }
      print(x)
    })

    # output$help_group <- renderUI({
    #   req(input$help_category)
    #   groups <- unique(cheatsheet[cheatsheet$category == input$help_category, ]$group)
    #   if (is.na(groups[1])) {
    #     NULL
    #   } else {
    #     selectInput("help_group", "Group", groups)
    #   }
    # })

    # ---- Help Section ---- #
    help_text <- reactiveVal("<p>Select a category from the left sidebar.</p>")

    output$help_text_selected <- renderUI({
      HTML(help_text())
    })

    make_html_table <- function(x) {
      select(x, .data$regexp, .data$text) %>%
        knitr::kable(
          col.names = c("Regexp", "Text"),
          escape = FALSE,
          format = "html")
    }

    observeEvent(input$help_cat_character_classes_regular, {
      cheatsheet %>%
        filter(category == "character classes", group == "regular") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_character_classes_prebuilt, {
      cheatsheet %>%
        filter(category == "character classes", group == "pre-built") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_anchors, {
      cheatsheet %>%
        filter(category == "anchors") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_escaped_general, {
      cheatsheet %>%
        filter(category == "escaped characters", group == "general") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_escaped_hex, {
      cheatsheet %>%
        filter(category == "escaped characters", group == "hex") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_escaped_control, {
      cheatsheet %>%
        filter(category == "escaped characters", group == "control characters") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_groups, {
      cheatsheet %>%
        filter(category == "groups") %>%
        make_html_table %>%
        help_text
    })

    observeEvent(input$help_cat_quantifiers, {
      cheatsheet %>%
        filter(category == "quantifiers") %>%
        make_html_table %>%
        help_text
    })


    observeEvent(input$done, {
      # browser()
      if (pattern() != "") {
        pattern <- paste0('regex <- "', escape_backslash(pattern()), '"')
        rstudioapi::sendToConsole(pattern, FALSE)
      }
      stopApp()
    })

    observeEvent(input$cancel, {
      stopApp()
    })
  }

  viewer <- shiny::paneViewer(700)
  runGadget(ui, server, viewer = viewer)
}

sanitize_text_input <- function(x) {
  if (grepl("\\u|\\x|\\N|\\a|\\o", x)) {
    try({
      y <- stringi::stri_unescape_unicode(x)
    }, silent = TRUE)
    if (!is.na(y)) x <- y
  }
  # x <- gsub("\u201C|\u201D", '"', x)
  # x <- gsub("\u2018|\u2019", "'", x)
  x
}

toHTML <- function(...) {
  x <- paste(..., collapse = "")
  x <- gsub("\n", "\\\\n", x)
  x <- gsub("\t", "\\\\t", x)
  x <- gsub("\r", "\\\\r", x)
  HTML(x)
}

regexFn_choices <- list(
  "Choose a function" = "",
  base = c(
    "grep",
    "grepl",
    "regexpr",
    "gregexpr",
    "regexec"
  ),
  stringr = c(
    "str_detect",
    "str_locate",
    "str_locate_all",
    "str_extract",
    "str_extract_all",
    "str_match",
    "str_match_all",
    "str_split"
  )
)

get_pkg_namespace <- function(fn) {
  x <- names(purrr::keep(regexFn_choices, ~ (fn %in% .)))
  if (length(x) > 1) warning(fn, " matches multiple functions in regexFn_choices, please review.")
  x
}