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-26 22:26:56 +03:00
parent 9fd1874c72
commit 9dfe4fdda6
5 changed files with 96 additions and 194 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@@ -1,5 +1,4 @@
### 0.??.? ### 0.??.?
##### features ##### features
- added checkboxes input form; - added checkboxes input form;
- added button to reset data in forms; - added button to reset data in forms;

191
app.R
View File

@@ -54,7 +54,7 @@ SCHEME_MAIN <- readxl::read_xlsx(FILE_SCHEME) %>%
# get list of simple inputs # get list of simple inputs
inputs_simple_list <- SCHEME_MAIN %>% inputs_simple_list <- SCHEME_MAIN %>%
dplyr::filter(!form_type %in% c("inline_table", "description")) %>% dplyr::filter(!form_type %in% c("inline_table", "description", "description_header")) %>%
dplyr::distinct(form_id, form_type) %>% dplyr::distinct(form_id, form_type) %>%
tibble::deframe() tibble::deframe()
@@ -179,148 +179,9 @@ inline_tables <- purrr::map(
} }
) )
# создание объектов для ввода
# функция
# create_forms <- function(form_id, form_label, form_type) {
# # check if have condition
# condition <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>%
# dplyr::distinct(condition) %>%
# dplyr::pull()
# choices <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>%
# dplyr::pull(choices)
# # simple text or number input
# if (form_type %in% c("text", "number")) {
# form <- shiny::textAreaInput(
# inputId = form_id,
# label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# rows = 1
# )
# }
# # simple date input
# if (form_type == "date") {
# # supress warning while trying keep data form empty by default
# suppressWarnings({
# form <- dateInput(
# inputId = form_id,
# label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# value = NA, # keep empty
# format = "dd.mm.yyyy",
# weekstart = 1,
# language = "ru"
# )
# })
# }
# # еденичный выбор
# if (form_type == "select_one") {
# form <- selectizeInput(
# inputId = form_id,
# label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# choices = choices,
# selected = NULL,
# options = list(
# create = FALSE,
# onInitialize = I('function() { this.setValue(""); }')
# )
# )
# }
# # множественный выбор
# if (form_type == "select_multiple") {
# form <- selectizeInput(
# inputId = form_id,
# label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# choices = choices,
# selected = NULL,
# multiple = TRUE,
# options = list(
# create = FALSE,
# onInitialize = I('function() { this.setValue(""); }')
# )
# )
# }
# # множественный выбор
# if (form_type == "radio") {
# form <- radioButtons(
# inputId = form_id,
# label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# choices = choices,
# selected = character(0)
# )
# }
# if (form_type == "checkbox") {
# form <- checkboxGroupInput(
# inputId = form_id,
# # label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
# label = h6(form_label),
# choices = choices,
# selected = character(0)
# )
# }
# # вложенная таблица
# if (form_type == "inline_table") {
# form <- rHandsontableOutput(outputId = form_id)
# }
# # description part
# if (form_type == "description") {
# form <- div(HTML(form_label), style = "color:Gray;font-size: 90%;")
# }
# # если есть условие создать кондитионал панель
# if (!is.na(condition)) {
# form <- conditionalPanel(
# condition = condition,
# form
# )
# }
# form
# }
# GENERATE UI ==================================
# functions for making cards
# make_cards_fn <- function(sub_group) {
# subgroups_inputs <- df_forms %>%
# dplyr::filter(subgroup == {{sub_group}}) %>%
# dplyr::distinct(form_id, form_label, form_type)
# subgroups_inputs2 <- SCHEME_MAIN |>
# dplyr::filter(subgroup == {{sub_group}}) %>%
# dplyr::distinct(form_id, form_label, form_type, condition)
# print(subgroups_inputs2)
# bslib::card(
# bslib::card_header(sub_group, container = htmltools::h5),
# full_screen = TRUE,
# width = "4000px",
# bslib::card_body(
# fill = TRUE,
# # передаем все аргументы в функцию для создания елементов
# purrr::pmap(
# .l = subgroups_inputs,
# .f = utils$create_forms,
# scheme = SCHEME_MAIN
# )
# )
# )
# }
# get pages list # get pages list
pages_list <- unique(SCHEME_MAIN$part) pages_list <- unique(SCHEME_MAIN$part)
# # get all forms df
# df_forms <- SCHEME_MAIN %>%
# dplyr::distinct(part, subgroup, form_id, form_label, form_type)
# generate nav panels for each page # generate nav panels for each page
nav_panels_list <- purrr::map( nav_panels_list <- purrr::map(
.x = pages_list, .x = pages_list,
@@ -328,38 +189,6 @@ nav_panels_list <- purrr::map(
main_scheme = SCHEME_MAIN main_scheme = SCHEME_MAIN
) )
# nav_panels_list <- purrr::map(
# .x = pages_list,
# .f = \(x_page) {
# # get info about inputs for current page
# page_forms <- SCHEME_MAIN %>%
# dplyr::filter(part == {{x_page}}) %>%
# dplyr::distinct(subgroup, form_id, form_label, form_type)
# # get list of columns
# cols_list <- unique(page_forms$subgroup)
# # making cards
# cards <- purrr::map(
# .x = cols_list,
# .f = utils$make_cards_fn,
# main_scheme = SCHEME_MAIN
# )
# # make page wrap
# page_wrap <- bslib::layout_column_wrap(
# # width = "350px", height = NULL, #was 800
# width = 1 / 4, height = NULL, # was 800
# fixed_width = TRUE,
# !!!cards # unpack list of cards
# )
# # add panel wrap to nav_panel
# bslib::nav_panel(x_page, page_wrap)
# }
# )
# UI ======================= # UI =======================
ui <- page_sidebar( ui <- page_sidebar(
title = config$header, title = config$header,
@@ -371,7 +200,9 @@ ui <- page_sidebar(
textOutput("status_message2"), textOutput("status_message2"),
actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")), actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")),
downloadButton("downloadData", "Экспорт в .xlsx"), downloadButton("downloadData", "Экспорт в .xlsx"),
downloadButton("downloadDocx", "get .docx (test only)") downloadButton("downloadDocx", "get .docx (test only)"),
position = "left",
open = list(mobile = "always")
), ),
# list of rendered panels # list of rendered panels
navset_card_underline( navset_card_underline(
@@ -462,17 +293,20 @@ server <- function(input, output) {
# for `number` type: if in `choices` column has values then parsing them to range validation # 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 # value `0; 250` -> transform to rule validation value from 0 to 250
if (form_type == "number") { if (form_type == "number") {
iv$add_rule(x_input_id, function(x) { iv$add_rule(x_input_id, function(x) {
# exit if empty # exit if empty
if (check_for_empty_data(x)) { if (check_for_empty_data(x)) {
return(NULL) return(NULL)
} }
# check for numeric # check for numeric
if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом." # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
}) })
# проверка на соответствие диапазону значений
if (!is.na(choices)) { if (!is.na(choices)) {
# разделить на числа # разделить на несколько елементов
ranges <- as.integer(stringr::str_split_1(choices, "; ")) ranges <- as.integer(stringr::str_split_1(choices, "; "))
# проверка на кол-во значений # проверка на кол-во значений
@@ -482,12 +316,17 @@ server <- function(input, output) {
iv$add_rule( iv$add_rule(
x_input_id, x_input_id,
function(x) { function(x) {
# замена разделителя десятичных цифр
x <- stringr::str_replace(x, ",", ".")
# exit if empty # exit if empty
if (check_for_empty_data(x)) { if (check_for_empty_data(x)) {
return(NULL) return(NULL)
} }
# check for currect value # check for currect value
if (between(as.integer(x), ranges[1], ranges[2])) { if (between(as.double(x), ranges[1], ranges[2])) {
NULL NULL
} else { } else {
glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.") glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")

BIN
configs/schemas/main.xlsx
View File

Binary file not shown.

1
helpers/functions.R
View File

@@ -28,6 +28,7 @@ get_dummy_df <- function() {
#' #'
#' Needed for proper data validation. #' Needed for proper data validation.
check_for_empty_data <- function(value_to_check) { check_for_empty_data <- function(value_to_check) {
# for any 0-length # for any 0-length
if (length(value_to_check) == 0) return(TRUE) if (length(value_to_check) == 0) return(TRUE)

95
modules/utils.R
View File

@@ -5,7 +5,6 @@
'Module path: "', basename(box::file()), '"' 'Module path: "', basename(box::file()), '"'
) )
} }
# ================
# asdasd # asdasd
#' @export #' @export
@@ -22,7 +21,7 @@ make_panels <- function(page_name, main_scheme) {
# making cards # making cards
cards <- purrr::map( cards <- purrr::map(
.x = cols_list, .x = cols_list,
.f = make_cards_fn, .f = render_cards_with_forms,
main_scheme = main_scheme main_scheme = main_scheme
) )
@@ -43,8 +42,27 @@ make_panels <- function(page_name, main_scheme) {
} }
# functions for making cards # functions for making cards
# DO THIS INSTEAD !!!
#' @export #' @export
make_cards_fn <- function(sub_group, main_scheme) { # make_forms_by_scheme <- function(tool_id, main_scheme, ns) {
# ns <- NS(ns(tool_id))
# main_scheme <<- main_scheme
# subgroup_schema <- main_scheme |>
# dplyr::filter(tool_id == {{tool_id}})
# purrr::pmap(
# .l = dplyr::distinct(subgroup_schema, form_id, form_label, form_type),
# .f = render_forms,
# schema = subgroup_schema,
# ns = ns
# )
# }
# functions for making cards
#' @export
render_cards_with_forms <- function(sub_group, main_scheme) {
main_scheme <<- main_scheme main_scheme <<- main_scheme
subgroups_inputs <- main_scheme |> subgroups_inputs <- main_scheme |>
@@ -54,13 +72,14 @@ make_cards_fn <- function(sub_group, main_scheme) {
bslib::card( bslib::card(
bslib::card_header(sub_group, container = htmltools::h5), bslib::card_header(sub_group, container = htmltools::h5),
full_screen = TRUE, full_screen = TRUE,
fill = TRUE,
width = "4000px", width = "4000px",
bslib::card_body( bslib::card_body(
fill = TRUE, fill = TRUE,
# передаем все аргументы в функцию для создания елементов # передаем все аргументы в функцию для создания елементов
purrr::pmap( purrr::pmap(
.l = subgroups_inputs, .l = subgroups_inputs,
.f = create_forms, .f = render_forms,
main_scheme = main_scheme main_scheme = main_scheme
) )
) )
@@ -70,20 +89,52 @@ make_cards_fn <- function(sub_group, main_scheme) {
# UI RELATED ============================ # UI RELATED ============================
#' @export #' @export
#' @param TEST s #' @param TEST s
create_forms <- function( render_forms <- function(
form_id, form_id,
form_label, form_label,
form_type, form_type,
main_scheme main_scheme
) { ) {
filterd_line <- dplyr::filter(main_scheme, form_id == {{form_id}})
# check if have condition # check if have condition
condition <- dplyr::filter(main_scheme, form_id == {{form_id}}) |> condition <- unique(filterd_line$condition)
dplyr::distinct(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) |>
dplyr::pull() dplyr::pull()
choices <- dplyr::filter(main_scheme, form_id == {{form_id}}) |> # описание
dplyr::pull(choices) if (length(description) > 1) {
rlang::abort(sprintf(
"%s - более чем 1 уникальный вариант описания:\n%s", form_id, paste0(description, collapse = "\n")
))
} else if (length(description) == 0) {
description <- NA
}
# отдельно создаем заголовки
label <- if (is.na(description) && is.na(form_label)) {
NULL
} else {
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;")
}
)
}
# simple text or number input # simple text or number input
if (form_type == "text") { if (form_type == "text") {
@@ -93,7 +144,7 @@ create_forms <- function(
form <- shiny::textAreaInput( form <- shiny::textAreaInput(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
rows = rows_to_show rows = rows_to_show
) )
} }
@@ -101,7 +152,7 @@ create_forms <- function(
if (form_type == "number") { if (form_type == "number") {
form <- shiny::textAreaInput( form <- shiny::textAreaInput(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
rows = 1 rows = 1
) )
} }
@@ -112,7 +163,7 @@ create_forms <- function(
suppressWarnings({ suppressWarnings({
form <- shiny::dateInput( form <- shiny::dateInput(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
value = NA, # keep empty value = NA, # keep empty
format = "dd.mm.yyyy", format = "dd.mm.yyyy",
weekstart = 1, weekstart = 1,
@@ -125,7 +176,7 @@ create_forms <- function(
if (form_type == "select_one") { if (form_type == "select_one") {
form <- shiny::selectizeInput( form <- shiny::selectizeInput(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
choices = choices, choices = choices,
selected = NULL, selected = NULL,
options = list( options = list(
@@ -139,7 +190,7 @@ create_forms <- function(
if (form_type == "select_multiple") { if (form_type == "select_multiple") {
form <- shiny::selectizeInput( form <- shiny::selectizeInput(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
choices = choices, choices = choices,
selected = NULL, selected = NULL,
multiple = TRUE, multiple = TRUE,
@@ -154,7 +205,7 @@ create_forms <- function(
if (form_type == "radio") { if (form_type == "radio") {
form <- shiny::radioButtons( form <- shiny::radioButtons(
inputId = form_id, inputId = form_id,
label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), label = label,
choices = choices, choices = choices,
selected = character(0) selected = character(0)
) )
@@ -163,7 +214,7 @@ create_forms <- function(
if (form_type == "checkbox") { if (form_type == "checkbox") {
form <- shiny::checkboxGroupInput( form <- shiny::checkboxGroupInput(
inputId = form_id, inputId = form_id,
# label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), # label = label,
label = shiny::h6(form_label), label = shiny::h6(form_label),
choices = choices, choices = choices,
selected = character(0) selected = character(0)
@@ -177,8 +228,19 @@ create_forms <- function(
# description part # description part
if (form_type == "description") { if (form_type == "description") {
if(is.na(form_label)) {
form <- shiny::hr(style = "margin-bottom: -3px;")
} else {
form <- shiny::div(shiny::HTML(form_label), style = "color: Gray; font-size: 90%;") form <- shiny::div(shiny::HTML(form_label), style = "color: Gray; font-size: 90%;")
} }
}
if (form_type == "description_header") {
form <- shiny::h5(
label,
style = "margin-bottom: -8px; margin-top: 10px;"
)
}
# если есть условие создать кондитионал панель # если есть условие создать кондитионал панель
if (!is.na(condition)) { if (!is.na(condition)) {
@@ -187,6 +249,7 @@ create_forms <- function(
form form
) )
} }
form form
} }