madeliri/shiny_form
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: correct data loading

Browse Source
This commit is contained in:
madeliri
2026-04-13 19:30:27 +03:00
parent 4c3d339361
commit 2f62a94afa
8 changed files with 97 additions and 97 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
app.R
View File

@@ -11,8 +11,6 @@ suppressPackageStartupMessages({
# КАК ЗАПРЯТЯАТЬ ID
source("helpers/functions.R")
# SOURCE FILES ============================
box::purge_cache()
box::use(
@@ -178,7 +176,7 @@ server <- function(input, output, session) {
} else {
# list of rendered panels
validator_main(data_validation$init_val(mhcs()$get_schema("main")))
validator_main(data_validation$init_val(mhcs()$get_scheme("main")))
validator_main()$enable()
mhcs()$get_main_form_ui
}
@@ -206,8 +204,8 @@ server <- function(input, output, session) {
if (missing(ns)) ns <- NULL
# transform df to list
loaded_df_for_id <- as.list(df)
loaded_df_for_id <- df[input_ids]
# loaded_df_for_id <- as.list(df)
# loaded_df_for_id <- df[input_ids]
# rewrite input forms
purrr::walk2(
@@ -220,7 +218,7 @@ server <- function(input, output, session) {
form_id = x_id,
form_type = x_type,
value = df[[x_id]],
scheme = mhcs()$get_schema(table_name),
scheme = mhcs()$get_scheme(table_name),
ns = ns
)
}
@@ -341,7 +339,7 @@ server <- function(input, output, session) {
key_id <- mhcs()$get_key_id(values$nested_form_id)
# загрузка схемы для данной вложенной формы
this_nested_form_scheme <- mhcs()$get_schema(values$nested_form_id)
this_nested_form_scheme <- mhcs()$get_scheme(values$nested_form_id)
# мини-схема для ключа
this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == key_id)
@@ -431,16 +429,17 @@ server <- function(input, output, session) {
con = con
)
col_types <- mhcs()$get_schema_with_values_forms(values$nested_form_id) |>
col_types <- mhcs()$get_scheme_with_values_forms(values$nested_form_id) |>
dplyr::distinct(form_id, form_type, form_label)
date_cols <- which(col_types$form_type == "date")
str_cols <- which(col_types$form_type != "date")
values$data <- values$data |>
select(-mhcs()$get_main_key_id) |>
mutate(
dplyr::across(tidyselect::all_of({{date_cols}}), as.Date)
dplyr::across(tidyselect::all_of({{date_cols}}), as.Date),
dplyr::across(tidyselect::all_of({{str_cols}}), as.character),
) |>
arrange({{key_id}})
@@ -460,7 +459,8 @@ server <- function(input, output, session) {
keys = TRUE
)
) |>
DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU')) |>
DT::formatString(str_cols)
)
showModal(modalDialog(
@@ -598,7 +598,7 @@ server <- function(input, output, session) {
removeModal()
# та самая форма для ключа
scheme_for_key_input <- mhcs()$get_schema(values$nested_form_id) |>
scheme_for_key_input <- mhcs()$get_scheme(values$nested_form_id) |>
dplyr::filter(form_id == mhcs()$get_key_id(values$nested_form_id))
ui1 <- rlang::exec(
@@ -678,7 +678,7 @@ server <- function(input, output, session) {
observeEvent(input$add_new_main_key_button, {
# данные для главного ключа
scheme_for_key_input <- mhcs()$get_schema("main") |>
scheme_for_key_input <- mhcs()$get_scheme("main") |>
dplyr::filter(form_id == mhcs()$get_main_key_id)
# создать форму для выбора ключа
@@ -864,7 +864,7 @@ server <- function(input, output, session) {
tibble::as_tibble()
# handle with data
scheme <- mhcs()$get_schema(x)
scheme <- mhcs()$get_scheme(x)
date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
@@ -916,10 +916,11 @@ server <- function(input, output, session) {
"---",
"\n"
)
box::use(modules/data_manipulations[is_this_empty_value])
# iterate by scheme parts
purrr::walk(
.x = unique(mhcs()$get_schema("main")$part),
.x = unique(mhcs()$get_scheme("main")$part),
.f = \(x_iter1) {
# write level 1 header
HEADER_1 <- paste("#", x_iter1, "\n")
@@ -927,14 +928,14 @@ server <- function(input, output, session) {
# iterate by level2 headers (subgroups)
purrr::walk(
.x = dplyr::pull(unique(subset(mhcs()$get_schema("main"), part == x_iter1, "subgroup"))),
.x = dplyr::pull(unique(subset(mhcs()$get_scheme("main"), part == x_iter1, "subgroup"))),
.f = \(x_iter2) {
# get header 2 name
HEADER_2 <- paste("##", x_iter2, "\n")
# for some reason set litle scheme...
litle_scheme <- subset(
x = mhcs()$get_schema("main"),
x = mhcs()$get_scheme("main"),
subset = part == x_iter1 & subgroup == x_iter2,
select = c("form_id", "form_label", "form_type")
) |>
@@ -955,7 +956,7 @@ server <- function(input, output, session) {
if (length(docx_value) > 1) docx_value <- paste(docx_value, collapse = ", ")
# if non empty data - add string
if (!check_for_empty_data(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA
if (!is_this_empty_value(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA
} else if (docx_type == "description") {
# treat description label as citation text
paste0(">", docx_label, "\n")
@@ -1039,7 +1040,7 @@ server <- function(input, output, session) {
for (table_name in mhcs()$all_tables_names) {
df <- openxlsx2::read_xlsx(wb, table_name)
scheme <- mhcs()$get_schema_with_values_forms(table_name)
scheme <- mhcs()$get_scheme_with_values_forms(table_name)
# столбцы в таблицы и схема
df_to_schema_compare <- setdiff(colnames(df), unique(scheme$form_id))
@@ -1064,7 +1065,7 @@ server <- function(input, output, session) {
for (table_name in mhcs()$all_tables_names) {
df <- openxlsx2::read_xlsx(wb, table_name)
scheme <- mhcs()$get_schema_with_values_forms(table_name)
scheme <- mhcs()$get_scheme_with_values_forms(table_name)
date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)

27
helpers/functions.R
View File

@@ -1,27 +0,0 @@
#' @description Function check if variable contains some sort of empty data
#' (NULL, NA, "", other 0-length data) and return `TRUE` (`FALSE` if data is
#' not 'empty').
#'
#' Needed for proper data validation.
#' (ДУБЛИРУЕТ МОДУЛЬ `data_manipulation`)
check_for_empty_data <- function(value_to_check) {
# for any 0-length
if (length(value_to_check) == 0) return(TRUE)
# for NA
if (is.logical(value_to_check) && is.na(value_to_check)) return(TRUE)
# for NULL
if (is.null(value_to_check)) return(TRUE)
# for non-empty Date (RETURN FALSE)
if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE)
# for empty strings (stands before checking non-empty data for avoid mistakes)
if (value_to_check == "") return(TRUE)
FALSE
}

14
modules/data_manipulations.R
View File

@@ -4,7 +4,8 @@
#' not 'empty').
#'
#' Needed for proper data validation.
check_for_empty_data = function(value_to_check) {
#' @export
is_this_empty_value = function(value_to_check) {
# for any 0-length
if (length(value_to_check) == 0) return(TRUE)
@@ -19,7 +20,14 @@ check_for_empty_data = function(value_to_check) {
if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE)
# for empty strings (stands before checking non-empty data for avoid mistakes)
if (is.character(value_to_check)) {
if (is.na(value_to_check)) return(TRUE)
if (value_to_check == "") return(TRUE)
FALSE
}
if (is.double(value_to_check)) {
if (is.na(value_to_check)) return(TRUE)
}
return(FALSE)
}

10
modules/data_validation.R
View File

@@ -3,7 +3,7 @@
init_val = function(scheme, ns) {
options(box.path = here::here())
box::use(modules/data_manipulations[check_for_empty_data])
box::use(modules/data_manipulations[is_this_empty_value])
iv <- shinyvalidate::InputValidator$new()
@@ -39,7 +39,7 @@ init_val = function(scheme, ns) {
iv$add_rule(x_input_id, function(x) {
# exit if empty
if (check_for_empty_data(x)) {
if (is_this_empty_value(x)) {
return(NULL)
}
# хак для пропуска значений
@@ -64,7 +64,7 @@ init_val = function(scheme, ns) {
function(x) {
# exit if empty
if (check_for_empty_data(x)) {
if (is_this_empty_value(x)) {
return(NULL)
}
@@ -85,11 +85,11 @@ init_val = function(scheme, ns) {
}
}
if (form_type %in% c("select_multiple", "select_one")) {
if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) {
iv$add_rule(x_input_id, function(x) {
if (length(x) == 1) {
if (check_for_empty_data(x)) return(NULL)
if (is_this_empty_value(x)) return(NULL)
}
# проверка на соответствие вариантов схеме ---------

2
modules/db.R
View File

@@ -185,7 +185,7 @@ write_df_to_db = function(
con
) {
scheme <- schm$get_schema(table_name)
scheme <- schm$get_scheme(table_name)
main_key_id <- schm$get_main_key_id
nested_key_id <- schm$get_key_id(table_name)

6
modules/global_options.R
View File

@@ -30,7 +30,8 @@ check_and_init_scheme = function() {
cli::cli_inform(c("*" = "проверка схемы..."))
files_to_watch <- c(
"modules/scheme_generator.R"
"modules/scheme_generator.R",
"modules/utils.R"
)
scheme_names <- enabled_schemas
@@ -59,8 +60,9 @@ check_and_init_scheme = function() {
# если данные были изменены проводим реинициализацию таблицы и схемы
if (!all(exist_hash == saved_hash)) {
cli::cli_inform(c(">" = "Данные схемы были изменены..."))
cli::cli_inform(c(">" = "Данные схем были изменены..."))
init_scheme(scheme_file)
} else {
cli::cli_alert_success("изменений нет")
}

10
modules/scheme_generator.R
View File

@@ -1,14 +1,14 @@
#' @export
scheme_R6 <- R6::R6Class(
"schemes_f",
"schemes_generator",
public = list(
initialize = function(scheme_file_path = NULL) {
private$scheme_file_path <- scheme_file_path
# make list of schemas
# make list of schemes
private$schemes_list <- list()
private$schemes_list[["main"]] <- private$load_scheme_from_xlsx("main")
@@ -67,11 +67,11 @@ scheme_R6 <- R6::R6Class(
# возврат схемы ------------------------------------
## полностью -------
get_schema = function(table_name) {
get_scheme = function(table_name) {
private$schemes_list[[table_name]]
},
## с полями имеющие значение -------
get_schema_with_values_forms = function(table_name) {
get_scheme_with_values_forms = function(table_name) {
private$schemes_list[[table_name]] |>
dplyr::filter(!form_type %in% private$excluded_types)
},
@@ -144,7 +144,7 @@ scheme_R6 <- R6::R6Class(
# schm$get_forms_ids("main")
# schm$get_all_ids("main")
# schm$get_schema("main")
# schm$get_scheme("main")
# schm$get_id_type_list("allergo_anamnesis")

74
modules/utils.R
View File

@@ -264,6 +264,14 @@ update_forms_with_data = function(
ns
) {
box::use(modules/data_manipulations[is_this_empty_value])
# print("-----------------")
# cli::cli_inform("form_id: {form_id} | form_type: {form_type}")
# print(value)
# print(typeof(value))
# print(is_this_empty_value(value))
filterd_line <- scheme |>
dplyr::filter(form_id == {{form_id}})
@@ -294,14 +302,46 @@ update_forms_with_data = function(
new_choices <- unique(c(old_choices, value))
new_choices <- new_choices[!is.na(new_choices)]
shiny::updateSelectizeInput(inputId = form_id, selected = value, choices = new_choices)
# shiny::updateSelectizeInput(inputId = form_id, selected = value)
}
# select_multiple
# check if value is not NA and split by delimetr
if (form_type == "select_multiple" && !is.na(value)) {
if (form_type == "select_multiple") {
if (is_this_empty_value(value)) {
shiny::updateSelectizeInput(inputId = form_id, selected = as.character(0))
} else {
vars <- stringr::str_split_1(value, local_delimeter)
# update choices
old_choices <- filterd_line$choices
new_choices <- unique(c(old_choices, vars))
new_choices <- new_choices[!is.na(new_choices)]
shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
}
}
# radio buttons
if (form_type == "radio") {
if (is_this_empty_value(value)) {
shiny::updateRadioButtons(inputId = form_id, selected = character(0))
} else {
# update choices
old_choices <- filterd_line$choices
new_choices <- unique(c(old_choices, value))
new_choices <- new_choices[!is.na(new_choices)]
shiny::updateRadioButtons(inputId = form_id, selected = value, choices = new_choices)
}
}
# checkboxes
if (form_type == "checkbox") {
if (is_this_empty_value(value)) {
shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
} else {
vars <- stringr::str_split_1(value, local_delimeter)
# update choices
@@ -309,35 +349,11 @@ update_forms_with_data = function(
new_choices <- unique(c(old_choices, vars))
new_choices <- new_choices[!is.na(new_choices)]
shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
# shiny::updateSelectizeInput(inputId = form_id, selected = vars)
shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars, choices = new_choices)
}
# in other case fill with `character(0)` to proper reseting form
if (form_type == "select_multiple" && is.na(value)) {
shiny::updateSelectizeInput(inputId = form_id, selected = character(0))
}
# radio buttons
if (form_type == "radio" && !is.na(value)) {
shiny::updateRadioButtons(inputId = form_id, selected = value)
}
if (form_type == "radio" && is.na(value)) {
shiny::updateRadioButtons(inputId = form_id, selected = character(0))
}
# checkboxes
if (form_type == "checkbox" && !is.na(value)) {
vars <- stringr::str_split_1(value, local_delimeter)
shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars)
}
if (form_type == "checkbox" && is.na(value)) {
shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
}
# if (type == "inline_table") {
# message("EMPTY")
# }
}
#' @export
@@ -361,7 +377,7 @@ clean_forms = function(
form_id = x_id,
form_type = x_type,
value = get_empty_data(x_type),
scheme = schm$get_schema(table_name),
scheme = schm$get_scheme(table_name),
ns = ns
)
}