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

0.15.0 (2026-04-07)

Browse Source
This commit is contained in:
madeliri
2026-04-07 11:56:24 +03:00
parent a631166f09
commit 667e511bd9
10 changed files with 875 additions and 566 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
modules/data_validation.R
View File

@@ -15,7 +15,7 @@ init_val <- function(scheme, ns) {
# формируем список id - тип
inputs_simple_list <- scheme |>
dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |>
dplyr::filter(!form_type %in% c("nested_forms","description", "description_header")) |>
dplyr::distinct(form_id, form_type) |>
tibble::deframe()
@@ -42,6 +42,8 @@ init_val <- function(scheme, ns) {
if (check_for_empty_data(x)) {
return(NULL)
}
# хак для пропуска значений
if (x == "NA") return(NULL)
# check for numeric
# if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
@@ -60,14 +62,16 @@ init_val <- function(scheme, ns) {
x_input_id,
function(x) {
# замена разделителя десятичных цифр
x <- stringr::str_replace(x, ",", ".")
# exit if empty
if (check_for_empty_data(x)) {
return(NULL)
}
if (x == "NA") return(NULL)
# замена разделителя десятичных цифр
x <- stringr::str_replace(x, ",", ".")
# check for currect value
if (dplyr::between(as.double(x), ranges[1], ranges[2])) {
NULL

116
modules/db.R
View File

@@ -38,11 +38,25 @@ check_if_table_is_exist_and_init_if_not <- function(
} else {
dummy_df <- dplyr::mutate(get_dummy_df(forms_id_type_list), id = "dummy")
if (table_name == "main") {
dummy_df <- dplyr::mutate(
get_dummy_df(forms_id_type_list),
main_key = "dummy",
.before = 1
)
}
if (table_name != "main") {
dummy_df <- get_dummy_df(forms_id_type_list) |>
dplyr::mutate(
main_key = "dummy",
nested_key = "dummy",
.before = 1
)
}
# write dummy df into base, then delete dummy row
DBI::dbWriteTable(con, table_name, dummy_df, append = TRUE)
DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'")
DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = 'dummy'"))
cli::cli_alert_success("таблица '{table_name}' успешно создана")
}
@@ -86,34 +100,43 @@ compare_existing_table_with_schema <- function(
con = rlang::env_get(rlang::caller_env(), nm = "con")
) {
forms_id_type_list_names <- names(forms_id_type_list)
if (table_name == "main") {
forms_id_type_list_names <- c("main_key", forms_id_type_list_names)
} else {
forms_id_type_list_names <- c("main_key", "nested_key", forms_id_type_list_names)
}
options(box.path = here::here())
box::use(modules/utils)
# checking if db structure in form compatible with alrady writed data (in case on changig form)
if (identical(colnames(DBI::dbReadTable(con, table_name)), names(forms_id_type_list))) {
if (identical(colnames(DBI::dbReadTable(con, table_name)), forms_id_type_list_names)) {
# ...
} else {
df_to_rewrite <- DBI::dbReadTable(con, table_name)
form_base_difference <- setdiff(names(forms_id_type_list), colnames(df_to_rewrite))
base_form_difference <- setdiff(colnames(df_to_rewrite), names(forms_id_type_list))
form_base_difference <- setdiff(forms_id_type_list_names, colnames(df_to_rewrite))
base_form_difference <- setdiff(colnames(df_to_rewrite), forms_id_type_list_names)
# if lengths are equal
if (length(names(forms_id_type_list)) == length(colnames(df_to_rewrite)) &&
if (length(forms_id_type_list_names) == length(colnames(df_to_rewrite)) &&
length(form_base_difference) == 0 &&
length(base_form_difference) == 0) {
warning("changes in scheme file detected: assuming order changed only")
cli::cli_warn("changes in scheme file detected: assuming order changed only")
print(forms_id_type_list_names)
}
if (length(names(forms_id_type_list)) == length(colnames(df_to_rewrite)) &&
if (length(forms_id_type_list_names) == length(colnames(df_to_rewrite)) &&
length(form_base_difference) != 0 &&
length(base_form_difference) != 0) {
stop("changes in scheme file detected: structure has been changed")
cli::cli_abort("changes in scheme file detected: structure has been changed")
}
if (length(names(forms_id_type_list)) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) {
warning("changes in scheme file detected: new inputs form was added")
warning("trying to adapt database")
if (length(forms_id_type_list_names) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) {
cli::cli_warn("changes in scheme file detected: new inputs form was added")
cli::cli_warn("trying to adapt database")
# add empty data for each new input form
for (i in form_base_difference) {
@@ -123,15 +146,76 @@ compare_existing_table_with_schema <- function(
# reorder due to scheme
df_to_rewrite <- df_to_rewrite |>
dplyr::select(dplyr::all_of(names(forms_id_type_list)))
dplyr::select(dplyr::all_of(forms_id_type_list_names))
DBI::dbWriteTable(con, table_name, df_to_rewrite, overwrite = TRUE)
DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'")
DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = 'dummy'"))
}
if (length(names(forms_id_type_list)) < length(colnames(df_to_rewrite))) {
stop("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!")
if (length(forms_id_type_list_names) < length(colnames(df_to_rewrite))) {
cli::cli_abort("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!")
}
}
}
#' @export
write_df_to_db <- function(df, table_name, main_key, nested_key, con) {
# if(!missing(nested_key)) del_query <- glue::glue("DELETE FROM {table_name} WHERE key = '{key}'")
if (table_name == "main") {
del_query <- glue::glue("DELETE FROM main WHERE main_key = '{main_key}'")
DBI::dbExecute(con, del_query)
}
if (table_name != "main") {
del_query <- glue::glue("DELETE FROM '{table_name}' WHERE main_key = '{main_key}' AND nested_key = '{nested_key}'")
DBI::dbExecute(con, del_query)
}
# записать данные
DBI::dbWriteTable(con, table_name, df, append = TRUE)
# report
cli::cli_alert_success("данные для '{main_key}' в таблице '{table_name}' успешно обновлены")
}
#' @export
#' reading tables from db by name and id ========
read_df_from_db_by_id <- function(table_name, main_key, nested_key, con) {
# check if this table exist
if (table_name == "main") {
query <- glue::glue("
SELECT *
FROM main
WHERE main_key = '{main_key}'
")
}
if (table_name != "main") {
query <- glue::glue("
SELECT *
FROM {table_name}
WHERE main_key = '{main_key}' AND nested_key = '{nested_key}'
")
}
DBI::dbGetQuery(con, query)
}
#' @export
get_keys_from_table <- function(table_name, con) {
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT main_key FROM {table_name}")) |>
dplyr::pull()
}
#' @export
get_nested_keys_from_table <- function(table_name, main_key, con) {
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT nested_key FROM {table_name} WHERE main_key == '{main_key}'")) |>
dplyr::pull()
}

94
modules/utils.R
View File

@@ -49,7 +49,8 @@ render_forms <- function(
form <- NULL
# параметры только для этой формы
filterd_line <- dplyr::filter(main_scheme, form_id == {{form_id}})
filterd_line <- main_scheme |>
dplyr::filter(form_id == {{form_id}})
# если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
if (!missing(ns)) {
@@ -178,12 +179,8 @@ render_forms <- function(
)
}
# вложенная таблица
if (form_type == "inline_table") {
form <- rhandsontable::rHandsontableOutput(outputId = form_id)
}
if (form_type == "inline_table2") {
# вложенная форма
if (form_type == "nested_forms") {
form <- shiny::actionButton(inputId = form_id, label = label)
}
@@ -235,75 +232,104 @@ get_empty_data <- function(type) {
#' @param value - value to update;
#' @param local_delimeter - delimeter to split file
update_forms_with_data <- function(
id,
type,
form_id,
form_type,
value,
local_delimeter = getOption("SYMBOL_DELIM")
local_delimeter = getOption("SYMBOL_DELIM"),
ns
) {
if (type == "text") {
shiny::updateTextAreaInput(inputId = id, value = value)
# если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
if (!missing(ns) & !is.null(ns)) {
form_id <- ns(form_id)
}
if (type == "number") {
shiny::updateTextAreaInput(inputId = id, value = value)
if (form_type == "text") {
shiny::updateTextAreaInput(inputId = form_id, value = value)
}
if (form_type == "number") {
shiny::updateTextAreaInput(inputId = form_id, value = value)
}
# supress warnings when applying NA or NULL to date input form
if (type == "date") {
if (form_type == "date") {
suppressWarnings(
shiny::updateDateInput(inputId = id, value = value)
shiny::updateDateInput(inputId = form_id, value = value)
)
}
# select_one
if (type == "select_one") {
if (form_type == "select_one") {
# update choices
# old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull()
# old_choices <- subset(scheme, form_id == form_id, choices) |> dplyr::pull()
# new_choices <- unique(c(old_choices, value))
# new_choices <- new_choices[!is.na(new_choices)]
# shiny::updateSelectizeInput(inputId = id, selected = value, choices = new_choices)
shiny::updateSelectizeInput(inputId = id, selected = value)
# 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 (type == "select_multiple" && !is.na(value)) {
if (form_type == "select_multiple" && !is.na(value)) {
vars <- stringr::str_split_1(value, local_delimeter)
# update choices
# old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull()
# old_choices <- subset(scheme, form_id == form_id, choices) |> dplyr::pull()
# new_choices <- unique(c(old_choices, vars))
# new_choices <- new_choices[!is.na(new_choices)]
# shiny::updateSelectizeInput(inputId = id, selected = vars, choices = new_choices)
shiny::updateSelectizeInput(inputId = id, selected = vars)
# shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
shiny::updateSelectizeInput(inputId = form_id, selected = vars)
}
# in other case fill with `character(0)` to proper reseting form
if (type == "select_multiple" && is.na(value)) {
shiny::updateSelectizeInput(inputId = id, selected = character(0))
if (form_type == "select_multiple" && is.na(value)) {
shiny::updateSelectizeInput(inputId = form_id, selected = character(0))
}
# radio buttons
if (type == "radio" && !is.na(value)) {
shiny::updateRadioButtons(inputId = id, selected = value)
if (form_type == "radio" && !is.na(value)) {
shiny::updateRadioButtons(inputId = form_id, selected = value)
}
if (type == "radio" && is.na(value)) {
shiny::updateRadioButtons(inputId = id, selected = character(0))
if (form_type == "radio" && is.na(value)) {
shiny::updateRadioButtons(inputId = form_id, selected = character(0))
}
# checkboxes
if (type == "checkbox" && !is.na(value)) {
if (form_type == "checkbox" && !is.na(value)) {
vars <- stringr::str_split_1(value, local_delimeter)
shiny::updateCheckboxGroupInput(inputId = id, selected = vars)
shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars)
}
if (type == "checkbox" && is.na(value)) {
shiny::updateCheckboxGroupInput(inputId = id, selected = character(0))
if (form_type == "checkbox" && is.na(value)) {
shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
}
# if (type == "inline_table") {
# message("EMPTY")
# }
}
#' @export
clean_forms <- function(id_and_types_list, ns) {
# если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
if (missing(ns)) ns <- NULL
purrr::walk2(
.x = id_and_types_list,
.y = names(id_and_types_list),
.f = \(x_type, x_id) {
# using function to update forms
update_forms_with_data(
form_id = x_id,
form_type = x_type,
value = get_empty_data(x_type),
ns = ns
)
}
)
}