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

4
R/helpers.R
View file

@ -230,8 +230,8 @@ default_parsing <- function(data) {
REDCapCAST::as_factor() |> REDCapCAST::as_factor() |>
REDCapCAST::numchar2fct(numeric.threshold = 8, REDCapCAST::numchar2fct(numeric.threshold = 8,
character.throshold = 10) |> character.throshold = 10) |>
REDCapCAST::as_logical() |> REDCapCAST::as_logical() #|>
REDCapCAST::fct_drop() # REDCapCAST::fct_drop()
}) })
# out <- # out <-
# #

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

@ -29,15 +29,26 @@ update_factor_ui <- function(id) {
), ),
fluidRow( fluidRow(
column( column(
width = 6, width = 3,
shinyWidgets::virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("variable"), inputId = ns("variable"),
label = i18n$t("Factor variable to reorder:"), label = i18n$t("Choose variable:"),
choices = NULL, choices = NULL,
width = "100%", width = "100%",
zIndex = 50 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( column(
width = 3, width = 3,
class = "d-flex align-items-end", class = "d-flex align-items-end",
@ -70,7 +81,9 @@ update_factor_ui <- function(id) {
class = "float-end", class = "float-end",
shinyWidgets::prettyCheckbox( shinyWidgets::prettyCheckbox(
inputId = ns("new_var"), 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, value = FALSE,
status = "primary", status = "primary",
outline = TRUE, outline = TRUE,
@ -125,6 +138,20 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
rv$data_grid <- grid 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, { observeEvent(input$sort_levels, {
if (input$sort_levels %% 2 == 1) { if (input$sort_levels %% 2 == 1) {
decreasing <- FALSE decreasing <- FALSE
@ -208,7 +235,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
) )
data <- tryCatch({ data <- tryCatch({
with_labels(data,{ with_labels(data, {
rlang::exec(factor_new_levels_labels, rlang::exec(factor_new_levels_labels,
!!!modifyList(parameters, val = list(data = data))) !!!modifyList(parameters, val = list(data = data)))
}) })
@ -370,3 +397,12 @@ unique_names <- function(new, existing = character()) {
new_names[-seq_along(existing)] new_names[-seq_along(existing)]
} }
has_empty_levels <- function(x) {
if (is.factor(x)) {
any(!levels(x) %in% x)
} else {
return(FALSE)
}
}