mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-12-16 09:32:10 +01:00
450 lines
11 KiB
R
450 lines
11 KiB
R
#' String split module based on tidyr::separate_
|
|
#'
|
|
#' @param id id
|
|
#'
|
|
#' @returns A shiny ui module
|
|
#' @export
|
|
#'
|
|
#' @name split-string
|
|
#'
|
|
string_split_ui <- function(id) {
|
|
ns <- NS(id)
|
|
tagList(
|
|
shiny::fluidRow(
|
|
# shiny::textOutput(outputId = ns("no_splits")),
|
|
column(
|
|
width = 4,
|
|
shiny::uiOutput(outputId = ns("variable"))
|
|
),
|
|
column(
|
|
width = 4,
|
|
shiny::uiOutput(outputId = ns("delim"))
|
|
),
|
|
column(
|
|
width = 4,
|
|
shiny::uiOutput(outputId = ns("direction"))
|
|
) # ,
|
|
# column(
|
|
# width = 3,
|
|
# actionButton(
|
|
# inputId = ns("split"),
|
|
# label = tagList(phosphoricons::ph("scissors"), i18n$t("Split the variable")),
|
|
# class = "btn-outline-primary float-end"
|
|
# )
|
|
# )
|
|
),
|
|
shiny::fluidRow(
|
|
column(
|
|
width = 4,
|
|
shiny::h4(i18n$t("Original data")),
|
|
toastui::datagridOutput2(outputId = ns("orig_data"))
|
|
# DT::DTOutput(outputId = ns("orig_data_3"))
|
|
# This doesn't render...
|
|
# toastui::datagridOutput2(outputId = ns("orig_data_2"))
|
|
),
|
|
column(
|
|
width = 8,
|
|
shiny::h4(i18n$t("Preview of result")),
|
|
toastui::datagridOutput2(outputId = ns("new_data"))
|
|
)
|
|
),
|
|
actionButton(
|
|
inputId = ns("create"),
|
|
label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")),
|
|
class = "btn-outline-primary float-end"
|
|
),
|
|
tags$div(class = "clearfix")
|
|
)
|
|
}
|
|
|
|
|
|
|
|
#' @param data_r reactive data
|
|
#'
|
|
#' @returns shiny module server
|
|
#' @export
|
|
#'
|
|
#' @name split-string
|
|
#'
|
|
string_split_server <- function(id, data_r = reactive(NULL)) {
|
|
moduleServer(
|
|
id,
|
|
function(input, output, session) {
|
|
rv <- reactiveValues(data = NULL, target=NULL, temp = NULL, out=NULL)
|
|
|
|
ns <- session$ns
|
|
|
|
# output$no_splits <- shiny::renderText({
|
|
# req({
|
|
# data_r()
|
|
# })
|
|
#
|
|
# if (any(is_splittable(data_r()))) {
|
|
# i18n$t("No character variables with accepted delimiters detected.")
|
|
# }
|
|
# })
|
|
|
|
shiny::observe({
|
|
req(data_r())
|
|
|
|
# if (any(is_splittable(data_r()))) {
|
|
data <- data_r()
|
|
rv$data <- data
|
|
|
|
vars_num <- vapply(data, \(.x){
|
|
is_splittable(.x)
|
|
}, logical(1))
|
|
vars_num <- names(vars_num)[vars_num]
|
|
|
|
req(length(vars_num)>0)
|
|
|
|
output$variable <- shiny::renderUI(
|
|
columnSelectInput(
|
|
inputId = ns("variable"),
|
|
data = data,
|
|
label = i18n$t("Variable to split:"),
|
|
width = "100%",
|
|
col_subset = vars_num,
|
|
selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
|
|
)
|
|
)
|
|
# }
|
|
# shinyWidgets::updateVirtualSelect(
|
|
# inputId = "variable",
|
|
# choices = vars_num,
|
|
# selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
|
|
# )
|
|
})
|
|
|
|
output$delim <- shiny::renderUI({
|
|
req(rv$data)
|
|
req(input$variable)
|
|
# browser()
|
|
|
|
req(input$variable %in% names(rv$data))
|
|
# req({
|
|
# any(apply(data_r(),2,is_splittable))
|
|
# })
|
|
# if (any(is_splittable(data_r()))) {
|
|
data <- rv$data |>
|
|
dplyr::select(tidyselect::all_of(input$variable))
|
|
|
|
delimiters <- Reduce(c, unique(sapply(data[[1]], detect_delimiter)))
|
|
|
|
# shiny::textInput(inputId = ns("delim"), label = i18n$t("Text or character to split string by"))
|
|
shiny::selectInput(
|
|
inputId = ns("delim"), label = i18n$t("Select delimiter"),
|
|
choices = setNames(
|
|
delimiters,
|
|
glue::glue("'{delimiters}'")
|
|
), selected = 1
|
|
)
|
|
# }
|
|
})
|
|
|
|
|
|
output$direction <- shiny::renderUI({
|
|
# req({
|
|
# rv$data
|
|
# })
|
|
|
|
# if (any(is_splittable(data_r()))) {
|
|
vectorSelectInput(
|
|
inputId = ns("direction"),
|
|
label = i18n$t("Direction:"),
|
|
choices = setNames(
|
|
c(
|
|
"wide",
|
|
"long"
|
|
),
|
|
c(
|
|
i18n$t("Split string to multiple columns. Keep number of rows."),
|
|
i18n$t("Split string to multiple observations (rows) in the same column. Also ads id and instance columns")
|
|
)
|
|
),
|
|
selected = "wide",
|
|
width = "100%"
|
|
)
|
|
# }
|
|
})
|
|
|
|
observeEvent(
|
|
list(
|
|
input$variable,
|
|
input$delim,
|
|
input$direction
|
|
),
|
|
{
|
|
req(rv$data)
|
|
req(input$variable)
|
|
req(input$delim)
|
|
req(input$direction)
|
|
|
|
data <- rv$data |>
|
|
dplyr::select(tidyselect::all_of(input$variable))
|
|
# browser()
|
|
rv$temp <- separate_string(
|
|
data = data,
|
|
col = input$variable,
|
|
delim = input$delim,
|
|
direction = input$direction
|
|
)
|
|
}
|
|
)
|
|
|
|
# shiny::observeEvent(input$split, {
|
|
# show_data(rv$temp, title = i18n$t("Browse data preview"), type = "modal")
|
|
# })
|
|
|
|
## Toastui would not render the original data, so the solution was to go
|
|
## with native table rendering, which works, but doesn't please the eye
|
|
|
|
# output$orig_data <- shiny::renderTable({
|
|
# req(data_r())
|
|
# req(input$variable)
|
|
# data <- data_r() |>
|
|
# dplyr::select(tidyselect::all_of(input$variable))
|
|
# # browser()
|
|
# head(data, 10)
|
|
# })
|
|
|
|
output$orig_data <- toastui::renderDatagrid2({
|
|
req(data_r())
|
|
req(input$variable)
|
|
|
|
req(hasName(rv$data, input$variable))
|
|
|
|
data <- data_r() |>
|
|
dplyr::select(tidyselect::all_of(input$variable)) |>
|
|
head(30) |>
|
|
dplyr::mutate(row=dplyr::row_number()) |>
|
|
dplyr::select(row,tidyselect::everything())
|
|
# browser()
|
|
toastui::datagrid(
|
|
data = data,
|
|
rowHeight = 40,
|
|
colwidths = "guess",
|
|
theme = "default",
|
|
bodyHeight = "auto",
|
|
pagination = 10)
|
|
})
|
|
|
|
output$new_data <- toastui::renderDatagrid2({
|
|
shiny::req(rv$temp)
|
|
data <- rv$temp
|
|
toastui::datagrid(
|
|
data = head(data, 30),
|
|
rowHeight = 40,
|
|
colwidths = "guess",
|
|
theme = "default",
|
|
bodyHeight = "auto", pagination = 10
|
|
)
|
|
})
|
|
|
|
data_split_r <- reactive({
|
|
req(rv$temp)
|
|
|
|
data <- rv$data
|
|
|
|
parameters <- list(
|
|
col = input$variable,
|
|
delim = input$delim,
|
|
direction = input$direction
|
|
)
|
|
|
|
out <- tryCatch({
|
|
rlang::exec(separate_string, !!!modifyList(
|
|
parameters,
|
|
list(
|
|
data = data
|
|
)
|
|
))
|
|
})
|
|
# browser()
|
|
|
|
# separate_string(
|
|
# data = data,
|
|
#
|
|
# )
|
|
|
|
code <- rlang::call2(
|
|
"separate_string",
|
|
!!!parameters,
|
|
.ns = "FreesearchR"
|
|
)
|
|
attr(out, "code") <- code
|
|
out})
|
|
|
|
data_returned_r <- observeEvent(input$create, {
|
|
rv$out <- data_split_r()
|
|
})
|
|
|
|
return(reactive(rv$out))
|
|
}
|
|
)
|
|
}
|
|
|
|
|
|
#' @param title Modal title
|
|
#' @param easyClose easyClose
|
|
#' @param size size
|
|
#' @param footer footer
|
|
#'
|
|
#' @returns shiny modal
|
|
#' @export
|
|
#'
|
|
#' @name split-string
|
|
modal_string_split <- function(id,
|
|
title = i18n$t("Split character string"),
|
|
easyClose = TRUE,
|
|
size = "xl",
|
|
footer = NULL) {
|
|
ns <- NS(id)
|
|
showModal(modalDialog(
|
|
title = tagList(title, datamods:::button_close_modal()),
|
|
string_split_ui(id),
|
|
tags$div(
|
|
style = "display: none;",
|
|
textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
|
),
|
|
easyClose = easyClose,
|
|
size = size,
|
|
footer = footer
|
|
))
|
|
}
|
|
|
|
|
|
### Helpers
|
|
|
|
#' Separate string wide or long
|
|
#'
|
|
#' @param data data
|
|
#' @param col column
|
|
#' @param delim delimiter
|
|
#' @param direction target direction
|
|
#'
|
|
#' @returns data.frame
|
|
#' @export
|
|
#'
|
|
separate_string <- function(data, col, delim, direction = c("wide", "long")) {
|
|
direction <- match.arg(direction)
|
|
|
|
if (direction == "long") {
|
|
out <- data |>
|
|
dplyr::mutate(id_str_split = dplyr::row_number()) |>
|
|
dplyr::group_by_at("id_str_split") |>
|
|
tidyr::separate_longer_delim(cols = tidyselect::all_of(col), delim = delim) |>
|
|
dplyr::mutate(instance_str_split = dplyr::row_number()) |>
|
|
# add_instance(by="id")
|
|
dplyr::ungroup() |>
|
|
dplyr::mutate(dplyr::across(tidyselect::matches(col), trimws))
|
|
} else if (direction == "wide") {
|
|
## Experiment of wide to long
|
|
|
|
out <- data |>
|
|
tidyr::separate_wider_delim(
|
|
cols = tidyselect::all_of(col),
|
|
delim = delim,
|
|
names_sep = "_",
|
|
too_few = "align_start"
|
|
) |>
|
|
dplyr::mutate(dplyr::across(tidyselect::starts_with(col), trimws))
|
|
}
|
|
|
|
out
|
|
}
|
|
|
|
|
|
|
|
#' Detect delimiters in string based on allowed delimiters
|
|
#'
|
|
#' @description
|
|
#' Accepts any repeat of delimiters and includes surrounding whitespace
|
|
#'
|
|
#'
|
|
#' @param text character vector
|
|
#' @param delimiters allowed delimiters
|
|
#'
|
|
#' @returns character vector
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' sapply(c("Walk - run", "Sel__Re", "what;now"), detect_delimiter)
|
|
detect_delimiter <- function(data, delimiters = c("_", "-", ";", "\n", ",")) {
|
|
# Create patterns for each delimiter with potential surrounding whitespace
|
|
patterns <- paste0("\\s*\\", delimiters, "+\\s*")
|
|
|
|
# Check each pattern
|
|
out <- sapply(patterns, \(.x){
|
|
if (grepl(.x, data)) {
|
|
# Extract the actual matched delimiter with whitespace
|
|
regmatches(data, regexpr(.x, data))
|
|
}
|
|
})
|
|
|
|
Reduce(c, out)
|
|
}
|
|
|
|
|
|
#' Determine if any variable in data frame character and contains recognized delimiters
|
|
#'
|
|
#' @param data vector or data.frame
|
|
#'
|
|
#' @returns logical
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' any(apply(mtcars, 2, is_splittable))
|
|
#' is_splittable(mtcars)
|
|
is_splittable <- function(data) {
|
|
if (is.data.frame(data)) {
|
|
return(apply(data, 2, is_splittable))
|
|
}
|
|
|
|
if (is.character(data)) {
|
|
if (length(Reduce(c, unique(sapply(data, detect_delimiter)))) > 0) {
|
|
TRUE
|
|
} else {
|
|
FALSE
|
|
}
|
|
} else {
|
|
FALSE
|
|
}
|
|
}
|
|
|
|
# mtcars |> simple_dt()
|
|
simple_dt <- function(data,...){
|
|
headerCallbackRemoveHeaderFooter <- c(
|
|
"function(thead, data, start, end, display){",
|
|
" $('th', thead).css('display', 'none');",
|
|
"}"
|
|
)
|
|
|
|
DT::datatable(
|
|
data,
|
|
options = list(
|
|
dom = "t",
|
|
ordering = FALSE,
|
|
paging = FALSE,
|
|
searching = FALSE,
|
|
# headerCallback = DT::JS(headerCallbackRemoveHeaderFooter),
|
|
columnDefs = list(
|
|
list(
|
|
targets = 1,
|
|
render = DT::JS(
|
|
"function(data, type, row, meta) {",
|
|
"return type === 'display' && data.length > 10 ?",
|
|
"'<span title=\"' + data + '\">' + data.substr(0, 10) + '...</span>' : data;",
|
|
"}")))
|
|
),
|
|
selection = 'none',
|
|
callback = DT::JS(
|
|
"$('table.dataTable.no-footer').css('border-bottom', 'none');"
|
|
),
|
|
class = 'row-border',
|
|
escape = FALSE,
|
|
rownames = FALSE,
|
|
# width = 500,
|
|
filter = "none"
|
|
)
|
|
}
|