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

new version and formatted code

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-02-23 13:22:52 +01:00
commit a7d8fd4b36
No known key found for this signature in database
27 changed files with 3736 additions and 3189 deletions
Download patch file Download diff file Expand all files Collapse all files

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'26.1.2'
app_version <- function()'26.2.1'

132
R/helpers.R
View file

@ -50,7 +50,7 @@ write_quarto <- function(data, ...) {
)
}
write_rmd <- function(data, ..., params.args=NULL) {
write_rmd <- function(data, ..., params.args = NULL) {
# Exports data to temporary location
#
# I assume this is more secure than putting it in the www folder and deleting
@ -65,7 +65,10 @@ write_rmd <- function(data, ..., params.args=NULL) {
## Ref: https://github.com/quarto-dev/quarto-cli/discussions/4041
## Outputs to the same as the .qmd file
rmarkdown::render(
params = modifyList(list(data.file = "web_data.rds",version=app_version()),params.args),
params = modifyList(
list(data.file = "web_data.rds", version = app_version()),
params.args
),
# execute_params = list(data.file = temp),
...
)
@ -133,12 +136,7 @@ argsstring2list <- function(string) {
factorize <- function(data, vars) {
if (!is.null(vars)) {
data |>
dplyr::mutate(
dplyr::across(
dplyr::all_of(vars),
REDCapCAST::as_factor
)
)
dplyr::mutate(dplyr::across(dplyr::all_of(vars), REDCapCAST::as_factor))
} else {
data
}
@ -171,32 +169,30 @@ dummy_Imports <- function() {
#' @returns data
#' @export
#'
file_export <- function(data, output.format = c("df", "teal", "list"), filename, ...) {
file_export <- function(data,
output.format = c("df", "teal", "list"),
filename,
...) {
output.format <- match.arg(output.format)
filename <- gsub("-", "_", filename)
if (output.format == "teal") {
out <- within(
teal_data(),
{
assign(name, value |>
out <- within(teal_data(), {
assign(
name,
value |>
dplyr::bind_cols(.name_repair = "unique_quiet") |>
default_parsing())
},
value = data,
name = filename
)
default_parsing()
)
}, value = data, name = filename)
datanames(out) <- filename
} else if (output.format == "df") {
out <- data |>
default_parsing()
} else if (output.format == "list") {
out <- list(
data = data,
name = filename
)
out <- list(data = data, name = filename)
out <- c(out, ...)
}
@ -231,7 +227,8 @@ default_parsing <- function(data) {
remove_nested_list() |>
REDCapCAST::parse_data() |>
REDCapCAST::as_factor() |>
REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |>
REDCapCAST::numchar2fct(numeric.threshold = 8,
character.throshold = 10) |>
REDCapCAST::as_logical() |>
REDCapCAST::fct_drop()
@ -295,9 +292,11 @@ remove_empty_attr <- function(data) {
#' @examples
#' data.frame(a = 1:10, b = NA, c = c(2, NA)) |> remove_empty_cols(cutoff = .5)
remove_empty_cols <- function(data, cutoff = .7) {
filter <- apply(X = data, MARGIN = 2, FUN = \(.x){
sum(as.numeric(!is.na(.x))) / length(.x)
}) >= cutoff
filter <- apply(X = data,
MARGIN = 2,
FUN = \(.x) {
sum(as.numeric(!is.na(.x))) / length(.x)
}) >= cutoff
data[filter]
}
@ -357,14 +356,25 @@ missing_fraction <- function(data) {
#' sample(c(1:8, NA), 20, TRUE)
#' ) |> data_description()
data_description <- function(data, data_text = "Data") {
data <- if (shiny::is.reactive(data)) data() else data
data <- if (shiny::is.reactive(data))
data()
else
data
n <- nrow(data)
n_var <- ncol(data)
n_complete <- sum(complete.cases(data))
p_complete <- signif(100 * n_complete / n, 3)
glue::glue(i18n$t("{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases."))
if (is.null(data)) {
i18n$t("No data present.")
} else {
glue::glue(
i18n$t(
"{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases."
)
)
}
# sprintf(
# "%s has %s observations and %s variables, with %s (%s%%) complete cases.",
# data_text,
@ -473,7 +483,8 @@ if_not_missing <- function(data, default = NULL) {
#' ) |> merge_expression()
merge_expression <- function(data) {
Reduce(
f = function(x, y) rlang::expr(!!x %>% !!y),
f = function(x, y)
rlang::expr(!!x %>% !!y),
x = data
)
}
@ -497,7 +508,8 @@ merge_expression <- function(data) {
pipe_string <- function(data, collapse = "|>\n") {
if (is.list(data)) {
Reduce(
f = function(x, y) glue::glue("{x}{collapse}{y}"),
f = function(x, y)
glue::glue("{x}{collapse}{y}"),
x = data
)
} else {
@ -521,10 +533,15 @@ pipe_string <- function(data, collapse = "|>\n") {
#' merge_expression() |>
#' expression_string()
expression_string <- function(data, assign.str = "") {
exp.str <- if (is.call(data)) deparse(data) else data
exp.str <- if (is.call(data))
deparse(data)
else
data
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = "")))
out <- collapse_spaces(out,preserve_newlines = FALSE)
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub(
'"', "'", paste(exp.str, collapse = "")
), collapse = "")))
out <- collapse_spaces(out, preserve_newlines = FALSE)
gsub("`", "", out)
}
@ -628,10 +645,16 @@ remove_nested_list <- function(data) {
#' rlang::expr(FreesearchR::set_column_label(label = !!ls3)) |> expression_string()
set_column_label <- function(data, label, overwrite = TRUE) {
purrr::imap(data, function(.data, .name) {
ls <- if (is.list(label)) unlist(label) else label
ls <- if (is.list(label))
unlist(label)
else
label
ls[ls == ""] <- NA
if (.name %in% names(ls)) {
out <- REDCapCAST::set_attr(.data, unname(ls[.name]), attr = "label", overwrite = overwrite)
out <- REDCapCAST::set_attr(.data,
unname(ls[.name]),
attr = "label",
overwrite = overwrite)
remove_empty_attr(out)
} else {
.data
@ -682,11 +705,8 @@ append_column <- function(data, column, name, index = "right") {
}
new_df <- setNames(data.frame(column), name)
list(
data[seq_len(index - 1)],
new_df,
if (!index > ncol(data)) data[index:ncol(data)]
) |>
list(data[seq_len(index - 1)], new_df, if (!index > ncol(data))
data[index:ncol(data)]) |>
dplyr::bind_cols()
}
@ -711,7 +731,7 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
lagged <- c(FALSE, data[seq_len(length(data) - 1)])
}
vapply(seq_len(length(data)), \(.x){
vapply(seq_len(length(data)), \(.x) {
if (isTRUE(no.name)) {
identical(unname(lagged[.x]), unname(data[.x]))
} else {
@ -730,8 +750,11 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
#'
#' @examples
#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
simple_snake <- function(data){
gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE)
simple_snake <- function(data) {
gsub("[\\s+]",
"_",
gsub("[^\\w\\s:-]", "", tolower(data), perl = TRUE),
perl = TRUE)
}
#' Data type assessment.
@ -768,7 +791,8 @@ data_type <- function(data) {
out <- "empty"
} else if (l_unique < 2) {
out <- "monotone"
} else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) {
} else if (any(c("factor", "logical") %in% cl_d) |
l_unique == 2) {
if (identical("logical", cl_d) | l_unique == 2) {
out <- "dichotomous"
} else {
@ -804,13 +828,17 @@ data_type <- function(data) {
#' data_types()
data_types <- function() {
list(
"empty" = list(descr="Variable of all NAs",classes="Any class"),
"monotone" = list(descr="Variable with only one unique value",classes="Any class"),
"dichotomous" = list(descr="Variable with only two unique values",classes="Any class"),
"categorical"= list(descr="Factor variable",classes="factor (ordered or unordered)"),
"text"= list(descr="Character variable",classes="character"),
"datetime"= list(descr="Variable of time, date or datetime values",classes="hms, Date, POSIXct and POSIXt"),
"continuous"= list(descr="Numeric variable",classes="numeric, integer or double"),
"unknown"= list(descr="Anything not falling within the previous",classes="Any other class")
"empty" = list(descr = "Variable of all NAs", classes = "Any class"),
"monotone" = list(descr = "Variable with only one unique value", classes =
"Any class"),
"dichotomous" = list(descr = "Variable with only two unique values", classes =
"Any class"),
"categorical" = list(descr = "Factor variable", classes = "factor (ordered or unordered)"),
"text" = list(descr = "Character variable", classes = "character"),
"datetime" = list(descr = "Variable of time, date or datetime values", classes =
"hms, Date, POSIXct and POSIXt"),
"continuous" = list(descr = "Numeric variable", classes = "numeric, integer or double"),
"unknown" = list(descr = "Anything not falling within the previous", classes =
"Any other class")
)
}

2
R/hosted_version.R
View file

@ -1 +1 @@
hosted_version <- function()'v26.1.2-260112'
hosted_version <- function()'v26.2.1-260223'

BIN
R/sysdata.rda
View file

Binary file not shown.

1
R/translate.R
View file

@ -7,4 +7,3 @@ language_choices <- function() {
# "🇸🇪 Svenska" = "sv"
)
}

203
R/ui_elements.R
View file

@ -25,7 +25,7 @@ ui_elements <- function(selection) {
## Default just output "NULL"
## This could probably be achieved more legantly, but this works.
dev_banner(),
landing_page_ui(i18n=i18n),
landing_page_ui(i18n = i18n),
# shiny::column(width = 2),
# shiny::column(
# width = 8,
@ -68,7 +68,11 @@ ui_elements <- function(selection) {
),
# shiny::tags$script('document.querySelector("#source div").style.width = "100%"'),
## Update this to change depending on run locally or hosted
shiny::helpText(i18n$t("Upload a file, get data directly from REDCap or use local or sample data.")),
shiny::helpText(
i18n$t(
"Upload a file, get data directly from REDCap or use local or sample data."
)
),
shiny::br(),
shiny::br(),
shiny::conditionalPanel(
@ -77,7 +81,11 @@ ui_elements <- function(selection) {
id = "file_import",
layout_params = "dropdown",
# title = "Choose a datafile to upload",
file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta")
file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta"),
limit_default = global_freesearchR$data_limit_default,
limit_lower = global_freesearchR$data_limit_lower,
limit_upper = global_freesearchR$data_limit_upper
)
),
shiny::conditionalPanel(
@ -90,17 +98,15 @@ ui_elements <- function(selection) {
# shiny::HTML(i18n$t("<p>The <em><strong>FreesearchR</strong></em> app only stores data for analyses, but please only use with sensitive data when running locally. <a href='https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine'>Read more here</a></p>")),
# dismissible = TRUE
# ),
m_redcap_readUI(
id = "redcap_import",
title = ""
)
m_redcap_readUI(id = "redcap_import", title = "")
),
shiny::conditionalPanel(
condition = "input.source=='env'",
import_globalenv_ui(
id = "env",
title = NULL,
packages = c("NHANES", "stRoke", "datasets", "MASS")
packages = c("NHANES", "stRoke", "datasets", "MASS"),
globalenv = global_freesearchR$include_globalenv
)
),
# shiny::conditionalPanel(
@ -136,7 +142,11 @@ ui_elements <- function(selection) {
format = shinyWidgets::wNumbFormat(decimals = 0),
color = datamods:::get_primary_color()
),
shiny::helpText(i18n$t("At 0, only complete variables are included; at 100, all variables are included.")),
shiny::helpText(
i18n$t(
"At 0, only complete variables are included; at 100, all variables are included."
)
),
shiny::br()
),
shiny::column(
@ -185,7 +195,9 @@ ui_elements <- function(selection) {
width = 9,
shiny::uiOutput(outputId = "data_info", inline = TRUE),
shiny::tags$p(
i18n$t("Below you find a summary table for quick insigths, and on the right you can visualise data classes, browse observations and apply different data filters.")
i18n$t(
"Below you find a summary table for quick insigths, and on the right you can visualise data classes, browse observations and apply different data filters."
)
)
),
shiny::column(
@ -221,16 +233,18 @@ ui_elements <- function(selection) {
shiny::column(
width = 3,
shiny::tags$h6(i18n$t("Filter data types")),
shiny::uiOutput(
outputId = "column_filter"
),
shiny::uiOutput(outputId = "column_filter"),
## This needs to run in server for translation
shiny::helpText("Read more on how ", tags$a(
"data types",
href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html",
target = "_blank",
rel = "noopener noreferrer"
), " are defined."),
shiny::helpText(
"Read more on how ",
tags$a(
"data types",
href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html",
target = "_blank",
rel = "noopener noreferrer"
),
" are defined."
),
validation_ui("validation_var"),
shiny::br(),
shiny::br(),
@ -250,21 +264,26 @@ ui_elements <- function(selection) {
title = i18n$t("Edit and create data"),
icon = shiny::icon("file-pen"),
tags$h3(i18n$t("Subset, rename and convert variables")),
fluidRow(
shiny::column(
width = 9,
shiny::tags$p(
i18n$t("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."),
i18n$t("There are more advanced options to modify factor/categorical variables as well as create new factor from an existing variable or new variables with R code. At the bottom you can restore the original data."),
i18n$t("Please note that data modifications are applied before any filtering.")
fluidRow(shiny::column(
width = 9, shiny::tags$p(
i18n$t(
"Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."
),
i18n$t(
"There are more advanced options to modify factor/categorical variables as well as create new factor from an existing variable or new variables with R code. At the bottom you can restore the original data."
),
i18n$t(
"Please note that data modifications are applied before any filtering."
)
)
),
)),
update_variables_ui("modal_variables"),
shiny::tags$br(),
shiny::tags$br(),
shiny::tags$h4(i18n$t("Advanced data manipulation")),
shiny::tags$p(i18n$t("Below options allow more advanced varaible manipulations.")),
shiny::tags$p(
i18n$t("Below options allow more advanced varaible manipulations.")
),
shiny::tags$br(),
shiny::tags$br(),
shiny::fluidRow(
@ -276,7 +295,9 @@ ui_elements <- function(selection) {
width = "100%"
),
shiny::tags$br(),
shiny::helpText(i18n$t("Reorder or rename the levels of factor/categorical variables.")),
shiny::helpText(
i18n$t("Reorder or rename the levels of factor/categorical variables.")
),
shiny::tags$br(),
shiny::tags$br()
),
@ -288,7 +309,11 @@ ui_elements <- function(selection) {
width = "100%"
),
shiny::tags$br(),
shiny::helpText(i18n$t("Create factor/categorical variable from a continous variable (number/date/time).")),
shiny::helpText(
i18n$t(
"Create factor/categorical variable from a continous variable (number/date/time)."
)
),
shiny::tags$br(),
shiny::tags$br()
),
@ -300,7 +325,9 @@ ui_elements <- function(selection) {
width = "100%"
),
shiny::tags$br(),
shiny::helpText(i18n$t("Split a text column by a recognised delimiter.")),
shiny::helpText(i18n$t(
"Split a text column by a recognised delimiter."
)),
shiny::tags$br(),
shiny::tags$br()
),
@ -312,16 +339,18 @@ ui_elements <- function(selection) {
width = "100%"
),
shiny::tags$br(),
shiny::helpText(i18n$t("Create a new variable based on an R-expression.")),
shiny::helpText(i18n$t(
"Create a new variable based on an R-expression."
)),
shiny::tags$br(),
shiny::tags$br()
)
),
tags$h4(i18n$t("Compare modified data to original")),
shiny::tags$br(),
shiny::tags$p(
i18n$t("Raw print of the original vs the modified data.")
),
shiny::tags$p(i18n$t(
"Raw print of the original vs the modified data."
)),
shiny::tags$br(),
shiny::fluidRow(
shiny::column(
@ -342,7 +371,11 @@ ui_elements <- function(selection) {
width = "100%"
),
shiny::tags$br(),
shiny::helpText(i18n$t("Reset to original imported dataset. Careful! There is no un-doing.")),
shiny::helpText(
i18n$t(
"Reset to original imported dataset. Careful! There is no un-doing."
)
),
shiny::tags$br(),
shiny::tags$br()
)
@ -388,7 +421,11 @@ ui_elements <- function(selection) {
# ),
shiny::uiOutput("detail_level"),
shiny::uiOutput("strat_var"),
shiny::helpText(i18n$t("Only factor/categorical variables are available for stratification. Go back to the 'Prepare' tab to reclass a variable if it's not on the list.")),
shiny::helpText(
i18n$t(
"Only factor/categorical variables are available for stratification. Go back to the 'Prepare' tab to reclass a variable if it's not on the list."
)
),
shiny::conditionalPanel(
condition = "input.strat_var!='none'",
shiny::radioButtons(
@ -396,10 +433,7 @@ ui_elements <- function(selection) {
label = i18n$t("Compare strata?"),
selected = "no",
inline = TRUE,
choices = list(
"No" = "no",
"Yes" = "yes"
)
choices = list("No" = "no", "Yes" = "yes")
),
# shiny::helpText(i18n$t("Option to perform statistical comparisons between strata in baseline table.")),
shiny::br(),
@ -408,10 +442,7 @@ ui_elements <- function(selection) {
label = i18n$t("Include group differences"),
selected = "no",
inline = TRUE,
choices = list(
"No" = "no",
"Yes" = "yes"
)
choices = list("No" = "no", "Yes" = "yes")
)
),
shiny::br(),
@ -422,7 +453,9 @@ ui_elements <- function(selection) {
icon = shiny::icon("calculator"),
disabled = TRUE
),
shiny::helpText(i18n$t("Press 'Evaluate' to create the comparison table."))
shiny::helpText(i18n$t(
"Press 'Evaluate' to create the comparison table."
))
)
)
),
@ -444,7 +477,11 @@ ui_elements <- function(selection) {
title = "Settings",
icon = bsicons::bs_icon("bounding-box"),
shiny::uiOutput("outcome_var_cor"),
shiny::helpText(i18n$t("To avoid evaluating the correlation of the outcome variable, this can be excluded from the plot or select 'none'.")),
shiny::helpText(
i18n$t(
"To avoid evaluating the correlation of the outcome variable, this can be excluded from the plot or select 'none'."
)
),
shiny::br(),
shinyWidgets::noUiSliderInput(
inputId = "cor_cutoff",
@ -456,24 +493,22 @@ ui_elements <- function(selection) {
format = shinyWidgets::wNumbFormat(decimals = 2),
color = datamods:::get_primary_color()
),
shiny::helpText(i18n$t("Set the cut-off for considered 'highly correlated'."))
shiny::helpText(i18n$t(
"Set the cut-off for considered 'highly correlated'."
))
)
)
),
data_correlations_ui(id = "correlations", height = 600)
)
),
do.call(
bslib::nav_panel,
c(
list(
title = i18n$t("Missings"),
icon = bsicons::bs_icon("x-circle")
),
data_missings_ui(id = "missingness",
validation_ui("validation_mcar"))
)
)
do.call(bslib::nav_panel, c(
list(
title = i18n$t("Missings"),
icon = bsicons::bs_icon("x-circle")
),
data_missings_ui(id = "missingness", validation_ui("validation_mcar"))
))
),
##############################################################################
#########
@ -508,10 +543,7 @@ ui_elements <- function(selection) {
title = i18n$t("Regression"),
icon = shiny::icon("calculator"),
value = "nav_analyses",
do.call(
bslib::navset_card_tab,
regression_ui("regression")
)
do.call(bslib::navset_card_tab, regression_ui("regression"))
),
##############################################################################
#########
@ -533,7 +565,11 @@ ui_elements <- function(selection) {
shiny::column(
width = 6,
shiny::h4(i18n$t("Report")),
shiny::helpText(i18n$t("Choose your favourite output file format for further work, and download, when the analyses are done.")),
shiny::helpText(
i18n$t(
"Choose your favourite output file format for further work, and download, when the analyses are done."
)
),
shiny::br(),
shiny::br(),
shiny::selectInput(
@ -561,7 +597,9 @@ ui_elements <- function(selection) {
shiny::column(
width = 6,
shiny::h4("Data"),
shiny::helpText("Choose your favourite output data format to download the modified data."),
shiny::helpText(
"Choose your favourite output data format to download the modified data."
),
shiny::br(),
shiny::br(),
shiny::selectInput(
@ -588,16 +626,27 @@ ui_elements <- function(selection) {
shiny::br(),
shiny::br(),
shiny::h4("Code snippets"),
shiny::tags$p("Below are the code bits used to create the final data set and the main analyses."),
shiny::tags$p("This can be used as a starting point for learning to code and for reproducibility."),
shiny::tagList(
lapply(
paste0("code_", c(
"import", "format", "data", "variables", "filter", "table1", "univariable", "multivariable"
)),
\(.x)shiny::htmlOutput(outputId = .x)
)
shiny::tags$p(
"Below are the code bits used to create the final data set and the main analyses."
),
shiny::tags$p(
"This can be used as a starting point for learning to code and for reproducibility."
),
shiny::tagList(lapply(
paste0(
"code_",
c(
"import",
"format",
"data",
"variables",
"filter",
"table1",
"univariable",
"multivariable"
)
), \(.x)shiny::htmlOutput(outputId = .x)
)),
shiny::tags$br(),
shiny::br()
),
@ -613,7 +662,8 @@ ui_elements <- function(selection) {
# shiny::img(shiny::icon("book")),
shiny::tags$a(
href = "https://redcap.au.dk/surveys/?s=JPCLPTXYDKFA8DA8",
"Feedback", shiny::icon("arrow-up-right-from-square"),
"Feedback",
shiny::icon("arrow-up-right-from-square"),
target = "_blank",
rel = "noopener noreferrer"
)
@ -627,7 +677,8 @@ ui_elements <- function(selection) {
# shiny::img(shiny::icon("book")),
shiny::tags$a(
href = "https://agdamsbo.github.io/FreesearchR/",
"Docs", shiny::icon("arrow-up-right-from-square"),
"Docs",
shiny::icon("arrow-up-right-from-square"),
target = "_blank",
rel = "noopener noreferrer"
)

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

@ -78,7 +78,10 @@ update_factor_ui <- function(id) {
),
actionButton(
inputId = ns("create"),
label = tagList(phosphoricons::ph("arrow-clockwise"), i18n$t("Update factor variable")),
label = tagList(
phosphoricons::ph("arrow-clockwise"),
i18n$t("Update factor variable")
),
class = "btn-outline-primary"
)
),
@ -97,154 +100,136 @@ update_factor_ui <- function(id) {
#'
#' @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)
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)
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$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(phosphoricons::ph("sort-descending"),
i18n$t("Sort by Levels"))
} else {
decreasing <- TRUE
label <- tagList(phosphoricons::ph("sort-ascending"),
i18n$t("Sort by Levels"))
}
updateActionButton(inputId = "sort_levels", label = 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(phosphoricons::ph("sort-descending"),
i18n$t("Sort by count"))
} else {
decreasing <- TRUE
label <- tagList(phosphoricons::ph("sort-ascending"),
i18n$t("Sort by count"))
}
updateActionButton(inputId = "sort_occurrences", label = 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$t("Levels"), "New label", i18n$t("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)
parameters <- list(
variable = variable,
new_variable = isTRUE(input$new_var) |
any(grid[["Var1_toset"]] == "New label"),
new_levels = as.character(grid[["Var1"]]),
new_labels = as.character(grid[["Var1_toset"]]),
ignore = "New label"
)
data <- tryCatch({
rlang::exec(factor_new_levels_labels,
!!!modifyList(parameters, val = list(data = data)))
}, error = function(err) {
showNotification(paste(
"We encountered the following error creating the new factor:",
err
),
type = "err")
})
observeEvent(input$sort_levels, {
if (input$sort_levels %% 2 == 1) {
decreasing <- FALSE
label <- tagList(
phosphoricons::ph("sort-descending"),
i18n$t("Sort by Levels")
)
} else {
decreasing <- TRUE
label <- tagList(
phosphoricons::ph("sort-ascending"),
i18n$t("Sort by Levels")
)
}
updateActionButton(inputId = "sort_levels", label = label)
rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ]
})
# browser()
code <- rlang::call2("factor_new_levels_labels", !!!parameters, .ns = "FreesearchR")
attr(data, "code") <- code
observeEvent(input$sort_occurrences, {
if (input$sort_occurrences %% 2 == 1) {
decreasing <- FALSE
label <- tagList(
phosphoricons::ph("sort-descending"),
i18n$t("Sort by count")
)
} else {
decreasing <- TRUE
label <- tagList(
phosphoricons::ph("sort-ascending"),
i18n$t("Sort by count")
)
}
updateActionButton(inputId = "sort_occurrences", label = label)
rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ]
})
data
})
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$t("Levels"), "New label", i18n$t("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)
parameters <- list(
variable = variable,
new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
new_levels = as.character(grid[["Var1"]]),
new_labels = as.character(grid[["Var1_toset"]]),
ignore = "New label"
)
data <- tryCatch(
{
rlang::exec(
factor_new_levels_labels,
!!!modifyList(parameters,
val = list(data = data)
)
)
},
error = function(err) {
showNotification(paste("We encountered the following error creating the new factor:", err), type = "err")
}
)
# browser()
code <- rlang::call2(
"factor_new_levels_labels",
!!!parameters,
.ns = "FreesearchR"
)
attr(data, "code") <- code
data
})
data_returned_r <- observeEvent(input$create, {
rv$data <- data_updated_r()
})
return(reactive(rv$data))
}
)
data_returned_r <- observeEvent(input$create, {
rv$data <- data_updated_r()
})
return(reactive(rv$data))
})
}
#' Simple function to apply new levels and/or labels to factor
@ -261,13 +246,12 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
#' data_n <- mtcars
#' data_n$cyl <- factor(data_n$cyl)
#' factor_new_levels_labels(data_n, "cyl", new_labels = c("four", "New label", "New label"))
factor_new_levels_labels <- function(
data,
variable,
new_variable = TRUE,
new_levels = NULL,
new_labels = NULL,
ignore = "New label") {
factor_new_levels_labels <- function(data,
variable,
new_variable = TRUE,
new_levels = NULL,
new_labels = NULL,
ignore = "New label") {
if (!is.factor(data[[variable]])) {
return(data)
}
@ -280,21 +264,19 @@ factor_new_levels_labels <- function(
new_labels <- labels(data[[variable]])
}
with_level <- factor(
as.character(data[[variable]]),
levels = new_levels
)
with_label <- factor(
with_level,
labels = ifelse(new_labels == "New label", new_levels, new_labels)
)
with_level <- factor(as.character(data[[variable]]), levels = new_levels)
with_label <- factor(with_level,
labels = ifelse(new_labels == "New label", new_levels, new_labels))
if (isTRUE(new_variable)) {
append_column(
data = data,
column = with_label,
name = unique_names(new = paste0(variable, "_updated"), existing = names(data))
name = unique_names(
new = paste0(variable, "_updated"),
existing = names(data)
)
)
} else {
data[[variable]] <- with_label
@ -303,7 +285,6 @@ factor_new_levels_labels <- function(
}
#' @inheritParams shiny::modalDialog
#' @export
#'
@ -317,17 +298,23 @@ modal_update_factor <- function(id,
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
))
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
)
)
}
@ -346,10 +333,11 @@ winbox_update_factor <- function(id,
title = title,
ui = tagList(
update_factor_ui(id),
tags$div(
style = "display: none;",
textInput(inputId = ns("hidden"), label = NULL, value = genId())
)
tags$div(style = "display: none;", textInput(
inputId = ns("hidden"),
label = NULL,
value = genId()
))
),
options = modifyList(
shinyWidgets::wbOptions(height = "615px", modal = TRUE),