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

feat: вместо встроенных таблиц - вложенные формы, перемещение кода в отдельные модули, инициация таблиц для вложенных форм

Browse Source
This commit is contained in:
madeliri
2026-03-29 18:40:49 +03:00
parent cdf92a81a3
commit 339f2b9127
9 changed files with 318 additions and 173 deletions
Download Patch File Download Diff File Expand all files Collapse all files

221
app.R
View File

@@ -28,7 +28,8 @@ box::purge_cache()
box::use(
modules/utils,
modules/global_options,
modules/db
modules/db,
modules/data_validation
)
# SETTINGS ================================
@@ -41,7 +42,6 @@ rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
# TODO: dynamic button render depend on pandoc installation
if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
load_scheme_from_xlsx <- function(
filename,
colnames = c("part", "subgroup", "form_id", "form_label", "form_type")
@@ -56,15 +56,19 @@ load_scheme_from_xlsx <- function(
}
extract_forms_id_and_types_from_scheme <- function(scheme) {
scheme |>
dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |>
dplyr::distinct(form_id, form_type) |>
tibble::deframe()
}
# SCHEME_MAIN UNPACK ==========================
# load scheme
SCHEME_MAIN <- load_scheme_from_xlsx(FILE_SCHEME)
# get list of simple inputs
inputs_simple_list <- SCHEME_MAIN |>
dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |>
dplyr::distinct(form_id, form_type) |>
tibble::deframe()
inputs_simple_list <- extract_forms_id_and_types_from_scheme(SCHEME_MAIN)
# get list of inputs with inline tables
inputs_tables_list <- SCHEME_MAIN |>
@@ -80,61 +84,32 @@ inputs_table_df <- SCHEME_MAIN |>
con <- db$make_db_connection()
# init DB (write dummy data to "main" table)
if (!"main" %in% DBI::dbListTables(con)) {
dummy_df <- dplyr::mutate(get_dummy_df(), id = "dummy")
db$check_if_table_is_exist_and_init_if_not("main", inputs_simple_list)
# write dummy df into base, then delete dummy row
DBI::dbWriteTable(con, "main", dummy_df, append = TRUE)
DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'")
purrr::walk(
.x = unique(inputs_table_df$form_id),
.f = \(table_name) {
rm(dummy_df)
}
this_inline_table2_info <- inputs_table_df |>
dplyr::filter(form_id == {table_name})
# checking if db structure in form compatible with alrady writed data (in case on changig form)
if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list))) {
print("identical")
} else {
df_to_rewrite <- DBI::dbReadTable(con, "main")
form_base_difference <- setdiff(names(inputs_simple_list), colnames(df_to_rewrite))
base_form_difference <- setdiff(colnames(df_to_rewrite), names(inputs_simple_list))
# получение имя файла с таблицой
inline_table2_file_name <- this_inline_table2_info$choices
# загрузка схемы для данной вложенной формы
this_inline_table2_scheme <- fs::path(folder_with_schemas, inline_table2_file_name) |>
load_scheme_from_xlsx(colnames = c("subgroup","form_id", "form_label", "form_type"))
this_table_id_and_types_list <- extract_forms_id_and_types_from_scheme(this_inline_table2_scheme)
db$check_if_table_is_exist_and_init_if_not(
table_name,
this_table_id_and_types_list,
con = con
)
# if lengths are equal
if (length(names(inputs_simple_list)) == 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")
}
if (length(names(inputs_simple_list)) == 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")
}
if (length(names(inputs_simple_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")
# add empty data for each new input form
for (i in form_base_difference) {
df_to_rewrite <- df_to_rewrite |>
dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(inputs_simple_list[i]))
}
# reorder due to scheme
df_to_rewrite <- df_to_rewrite |>
dplyr::select(dplyr::all_of(names(inputs_simple_list)))
DBI::dbWriteTable(con, "main", df_to_rewrite, overwrite = TRUE)
DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'")
}
if (length(names(inputs_simple_list)) < length(colnames(df_to_rewrite))) {
stop("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!")
}
# cleaning
rm(df_to_rewrite, form_base_difference)
}
)
# close connection to prevent data loss
db$close_db_connection(con)
@@ -281,35 +256,66 @@ server <- function(input, output) {
observeEvent(input[[table_name]], {
ns <- NS(table_name)
# данные для данной вложенной формы
this_inline_table2_info <- inputs_table_df |>
dplyr::filter(form_id == {table_name})
# получение имя файла с таблицой
inline_table2_file_name <- this_inline_table2_info$choices
# загрузка схемы для данной вложенной формы
this_inline_table2_scheme <- fs::path(folder_with_schemas, inline_table2_file_name) |>
load_scheme_from_xlsx(colnames = c("form_id", "form_label", "form_type"))
load_scheme_from_xlsx(colnames = c("subgroup","form_id", "form_label", "form_type"))
yay_its_fun <- purrr::pmap(
.l = dplyr::distinct(this_inline_table2_scheme, form_id, form_label, form_type),
.f = utils$render_forms,
main_scheme = this_inline_table2_scheme
)
# # формирование карточек для данной формы
# yay_its_fun <- purrr::pmap(
# .l = dplyr::distinct(this_inline_table2_scheme, form_id, form_label, form_type),
# .f = utils$render_forms,
# main_scheme = this_inline_table2_scheme,
# ns = ns
# )
yay_its_fun <- purrr::map(
.x = unique(this_inline_table2_scheme$subgroup),
.f = \(subgroup) {
subroup_scheme <- this_inline_table2_scheme |>
filter(subgroup == {{subgroup}})
bslib::nav_panel(
title = subgroup,
purrr::pmap(
.l = dplyr::distinct(subroup_scheme, form_id, form_label, form_type),
.f = utils$render_forms,
main_scheme = subroup_scheme,
ns = ns
)
)
}
)
# ui для всплывающего окна
ui_for_inline_table <- card(
height = "800px",
layout_sidebar(
sidebar = selectizeInput(
inputId = "aboba",
label = "key",
choices = c("a", "b")
navset_card_underline(
sidebar = sidebar(
width = 300,
selectizeInput(
inputId = "aboba",
label = "key",
choices = c("a", "b")
)
),
yay_its_fun
!!!yay_its_fun
)
)
# проверка данных для внутренних таблиц
iv_inner <- data_validation$init_val(this_inline_table2_scheme, ns)
iv_inner$enable()
showModal(modalDialog(
ui_for_inline_table,
# title = modalButton("Dismiss"),,
footer = modalButton("Dismiss"),
size = "l"
))
@@ -320,76 +326,8 @@ server <- function(input, output) {
# VALIDATIONS ============================
# create new validator
iv <- shinyvalidate::InputValidator$new()
# add rules to all inputs
purrr::walk(
.x = names(inputs_simple_list),
.f = \(x_input_id) {
form_type <- inputs_simple_list[[x_input_id]]
choices <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) |>
dplyr::pull(choices)
val_required <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) |>
dplyr::distinct(required) |>
dplyr::pull(required)
# for `number` type: if in `choices` column has values then parsing them to range validation
# value `0; 250` -> transform to rule validation value from 0 to 250
if (form_type == "number") {
iv$add_rule(x_input_id, function(x) {
# exit if empty
if (check_for_empty_data(x)) {
return(NULL)
}
# check for numeric
# if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
})
# проверка на соответствие диапазону значений
if (!is.na(choices)) {
# разделить на несколько елементов
ranges <- as.integer(stringr::str_split_1(choices, "; "))
# проверка на кол-во значений
if (length(ranges) > 3) {
warning("Количество переданных элементов'", x_input_id, "' > 2")
} else {
iv$add_rule(
x_input_id,
function(x) {
# замена разделителя десятичных цифр
x <- stringr::str_replace(x, ",", ".")
# exit if empty
if (check_for_empty_data(x)) {
return(NULL)
}
# check for currect value
if (between(as.double(x), ranges[1], ranges[2])) {
NULL
} else {
glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
}
}
)
}
}
}
# if in `required` column value is `1` apply standart validation
if (!is.na(val_required) && val_required == 1) {
iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить."))
}
}
)
# enable validator
iv$enable()
iv_main <- data_validation$init_val(SCHEME_MAIN)
iv_main$enable()
# STATUSES ===============================
# вывести отображение что что-то не так
@@ -401,8 +339,7 @@ server <- function(input, output) {
})
output$status_message2 <- renderText({
iv$is_valid()
# res_auth$admin
iv_main$is_valid()
})
# CREATE RHANDSOME TABLES =====================

BIN
configs/schemas/main.xlsx
View File

Binary file not shown.

BIN
configs/schemas/test_inline2.xlsx
View File

Binary file not shown.

BIN
configs/schemas/test_inline3.xlsx Normal file
View File

Binary file not shown.

23
helpers/functions.R
View File

@@ -1,32 +1,11 @@
get_dummy_data <- function(type) {
if (type %in% c("text", "select_one", "select_multiple")) return("dummy")
if (type %in% c("radio", "checkbox")) return("dummy")
if (type %in% c("date")) return(as.Date("1990-01-01"))
if (type %in% c("number")) return(as.double(999))
}
# get_empty_data <- function(type) {
# if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA))
# if (type %in% c("radio", "checkbox")) return(as.character(NA))
# if (type %in% c("date")) return(as.Date(NA))
# if (type %in% c("number")) return(as.character(NA))
# }
get_dummy_df <- function() {
purrr::map(
.x = inputs_simple_list,
.f = get_empty_data
) %>%
as_tibble()
}
#' @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

25
modules/data_manipulations.R Normal file
View File

@@ -0,0 +1,25 @@
#' @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.
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
}

90
modules/data_validation.R Normal file
View File

@@ -0,0 +1,90 @@
init_val <- function(scheme, ns) {
options(box.path = here::here())
box::use(modules/data_manipulations[check_for_empty_data])
iv <- shinyvalidate::InputValidator$new()
# если передана функция с пространством имен, то происходит модификация id
if(!missing(ns)) {
scheme <- scheme |>
dplyr::mutate(form_id = ns(form_id))
}
# формируем список id - тип
inputs_simple_list <- scheme |>
dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |>
dplyr::distinct(form_id, form_type) |>
tibble::deframe()
# add rules to all inputs
purrr::walk(
.x = names(inputs_simple_list),
.f = \(x_input_id) {
form_type <- inputs_simple_list[[x_input_id]]
choices <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
dplyr::pull(choices)
val_required <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
dplyr::distinct(required) |>
dplyr::pull(required)
# for `number` type: if in `choices` column has values then parsing them to range validation
# value `0; 250` -> transform to rule validation value from 0 to 250
if (form_type == "number") {
iv$add_rule(x_input_id, function(x) {
# exit if empty
if (check_for_empty_data(x)) {
return(NULL)
}
# check for numeric
# if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
})
# проверка на соответствие диапазону значений
if (!is.na(choices)) {
# разделить на несколько елементов
ranges <- as.integer(stringr::str_split_1(choices, "; "))
# проверка на кол-во значений
if (length(ranges) > 3) {
warning("Количество переданных элементов'", x_input_id, "' > 2")
} else {
iv$add_rule(
x_input_id,
function(x) {
# замена разделителя десятичных цифр
x <- stringr::str_replace(x, ",", ".")
# exit if empty
if (check_for_empty_data(x)) {
return(NULL)
}
# check for currect value
if (dplyr::between(as.double(x), ranges[1], ranges[2])) {
NULL
} else {
glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
}
}
)
}
}
}
# if in `required` column value is `1` apply standart validation
if (!is.na(val_required) && val_required == 1) {
iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить."))
}
}
)
iv
}

106
modules/db.R
View File

@@ -24,4 +24,110 @@ close_db_connection <- function(con, where = "") {
warning = function(w) if (getOption("APP.DEBUG", FALSE)) message("=!= ALREADY DISCONNECTED ", where),
finally = if (getOption("APP.DEBUG", FALSE)) message("=/= DB DISCONNECT ", where)
)
}
#' @export
#' проверить если таблица есть в базе данных и инициировать ее, если от
check_if_table_is_exist_and_init_if_not <- function(
table_name,
forms_id_type_list,
con = rlang::env_get(rlang::caller_env(), nm = "con")
) {
if (table_name %in% DBI::dbListTables(con)) {
cli::cli_inform("таблица есть такая: 'table_name'")
# если таблица существует, производим проверку структуры таблицы
compare_existing_table_with_schema(table_name, forms_id_type_list)
} else {
dummy_df <- dplyr::mutate(get_dummy_df(forms_id_type_list), id = "dummy")
# 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'")
cli::cli_alert_success("таблица '{table_name}' успешно создана")
}
}
get_dummy_data <- function(type) {
if (type %in% c("text", "select_one", "select_multiple")) return("dummy")
if (type %in% c("radio", "checkbox")) return("dummy")
if (type %in% c("date")) return(as.Date("1990-01-01"))
if (type %in% c("number")) return(as.double(999))
}
get_dummy_df <- function(forms_id_type_list) {
options(box.path = here::here())
box::use(modules/utils)
purrr::map(
.x = forms_id_type_list,
.f = utils$get_empty_data
) |>
dplyr::as_tibble()
}
compare_existing_table_with_schema <- function(
table_name,
forms_id_type_list,
con = rlang::env_get(rlang::caller_env(), nm = "con")
) {
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))) {
print("identical")
} 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))
# if lengths are equal
if (length(names(forms_id_type_list)) == 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")
}
if (length(names(forms_id_type_list)) == 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")
}
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")
# add empty data for each new input form
for (i in form_base_difference) {
df_to_rewrite <- df_to_rewrite |>
dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(forms_id_type_list[i]))
}
# reorder due to scheme
df_to_rewrite <- df_to_rewrite |>
dplyr::select(dplyr::all_of(names(forms_id_type_list)))
DBI::dbWriteTable(con, table_name, df_to_rewrite, overwrite = TRUE)
DBI::dbExecute(con, "DELETE FROM main WHERE id = '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!")
}
# cleaning
rm(df_to_rewrite, form_base_difference)
}
}

26
modules/utils.R
View File

@@ -50,19 +50,28 @@ render_forms <- function(
form_id,
form_label,
form_type,
main_scheme
main_scheme,
ns
) {
# заготовку для формы (проверка на выходе функции)
form <- NULL
# параметры только для этой формы
filterd_line <- dplyr::filter(main_scheme, form_id == {{form_id}})
# check if have condition
# если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
if (!missing(ns)) {
form_id <- ns(form_id)
}
# отдельно извлечение параметров условного отображения
condition <- unique(filterd_line$condition)
# get choices from schema
# элементы выбора
choices <- filterd_line$choices
# get choices from schema
# описание
description <- unique(filterd_line) |>
dplyr::filter(!is.na(form_description)) |>
dplyr::distinct(form_description) |>
@@ -84,12 +93,11 @@ render_forms <- function(
shiny::tagList(
if (!is.na(form_label)) {
shiny::span(form_label, style = "color: #444444; font-weight: 550; line-height: 1.4;")
# если в схеме есть поле с описанием - добавлеяем его следующей строчкой
# если в схеме есть поле с описанием - добавляем его следующей строчкой
},
if (!is.na(description) && !is.na(form_label)) shiny::br(),
if (!is.na(description)) {
shiny::span(shiny::markdown(description)) |> htmltools::tagAppendAttributes(style = "color:gray; font-size:small; line-height: 1.4;")
# span(description, style = "color:gray; font-size:small;")
}
)
}
@@ -130,7 +138,7 @@ render_forms <- function(
})
}
# еденичный выбор
# единичный выбор
if (form_type == "select_one") {
form <- shiny::selectizeInput(
inputId = form_id,
@@ -208,7 +216,8 @@ render_forms <- function(
if (!is.na(condition)) {
form <- shiny::conditionalPanel(
condition = condition,
form
form,
ns = ifelse(missing(ns), shiny::NS(NULL), ns)
)
}
@@ -228,7 +237,6 @@ get_empty_data <- function(type) {
if (type %in% c("number")) as.character(NA)
}
#' @export
#' @description Function to update input forms (default variants only)
#' @param id - input form id;