andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 04:27:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

feat: dropped auto dropping empty factor levels

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-03-27 21:54:19 +01:00
commit 748a3c3e07
No known key found for this signature in database
2 changed files with 42 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

44
R/update-factor-ext.R
View file

@ -29,15 +29,26 @@ update_factor_ui <- function(id) {
),
fluidRow(
column(
width = 6,
width = 3,
shinyWidgets::virtualSelectInput(
inputId = ns("variable"),
label = i18n$t("Factor variable to reorder:"),
label = i18n$t("Choose variable:"),
choices = NULL,
width = "100%",
zIndex = 50
)
),
column(
width = 3,
class = "d-flex align-items-end",
actionButton(
disabled = TRUE,
inputId = ns("drop_levels"),
label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")),
class = "btn-outline-primary mb-3",
width = "100%"
)
),
column(
width = 3,
class = "d-flex align-items-end",
@ -70,7 +81,9 @@ update_factor_ui <- function(id) {
class = "float-end",
shinyWidgets::prettyCheckbox(
inputId = ns("new_var"),
label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"),
label = i18n$t(
"Create a new variable; otherwise replaces (Updating labels always creates new variable)"
),
value = FALSE,
status = "primary",
outline = TRUE,
@ -125,6 +138,20 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
rv$data_grid <- grid
})
observeEvent(rv$data_grid, {
variable <- req(input$variable)
if (isTRUE(has_empty_levels(rv$data[[variable]]))) {
# browser()
updateActionButton(inputId = "drop_levels", disabled = FALSE)
} else {
updateActionButton(inputId = "drop_levels", disabled = TRUE)
}
})
observeEvent(input$drop_levels, {
rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,]
})
observeEvent(input$sort_levels, {
if (input$sort_levels %% 2 == 1) {
decreasing <- FALSE
@ -208,7 +235,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
)
data <- tryCatch({
with_labels(data,{
with_labels(data, {
rlang::exec(factor_new_levels_labels,
!!!modifyList(parameters, val = list(data = data)))
})
@ -370,3 +397,12 @@ unique_names <- function(new, existing = character()) {
new_names[-seq_along(existing)]
}
has_empty_levels <- function(x) {
if (is.factor(x)) {
any(!levels(x) %in% x)
} else {
return(FALSE)
}
}