Garrick Aden-Buie 6 лет назад
Родитель
Сommit
ecb9a4a338
11 измененных файлов: 485 добавлений и 289 удалений
  1. +32
    -20
      R/addins.R
  2. +28
    -12
      R/gadget.R
  3. +307
    -181
      R/gadget_server.R
  4. +10
    -7
      R/help_ui.R
  5. +34
    -23
      R/regex.R
  6. +55
    -31
      R/shiny_modified_inputs.R
  7. +5
    -5
      R/utils.R
  8. +3
    -3
      tests/testthat/test-regex.R
  9. +1
    -1
      tests/testthat/test-sanitize_text_input.R
  10. +8
    -4
      tests/testthat/test-wrap_regex.R
  11. +2
    -2
      tests/testthat/test-wrap_result.R

+ 32
- 20
R/addins.R Просмотреть файл



# If it is one line and evaluates to something, use that # If it is one line and evaluates to something, use that
# Otherwise treat as text # Otherwise treat as text
obj <- tryCatch({
if (grepl("\n", ctx_text)) {
ctx_text[1:min(length(ctx_text), max_lines)]
} else {
x <- eval(parse(text = ctx_text))
if (inherits(x, "list")) x <- unlist(x)
x <- as.character(x)
if (length(x) == 1 && grepl("\n", x))
x <- strsplit(x, "\n")[[1]]
x <- unique(x)
if (length(x) > max_lines) {
message(ctx_text, " gave ", length(x), " lines, limiting to first ",
max_lines, " unique lines. Set ",
"options('regexplain.addin.max_lines') to a higher value to ",
"increase the number of lines.")
obj <- tryCatch(
{
if (grepl("\n", ctx_text)) {
ctx_text[1:min(length(ctx_text), max_lines)]
} else {
x <- eval(parse(text = ctx_text))
if (inherits(x, "list")) x <- unlist(x)
x <- as.character(x)
if (length(x) == 1 && grepl("\n", x)) {
x <- strsplit(x, "\n")[[1]]
}
x <- unique(x) x <- unique(x)
x[1:min(length(x), max_lines)]
} else x
if (length(x) > max_lines) {
message(
ctx_text,
" gave ",
length(x),
" lines, limiting to first ",
max_lines,
" unique lines. Set ",
"options('regexplain.addin.max_lines') to a higher value to ",
"increase the number of lines."
)
x <- unique(x)
x[1:min(length(x), max_lines)]
} else {
x
}
}
},
error = function(e) {
as.character(ctx_text[1:min(length(ctx_text), max_lines)])
} }
},
error = function(e) {as.character(ctx_text[1:min(length(ctx_text), max_lines)])})
)


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

} }


#' @describeIn regexplain_gadget Opens file chooser to pick file, reads lines, #' @describeIn regexplain_gadget Opens file chooser to pick file, reads lines,

+ 28
- 12
R/gadget.R Просмотреть файл

runGadget( runGadget(
regexplain_gadget_ui(text, pattern, start_page), regexplain_gadget_ui(text, pattern, start_page),
regexplain_gadget_server(check_version()), regexplain_gadget_server(check_version()),
viewer = viewer)
viewer = viewer
)
} }


#' @describeIn regexplain_gadget Launches the RegExplain gadget in a browser or an #' @describeIn regexplain_gadget Launches the RegExplain gadget in a browser or an


shinyApp( shinyApp(
regexplain_gadget_ui(text, pattern, start_page), regexplain_gadget_ui(text, pattern, start_page),
regexplain_gadget_server(check_version()), ...)
regexplain_gadget_server(check_version()),
...
)
} }


# ---- Gadget Helper Functions and Variables ---- # ---- Gadget Helper Functions and Variables ----


sanitize_text_input <- function(x) { sanitize_text_input <- function(x) {
if (is.null(x) || !nchar(x)) return(x)
if (is.null(x) || !nchar(x)) {
return(x)
}
rx_unicode <- "\\\\u[0-9a-f]{4,8}" rx_unicode <- "\\\\u[0-9a-f]{4,8}"
rx_hex <- "\\\\x[0-9a-f]{2}|\\\\x\\{[0-9a-f]{1,6}\\}" rx_hex <- "\\\\x[0-9a-f]{2}|\\\\x\\{[0-9a-f]{1,6}\\}"
rx_octal <- "\\\\[0][0-7]{1,3}" rx_octal <- "\\\\[0][0-7]{1,3}"
rx_escape <- paste(rx_unicode, rx_hex, rx_octal, sep = "|") rx_escape <- paste(rx_unicode, rx_hex, rx_octal, sep = "|")
if (grepl(rx_escape, x, ignore.case = TRUE)) { if (grepl(rx_escape, x, ignore.case = TRUE)) {
try({
y <- stringi::stri_unescape_unicode(x)
}, silent = TRUE)
try(
{
y <- stringi::stri_unescape_unicode(x)
},
silent = TRUE
)
if (!is.na(y)) x <- y if (!is.na(y)) x <- y
} }
# x <- gsub("\u201C|\u201D", '"', x) # x <- gsub("\u201C|\u201D", '"', x)
check_version <- function( check_version <- function(
gh_user = "gadenbuie", gh_user = "gadenbuie",
gh_repo = "regexplain", gh_repo = "regexplain",
this_version = packageVersion('regexplain')
this_version = packageVersion("regexplain")
) { ) {
ok_to_check <- getOption("regexplain.no.check.version", TRUE) ok_to_check <- getOption("regexplain.no.check.version", TRUE)
if (!isTRUE(ok_to_check)) return(NULL)
if (!requireNamespace('jsonlite', quietly = TRUE)) return(NULL)
if (!isTRUE(ok_to_check)) {
return(NULL)
}
if (!requireNamespace("jsonlite", quietly = TRUE)) {
return(NULL)
}
get_json <- purrr::possibly(jsonlite::fromJSON, NULL) get_json <- purrr::possibly(jsonlite::fromJSON, NULL)
gh_tags <- get_json( gh_tags <- get_json(
paste0("https://api.github.com/repos/", gh_user, "/", gh_repo, "/git/refs/tags"), paste0("https://api.github.com/repos/", gh_user, "/", gh_repo, "/git/refs/tags"),
link = paste("https://github.com", gh_user, gh_repo, "releases/tag", max_tag, sep = "/") link = paste("https://github.com", gh_user, gh_repo, "releases/tag", max_tag, sep = "/")
) )
) )
} else return(NULL)
} else {
return(NULL)
}
} }


#' Loads Regex Pattern Library #' Loads Regex Pattern Library
return(NULL) return(NULL)
} }
f_patterns <- system.file("extdata", "patterns.json", package = "regexplain") f_patterns <- system.file("extdata", "patterns.json", package = "regexplain")
if (!file.exists(f_patterns)) return(NULL)
if (!file.exists(f_patterns)) {
return(NULL)
}
patterns <- jsonlite::fromJSON( patterns <- jsonlite::fromJSON(
f_patterns, f_patterns,
simplifyVector = FALSE, simplifyVector = FALSE,
simplifyMatrix = FALSE simplifyMatrix = FALSE
) )
patterns <- purrr::keep(patterns, ~ .$name != "") patterns <- purrr::keep(patterns, ~ .$name != "")
patterns[order(purrr::map_chr(patterns, 'name'))]
patterns[order(purrr::map_chr(patterns, "name"))]
} }

+ 307
- 181
R/gadget_server.R Просмотреть файл

footer = modalButton("OK"), footer = modalButton("OK"),
tagList( tagList(
tags$p( tags$p(
"Version", update_available$version, "is",
tags$a(href = update_available$link,
"available on GitHub.")
),
if ("devtools" %in% installed.packages()) tags$p(
"The fastest way to update is with devtools:",
tags$pre(
"devtools::update_packages(\"regexplain\")"
"Version",
update_available$version,
"is",
tags$a(
href = update_available$link,
"available on GitHub."
) )
), ),
if ("devtools" %in% installed.packages()) {
tags$p(
"The fastest way to update is with devtools:",
tags$pre(
"devtools::update_packages(\"regexplain\")"
)
)
},
tags$p( tags$p(
class = 'help-block',
class = "help-block",
"This message won't be shown again during this R session." "This message won't be shown again during this R session."
) )
) )


# ---- Server - Global ---- # ---- Server - Global ----
rtext <- reactive({ rtext <- reactive({
x <- if ('text_break_lines' %in% input$regex_options) {
x <- if ("text_break_lines" %in% input$regex_options) {
strsplit(input$text, "\n")[[1]] strsplit(input$text, "\n")[[1]]
} else input$text
} else {
input$text
}
x x
}) })


}) })


observe({ observe({
if (getOption('regexplain.debug.gadget.text', FALSE)) {
if (getOption("regexplain.debug.gadget.text", FALSE)) {
cat("\ntext :", rtext()) cat("\ntext :", rtext())
} }
if (getOption('regexplain.debug.gadget.pattern', FALSE)) {
if (getOption("regexplain.debug.gadget.pattern", FALSE)) {
cat("\npattern:", pattern()) cat("\npattern:", pattern())
} }
if (getOption('regexplain.debug.gadget.replacement', FALSE)) {
if (getOption("regexplain.debug.gadget.replacement", FALSE)) {
cat("\nreplace:", replacement()) cat("\nreplace:", replacement())
} }
cat("\n") cat("\n")
alert_result <- function(msg, type = "danger") { alert_result <- function(msg, type = "danger") {
msg <- gsub("\n", "<br>", msg) msg <- gsub("\n", "<br>", msg)
msg <- gsub("\t", "&nbsp;&nbsp;", 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>")
paste0(
"<pre class='alert alert-",
type,
"' ",
"style='padding: 4px; margin-top: 1px; margin-bottom: 4px;'>",
paste(msg, collapse = "<br>"),
"</pre>"
)
} }


# ---- Server - Tab - Regex ---- # ---- Server - Tab - Regex ----
output$result <- renderUI({ output$result <- renderUI({
if (is.null(rtext())) return(NULL)
delay <- getOption('regexplain.input_delay_ms', NULL)
if (is.null(rtext())) {
return(NULL)
}
delay <- getOption("regexplain.input_delay_ms", NULL)
if (!is.null(delay)) invalidateLater(delay, session) if (!is.null(delay)) invalidateLater(delay, session)
if (pattern() == "") { if (pattern() == "") {
return(toHTML(paste('<p class="regexplain">', escape_html(rtext()), "</p>", collapse = ""))) return(toHTML(paste('<p class="regexplain">', escape_html(rtext()), "</p>", collapse = "")))
res <- NULL res <- NULL
error_message <- NULL error_message <- NULL
warning_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,
exact = FALSE,
global = "global" %in% input$regex_options),
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 = "")
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,
exact = FALSE,
global = "global" %in% input$regex_options
),
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)) toHTML(paste(error_message, warning_message, res))
}) })


modalButton("Cancel"), modalButton("Cancel"),
actionButton("library_apply_pattern", "Use Pattern", class = "btn-success") actionButton("library_apply_pattern", "Use Pattern", class = "btn-success")
), ),
selectInput("library_pattern", "Pattern",
choices = c("Choose pattern" = "",
purrr::set_names(purrr::map_chr(library_patterns, 'name')))),
selectInput(
"library_pattern",
"Pattern",
choices = c(
"Choose pattern" = "",
purrr::set_names(purrr::map_chr(library_patterns, "name"))
)
),
uiOutput("library_pattern_info") uiOutput("library_pattern_info")
) )
) )
tags$p(HTML(tp$description)), tags$p(HTML(tp$description)),
tags$h5("Pattern"), tags$h5("Pattern"),
tags$pre(tp$regex), tags$pre(tp$regex),
if (!is.null(tp$source)) tags$p(
"Source:",
if (grepl(rx_url, tp$source)) tags$a(href = tp$source, tp$source) else HTML(tp$source)
)
if (!is.null(tp$source)) {
tags$p(
"Source:",
if (grepl(rx_url, tp$source)) tags$a(href = tp$source, tp$source) else HTML(tp$source)
)
}
) )
}) })




observe({ observe({
is_empty <- input$pattern == "" is_empty <- input$pattern == ""
if (is_empty) updateTextInput(
session, "pattern",
placeholder = "Standard RegEx, e.g. \\w+_\\d{2,4}\\s+")
if (is_empty) {
updateTextInput(
session,
"pattern",
placeholder = "Standard RegEx, e.g. \\w+_\\d{2,4}\\s+"
)
}
}) })


# ---- Server - Tab - Output ---- # ---- Server - Tab - Output ----


output$output_sub <- renderUI({ output$output_sub <- renderUI({
req(input$regexFn) req(input$regexFn)
if (!input$regexFn %in% regexFn_substitute) return(NULL)
textInputCode('regexFn_replacement', 'Subsitution',
value = regexFn_replacement_val,
placeholder = "Replacement Text")
if (!input$regexFn %in% regexFn_substitute) {
return(NULL)
}
textInputCode(
"regexFn_replacement",
"Subsitution",
value = regexFn_replacement_val,
placeholder = "Replacement Text"
)
}) })


replacement <- reactive({ replacement <- reactive({
if (!requireNamespace(regexPkg, quietly = TRUE)) { if (!requireNamespace(regexPkg, quietly = TRUE)) {
return(cat( return(cat(
paste0( paste0(
"The package `", regexPkg, "` is not installed.\n",
"The package `",
regexPkg,
"` is not installed.\n",
"To preview results from this package, please run\n\n", "To preview results from this package, please run\n\n",
" install.packages(\"", regexPkg, "\")"
" install.packages(\"",
regexPkg,
"\")"
) )
)) ))
} }
x <- if (regexPkg == "base") { x <- if (regexPkg == "base") {
if (req_sub_arg) { if (req_sub_arg) {
req(replacement()) req(replacement())
regexFn(pattern(), replacement(), rtext(),
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)
regexFn(
pattern(),
replacement(),
rtext(),
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
)
} else { } else {
regexFn(pattern(), rtext(),
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)
regexFn(
pattern(),
rtext(),
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
)
} }
} else if (regexPkg == "stringr") { } else if (regexPkg == "stringr") {
if (req_sub_arg) { if (req_sub_arg) {
rtext(), rtext(),
stringr_regex( stringr_regex(
pattern(), pattern(),
ignore_case = 'ignore.case' %in% input$regex_options,
literal = 'fixed' %in% input$regex_options
ignore_case = "ignore.case" %in% input$regex_options,
literal = "fixed" %in% input$regex_options
), ),
replacement() replacement()
) )
rtext(), rtext(),
stringr_regex( stringr_regex(
pattern(), pattern(),
ignore_case = 'ignore.case' %in% input$regex_options,
literal = 'fixed' %in% input$regex_options
ignore_case = "ignore.case" %in% input$regex_options,
literal = "fixed" %in% input$regex_options
) )
) )
} }
} else if (regexPkg == "rematch2") { } else if (regexPkg == "rematch2") {
regexFn(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)
regexFn(
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
)
} else { } else {
"Um. Not sure how I got here." "Um. Not sure how I got here."
} }
}) })


stringr_regex <- function(pattern, ignore_case = FALSE, literal = FALSE) { stringr_regex <- function(pattern, ignore_case = FALSE, literal = FALSE) {
if (!requireNamespace("stringr", quietly = TRUE)) return(NULL)
if (!requireNamespace("stringr", quietly = TRUE)) {
return(NULL)
}
do.call( do.call(
eval(parse(text = "stringr::regex")), eval(parse(text = "stringr::regex")),
list(pattern = pattern, ignore_case, ignore_case, literal = literal) list(pattern = pattern, ignore_case, ignore_case, literal = literal)
) )


# avoid CRAN check NOTES # avoid CRAN check NOTES
help_text <- NULL # in help_server.R
help_text <- NULL # in help_server.R
make_help_tab_text <- NULL # in help_server.R make_help_tab_text <- NULL # in help_server.R
source(system.file("shiny", "help_server.R", package = "regexplain"), local = TRUE) source(system.file("shiny", "help_server.R", package = "regexplain"), local = TRUE)


tags$p("There are lots of great resources available for learning and working with regular expressions."), tags$p("There are lots of great resources available for learning and working with regular expressions."),
tags$h4("Regular Expressions in R"), tags$h4("Regular Expressions in R"),
tags$ul( tags$ul(
tags$li(tags$p("The", tags$a(href = "http://stringr.tidyverse.org/articles/regular-expressions.html", "Regular Expressions vignette"),
"from", tags$code("stringr"), "is an excellent first introduction to regular expressions in R.")),
tags$li(tags$p("The", tags$a(href = "http://r4ds.had.co.nz/strings.html", "chapter on strings"),
"in", tags$a(href = "http://r4ds.had.co.nz/", "R for Data Science"),
"is also a great overall introduction.")),
tags$li(tags$p("RStudio's",
tags$a(href = "https://www.rstudio.com/wp-content/uploads/2016/09/RegExCheatsheet.pdf", "RegEx CheatSheet"),
"is a good pocket reference.")),
tags$li(tags$p(
"The",
tags$a(href = "http://stringr.tidyverse.org/articles/regular-expressions.html", "Regular Expressions vignette"),
"from",
tags$code("stringr"),
"is an excellent first introduction to regular expressions in R."
)),
tags$li(tags$p(
"The",
tags$a(href = "http://r4ds.had.co.nz/strings.html", "chapter on strings"),
"in",
tags$a(href = "http://r4ds.had.co.nz/", "R for Data Science"),
"is also a great overall introduction."
)),
tags$li(tags$p(
"RStudio's",
tags$a(href = "https://www.rstudio.com/wp-content/uploads/2016/09/RegExCheatsheet.pdf", "RegEx CheatSheet"),
"is a good pocket reference."
)),
tags$li(tags$p("Or try the", tags$strong("Regexplain Cheatsheet"), "addin installed with this package.")) tags$li(tags$p("Or try the", tags$strong("Regexplain Cheatsheet"), "addin installed with this package."))
), ),
tags$h4("Online Resources"), tags$h4("Online Resources"),
load_buttons <- function(..., extra_btns = NULL) { load_buttons <- function(..., extra_btns = NULL) {
prefix <- paste(..., sep = "_") prefix <- paste(..., sep = "_")
btns <- c( btns <- c(
list(c("text", "Load Text", "btn-success"),
c("pattern", "Load Pattern", "btn-primary")),
list(
c("text", "Load Text", "btn-success"),
c("pattern", "Load Pattern", "btn-primary")
),
extra_btns extra_btns
) )
tags$span( tags$span(
observeEvent(input$help_try_this, { observeEvent(input$help_try_this, {
tagList( tagList(
tags$h3("Try These Examples"), tags$h3("Try These Examples"),
tags$p("Here are a couple interesting text extraction challenges you can try",
"with this gadget."),
tags$p(
"Here are a couple interesting text extraction challenges you can try",
"with this gadget."
),
tags$h4("Harvard Sentences"), tags$h4("Harvard Sentences"),
tags$p("These examples come from the",
tags$a(href = "http://r4ds.had.co.nz/strings.html", "R for Data Science"),
"book and are based on a collection of short sentences called the Harvard Sentences."),
tags$p(
"These examples come from the",
tags$a(href = "http://r4ds.had.co.nz/strings.html", "R for Data Science"),
"book and are based on a collection of short sentences called the Harvard Sentences."
),
tags$ol( tags$ol(
tags$li(tags$p( tags$li(tags$p(
"Find sentences that contain a color (i.e. red, orange, yellow, green, blue, purple).", "Find sentences that contain a color (i.e. red, orange, yellow, green, blue, purple).",
load_buttons("help_try_this", "hs", "colors"))),
load_buttons("help_try_this", "hs", "colors")
)),
tags$li(tags$p( tags$li(tags$p(
"Use the text from Exercise 1 and make sure that only full words that are colors are found.", "Use the text from Exercise 1 and make sure that only full words that are colors are found.",
HTML("E.g. <code>red</code> and not <code>flickered</code>."), HTML("E.g. <code>red</code> and not <code>flickered</code>."),
tags$span(style = "display: inline-block;",
actionButton("help_try_this_hs_colors_word", "Load Pattern", class = "btn-xs btn-primary"),
actionButton("help_try_this_hs_colors_hint", "Show Hint", class = "btn-xs"))
tags$span(
style = "display: inline-block;",
actionButton("help_try_this_hs_colors_word", "Load Pattern", class = "btn-xs btn-primary"),
actionButton("help_try_this_hs_colors_hint", "Show Hint", class = "btn-xs")
)
)), )),
tags$li(tags$p( tags$li(tags$p(
"Extract nouns from sentences by finding any word that comes after \"a\" or \"the\".", "Extract nouns from sentences by finding any word that comes after \"a\" or \"the\".",
"Use", actionLink("help_try_this_hs_words_go2_groups", "Groups"),
"Use",
actionLink("help_try_this_hs_words_go2_groups", "Groups"),
"to extract the article and possible noun separately and check your results with", "to extract the article and possible noun separately and check your results with",
HTML("<code>stringr::str_match()</code>:"), HTML("<code>stringr::str_match()</code>:"),
load_buttons("help_try_this", "hs", "words",
extra_btns = list(c("output", "Check str_match()")))
load_buttons(
"help_try_this",
"hs",
"words",
extra_btns = list(c("output", "Check str_match()"))
)
)), )),
tags$li(tags$p( tags$li(tags$p(
"Switch the order of the two words following the articles", '"a" or "the"',
"using", actionLink("help_try_this_hs_refs_go2_groups", "backreferences,"),
"so that", tags$code("the birch canoe"), "would read",
"Switch the order of the two words following the articles",
'"a" or "the"',
"using",
actionLink("help_try_this_hs_refs_go2_groups", "backreferences,"),
"so that",
tags$code("the birch canoe"),
"would read",
HTML("<code>the canoe birch</code>. Use <code>sub</code>"), HTML("<code>the canoe birch</code>. Use <code>sub</code>"),
"in the", tags$strong("Output"), "tab to replace the matched pattern.",
load_buttons("help_try_this", "hs", "refs",
extra_btns = list(c("output", "Load Replacement")))
"in the",
tags$strong("Output"),
"tab to replace the matched pattern.",
load_buttons(
"help_try_this",
"hs",
"refs",
extra_btns = list(c("output", "Load Replacement"))
)
)) ))
), ),
tags$h4("Phone Numbers"), tags$h4("Phone Numbers"),
tags$p("This example is also from the",
tags$a(href = "http://r4ds.had.co.nz/strings.html#other-types-of-pattern",
"R for Data Science"),
"book. Phone numbers in the United States start with a 3-digit area code,",
"followed by another 3 digits and a final 4-digit group.",
"Sometimes the area code is wrapped in parenthesis, or sometimes dots or dashes",
"are used to separate the digit groups. Try to extract each digit group from these phone numbers:",
load_buttons("help_try_this", "phone",
extra_btns = list(c("output", "Check str_match()")))),
tags$p(
"This example is also from the",
tags$a(
href = "http://r4ds.had.co.nz/strings.html#other-types-of-pattern",
"R for Data Science"
),
"book. Phone numbers in the United States start with a 3-digit area code,",
"followed by another 3 digits and a final 4-digit group.",
"Sometimes the area code is wrapped in parenthesis, or sometimes dots or dashes",
"are used to separate the digit groups. Try to extract each digit group from these phone numbers:",
load_buttons(
"help_try_this",
"phone",
extra_btns = list(c("output", "Check str_match()"))
)
),
tags$h4("CSS Unit Validation"), tags$h4("CSS Unit Validation"),
tags$p("This example is used in", tags$code("validateCssUnit()"),
"in the", tags$a(href="https://www.r-pkg.org/pkg/htmltools", "htmltools package."),
"CSS units can be integer or decimal numbers with units such as",
"in, cm, mm, em, ex, pt, px, etc. (see the list",
HTML('<a href="https://www.w3.org/Style/Examples/007/units.en.html">here</a>).'),
"Try to extract the number and unit from these units:",
load_buttons("help_try_this", "css")),
tags$p(
"This example is used in",
tags$code("validateCssUnit()"),
"in the",
tags$a(href = "https://www.r-pkg.org/pkg/htmltools", "htmltools package."),
"CSS units can be integer or decimal numbers with units such as",
"in, cm, mm, em, ex, pt, px, etc. (see the list",
HTML('<a href="https://www.w3.org/Style/Examples/007/units.en.html">here</a>).'),
"Try to extract the number and unit from these units:",
load_buttons("help_try_this", "css")
),
tags$h4("Parse Github Repos"), tags$h4("Parse Github Repos"),
tags$p("This example is from the",
tags$a(href = "https://www.r-pkg.org/pkg/rematch2", "rematch2 package."),
"Github repositories are often specified in like",
HTML("<code>user/repo/subdir@ref*release</code> or <code>user/repo/subdir#PR</code>"),
"where only", tags$code("user"), "and", tags$code("repo"), "are required elements.",
"Try to extract each piece of the repo text and use",
tags$code("rematch2::re_match()"), "to extract a tidy tibble of matches:",
load_buttons("help_try_this", "github",
extra_btns = list(c("output", "Check re_match()"))))
tags$p(
"This example is from the",
tags$a(href = "https://www.r-pkg.org/pkg/rematch2", "rematch2 package."),
"Github repositories are often specified in like",
HTML("<code>user/repo/subdir@ref*release</code> or <code>user/repo/subdir#PR</code>"),
"where only",
tags$code("user"),
"and",
tags$code("repo"),
"are required elements.",
"Try to extract each piece of the repo text and use",
tags$code("rematch2::re_match()"),
"to extract a tidy tibble of matches:",
load_buttons(
"help_try_this",
"github",
extra_btns = list(c("output", "Check re_match()"))
)
)
) %>% ) %>%
as.character() %>% as.character() %>%
help_text() help_text()
color_text <- stringr::sentences[grepl(color_match, stringr::sentences)] color_text <- stringr::sentences[grepl(color_match, stringr::sentences)]
color_text <- sample(color_text, 25) color_text <- sample(color_text, 25)
updateTextAreaInput(session, "text", value = paste(color_text, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(color_text, collapse = "\n"))
showNotification("Text loaded! View it in Text tab", type = 'message')
showNotification("Text loaded! View it in Text tab", type = "message")
} else { } else {
showNotification("Please install {stringr} for this example", type = 'error')
showNotification("Please install {stringr} for this example", type = "error")
} }
}) })


observeEvent(input$help_try_this_hs_colors_pattern, { observeEvent(input$help_try_this_hs_colors_pattern, {
color_match <- "red|orange|yellow|green|blue|purple" color_match <- "red|orange|yellow|green|blue|purple"
updateTextInput(session, 'pattern', value = color_match)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines', 'perl'))
showNotification("Pattern loaded! View it in RegEx tab", type = 'message')
updateTextInput(session, "pattern", value = color_match)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines", "perl"))
showNotification("Pattern loaded! View it in RegEx tab", type = "message")
}) })


observeEvent(input$help_try_this_hs_colors_word, { observeEvent(input$help_try_this_hs_colors_word, {
color_match <- "\\b(red|orange|yellow|green|blue|purple)\\b" color_match <- "\\b(red|orange|yellow|green|blue|purple)\\b"
updateTextInput(session, 'pattern', value = color_match)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines', 'perl'))
showNotification("Pattern loaded! View it in RegEx tab", type = 'message')
updateTextInput(session, "pattern", value = color_match)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines", "perl"))
showNotification("Pattern loaded! View it in RegEx tab", type = "message")
}) })


observeEvent(input$help_try_this_hs_colors_hint, { observeEvent(input$help_try_this_hs_colors_hint, {
showModal( showModal(
modalDialog(title = "Hint \U0001f575", footer = NULL, easyClose = TRUE,
tags$p("Try using the", tags$strong("word boundary"), "anchor."))
modalDialog(
title = "Hint \U0001f575",
footer = NULL,
easyClose = TRUE,
tags$p("Try using the", tags$strong("word boundary"), "anchor.")
)
) )
}) })


}) })


observeEvent(input$help_try_this_hs_words_output, { observeEvent(input$help_try_this_hs_words_output, {
updateSelectInput(session, 'regexFn', selected = 'str_match')
updateSelectInput(session, "regexFn", selected = "str_match")
showNotification("Go to Output tab to see results from str_match()", type = "message") showNotification("Go to Output tab to see results from str_match()", type = "message")
}) })


if (requireNamespace("stringr", quietly = TRUE)) { if (requireNamespace("stringr", quietly = TRUE)) {
hs_text <- sample(stringr::sentences, 25) hs_text <- sample(stringr::sentences, 25)
updateTextAreaInput(session, "text", value = paste(hs_text, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(hs_text, collapse = "\n"))
showNotification("Text loaded! View it in Text tab", type = 'message')
showNotification("Text loaded! View it in Text tab", type = "message")
} else { } else {
showNotification("Please install {stringr} for this example", type = 'error')
showNotification("Please install {stringr} for this example", type = "error")
} }
}) })


observeEvent(input$help_try_this_hs_words_pattern, { observeEvent(input$help_try_this_hs_words_pattern, {
noun_pattern <- "(a|the) ([^ ]+)" noun_pattern <- "(a|the) ([^ ]+)"
updateTextInput(session, 'pattern', value = noun_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines'))
updateSelectInput(session, 'regexFn', selected = "str_match")
showNotification("Pattern loaded! View it in RegEx and Output tabs", type = 'message')
updateTextInput(session, "pattern", value = noun_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines"))
updateSelectInput(session, "regexFn", selected = "str_match")
showNotification("Pattern loaded! View it in RegEx and Output tabs", type = "message")
}) })


observeEvent(input$help_try_this_hs_refs_go2_groups, { observeEvent(input$help_try_this_hs_refs_go2_groups, {


observeEvent(input$help_try_this_hs_refs_output, { observeEvent(input$help_try_this_hs_refs_output, {
regexFn_replacement_val <<- "\\1 \\3 \\2" regexFn_replacement_val <<- "\\1 \\3 \\2"
updateSelectInput(session, 'regexFn', selected = 'sub')
updateSelectInput(session, "regexFn", selected = "sub")
showNotification("Replacement loaded! Go to Output tab to see results", type = "message") showNotification("Replacement loaded! Go to Output tab to see results", type = "message")
}) })


if (requireNamespace("stringr", quietly = TRUE)) { if (requireNamespace("stringr", quietly = TRUE)) {
hs_text <- sample(stringr::sentences, 25) hs_text <- sample(stringr::sentences, 25)
updateTextAreaInput(session, "text", value = paste(hs_text, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(hs_text, collapse = "\n"))
showNotification("Text loaded! View it in Text tab", type = 'message')
showNotification("Text loaded! View it in Text tab", type = "message")
} else { } else {
showNotification("Please install {stringr} for this example", type = 'error')
showNotification("Please install {stringr} for this example", type = "error")
} }
}) })


observeEvent(input$help_try_this_hs_refs_pattern, { observeEvent(input$help_try_this_hs_refs_pattern, {
noun_pattern <- "(a|the) ([^ ]+) ([^ ]+)" noun_pattern <- "(a|the) ([^ ]+) ([^ ]+)"
updateTextInput(session, 'pattern', value = noun_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines'))
showNotification("Pattern loaded! View it in RegEx tab", type = 'message')
updateTextInput(session, "pattern", value = noun_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines"))
showNotification("Pattern loaded! View it in RegEx tab", type = "message")
}) })


observeEvent(input$help_try_this_phone_output, { observeEvent(input$help_try_this_phone_output, {
updateSelectInput(session, 'regexFn', selected = 'str_match')
updateSelectInput(session, "regexFn", selected = "str_match")
showNotification("Go to Output tab to see results from str_match()", type = "message") showNotification("Go to Output tab to see results from str_match()", type = "message")
}) })


} }
phone_numbers <- replicate(25, phone_number()) phone_numbers <- replicate(25, phone_number())
updateTextAreaInput(session, "text", value = paste(phone_numbers, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(phone_numbers, collapse = "\n"))
showNotification("Text loaded! View it in Text tab", type = 'message')
showNotification("Text loaded! View it in Text tab", type = "message")
}) })


observeEvent(input$help_try_this_phone_pattern, { observeEvent(input$help_try_this_phone_pattern, {
phone_pattern <- "\\(?(\\d{3})[-). ]?(\\d{3})[- .]?(\\d{4})" phone_pattern <- "\\(?(\\d{3})[-). ]?(\\d{3})[- .]?(\\d{4})"
updateTextInput(session, 'pattern', value = phone_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines'))
showNotification("Pattern loaded! View it in RegEx tab", type = 'message')
updateTextInput(session, "pattern", value = phone_pattern)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines"))
showNotification("Pattern loaded! View it in RegEx tab", type = "message")
}) })


observeEvent(input$help_try_this_github_text, { observeEvent(input$help_try_this_github_text, {
"r-lib/remotes@550a3c7d3f9e1493a2ba" "r-lib/remotes@550a3c7d3f9e1493a2ba"
) )
updateTextAreaInput(session, "text", value = paste(github_repos, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(github_repos, collapse = "\n"))
showNotification("Text loaded! Go to RegEx Tab", type = 'message')
showNotification("Text loaded! Go to RegEx Tab", type = "message")
}) })


observeEvent(input$help_try_this_github_pattern, { observeEvent(input$help_try_this_github_pattern, {
owner_rx <- "(?:(?<owner>[^/]+)/)?"
repo_rx <- "(?<repo>[^/@#]+)"
subdir_rx <- "(?:/(?<subdir>[^@#]*[^@#/]))?"
ref_rx <- "(?:@(?<ref>[^*].*))"
pull_rx <- "(?:#(?<pull>[0-9]+))"
owner_rx <- "(?:(?<owner>[^/]+)/)?"
repo_rx <- "(?<repo>[^/@#]+)"
subdir_rx <- "(?:/(?<subdir>[^@#]*[^@#/]))?"
ref_rx <- "(?:@(?<ref>[^*].*))"
pull_rx <- "(?:#(?<pull>[0-9]+))"
release_rx <- "(?:@(?<release>[*]release))" release_rx <- "(?:@(?<release>[*]release))"


subtype_rx <- sprintf("(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx) subtype_rx <- sprintf("(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx)
github_rx <- sprintf(
github_rx <- sprintf(
"^(?:%s%s%s%s|(?<catchall>.*))$", "^(?:%s%s%s%s|(?<catchall>.*))$",
owner_rx, repo_rx, subdir_rx, subtype_rx
owner_rx,
repo_rx,
subdir_rx,
subtype_rx
) )


updateTextInput(session, 'pattern', value = github_rx)
updateCheckboxGroupInput(session, "regex_options", selected = c('text_break_lines', 'perl'))
showNotification("Pattern loaded! Go to RegEx Tab", type = 'message')
updateTextInput(session, "pattern", value = github_rx)
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines", "perl"))
showNotification("Pattern loaded! Go to RegEx Tab", type = "message")
}) })


observeEvent(input$help_try_this_github_output, { observeEvent(input$help_try_this_github_output, {
updateSelectInput(session, 'regexFn', selected = 're_match')
updateSelectInput(session, "regexFn", selected = "re_match")
showNotification("Go to Output tab to see results from re_match()", type = "message") showNotification("Go to Output tab to see results from re_match()", type = "message")
}) })


observeEvent(input$help_try_this_css_text, { observeEvent(input$help_try_this_css_text, {
css_units <- c( css_units <- c(
"125%","16pt","2cm","7em","3ex","24pt",
".15in","20pc","5.9vw","3.0vh","2vmin"
"125%",
"16pt",
"2cm",
"7em",
"3ex",
"24pt",
".15in",
"20pc",
"5.9vw",
"3.0vh",
"2vmin"
) )
showNotification("Example text loaded! Go to RegEx tab", type = "message") showNotification("Example text loaded! Go to RegEx tab", type = "message")
updateTextAreaInput(session, "text", value = paste(css_units, collapse = "\n")) updateTextAreaInput(session, "text", value = paste(css_units, collapse = "\n"))
observeEvent(input$help_try_this_css_pattern, { observeEvent(input$help_try_this_css_pattern, {
pattern <- "^(auto|inherit|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|em|ex|pt|pc|px|vh|vw|vmin|vmax))$" pattern <- "^(auto|inherit|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|em|ex|pt|pc|px|vh|vw|vmin|vmax))$"
updateTextInput(session, "pattern", value = pattern) updateTextInput(session, "pattern", value = pattern)
updateCheckboxGroupInput(session, 'regex_options', selected = c('text_break_lines', 'perl'))
updateCheckboxGroupInput(session, "regex_options", selected = c("text_break_lines", "perl"))
showNotification("Pattern loaded! Go to RegEx tab", type = "message") showNotification("Pattern loaded! Go to RegEx tab", type = "message")
}) })


} }
if ("regexFn_replacement" %in% names(input) && isTruthy(replacement())) { if ("regexFn_replacement" %in% names(input) && isTruthy(replacement())) {
pattern <- paste0( pattern <- paste0(
pattern, "\n",
'replacement <- "', escape_backslash(replacement()), '"'
pattern,
"\n",
'replacement <- "',
escape_backslash(replacement()),
'"'
) )
} }
rstudioapi::sendToConsole(pattern, FALSE) rstudioapi::sendToConsole(pattern, FALSE)

+ 10
- 7
R/help_ui.R Просмотреть файл

shiny::tagList( shiny::tagList(
shiny::tags$ul( shiny::tags$ul(
id = "help-sidebar", id = "help-sidebar",
if (!cheatsheet_only) shiny::tagList(
shiny::tags$li(shiny::tags$strong("RegExplain"), class = "header"),
shiny::tags$li(shiny::actionLink("help_default", "Introduction")),
shiny::tags$li(shiny::actionLink("help_try_this", "Try These Examples")),
shiny::tags$li(shiny::actionLink("help_resources", "Resources")),
shiny::tags$li(class = "header", style = "margin-top: 5px;", shiny::tags$strong("Reference"))),
if (!cheatsheet_only) {
shiny::tagList(
shiny::tags$li(shiny::tags$strong("RegExplain"), class = "header"),
shiny::tags$li(shiny::actionLink("help_default", "Introduction")),
shiny::tags$li(shiny::actionLink("help_try_this", "Try These Examples")),
shiny::tags$li(shiny::actionLink("help_resources", "Resources")),
shiny::tags$li(class = "header", style = "margin-top: 5px;", shiny::tags$strong("Reference"))
)
},
shiny::tags$li("Character Classes", class = "header"), shiny::tags$li("Character Classes", class = "header"),
shiny::tags$ul( shiny::tags$ul(
class = "subgroup", class = "subgroup",
), ),
shiny::tags$div( shiny::tags$div(
style = "width: 100%; padding-left: 10px;", style = "width: 100%; padding-left: 10px;",
shiny::uiOutput('help_text_selected')
shiny::uiOutput("help_text_selected")
) )
) )
) )

+ 34
- 23
R/regex.R Просмотреть файл

m <- purrr::map2(text, m, ~ list(text = .x, idx = expand_matches(.y))) m <- purrr::map2(text, m, ~ list(text = .x, idx = expand_matches(.y)))


attr(m, "global") <- global attr(m, "global") <- global
if (!global) return(m)
if (!global) {
return(m)
}


mmi <- max_match_index(m) mmi <- max_match_index(m)
if (any(!is.na(mmi))) { if (any(!is.na(mmi))) {
subtext <- purrr::map_chr(m, "text") %>% purrr::map2_chr(mmi, substring)
subtext <- purrr::map_chr(m, "text") %>% purrr::map2_chr(mmi, substring)
sub_idx <- which(!is.na(subtext)) sub_idx <- which(!is.na(subtext))
m2 <- regex(subtext[sub_idx], pattern, ignore.case, perl, fixed, useBytes) m2 <- regex(subtext[sub_idx], pattern, ignore.case, perl, fixed, useBytes)
for (i in seq_along(m2)) { for (i in seq_along(m2)) {
} }


expand_matches <- function(m) { expand_matches <- function(m) {
if (m[1] == -1) return(NULL)
if (m[1] == -1) {
return(NULL)
}
m_length <- attr(m, "match.length") m_length <- attr(m, "match.length")
if (identical(as.vector(m[[1]]), 1L) && m_length == 0) return(NULL)
if (identical(as.vector(m[[1]]), 1L) && m_length == 0) {
return(NULL)
}
x <- purrr::map2(m, m_length, ~ c(.x, .x + .y)) x <- purrr::map2(m, m_length, ~ c(.x, .x + .y))
x <- as.data.frame(do.call(rbind, x)) x <- as.data.frame(do.call(rbind, x))
names(x) <- c("start", "end") names(x) <- c("start", "end")
x$start <- ifelse(x$start == 0L, NA_integer_, x$start) x$start <- ifelse(x$start == 0L, NA_integer_, x$start)
x$end <- ifelse(x$end == 0L, NA_integer_, x$end)
x$end <- ifelse(x$end == 0L, NA_integer_, x$end)
x$group <- 1:nrow(x) - 1L x$group <- 1:nrow(x) - 1L
x$pass <- 1L
x$pass <- 1L
x x
} }


purrr::map_int(function(idx) { purrr::map_int(function(idx) {
if (!is.null(idx)) { if (!is.null(idx)) {
max(idx$start, idx$end, na.rm = TRUE) max(idx$start, idx$end, na.rm = TRUE)
} else NA
} else {
NA
}
}) })
} }


if (inserts$i[j] == 0) next if (inserts$i[j] == 0) next
if (is.na(inserts$start[j]) || is.na(inserts$end[j])) next if (is.na(inserts$start[j]) || is.na(inserts$end[j])) next
overlap <- filter( overlap <- filter(
inserts[1:(j-1), ],
inserts[1:(j - 1), ],
.data$i != 0, .data$i != 0,
.data$start <= !!inserts$start[j] & .data$end >= !!inserts$end[j])
inserts[j, 'pad'] <- inserts$pad[j] + nrow(overlap)
.data$start <= !!inserts$start[j] & .data$end >= !!inserts$end[j]
)
inserts[j, "pad"] <- inserts$pad[j] + nrow(overlap)
} }
inserts <- dplyr::bind_rows( inserts <- dplyr::bind_rows(
inserts %>% select(-.data$end, dplyr::everything(), loc = .data$start) %>% mutate(type = "start"), inserts %>% select(-.data$end, dplyr::everything(), loc = .data$start) %>% mutate(type = "start"),
dplyr::arrange(loc, class, dplyr::desc(type)) %>% dplyr::arrange(loc, class, dplyr::desc(type)) %>%
mutate( mutate(
class = ifelse(.data$pad > 0, sprintf("%s pad%02d", .data$class, .data$pad), .data$class), class = ifelse(.data$pad > 0, sprintf("%s pad%02d", .data$class, .data$pad), .data$class),
insert = ifelse(.data$type == 'start', sprintf('<span class="%s">', .data$class), "</span>")
insert = ifelse(.data$type == "start", sprintf('<span class="%s">', .data$class), "</span>")
) )


inserts <- if (max(inserts$pass) == 1) { inserts <- if (max(inserts$pass) == 1) {
# start at 0, unless there's a hit on first character # start at 0, unless there's a hit on first character
# end at nchar(text) + 1 because window is idx[k] to idx[k+1]-1 # end at nchar(text) + 1 because window is idx[k] to idx[k+1]-1
idx_split <- c(0 - (inserts$loc[1] == 0), inserts$loc) idx_split <- c(0 - (inserts$loc[1] == 0), inserts$loc)
if (!(nchar(text) + 1) %in% idx_split)
if (!(nchar(text) + 1) %in% idx_split) {
idx_split <- c(idx_split, nchar(text) + 1) idx_split <- c(idx_split, nchar(text) + 1)
}
text_split <- c() text_split <- c()
for (k in seq_along(idx_split[-1])) { for (k in seq_along(idx_split[-1])) {
text_split <- c(text_split, substr(text, idx_split[k], idx_split[k+1] - 1))
text_split <- c(text_split, substr(text, idx_split[k], idx_split[k + 1] - 1))
} }
out <- c() out <- c()
for (j in seq_along(text_split)) { for (j in seq_along(text_split)) {
) )
} }
if (exact) out <- escape_backslash(out) if (exact) out <- escape_backslash(out)
paste(out, collapse = '')
paste(out, collapse = "")
} }


collapse_span_inserts <- function(inserts) { collapse_span_inserts <- function(inserts) {
) %>% ) %>%
mutate(type = sprintf("%05d%s", dplyr::row_number(), type)) %>% mutate(type = sprintf("%05d%s", dplyr::row_number(), type)) %>%
group_by(.data$loc, .data$type) %>% group_by(.data$loc, .data$type) %>%
summarize(insert = paste(.data$insert, collapse = '')) %>%
summarize(insert = paste(.data$insert, collapse = "")) %>%
dplyr::ungroup() %>% dplyr::ungroup() %>%
mutate(type = sub("^\\d{5}", "", type)) mutate(type = sub("^\\d{5}", "", type))
} }
if (pattern_chars[i] == "(") { if (pattern_chars[i] == "(") {
backslash_count <- 0 backslash_count <- 0
if (i != 1) { if (i != 1) {
j <- i-1
j <- i - 1
while (pattern_chars[j] == "\\" && j > 0) { while (pattern_chars[j] == "\\" && j > 0) {
backslash_count <- backslash_count + 1 backslash_count <- backslash_count + 1
j <- j - 1 j <- j - 1
} }
if (is_capture_group) { if (is_capture_group) {
group <- group + 1 group <- group + 1
paren_stack <- c(TRUE, paren_stack) #push
paren_stack <- c(TRUE, paren_stack) # push
out <- c(out, paste0('<span class="g', sprintf("%02d", group), '">(')) out <- c(out, paste0('<span class="g', sprintf("%02d", group), '">('))
} else { } else {
paren_stack <- c(FALSE, paren_stack) #push
paren_stack <- c(FALSE, paren_stack) # push
out <- c(out, "(") out <- c(out, "(")
} }
} else if (pattern_chars[i] == ")") { } else if (pattern_chars[i] == ")") {
closes_capture_group <- paren_stack[1] closes_capture_group <- paren_stack[1]
paren_stack <- paren_stack[-1] #pop
paren_stack <- paren_stack[-1] # pop
if (closes_capture_group) { if (closes_capture_group) {
out <- c(out, ")</span>") out <- c(out, ")</span>")
} else { } else {
#' If the output is destined for a [knitr] document, set `knitr` to `TRUE`. #' If the output is destined for a [knitr] document, set `knitr` to `TRUE`.
#' #'
#' @examples #' @examples
#' view_regex("example", "amp", render=FALSE)
#'
#' view_regex("example", "amp", render = FALSE)
#' @param text Text to search #' @param text Text to search
#' @param pattern Regex pattern to look for #' @param pattern Regex pattern to look for
#' @param render Render results as HTML? #' @param render Render results as HTML?
exact = escape, exact = escape,
result_only = FALSE result_only = FALSE
) { ) {
knitr <- isTRUE(getOption('knitr.in.progress'))
knitr <- isTRUE(getOption("knitr.in.progress"))
if (knitr) { if (knitr) {
render <- FALSE render <- FALSE
escape <- TRUE escape <- TRUE
) )
) )
} }
if (!render) return(res)
if (!render) {
return(res)
}
page <- result_page(wrap_regex(pattern, escape, exact), res, "View Regex") page <- result_page(wrap_regex(pattern, escape, exact), res, "View Regex")
htmltools::browsable(page) htmltools::browsable(page)
} }

+ 55
- 31
R/shiny_modified_inputs.R Просмотреть файл

#' @inheritParams shiny::textAreaInput #' @inheritParams shiny::textAreaInput
#' @param is_code Should the text input be considered verbatim code input? #' @param is_code Should the text input be considered verbatim code input?
#' @family modified shiny inputs #' @family modified shiny inputs
textAreaInputAlt <- function(inputId, label, value = "", width = NULL, height = NULL,
cols = NULL, rows = NULL, placeholder = NULL, resize = NULL,
is_code = TRUE) {
textAreaInputAlt <- function(
inputId,
label,
value = "",
width = NULL,
height = NULL,
cols = NULL,
rows = NULL,
placeholder = NULL,
resize = NULL,
is_code = TRUE
) {
`%AND%` <- getFromNamespace("%AND%", "shiny") `%AND%` <- getFromNamespace("%AND%", "shiny")


value <- shiny::restoreInput(id = inputId, default = value) value <- shiny::restoreInput(id = inputId, default = value)
} }


style <- paste( style <- paste(
if (!is.null(width)) paste0("width: ", shiny::validateCssUnit(width), ";"),
if (!is.null(width)) paste0("width: ", shiny::validateCssUnit(width), ";"),
if (!is.null(height)) paste0("height: ", shiny::validateCssUnit(height), ";"), if (!is.null(height)) paste0("height: ", shiny::validateCssUnit(height), ";"),
if (!is.null(resize)) paste0("resize: ", resize, ";"), if (!is.null(resize)) paste0("resize: ", resize, ";"),
if (is_code) 'font-family: "Monaco", "Inconsolata", monospace;' if (is_code) 'font-family: "Monaco", "Inconsolata", monospace;'
# https://github.com/rstudio/htmltools/issues/65 # https://github.com/rstudio/htmltools/issues/65
if (length(style) == 0) style <- NULL if (length(style) == 0) style <- NULL


shiny::div(class = "form-group shiny-input-container",
label %AND% shiny::tags$label(label, `for` = inputId),
style = if (!parent_style %in% c(" ", "", " ")) parent_style,
shiny::tags$textarea(
id = inputId,
class = "form-control",
placeholder = placeholder,
style = style,
rows = rows,
cols = cols,
autocomplete = "off",
autocorrect = "off",
autocapitalize = "off",
spellcheck = "false",
value
)
shiny::div(
class = "form-group shiny-input-container",
label %AND% shiny::tags$label(label, `for` = inputId),
style = if (!parent_style %in% c(" ", "", " ")) parent_style,
shiny::tags$textarea(
id = inputId,
class = "form-control",
placeholder = placeholder,
style = style,
rows = rows,
cols = cols,
autocomplete = "off",
autocorrect = "off",
autocapitalize = "off",
spellcheck = "false",
value
)
) )
} }


#' @param width Width of `shiny-input-container` div. #' @param width Width of `shiny-input-container` div.
#' @param ... Extra elements to be included in the `input-group` div. #' @param ... Extra elements to be included in the `input-group` div.
#' @family modified shiny inputs #' @family modified shiny inputs
textInputCode <- function(inputId, label, value = "", width = NULL,
placeholder = NULL, ...) {
textInputCode <- function(
inputId,
label,
value = "",
width = NULL,
placeholder = NULL,
...
) {
`%AND%` <- getFromNamespace("%AND%", "shiny") `%AND%` <- getFromNamespace("%AND%", "shiny")
value <- shiny::restoreInput(id = inputId, default = value) value <- shiny::restoreInput(id = inputId, default = value)


shiny::div(class = "input-group shiny-input-container",
style = if (!is.null(width)) paste0("width: ", shiny::validateCssUnit(width), ";"),
label %AND% shiny::tags$label(label, `for` = inputId),
shiny::tags$input(id = inputId, type="text", class="form-control", value=value,
style = 'font-family: "Monaco", "Inconsolata", monospace;',
autocomplete = "off", autocorrect = "off",
autocapitalize = "off", spellcheck = "false",
placeholder = placeholder),
...
shiny::div(
class = "input-group shiny-input-container",
style = if (!is.null(width)) paste0("width: ", shiny::validateCssUnit(width), ";"),
label %AND% shiny::tags$label(label, `for` = inputId),
shiny::tags$input(
id = inputId,
type = "text",
class = "form-control",
value = value,
style = 'font-family: "Monaco", "Inconsolata", monospace;',
autocomplete = "off",
autocorrect = "off",
autocapitalize = "off",
spellcheck = "false",
placeholder = placeholder
),
...
) )
} }

+ 5
- 5
R/utils.R Просмотреть файл

# highr:::escape_html # highr:::escape_html
# by Yihui Xie, GPL license # by Yihui Xie, GPL license
# https://github.com/yihui/highr/blob/4f54a5b8960d6246daadacea1020ebcdc458ce50/R/utils.R#L54-L61 # https://github.com/yihui/highr/blob/4f54a5b8960d6246daadacea1020ebcdc458ce50/R/utils.R#L54-L61
escape_html = function(x) {
x = gsub('&', '&amp;', x)
x = gsub('<', '&lt;', x)
x = gsub('>', '&gt;', x)
x = gsub('"', '&quot;', x)
escape_html <- function(x) {
x <- gsub("&", "&amp;", x)
x <- gsub("<", "&lt;", x)
x <- gsub(">", "&gt;", x)
x <- gsub('"', "&quot;", x)
x x
} }



+ 3
- 3
tests/testthat/test-regex.R Просмотреть файл

m <- regexec("(a)(b)(d)?", "abcaba") m <- regexec("(a)(b)(d)?", "abcaba")
idx <- data.frame( idx <- data.frame(
start = c(1L, 1L, 2L, NA_integer_), start = c(1L, 1L, 2L, NA_integer_),
end = c(3L, 2L, 3L, NA_integer_),
end = c(3L, 2L, 3L, NA_integer_),
group = c(0L, 1L, 2L, 3L), group = c(0L, 1L, 2L, 3L),
pass = rep(1L, 4)
pass = rep(1L, 4)
) )
expect_equal(expand_matches(m[[1]]), idx) expect_equal(expand_matches(m[[1]]), idx)
}) })
pattern <- "(a)(b)" pattern <- "(a)(b)"
m <- regex(text, pattern, global = TRUE) m <- regex(text, pattern, global = TRUE)
expect_type(m[[1]]$idx$start, "integer") expect_type(m[[1]]$idx$start, "integer")
expect_type(m[[1]]$idx$end, "integer")
expect_type(m[[1]]$idx$end, "integer")
expect_type(m[[1]]$idx$group, "integer") expect_type(m[[1]]$idx$group, "integer")
}) })



+ 1
- 1
tests/testthat/test-sanitize_text_input.R Просмотреть файл

expect_equal(sanitize_text_input("\a"), "\a") expect_equal(sanitize_text_input("\a"), "\a")
expect_equal(sanitize_text_input("\\a"), "\\a") expect_equal(sanitize_text_input("\\a"), "\\a")
expect_equal(sanitize_text_input("x"), "x") expect_equal(sanitize_text_input("x"), "x")
#expect_error(sanitize_text_input("\x"))
# expect_error(sanitize_text_input("\x"))
expect_equal(sanitize_text_input("\\x"), "\\x") expect_equal(sanitize_text_input("\\x"), "\\x")
}) })

+ 8
- 4
tests/testthat/test-wrap_regex.R Просмотреть файл

context("test-wrap_regex.R") context("test-wrap_regex.R")


test_that("wrap_regex generally works", { test_that("wrap_regex generally works", {
expect_equal(wrap_regex("(a)(b)"),
"<span class=\"g01\">(a)</span><span class=\"g02\">(b)</span>")
expect_equal(
wrap_regex("(a)(b)"),
"<span class=\"g01\">(a)</span><span class=\"g02\">(b)</span>"
)
}) })


test_that("wrap_regex doesn't add parens", { test_that("wrap_regex doesn't add parens", {


test_that("wrap_regex doesn't wrap non-capture groups", { test_that("wrap_regex doesn't wrap non-capture groups", {
expect_equal(wrap_regex("(?:a)(b)"), "(?:a)<span class=\"g01\">(b)</span>") expect_equal(wrap_regex("(?:a)(b)"), "(?:a)<span class=\"g01\">(b)</span>")
expect_equal(wrap_regex("((?:a(b))c)"),
"<span class=\"g01\">((?:a<span class=\"g02\">(b)</span>)c)</span>")
expect_equal(
wrap_regex("((?:a(b))c)"),
"<span class=\"g01\">((?:a<span class=\"g02\">(b)</span>)c)</span>"
)
}) })


test_that("wrap_regex returns text if no matches", { test_that("wrap_regex returns text if no matches", {

+ 2
- 2
tests/testthat/test-wrap_result.R Просмотреть файл

test_that("wrap_results works when groups start and end at same index", { test_that("wrap_results works when groups start and end at same index", {
text <- "7282298386" text <- "7282298386"
pattern <- "\\(?(\\d{3})[-). ]?(\\d{3})[- .]?(\\d{4})" pattern <- "\\(?(\\d{3})[-). ]?(\\d{3})[- .]?(\\d{4})"
res <- wrap_result(regex(text, pattern, perl = TRUE, global = FALSE)[[1]])
res <- wrap_result(regex(text, pattern, perl = TRUE, global = FALSE)[[1]])
expect_equal(res, "<span class=\"group g00\"><span class=\"group g01\">728</span><span class=\"group g02\">229</span><span class=\"group g03\">8386</span></span>") expect_equal(res, "<span class=\"group g00\"><span class=\"group g01\">728</span><span class=\"group g02\">229</span><span class=\"group g03\">8386</span></span>")
}) })


'<span class=\"group g00\"><span class=\"group g01\">The</span> <span class=\"group g02\">big</span> </span>', '<span class=\"group g00\"><span class=\"group g01\">The</span> <span class=\"group g02\">big</span> </span>',
'<span class=\"group g00\"><span class=\"group g01\">red</span> <span class=\"group g02\">apple</span> </span>', '<span class=\"group g00\"><span class=\"group g01\">red</span> <span class=\"group g02\">apple</span> </span>',
'<span class=\"group g00\"><span class=\"group g01\">fell</span> <span class=\"group g02\">to</span> </span>', '<span class=\"group g00\"><span class=\"group g01\">fell</span> <span class=\"group g02\">to</span> </span>',
'the ground.'
"the ground."
) )
expect_equal(wrap_result(regex(text, pattern, global = TRUE)[[1]]), result) expect_equal(wrap_result(regex(text, pattern, global = TRUE)[[1]]), result)
}) })

Загрузка…
Отмена
Сохранить