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 = 3, shiny::h4(i18n$t("Original data")), shiny::tableOutput(outputId = ns("orig_data")) # This doesn't render... # toastui::datagridOutput2(outputId = ns("orig_data_2")) ), column(width = 1), column( width = 8, shiny::h4(i18n$t("Preview of result")), shiny::tableOutput(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") ) } string_split_server <- function(id, data_r = reactive(NULL)) { moduleServer( id, function(input, output, session) { rv <- reactiveValues(data = 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] 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({ # 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_2 <- toastui::renderDatagrid2({ # req(data_r()) # req(input$variable) # data <- data_r() |> # dplyr::select(tidyselect::all_of(input$variable)) # # browser() # toastui::datagrid(head(data, 10)) # }) output$new_data <- shiny::renderTable({ shiny::req(rv$temp) data <- rv$temp head(data, 10) # toastui::datagrid( # data = head(data, 100), # 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)) } ) } 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 } }