mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
bumped to 25.2.1 - new visuals tab - all functions in place - code cleanup has started
This commit is contained in:
parent
c4b5a7ba79
commit
14edce9912
36 changed files with 3564 additions and 2976 deletions
292
R/update-factor-ext.R
Normal file
292
R/update-factor-ext.R
Normal file
|
|
@ -0,0 +1,292 @@
|
|||
|
||||
## Works, but not implemented
|
||||
##
|
||||
## These edits mainly allows for
|
||||
|
||||
|
||||
#' @title Module to Reorder the Levels of a Factor Variable
|
||||
#'
|
||||
#' @description
|
||||
#' This module contain an interface to reorder the levels of a factor variable.
|
||||
#'
|
||||
#'
|
||||
#' @param id Module ID.
|
||||
#'
|
||||
#' @return A [shiny::reactive()] function returning the data.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny NS fluidRow tagList column actionButton
|
||||
#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox
|
||||
#' @importFrom toastui datagridOutput
|
||||
#' @importFrom htmltools tags
|
||||
#'
|
||||
#' @name update-factor
|
||||
#'
|
||||
#' @example examples/update_factor.R
|
||||
update_factor_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
tags$style(
|
||||
".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}"
|
||||
),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Factor variable to reorder:"),
|
||||
choices = NULL,
|
||||
width = "100%",
|
||||
zIndex = 50
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
class = "d-flex align-items-end",
|
||||
actionButton(
|
||||
inputId = ns("sort_levels"),
|
||||
label = tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort by levels")
|
||||
),
|
||||
class = "btn-outline-primary mb-3",
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
class = "d-flex align-items-end",
|
||||
actionButton(
|
||||
inputId = ns("sort_occurrences"),
|
||||
label = tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort by count")
|
||||
),
|
||||
class = "btn-outline-primary mb-3",
|
||||
width = "100%"
|
||||
)
|
||||
)
|
||||
),
|
||||
datagridOutput(ns("grid")),
|
||||
tags$div(
|
||||
class = "float-end",
|
||||
prettyCheckbox(
|
||||
inputId = ns("new_var"),
|
||||
label = i18n("Create a new variable (otherwise replaces the one selected)"),
|
||||
value = FALSE,
|
||||
status = "primary",
|
||||
outline = TRUE,
|
||||
inline = TRUE
|
||||
),
|
||||
actionButton(
|
||||
inputId = ns("create"),
|
||||
label = tagList(ph("arrow-clockwise"), i18n("Update factor variable")),
|
||||
class = "btn-outline-primary"
|
||||
)
|
||||
),
|
||||
tags$div(class = "clearfix")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton
|
||||
#' @importFrom shinyWidgets updateVirtualSelect
|
||||
#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar
|
||||
#'
|
||||
#' @rdname update-factor
|
||||
update_factor_server <- function(id, data_r = reactive(NULL)) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
|
||||
rv <- reactiveValues(data = NULL, data_grid = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
data <- data_r()
|
||||
rv$data <- data
|
||||
vars_factor <- vapply(data, is.factor, logical(1))
|
||||
vars_factor <- names(vars_factor)[vars_factor]
|
||||
updateVirtualSelect(
|
||||
inputId = "variable",
|
||||
choices = vars_factor,
|
||||
selected = if (isTruthy(input$variable)) input$variable else vars_factor[1]
|
||||
)
|
||||
}), data_r(), input$hidden)
|
||||
|
||||
observeEvent(input$variable, {
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- as.data.frame(table(data[[variable]]))
|
||||
rv$data_grid <- grid
|
||||
})
|
||||
|
||||
observeEvent(input$sort_levels, {
|
||||
if (input$sort_levels %% 2 == 1) {
|
||||
decreasing <- FALSE
|
||||
label <- tagList(
|
||||
ph("sort-descending"),
|
||||
"Sort Levels"
|
||||
)
|
||||
} else {
|
||||
decreasing <- TRUE
|
||||
label <- tagList(
|
||||
ph("sort-ascending"),
|
||||
"Sort Levels"
|
||||
)
|
||||
}
|
||||
updateActionButton(inputId = "sort_levels", label = as.character(label))
|
||||
rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ]
|
||||
})
|
||||
|
||||
observeEvent(input$sort_occurrences, {
|
||||
if (input$sort_occurrences %% 2 == 1) {
|
||||
decreasing <- FALSE
|
||||
label <- tagList(
|
||||
ph("sort-descending"),
|
||||
i18n("Sort count")
|
||||
)
|
||||
} else {
|
||||
decreasing <- TRUE
|
||||
label <- tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort count")
|
||||
)
|
||||
}
|
||||
updateActionButton(inputId = "sort_occurrences", label = as.character(label))
|
||||
rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ]
|
||||
})
|
||||
|
||||
|
||||
output$grid <- renderDatagrid({
|
||||
req(rv$data_grid)
|
||||
gridTheme <- getOption("datagrid.theme")
|
||||
if (length(gridTheme) < 1) {
|
||||
datamods:::apply_grid_theme()
|
||||
}
|
||||
on.exit(toastui::reset_grid_theme())
|
||||
data <- rv$data_grid
|
||||
data <- add_var_toset(data, "Var1", "New label")
|
||||
|
||||
grid <- datagrid(
|
||||
data = data,
|
||||
draggable = TRUE,
|
||||
sortable = FALSE,
|
||||
data_as_input = TRUE
|
||||
)
|
||||
grid <- grid_columns(
|
||||
grid,
|
||||
columns = c("Var1", "Var1_toset", "Freq"),
|
||||
header = c(i18n("Levels"), "New label", i18n("Count"))
|
||||
)
|
||||
grid <- grid_colorbar(
|
||||
grid,
|
||||
column = "Freq",
|
||||
label_outside = TRUE,
|
||||
label_width = "30px",
|
||||
background = "#D8DEE9",
|
||||
bar_bg = datamods:::get_primary_color(),
|
||||
from = c(0, max(rv$data_grid$Freq) + 1)
|
||||
)
|
||||
grid <- toastui::grid_style_column(
|
||||
grid = grid,
|
||||
column = "Var1_toset",
|
||||
fontStyle = "italic"
|
||||
)
|
||||
grid <- toastui::grid_editor(
|
||||
grid = grid,
|
||||
column = "Var1_toset",
|
||||
type = "text"
|
||||
)
|
||||
grid
|
||||
})
|
||||
|
||||
data_updated_r <- reactive({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- req(input$grid_data)
|
||||
name_var <- if (isTRUE(input$new_var)) {
|
||||
paste0(variable, "_updated")
|
||||
} else {
|
||||
variable
|
||||
}
|
||||
data[[name_var]] <- factor(
|
||||
as.character(data[[variable]]),
|
||||
levels = grid[["Var1"]]
|
||||
)
|
||||
data[[name_var]] <- factor(
|
||||
data[[variable]],
|
||||
labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
|
||||
)
|
||||
data
|
||||
})
|
||||
|
||||
data_returned_r <- observeEvent(input$create, {
|
||||
rv$data <- data_updated_r()
|
||||
})
|
||||
return(reactive(rv$data))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @inheritParams shiny::modalDialog
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny showModal modalDialog textInput
|
||||
#' @importFrom htmltools tagList
|
||||
#'
|
||||
#' @rdname update-factor
|
||||
modal_update_factor <- function(id,
|
||||
title = i18n("Update levels of a factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL) {
|
||||
ns <- NS(id)
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
update_factor_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
||||
),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
#' @inheritParams shinyWidgets::WinBox
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shinyWidgets WinBox wbOptions wbControls
|
||||
#' @importFrom htmltools tagList
|
||||
#' @rdname create-column
|
||||
winbox_update_factor <- function(id,
|
||||
title = i18n("Update levels of a factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()) {
|
||||
ns <- NS(id)
|
||||
WinBox(
|
||||
title = title,
|
||||
ui = tagList(
|
||||
update_factor_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = genId())
|
||||
)
|
||||
),
|
||||
options = modifyList(
|
||||
shinyWidgets::wbOptions(height = "615px", modal = TRUE),
|
||||
options
|
||||
),
|
||||
controls = controls,
|
||||
auto_height = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue