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::numchar2fct(numeric.threshold = 8,
character.throshold = 10) |>
REDCapCAST::as_logical() |>
REDCapCAST::fct_drop()
REDCapCAST::as_logical() #|>
# REDCapCAST::fct_drop()
})
# out <-
#

42
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
@ -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)
}
}