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

app.R

@@ -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 |>
+inputs_simple_list <- extract_forms_id_and_types_from_scheme(SCHEME_MAIN)
-  dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |>
-  dplyr::distinct(form_id, form_type) |>
-  tibble::deframe()
 
 # 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)) {
+db$check_if_table_is_exist_and_init_if_not("main", inputs_simple_list)
-  dummy_df <- dplyr::mutate(get_dummy_df(), id = "dummy")
 
-  # write dummy df into base, then delete dummy row
+purrr::walk(
-  DBI::dbWriteTable(con, "main", dummy_df, append = TRUE)
+  .x = unique(inputs_table_df$form_id),
-  DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'")
+  .f = \(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("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
+    )
 
-  rm(dummy_df)
-}
-
-# 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))
-
-  # 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),
+        # 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 = this_inline_table2_scheme
+                main_scheme = subroup_scheme,
+                ns = ns
+              )
+            )
+          }
         )
 
+        # ui для всплывающего окна 
         ui_for_inline_table <- card(
-            height = "800px",
+            navset_card_underline(
-            layout_sidebar(
+              sidebar = sidebar(
-              sidebar = selectizeInput(
+                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()
+  iv_main <- data_validation$init_val(SCHEME_MAIN)
-
+  iv_main$enable()
-  # 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()
 
   # STATUSES ===============================
   # вывести отображение что что-то не так
@@ -401,8 +339,7 @@ server <- function(input, output) {
   })
 
   output$status_message2 <- renderText({
-    iv$is_valid()
+    iv_main$is_valid()
-    # res_auth$admin
   })
 
   # CREATE RHANDSOME TABLES =====================

helpers/functions.R

@@ -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

modules/data_manipulations.R

@@ -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
+}

modules/data_validation.R

@@ -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
+}

modules/db.R

@@ -25,3 +25,109 @@ close_db_connection <- function(con, 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)
+  }
+}

modules/utils.R

@@ -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;