From f44d40703b0387a63986b2eee8b1baeef4c3066c Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Wed, 25 Mar 2026 00:17:06 +0530 Subject: [PATCH 1/6] feat: integrate management event schema json as source of truth --- .RData | Bin 2846 -> 0 bytes R/app_server.R | 41 +- R/app_ui.R | 3 +- R/fct_event_list.R | 25 + R/fct_files.R | 123 +- R/fct_language.R | 65 +- R/fct_schema.R | 496 +++ R/fct_schema_ui.R | 405 +++ R/fct_ui.R | 99 +- R/mod_event_list.R | 40 +- R/mod_form.R | 881 ++--- R/mod_table.R | 375 +- R/utils_global.R | 37 +- inst/app/www/schema.css | 49 + inst/app/www/script.js | 4 +- inst/extdata/management-event.schema.json | 3938 +++++++++++++++++++++ inst/extdata/ui_structure.json | 1247 ------- man/build_event_type_choices.Rd | 19 + man/build_property_descriptor.Rd | 25 + man/build_subtype_choices.Rd | 19 + man/clear_schema_value.Rd | 11 + man/convert_condition_to_js.Rd | 21 + man/determine_widget_type.Rd | 17 + man/extract_oneof_choices.Rd | 17 + man/get_all_schema_properties.Rd | 13 + man/get_event_list_colnames.Rd | 21 + man/get_relevant_properties.Rd | 21 + man/lang_to_iso.Rd | 17 + man/load_schema.Rd | 15 + man/lookup_property.Rd | 23 + man/make_required_label.Rd | 19 + man/normalize_legacy_event.Rd | 17 + man/render_array_table.Rd | 23 + man/render_event_panel.Rd | 25 + man/render_property_widget.Rd | 49 + man/render_schema_form.Rd | 21 + man/render_subtype_section.Rd | 11 + man/resolve_property.Rd | 19 + man/resolve_ref.Rd | 19 + man/schema_get_choices.Rd | 19 + man/schema_get_title.Rd | 21 + man/update_schema_value.Rd | 20 + man/update_schema_widget.Rd | 11 + tests/testthat/test-fct_schema.R | 331 ++ tests/testthat/test-schema_integration.R | 332 ++ 45 files changed, 7103 insertions(+), 1901 deletions(-) delete mode 100644 .RData create mode 100644 R/fct_schema.R create mode 100644 R/fct_schema_ui.R create mode 100644 inst/app/www/schema.css create mode 100644 inst/extdata/management-event.schema.json create mode 100644 man/build_event_type_choices.Rd create mode 100644 man/build_property_descriptor.Rd create mode 100644 man/build_subtype_choices.Rd create mode 100644 man/clear_schema_value.Rd create mode 100644 man/convert_condition_to_js.Rd create mode 100644 man/determine_widget_type.Rd create mode 100644 man/extract_oneof_choices.Rd create mode 100644 man/get_all_schema_properties.Rd create mode 100644 man/get_event_list_colnames.Rd create mode 100644 man/get_relevant_properties.Rd create mode 100644 man/lang_to_iso.Rd create mode 100644 man/load_schema.Rd create mode 100644 man/lookup_property.Rd create mode 100644 man/make_required_label.Rd create mode 100644 man/normalize_legacy_event.Rd create mode 100644 man/render_array_table.Rd create mode 100644 man/render_event_panel.Rd create mode 100644 man/render_property_widget.Rd create mode 100644 man/render_schema_form.Rd create mode 100644 man/render_subtype_section.Rd create mode 100644 man/resolve_property.Rd create mode 100644 man/resolve_ref.Rd create mode 100644 man/schema_get_choices.Rd create mode 100644 man/schema_get_title.Rd create mode 100644 man/update_schema_value.Rd create mode 100644 man/update_schema_widget.Rd create mode 100644 tests/testthat/test-fct_schema.R create mode 100644 tests/testthat/test-schema_integration.R diff --git a/.RData b/.RData deleted file mode 100644 index 1b94ba1d4f782f1699168e2af5927be6de13d300..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2846 zcmV+(3*q!1iwFP!000001ASI!P!m`e4TOXe0-*>&iS#BANiZ*0007*fIt8cbQA(WW~Tb`>Hq)}<59u@U;?lnd58mvfG2o(6LD_jBRJ3BxFdu8 z+xriM=?0lV`VoV0cz2@5j|6<(hlqE<{Q?J>9l@1;CQ8aE71jSH0Kh-WLXNJV_Wx@C zhDU<`IsXw4^1!(h$Upc&|3fZ|7miH!^(5hcHjuq>B=4W{34UHg65+p_{X*d2b~NAz z!OtQa9_NiiI+BjKe}S`-JbjTrH9?Pz@$W?r4-fZ`+`+G4N1_|S&I{-5{L6d}Ji$ld z$m|F{M-M~(rHvhFg7d(8x+BR10{&kbMiKxZO+AX~9NjT)OhA7X^2*_*%T}&XP42s= zt7s}}((7ZF>(FXCUsrgyhR(t{04MDXBS4-rnXq#uVg~1h%la8`_9XQR=YXG@w;4 z@TtQFt%OGq6%|n5nmg&>=oG%C*8)luzgIw3`s-spAI_KaAz~k#ahew!KxpYu6o*cN zuCXTdOu#0W#T*9dBd*@C<6P+yP~zm^bQ4uznSK1?fx?EGjOub<$7Uk*#38?fhX(+ zXWYqvVOW4Zr=n4aHCh{}>9Hlm@bP+jv0-(#sRQ-xR&t_Tzf(X*X#1GCyV&B1N4gyiV7uHFQYgfAxC&ziz zVR^|?Z8!U{U?phE@EreyCUW)$Gp6PSI}(0vOA%|WzsVT}6dICy8MlMvE<3v{Ry4|i zU=7W<&6O;=Ul&0Q!)%pX9$a09j^E03qxk2pqGJj0l z@zS!AKFbLiE=0vsv!?g*t$%i^R%U6o%^me=wOtP#|ep^0?U(DF)e*C#Q`@(~l2#X=*3~Bz~Te8meKdEDR z-ouho7JT=tvDpnd*pkmD;U{{I;eYCOo7-=S@42;Ywv21vE_BV(@-GsR`mzjhH&tMoRPCIVhN@b)#G{jIarvsJy`U~mw1kyH&1SFuXZ0M# zhQh3TWfQQpAKI(hj9vnXPHhn-Lr@fjw> zoYN@N@Z$6kjsNPbLB1(G=ye`MFBu&bq7U=90tZkMFVIliM>8_MoPV;N-*< zO5wp%XnXN)LU621MCoi|>*&A%+l$thC zM})%pWeN`>-dLZpM2}EICw8TbGh@9NKCdy&No9)4#otF1@7?dYU@73E!&p9wAA8(7 z?|NO-WNl(Hf931oO~ZwukJryuo0X{Nk<2}ViH~NmHM$eP=%mwb9y7}JXR+@0f3f|=!4*LPvctXvHLpVPm ze!Z(>FS$sAz6wqjwjr2u(hU6$8oA&W59NYb4qA%Tgn}j?j&bA)AMm0zW%wtpLu}}# zjJMOenm3n2yOXXWO6jYkZ4z{LRxIRX8MD8wx zFZC`akK1^oGBR$6NMI=4?c)(}}++;WTaP|Gp^ z4xT&RB~r*pOSDkt|I^|=K`q@srw6E>!Z^4y>aJS9aq3O5!dN=m_tMz>$qQXff!BLA zij9^yGR8QVwHo1pLd8-SXRoY$-yPCph+T_O=`K#HEFNh}q$ofd!*XVqMEs3Uo>8vO zjVpF7q?dG_fb@GLf_{I0I6ODSGVf8A)m(wGe`2iW9t_vT z1`e>SsuZCz+2-{%{pYd=r((n*EW9Pbp{*vVZGNCpLP`J2-}w3CYTsqdvHCf?MI)S2 zXZ+t|lzGz9NS`R`w%_!ps}l(3ND}(F7T3pp7i)bHWrCL|kzZlraAW$t#LM_8&}xCf zc>{=boT30c(qHyB+ikLod@CQYylo0YT5uH!w|Nu^om2@QPoY+_^5o!R`up8^ARqbH zNFB%4EsQ%PALeU3Gk>`0KX!Q~TDdXhp$d}=3N^6o0ITer2ICbyX-!&@t}@YW@0 zJ{u!D^1@9}YgMo<;%(iPPUamZT;6*hvWIVStsS~`31cPKMRbjE_nK=94&K z=UIk=*T;xPy{TJyQ*t9k<5~fI*zfaGTkNyR7XnVHN~66YTG$Q_2VTEbI4d!`rM|5B wYOmU=xc>sP;4Vc_X3qwZ?&g#)4NF@wd8?Ulp|A%2_b>3^FC7LRUA+qc00CjJ!T 0) return(title) + } + + cn + }, character(1)) } \ No newline at end of file diff --git a/R/fct_files.R b/R/fct_files.R index a144fde..6495624 100644 --- a/R/fct_files.R +++ b/R/fct_files.R @@ -5,6 +5,23 @@ # path to json file folder json_file_base_folder <- function() golem::get_golem_options("json_file_path") +# LIFECYCLE: This URL is embedded in every persisted event JSON file as "$schema". +# When bumping the schema version or moving the schema repository, update this +# value AND consider backward-compatibility for files already written with the +# old URL. Coordinate changes with write_json_file() below and any external +# consumers that validate events against this schema. +schema_url <- "https://raw.githubusercontent.com/hamk-uas/fieldobservatory-data-schemas/main/management-event.schema.json" + +# Legacy property name mapping for backward-compatible reading +legacy_name_map <- c( + "mgmt_event_notes" = "mgmt_event_short_notes", + "planting_notes" = "mgmt_event_long_notes", + "harvest_comments" = "mgmt_event_long_notes", + "fertilizer_comments" = "mgmt_event_long_notes", + "tillage_notes" = "mgmt_event_long_notes", + "chemical_notes" = "mgmt_event_long_notes" +) + #' Create a folder for a site-block combination #' #' Given a site and a block on that site, create a folder under @@ -21,8 +38,6 @@ json_file_base_folder <- function() golem::get_golem_options("json_file_path") #' FALSE otherwise. create_file_folder <- function(site, block, base_folder = json_file_base_folder()) { - # if the events directory (stored in json_file_base_folder) doesn't exist, - # stop if (!dir.exists(base_folder)) { stop(glue("Could not find folder {json_file_base_folder}")) } @@ -46,18 +61,17 @@ create_file_folder <- function(site, block, write_json_file <- function(site, block, event_list, rotation_list, base_folder = json_file_base_folder()) { - # this ensures that the folder to store this file exists create_file_folder(site, block) file_path <- file.path(base_folder, site, block, "events.json") - # if there are events in the list, do the following: - # - erase block information in each event - # - apply other exceptions if (length(event_list) > 0) { for (i in 1:length(event_list)) { event_list[[i]]$block <- NULL + # Add $schema field + event_list[[i]][["$schema"]] <- schema_url + ##### EXCEPTIONS event <- event_list[[i]] @@ -73,26 +87,17 @@ write_json_file <- function(site, block, event_list, rotation_list, } } - # If rotations on the list --> erase the block information like with events if (length(rotation_list) > 0) { for (j in 1:length(rotation_list)) { rotation_list[[j]]$block <- NULL - - rotation <- rotation_list[[j]] } } - # create appropriate structure experiment <- list() experiment$management <- list() - - # rotation will be part of the management experiment$management$rotation <- rotation_list - experiment$management$events <- event_list - - # create file jsonlite::write_json(experiment, path = file_path, pretty = TRUE, null = "list", auto_unbox = TRUE) } @@ -100,21 +105,20 @@ write_json_file <- function(site, block, event_list, rotation_list, #' Read the events from the events.json file #' #' Reads the events from the events.json file specific to this site and block -#' combination and returns as a list of events. +#' combination and returns as a list of events. Applies backward-compatible +#' normalization for legacy events. #' #' @param site The site to read from #' @param block The block to read from #' @param base_folder Included for testing reasons, the default value should #' otherwise be used #' -#' @return A list of events, which are themselves lists. If the corresponding -#' file does not exist or there are no events, returns an empty list. +#' @return A list with $events and $rotation components. read_json_file <- function(site, block, base_folder = json_file_base_folder()) { file_path <- file.path(base_folder, site, block, "events.json") - # if file doesn't exist or given names are empty, can't read it if (!file.exists(file_path)) { return(list()) } @@ -127,17 +131,10 @@ read_json_file <- function(site, block, rotation <- jsonlite::fromJSON(file_path, simplifyDataFrame = FALSE)$management$rotation - # if there are no events, return an empty list if (length(events) == 0) { return(list()) } - # # if there are no rotation, return an empty list - # if (length(rotation) == 0) { - # return(list()) - # } - - # add block information and apply exceptions to each event for (i in 1:length(events)) { events[[i]]$block <- block @@ -148,97 +145,95 @@ read_json_file <- function(site, block, events[[i]]$mgmt_operations_event <- "fertilizer" } + # Normalize legacy property names + events[[i]] <- normalize_legacy_event(events[[i]]) + ##### } - # add block info for rotations if (length(rotation) != 0){ for (j in 1:length(rotation)) { rotation[[j]]$block <- block } } - # Add events and rotation as a list objects which both will be returned - # when function is called management$events <- events management$rotation <- rotation return(management) } +#' Normalize a legacy event to use schema property names +#' @param event An event list +#' @return The event with legacy names mapped to schema names +normalize_legacy_event <- function(event) { + for (old_name in names(legacy_name_map)) { + new_name <- legacy_name_map[[old_name]] + if (!is.null(event[[old_name]]) && is.null(event[[new_name]])) { + event[[new_name]] <- event[[old_name]] + event[[old_name]] <- NULL + } + } + event +} + #' Copy a file related to an event and name it appropriately -#' +#' #' When a file (image) is uploaded through a fileInput widget, it is saved to a #' temporary folder. This function copies that file to an appropriate directory -#' and name. The file does not have to be originally in a temporary -#' folder, any file path is ok. Therefore this function can also be used e.g. -#' when cloning and event and the images associated with it need to be -#' duplicated. +#' and name. The file does not have to be originally in a temporary folder — +#' any file path is valid. This allows the function to also be used when cloning +#' an event and its associated images need to be duplicated. +#' +#' @details The new file name has the format +#' `yyyy-mm-dd_site_block_variable_name_#.ext` where `#` is an incrementing +#' number (0, 1, 2, ...) to ensure uniqueness within the target folder. +#' #' @param orig_filepath The path of the file to copy #' @param variable_name Which variable is this file for? E.g. canopeo_image #' @param site The site where the event took place #' @param block The block where the event took place -#' @param date The day of the event as a character string, the format must be -#' yyyy-mm-dd -#' @param filepath_is_relative If TRUE, json_file_base_folder will be added to -#' the beginning of filepath +#' @param date The day of the event as a character string, format yyyy-mm-dd +#' @param filepath_is_relative If TRUE, json_file_base_folder will be added #' @param delete_original Should the original file be deleted after copying? -#' @param base_folder Included for testing reasons, the default value should -#' otherwise be used -#' -#' @details The name will be of the format -#' yyyy-mm-dd_site_block_variable_name_# where # is a number (0, 1, 2, ...) to -#' ensure that files have unique names. +#' @param base_folder Included for testing reasons #' -#' @return A path to the new location of the file relative to the events.json -#' file. +#' @return A path to the new location of the file relative to events.json. #' #' @importFrom glue glue copy_file <- function(orig_filepath, variable_name, site, block, date, filepath_is_relative = FALSE, delete_original = FALSE, base_folder = json_file_base_folder()) { - # ensures the folder for this site-block combo is there create_file_folder(site, block) - # add json_file_base_folder to filepath if requested if (filepath_is_relative) { orig_filepath <- file.path(base_folder, orig_filepath) } - # check that the temporary file actually exists if (!file.exists(orig_filepath)) { stop(glue("The file {orig_filepath} to copy does not exist")) } file_extension <- tolower(tools::file_ext(orig_filepath)) allowed_extensions <- c("jpg", "jpeg", "tif", "tiff", "png") - # if the image format is not supported, stop if (!(file_extension %in% allowed_extensions)) { stop("This file extension is not supported") } - # base of the new file name file_base <- paste(date, site, block, variable_name, sep = "_") - - # path to the final file folder filepath <- file.path(base_folder, site, block, variable_name) if (!dir.exists(filepath)) { dir.create(filepath) } - # determine the number to add to the end of the file name to keep file names - # in the folder unique number <- 0 while (TRUE) { file_name <- paste(file_base, number, sep = "_") file_name <- paste(file_name, file_extension, sep = ".") if (!file.exists(file.path(filepath, file_name))) { - # we found a unique name. It will be available in file_name after - # the loop break } number <- number + 1 - # don't loop forever if (number >= 1000) { stop("Could not find a unique name for the file") @@ -252,7 +247,6 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, warning = function(cnd) {message(cnd); FALSE}, error = function(cnd) {message(cnd); FALSE}) - # if we succeeded in renaming, delete the original file if requested if (success & delete_original) { deleted_original <- tryCatch(expr = file.remove(orig_filepath), warning = function(cnd) {message(cnd)}, @@ -270,17 +264,12 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, #' Delete a file #' -#' Delete the file with the path filepath. Used to delete files (images) -#' associated with events, e.g. canopeo_image -#' #' @param filepath The path to the file which should be deleted. #' @param filepath_relative Set to TRUE and supply site and block if filepath is -#' relative to the events.json file. This allows the function to figure out -#' the correct path to the file. +#' relative to the events.json file. #' @param site The site where the event took place #' @param block The block where the event took place -#' @param base_folder Included for testing reasons, the default value should -#' otherwise be used +#' @param base_folder Included for testing reasons #' #' @importFrom glue glue delete_file <- function(filepath, site = NULL, block = NULL, @@ -296,4 +285,4 @@ delete_file <- function(filepath, site = NULL, block = NULL, } else { stop(glue("Could not delete file {filepath} because it was not found")) } -} \ No newline at end of file +} diff --git a/R/fct_language.R b/R/fct_language.R index 3e7eee9..1ddc2ae 100644 --- a/R/fct_language.R +++ b/R/fct_language.R @@ -97,19 +97,64 @@ get_disp_name <- function(code_name, language = NULL, #' replaced with display names replace_with_display_names <- function(events_with_code_names, language) { events_with_display_names <- events_with_code_names + iso <- lang_to_iso(language) for (variable_name in names(events_with_code_names)) { - # determine the type of element the variable corresponds to + # First check structure_lookup_list (app chrome elements) element <- structure_lookup_list[[variable_name]] + # If not in structure_lookup_list, try schema property registry if (is.null(element$type)) { - # this could be e.g. the date_ordering or event column + desc <- find_any_property_desc(mgmt_schema$property_registry, variable_name, + mgmt_schema$property_reverse_index) + if (!is.null(desc)) { + wtype <- desc$type + if (wtype == "selectInput") { + events_with_display_names[[variable_name]] <- + sapply(events_with_code_names[[variable_name]], + FUN = function(x) { + if (is.null(x) || identical(x, missingval)) return("") + # Try schema choices first + if (!is.null(desc$choices)) { + for (ch in desc$choices) { + if (identical(ch$value, x)) { + return(schema_get_title(ch$titles, iso, x)) + } + } + } + # Try display_names.csv + name <- get_disp_name(x, language = language) + if (length(name) > 1) { + name <- paste(ifelse(name == "", "-", name), + collapse = ", ") + } + name + }) + } else if (wtype %in% c("textAreaInput", "textInput", "numericInput")) { + events_with_display_names[[variable_name]] <- + sapply(events_with_code_names[[variable_name]], + FUN = function(x) { + if (length(x) > 1) { + paste(ifelse(x == missingval, "-", x), collapse = ", ") + } else { + ifelse(x == missingval, "", x) + } + }) + } else if (wtype == "dateInput") { + events_with_display_names[[variable_name]] <- + sapply(events_with_code_names[[variable_name]], + FUN = function(x) { + paste(format(as.Date(x, format = date_format_json), + date_format_display), + collapse = " - ") + }) + } + next + } next } - + if (element$type == "selectInput") { - # the pasting is done to ensure we get a nicely formatted name - # when x is a character vector events_with_display_names[[variable_name]] <- sapply(events_with_code_names[[variable_name]], FUN = function(x) { @@ -163,13 +208,21 @@ set_login_language <- function(language) { if (identical(language, "disp_name_fin")) { shinymanager::set_labels( language = "en", - # the \U codes are UTF-8 codes for Finnish letters a and o with dots "Please authenticate" = "Kirjaudu sy\U00f6tt\U00e4\U00e4ksesi tapahtumia", "Username:" = "Sijainti", "Password:" = "Salasana", "Login" = "Kirjaudu", "Logout" = "Kirjaudu ulos" ) + } else if (identical(language, "disp_name_swe")) { + shinymanager::set_labels( + language = "en", + "Please authenticate" = "Logga in f\U00f6r att registrera h\U00e4ndelser", + "Username:" = "Plats", + "Password:" = "L\U00f6senord", + "Login" = "Logga in", + "Logout" = "Logga ut" + ) } else if (identical(language, "disp_name_eng")) { shinymanager::set_labels( language = "en", diff --git a/R/fct_schema.R b/R/fct_schema.R new file mode 100644 index 0000000..f284c94 --- /dev/null +++ b/R/fct_schema.R @@ -0,0 +1,496 @@ +# Schema interpreter for management-event JSON schema +# Parses the bundled schema and builds registries for UI generation + +# Separator used in property_registry keys to namespace properties by +# event type and subtype (e.g. "crop_name___planting" or +# "soil_depth___observation___observation_type_soil"). +# Property names and event/subtype const values must NOT contain this string. +REGISTRY_KEY_SEP <- "___" + +schema_file_path <- function() { + system.file("extdata", "management-event.schema.json", + package = "fieldactivity") +} + +#' Load and parse the management-event schema +#' @return A list with components: raw (the full parsed schema), event_registry, +#' property_registry, common_properties, event_type_choices +load_schema <- function() { + raw <- jsonlite::fromJSON(schema_file_path(), simplifyVector = FALSE) + + defs <- raw[["$defs"]] + common_props <- raw$properties + one_of <- raw$oneOf + top_required <- if (!is.null(raw$required)) raw$required else character(0) + + event_registry <- list() + property_registry <- list() + + # Register common properties (shared across all events) + for (prop_name in names(common_props)) { + if (prop_name == "$schema") next + prop <- common_props[[prop_name]] + prop_resolved <- resolve_property(prop, defs) + desc <- build_property_descriptor(prop_name, prop_resolved, + required = prop_name %in% top_required, + event_type = "__common__", + is_array_item = FALSE) + property_registry[[prop_name]] <- desc + } + + common_prop_names <- setdiff(names(common_props), "$schema") + + # Build event type choices for the discriminator selectInput + event_type_choices <- list() + + for (event_def in one_of) { + event_props <- event_def$properties + + # The mgmt_operations_event const identifies the event type + event_const <- event_props$mgmt_operations_event[["const"]] + if (is.null(event_const)) next + + event_titles <- extract_titles(event_def) + event_required <- if (!is.null(event_def$required)) { + event_def$required + } else { + character(0) + } + + event_type_choices[[event_const]] <- event_titles + + # Detect nested oneOf (subtypes, e.g. fertilizer, observation) + nested_oneof <- event_def$oneOf + has_subtypes <- !is.null(nested_oneof) && length(nested_oneof) > 0 + + # Find the subtype discriminator if present + subtype_discriminator <- NULL + subtype_registry <- list() + + if (has_subtypes) { + # Find which property is the discriminator + for (pn in names(event_props)) { + if (pn == "mgmt_operations_event") next + p <- event_props[[pn]] + xui <- p[["x-ui"]] + if (!is.null(xui) && identical(xui$discriminator, TRUE)) { + subtype_discriminator <- pn + break + } + } + + for (subtype_def in nested_oneof) { + sub_props <- subtype_def$properties + # Find the const value for the discriminator + sub_const <- NULL + if (!is.null(subtype_discriminator) && + !is.null(sub_props[[subtype_discriminator]])) { + sub_const <- sub_props[[subtype_discriminator]][["const"]] + } + if (is.null(sub_const)) next + + sub_titles <- extract_titles(subtype_def) + sub_required <- if (!is.null(subtype_def$required)) { + subtype_def$required + } else { + character(0) + } + + # Register subtype-specific properties + sub_prop_names <- character(0) + for (spn in names(sub_props)) { + if (spn == subtype_discriminator) next + if (spn == "mgmt_operations_event") next + sp <- sub_props[[spn]] + sp_resolved <- resolve_property(sp, defs) + is_req <- spn %in% sub_required || spn %in% event_required + desc <- build_property_descriptor(spn, sp_resolved, + required = is_req, + event_type = event_const, + is_array_item = FALSE) + desc$subtype <- sub_const + property_registry[[paste0(spn, REGISTRY_KEY_SEP, event_const, REGISTRY_KEY_SEP, sub_const)]] <- desc + sub_prop_names <- c(sub_prop_names, spn) + } + + subtype_registry[[sub_const]] <- list( + const = sub_const, + titles = sub_titles, + property_names = sub_prop_names, + required = sub_required + ) + } + } + + # Register event-level properties (excluding mgmt_operations_event const + # and properties that only belong to subtypes) + event_prop_names <- character(0) + for (pn in names(event_props)) { + if (pn == "mgmt_operations_event") next + p <- event_props[[pn]] + + # Skip if this property has a const (it's the discriminator value itself) + if (!is.null(p[["const"]]) && is.null(p$type)) next + + p_resolved <- resolve_property(p, defs) + is_req <- pn %in% event_required + desc <- build_property_descriptor(pn, p_resolved, + required = is_req, + event_type = event_const, + is_array_item = FALSE) + # Use a unique key to avoid collision between events sharing property names + reg_key <- paste0(pn, REGISTRY_KEY_SEP, event_const) + property_registry[[reg_key]] <- desc + event_prop_names <- c(event_prop_names, pn) + } + + event_registry[[event_const]] <- list( + const = event_const, + titles = event_titles, + property_names = event_prop_names, + required = event_required, + has_subtypes = has_subtypes, + subtype_discriminator = subtype_discriminator, + subtypes = subtype_registry + ) + } + + # Build reverse-lookup index: bare prop_name -> first matching registry key. + # Avoids linear scan in find_any_property_desc(). + property_reverse_index <- list() + for (key in names(property_registry)) { + bare_name <- sub(paste0(REGISTRY_KEY_SEP, ".*"), "", key) + if (is.null(property_reverse_index[[bare_name]])) { + property_reverse_index[[bare_name]] <- key + } + } + + list( + raw = raw, + event_registry = event_registry, + property_registry = property_registry, + property_reverse_index = property_reverse_index, + common_properties = common_prop_names, + event_type_choices = event_type_choices + ) +} + +#' Resolve $ref and allOf in a property definition +#' @param prop The property definition (list) +#' @param defs The $defs section from the schema +#' @return The resolved property with refs inlined +resolve_property <- function(prop, defs) { + if (is.null(prop)) return(prop) + + # Handle allOf: merge titles from first element with content from resolved ref + if (!is.null(prop$allOf)) { + merged <- list() + for (part in prop$allOf) { + resolved <- resolve_ref(part, defs) + merged <- merge_lists(merged, resolved) + } + # Carry over any top-level keys not in allOf + for (k in names(prop)) { + if (k != "allOf" && is.null(merged[[k]])) { + merged[[k]] <- prop[[k]] + } + } + return(merged) + } + + # Handle direct $ref + prop <- resolve_ref(prop, defs) + + # Recursively resolve items for arrays + if (!is.null(prop$items) && is.list(prop$items)) { + prop$items <- resolve_property(prop$items, defs) + if (!is.null(prop$items$properties)) { + for (ipn in names(prop$items$properties)) { + prop$items$properties[[ipn]] <- resolve_property( + prop$items$properties[[ipn]], defs) + } + } + } + + prop +} + +#' Resolve a $ref pointer within the schema $defs +#' @param obj A list that may contain a $ref key +#' @param defs The $defs section from the schema +#' @return The resolved object +resolve_ref <- function(obj, defs) { + ref <- obj[["$ref"]] + if (is.null(ref)) return(obj) + + # refs are like "#/$defs/crop_ident_ICASA" + parts <- strsplit(sub("^#/", "", ref), "/")[[1]] + target <- defs + for (p in parts[-1]) { + target <- target[[p]] + } + if (is.null(target)) return(obj) + target +} + +merge_lists <- function(a, b) { + for (k in names(b)) { + a[[k]] <- b[[k]] + } + a +} + +extract_titles <- function(node) { + list( + en = node$title %||% "", + fi = node$title_fi %||% "", + sv = node$title_sv %||% "" + ) +} + +#' Determine the Shiny widget type from a schema property +#' @param prop A resolved property descriptor +#' @return A string: "selectInput", "numericInput", "dateInput", etc. +determine_widget_type <- function(prop) { + xui <- prop[["x-ui"]] + + if (!is.null(xui[["form-type"]])) { + return(xui[["form-type"]]) + } + + # const-only properties should not be rendered + if (!is.null(prop[["const"]]) && is.null(prop$type)) { + return("const") + } + + prop_type <- prop$type + + if (identical(prop_type, "array") && + !is.null(prop$items) && identical(prop$items$type, "object")) { + return("dataTable") + } + + if (identical(prop_type, "string")) { + if (!is.null(prop$oneOf) && length(prop$oneOf) > 0) return("selectInput") + if (!is.null(xui) && identical(xui$discriminator, TRUE)) return("selectInput") + if (identical(prop$format, "date")) return("dateInput") + return("textInput") + } + + if (identical(prop_type, "number") || identical(prop_type, "integer")) { + return("numericInput") + } + + "textInput" +} + +#' Build a property descriptor for the property registry +#' @param name Property name (used as input ID) +#' @param prop Resolved property definition +#' @param required Whether this property is required +#' @param event_type The event type this property belongs to +#' @param is_array_item Whether this property is inside an array items +#' @return A named list describing the property +build_property_descriptor <- function(name, prop, required, event_type, + is_array_item) { + xui <- prop[["x-ui"]] + widget_type <- determine_widget_type(prop) + + choices <- NULL + if (widget_type == "selectInput" && !is.null(prop$oneOf)) { + choices <- extract_oneof_choices(prop$oneOf) + } + + array_columns <- NULL + array_items_required <- NULL + if (widget_type == "dataTable" && !is.null(prop$items$properties)) { + array_columns <- list() + array_items_required <- if (!is.null(prop$items$required)) { + prop$items$required + } else { + character(0) + } + for (col_name in names(prop$items$properties)) { + col_prop <- prop$items$properties[[col_name]] + array_columns[[col_name]] <- build_property_descriptor( + col_name, col_prop, + required = col_name %in% array_items_required, + event_type = event_type, + is_array_item = TRUE) + } + } + + titles <- extract_titles(prop) + + # Unitless titles for table column headers + unitless_titles <- NULL + if (!is.null(xui)) { + ut_en <- xui$unitless_title %||% xui$unitless_title2 + ut_fi <- xui$unitless_title_fi %||% xui$unitless_title2_fi + ut_sv <- xui$unitless_title_sv %||% xui$unitless_title2_sv + if (!is.null(ut_en) || !is.null(ut_fi) || !is.null(ut_sv)) { + unitless_titles <- list( + en = ut_en %||% "", + fi = ut_fi %||% "", + sv = ut_sv %||% "" + ) + } + } + + placeholders <- NULL + if (!is.null(xui)) { + ph_en <- xui[["form-placeholder"]] %||% xui[["placeholder"]] + ph_fi <- xui[["form-placeholder_fi"]] %||% xui[["placeholder_fi"]] + ph_sv <- xui[["form-placeholder_sv"]] %||% xui[["placeholder_sv"]] + if (!is.null(ph_en) || !is.null(ph_fi)) { + placeholders <- list(en = ph_en %||% "", fi = ph_fi %||% "", + sv = ph_sv %||% "") + } + } + + # total_of info for auto-sum fields + total_of <- NULL + if (!is.null(xui$total_of_list)) { + total_of <- list( + list_name = xui$total_of_list, + property_name = xui$total_of_property + ) + } + + list( + name = name, + type = widget_type, + titles = titles, + unitless_titles = unitless_titles, + choices = choices, + required = required, + minimum = prop$minimum, + maximum = prop$maximum, + min_items = prop$minItems, + placeholders = placeholders, + total_of = total_of, + event_type = event_type, + is_array_item = is_array_item, + is_integer = identical(prop$type, "integer"), + is_discriminator = !is.null(xui) && identical(xui$discriminator, TRUE), + array_columns = array_columns, + array_items_required = array_items_required, + xui = xui + ) +} + +#' Extract selectInput choices from a oneOf array +#' @param one_of_array A list of oneOf entries each with const and title +#' @return A list of choice descriptors with const, titles +extract_oneof_choices <- function(one_of_array) { + choices <- list() + for (entry in one_of_array) { + const_val <- entry[["const"]] + if (is.null(const_val)) next + choices[[length(choices) + 1]] <- list( + value = const_val, + titles = extract_titles(entry) + ) + } + choices +} + +#' Get title in the requested language with fallback +#' @param titles A list with keys en, fi, sv +#' @param language Language code: "en", "fi", or "sv" +#' @param fallback A fallback string if all titles are empty +#' @return The title string +schema_get_title <- function(titles, language = "en", fallback = "") { + if (is.null(titles)) return(fallback) + lang_key <- language + result <- titles[[lang_key]] + if (!is.null(result) && nchar(result) > 0) return(result) + # fallback to English + result <- titles[["en"]] + if (!is.null(result) && nchar(result) > 0) return(result) + fallback +} + +#' Convert language column name to ISO code +#' @param language Either an ISO code or a display_names.csv column name +#' @return ISO language code +lang_to_iso <- function(language) { + mapping <- c( + "disp_name_eng" = "en", + "disp_name_fin" = "fi", + "disp_name_swe" = "sv", + "en" = "en", + "fi" = "fi", + "sv" = "sv" + ) + result <- mapping[[language]] + if (is.null(result)) "en" else result +} + +#' Build a named choice vector for selectInput from schema choices +#' @param choices A list of choice descriptors from extract_oneof_choices +#' @param language Language code or column name +#' @return A named character vector suitable for selectInput choices +schema_get_choices <- function(choices, language) { + if (is.null(choices) || length(choices) == 0) return(NULL) + iso <- lang_to_iso(language) + values <- vapply(choices, function(ch) ch$value, character(1)) + labels <- vapply(choices, function(ch) { + schema_get_title(ch$titles, iso, ch$value) + }, character(1)) + result <- c("", values) + names(result) <- c("", labels) + result +} + +#' Look up a property descriptor from the registry +#' @param registry The property registry +#' @param prop_name Property name +#' @param event_type Event type const (or NULL for common) +#' @param subtype Subtype const (or NULL) +#' @return The property descriptor, or NULL +lookup_property <- function(registry, prop_name, event_type = NULL, + subtype = NULL) { + # Try subtype-specific key first + if (!is.null(subtype) && !is.null(event_type)) { + key <- paste0(prop_name, REGISTRY_KEY_SEP, event_type, REGISTRY_KEY_SEP, subtype) + if (!is.null(registry[[key]])) return(registry[[key]]) + } + # Try event-specific key + if (!is.null(event_type)) { + key <- paste0(prop_name, REGISTRY_KEY_SEP, event_type) + if (!is.null(registry[[key]])) return(registry[[key]]) + } + # Try common property + if (!is.null(registry[[prop_name]])) return(registry[[prop_name]]) + NULL +} + +#' Get properties relevant to the currently selected event/subtype +#' @param schema The loaded schema (from load_schema) +#' @param event_type The selected event type const +#' @param subtype The selected subtype const (or NULL) +#' @return A list with: common, event_props, subtype_props, all +get_relevant_properties <- function(schema, event_type, subtype = NULL) { + common <- schema$common_properties + + event_entry <- schema$event_registry[[event_type]] + event_props <- character(0) + subtype_props <- character(0) + + if (!is.null(event_entry)) { + event_props <- event_entry$property_names + + if (event_entry$has_subtypes && !is.null(subtype) && + !is.null(event_entry$subtypes[[subtype]])) { + subtype_props <- event_entry$subtypes[[subtype]]$property_names + } + } + + list( + common = common, + event_props = event_props, + subtype_props = subtype_props, + all = unique(c(common, event_props, subtype_props)) + ) +} diff --git a/R/fct_schema_ui.R b/R/fct_schema_ui.R new file mode 100644 index 0000000..bf685ee --- /dev/null +++ b/R/fct_schema_ui.R @@ -0,0 +1,405 @@ +# Schema-driven UI renderer +# Generates Shiny widgets from the parsed management-event schema + +#' Create a label with a required asterisk indicator +#' @param label The label text +#' @param required Whether the field is required +#' @return The label, optionally with a red asterisk appended +make_required_label <- function(label, required) { + if (!isTRUE(required) || is.null(label) || identical(label, "")) return(label) + tagList(label, tags$span(" *", class = "required-asterisk")) +} + +#' Convert a condition string from schema x-ui format to JavaScript for conditionalPanel +#' Replaces input.FIELD with input['ns-FIELD'] for namespaced Shiny modules +#' @param condition The condition string (e.g. "input.organic_material == 'RE003'") +#' @param ns Namespace function +#' @return A JavaScript condition string with namespaced input references +convert_condition_to_js <- function(condition, ns) { + gsub("input\\.(\\w+)", paste0("input['", ns("\\1"), "']"), condition, + perl = TRUE) +} + +#' Render the full schema-driven form +#' @param schema The loaded schema (from load_schema) +#' @param ns Shiny namespace function +#' @param language Language code or column name +#' @return A tagList of Shiny UI elements +render_schema_form <- function(schema, ns, language) { + iso <- lang_to_iso(language) + er <- schema$event_registry + pr <- schema$property_registry + + # Build per-event-type conditional panels + event_panels <- lapply(names(er), function(event_const) { + event_entry <- er[[event_const]] + panel_content <- render_event_panel(event_entry, pr, ns, iso, event_const) + + condition <- paste0("input['", ns("mgmt_operations_event"), + "'] == '", event_const, "'") + conditionalPanel(condition = condition, panel_content) + }) + + tagList(event_panels) +} + +#' Render the panel for a single event type +#' @param event_entry An event registry entry +#' @param pr Property registry +#' @param ns Namespace function +#' @param iso ISO language code +#' @param event_const The event type const value +#' @return A tagList +render_event_panel <- function(event_entry, pr, ns, iso, event_const) { + widgets <- list() + + # Render event-level properties (excluding discriminator and const-only) + for (pn in event_entry$property_names) { + desc <- lookup_property(pr, pn, event_const) + if (is.null(desc)) next + if (desc$type == "const") next + + if (desc$type == "dataTable") { + w <- render_array_table(pn, desc, ns, iso) + } else if (desc$is_discriminator && event_entry$has_subtypes) { + w <- render_subtype_section(pn, desc, event_entry, pr, ns, iso, + event_const) + } else { + w <- render_property_widget(pn, desc, ns, iso) + } + # Wrap in conditionalPanel if x-ui condition is defined + if (!is.null(desc$xui$condition)) { + w <- conditionalPanel( + condition = convert_condition_to_js(desc$xui$condition, ns), w) + } + widgets[[length(widgets) + 1]] <- w + } + + tagList(widgets) +} + +#' Render a subtype discriminator and its conditional panels +render_subtype_section <- function(pn, desc, event_entry, pr, ns, iso, + event_const) { + # Render the discriminator selectInput with subtype choices + subtype_choices <- build_subtype_choices(event_entry, iso) + discriminator_widget <- render_property_widget(pn, desc, ns, iso, + override_choices = subtype_choices) + + # Build subtype conditional panels + subtype_panels <- lapply(names(event_entry$subtypes), function(sub_const) { + sub <- event_entry$subtypes[[sub_const]] + + sub_widgets <- list() + for (spn in sub$property_names) { + sdesc <- lookup_property(pr, spn, event_const, sub_const) + if (is.null(sdesc)) next + if (sdesc$type == "const") next + + if (sdesc$type == "dataTable") { + sw <- render_array_table(spn, sdesc, ns, iso) + } else { + sw <- render_property_widget(spn, sdesc, ns, iso) + } + if (!is.null(sdesc$xui$condition)) { + sw <- conditionalPanel( + condition = convert_condition_to_js(sdesc$xui$condition, ns), sw) + } + sub_widgets[[length(sub_widgets) + 1]] <- sw + } + + condition <- paste0("input['", ns(pn), "'] == '", sub_const, "'") + conditionalPanel(condition = condition, tagList(sub_widgets)) + }) + + tagList(discriminator_widget, subtype_panels) +} + +#' Render a single Shiny input widget from a property descriptor +#' @param prop_name Property name (used as input ID) +#' @param desc Property descriptor from the registry +#' @param ns Namespace function +#' @param iso ISO language code +#' @param override_code_name Optional code name override (for table cells) +#' @param override_label Optional label override +#' @param override_value Optional value override +#' @param override_choices Optional choices override +#' @param override_selected Optional selected value override +#' @param override_placeholder Optional placeholder override +#' @param width Optional width +#' @return A Shiny widget tag +render_property_widget <- function(prop_name, desc, ns, iso, + override_code_name = NULL, + override_label = NULL, + override_value = NULL, + override_choices = NULL, + override_selected = NULL, + override_placeholder = NULL, + width = NULL) { + input_id <- ns(if (!is.null(override_code_name)) { + override_code_name + } else { + prop_name + }) + + label <- if (!is.null(override_label)) { + override_label + } else { + make_required_label( + schema_get_title(desc$titles, iso, prop_name), + desc$required + ) + } + + value <- if (!is.null(override_value)) override_value else "" + + placeholder <- if (!is.null(override_placeholder)) { + override_placeholder + } else if (!is.null(desc$placeholders)) { + schema_get_title(desc$placeholders, iso, "") + } else { + NULL + } + + wtype <- desc$type + extra_args <- list() + if (!is.null(width)) extra_args$width <- width + + if (wtype == "selectInput") { + choices <- if (!is.null(override_choices)) { + override_choices + } else { + schema_get_choices(desc$choices, iso) + } + if (is.null(choices)) choices <- stats::setNames("", "") + selected <- override_selected + + do.call(selectInput, c(list( + inputId = input_id, + label = label, + choices = choices, + selected = selected + ), extra_args)) + + } else if (wtype == "numericInput") { + num_val <- if (is.numeric(override_value)) override_value else NA + num_min <- if (!is.null(desc$minimum)) desc$minimum else NA + num_max <- if (!is.null(desc$maximum)) desc$maximum else NA + + do.call(numericInput, c(list( + inputId = input_id, + label = label, + value = num_val, + min = num_min, + max = num_max, + step = if (isTRUE(desc$is_integer)) 1 else "any" + ), extra_args)) + + } else if (wtype == "dateInput") { + date_val <- if (!is.null(override_value) && nchar(override_value) > 0) { + tryCatch(as.Date(override_value), error = function(e) Sys.Date()) + } else { + Sys.Date() + } + + do.call(dateInput, c(list( + inputId = input_id, + label = label, + value = date_val, + format = "dd/mm/yyyy", + max = Sys.Date(), + weekstart = 1 + ), extra_args)) + + } else if (wtype == "textAreaInput") { + do.call(textAreaInput, c(list( + inputId = input_id, + label = label, + value = value, + resize = "vertical", + placeholder = placeholder + ), extra_args)) + + } else if (wtype == "textInput") { + do.call(textInput, c(list( + inputId = input_id, + label = label, + value = value, + placeholder = placeholder + ), extra_args)) + + } else { + # Fallback + textInput(inputId = input_id, label = label, value = value) + } +} + +#' Render a schema array property as a table module placeholder +#' @param prop_name The array property name (e.g. "planting_list") +#' @param desc The property descriptor +#' @param ns Namespace function +#' @param iso ISO language code +#' @return A tagList with the table module UI +render_array_table <- function(prop_name, desc, ns, iso) { + table_id <- paste0(prop_name, "_table") + table_ns <- NS(ns(table_id)) + w <- div( + class = "schema-array-table", + mod_table_ui(ns(table_id)), + div( + class = "schema-array-table__footer", + actionButton(table_ns("add_row"), + label = schema_table_add_row_label(iso), + icon = icon("plus"), + class = "btn-sm btn-default") + ) + ) + if (!is.null(desc$xui$condition)) { + w <- conditionalPanel( + condition = convert_condition_to_js(desc$xui$condition, ns), w) + } + w +} + +#' Update a single schema widget's label and choices +update_schema_widget <- function(session, prop_name, desc, iso, input) { + label <- make_required_label( + schema_get_title(desc$titles, iso, prop_name), + desc$required + ) + + if (desc$type == "selectInput") { + choices <- schema_get_choices(desc$choices, iso) + current <- input[[prop_name]] + if (is.null(choices)) { + updateSelectInput(session, prop_name, label = label, selected = current) + } else { + updateSelectInput(session, prop_name, label = label, choices = choices, + selected = current) + } + } else if (desc$type == "numericInput") { + updateNumericInput(session, prop_name, label = label) + } else if (desc$type == "dateInput") { + updateDateInput(session, prop_name, label = label) + } else if (desc$type == "textAreaInput") { + placeholder <- if (!is.null(desc$placeholders)) { + schema_get_title(desc$placeholders, iso, "") + } else { NULL } + updateTextAreaInput(session, prop_name, label = label, + placeholder = placeholder) + } else if (desc$type == "textInput") { + placeholder <- if (!is.null(desc$placeholders)) { + schema_get_title(desc$placeholders, iso, "") + } else { NULL } + updateTextInput(session, prop_name, label = label, + placeholder = placeholder) + } +} + +#' Build event type selectInput choices from the schema +#' @param schema Loaded schema +#' @param iso ISO language code +#' @return Named character vector for selectInput +build_event_type_choices <- function(schema, iso) { + values <- names(schema$event_type_choices) + labels <- vapply(schema$event_type_choices, function(titles) { + schema_get_title(titles, iso, "") + }, character(1)) + result <- c("", values) + names(result) <- c("", labels) + result +} + +#' Build subtype selectInput choices +#' @param event_entry An event registry entry +#' @param iso ISO language code +#' @return Named character vector for selectInput +build_subtype_choices <- function(event_entry, iso) { + if (!event_entry$has_subtypes) return(NULL) + subtypes <- event_entry$subtypes + values <- vapply(subtypes, function(s) s$const, character(1)) + labels <- vapply(subtypes, function(s) { + schema_get_title(s$titles, iso, s$const) + }, character(1)) + result <- c("", values) + names(result) <- c("", labels) + result +} + +#' Update a schema-driven widget value (for populating forms) +#' @param session Shiny session +#' @param prop_name Property name +#' @param desc Property descriptor +#' @param value The value to set +update_schema_value <- function(session, prop_name, desc, value) { + if (is.null(desc)) return() + + # Replace missingval with empty + if (!is.null(value) && is.atomic(value)) { + value[value == missingval] <- "" + } + + wtype <- desc$type + + if (wtype == "selectInput") { + if (is.null(value) || identical(value, "")) { + updateSelectInput(session, prop_name, selected = "") + } else { + updateSelectInput(session, prop_name, selected = value) + } + } else if (wtype == "numericInput") { + if (is.null(value) || identical(value, "") || identical(value, missingval)) { + updateNumericInput(session, prop_name, value = NA) + } else { + updateNumericInput(session, prop_name, value = as.numeric(value)) + } + } else if (wtype == "dateInput") { + date_val <- tryCatch(as.Date(value, format = date_format_json), + warning = function(cnd) NULL, + error = function(cnd) NULL) + updateDateInput(session, prop_name, value = date_val) + } else if (wtype == "textAreaInput") { + updateTextAreaInput(session, prop_name, + value = if (is.null(value)) "" else value) + } else if (wtype == "textInput") { + updateTextInput(session, prop_name, + value = if (is.null(value)) "" else value) + } +} + +#' Clear a schema-driven widget +clear_schema_value <- function(session, prop_name, desc) { + if (is.null(desc)) return() + wtype <- desc$type + + if (wtype == "selectInput") { + updateSelectInput(session, prop_name, selected = "") + } else if (wtype == "numericInput") { + updateNumericInput(session, prop_name, value = NA) + } else if (wtype == "dateInput") { + updateDateInput(session, prop_name, value = NULL) + } else if (wtype == "textAreaInput") { + updateTextAreaInput(session, prop_name, value = "") + } else if (wtype == "textInput") { + updateTextInput(session, prop_name, value = "") + } +} + +#' Get all schema property names as a flat vector (for registry iteration) +#' Used to find all properties that need validation, value collection, etc. +get_all_schema_properties <- function(schema) { + er <- schema$event_registry + all_props <- schema$common_properties + + for (ec in names(er)) { + event_entry <- er[[ec]] + all_props <- c(all_props, event_entry$property_names) + if (event_entry$has_subtypes) { + for (sc in names(event_entry$subtypes)) { + all_props <- c(all_props, event_entry$subtypes[[sc]]$property_names) + } + } + } + + unique(all_props) +} diff --git a/R/fct_ui.R b/R/fct_ui.R index 6c07a8d..c1b743b 100644 --- a/R/fct_ui.R +++ b/R/fct_ui.R @@ -1,11 +1,9 @@ # Builds the ui based on a json file -# e.g. builds additional options for the different activity types # Otto Kuusela 2021 -structure_file_path <- function() system.file("extdata", "ui_structure.json", +structure_file_path <- function() system.file("extdata", "ui_structure.json", package = "fieldactivity") structure <- jsonlite::fromJSON(structure_file_path(), simplifyMatrix = FALSE) -activity_options <- structure$form$mgmt_operations_event$sub_elements #' Recursively apply function to lists in a list @@ -27,13 +25,9 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { next } - # x is a list, so let's test it result <- fun(element, ...) if (!is.null(result)) { - - # if we have a naming function defined, use that - # index is either an actual index or name of the element if (is.null(name_fun)) { index <- length(results) + 1 } else { @@ -43,8 +37,6 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { results[[index]] <- result } - # more results might lurk on lower levels of the list. - # So let's investigate those more_results <- rlapply(element, fun, name_fun, ...) if (length(more_results) > 0) { @@ -56,7 +48,6 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { return(results) } else if (length(results) == 1) { return(results) - #return(results[[1]]) } else { return(NULL) } @@ -66,12 +57,11 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { #' Build lookup list for UI elements #' @description Build a list where the names are the code names of UI elements #' and the values are the corresponding element structures (lists) found in -#' ui_structure.json +#' ui_structure.json. Now only contains app chrome elements. #' @return The lookup list. build_structure_lookup_list <- function() { element_fetcher <- function(x) { if (!is.null(x$code_name)) { - # we don't need the sub_elements listed, those will come separately x$sub_elements <- NULL return(x) } else { @@ -88,12 +78,7 @@ build_structure_lookup_list <- function() { structure_lookup_list <- build_structure_lookup_list() -# help texts (technically textOutputs) have a different method of updating -# when the language is changed because they are outputs rather than inputs, -# and for that we need a list of the code names of these objects. -# The same goes for data tables (excluding event table). -# We also need the code names of fileInput delete buttons to set up observers -# for them +# Categorize code names by type for text outputs, tables, and fileInputs text_output_code_names <- NULL data_table_code_names <- NULL fileInput_code_names <- NULL @@ -110,7 +95,8 @@ for (element in structure_lookup_list) { #' Generate the UI for a list of elements in the structure file. #' #' For a given list of widget structures as read from ui_structure.json, -#' create_ui applies create_widget to each widget in the list +#' create_ui applies create_widget to each widget in the list. +#' Still used for app chrome rendering and by mod_table.R for legacy tables. #' #' @param widget_structure_list The list of widget structures (from #' ui_structure.json) to generate as UI @@ -121,7 +107,6 @@ for (element in structure_lookup_list) { create_ui <- function(widget_structure_list, ns) { new_elements <- lapply(widget_structure_list, create_widget, ns = ns) - # if there is a visibility condition, apply it if (!is.null(widget_structure_list$condition)) { new_elements <- conditionalPanel( condition = widget_structure_list$condition, @@ -132,11 +117,6 @@ create_ui <- function(widget_structure_list, ns) { return(new_elements) } -# creates the individual elements -# the override_label and ... functionalities are used for creating elements -# in dynamic (e.g. multi-crop) data tables. Do NOT supply the label argument in -# the unnamed arguments (...)! -# TODO: refactor. Get rid of those ugly override arguments create_widget <- function(element, ns = NS(NULL), override_label = NULL, override_code_name = NULL, @@ -145,22 +125,14 @@ create_widget <- function(element, ns = NS(NULL), override_selected = NULL, override_placeholder = NULL, ...) { - # element is a string, i.e. a visibility condition for a element set - # it has already been handled in create_ui if (!is.list(element)) { return() } - # element is a list of elements, because it doesn't have the type - # attribute. In that case we want to create all of the elements in that list if (is.null(element$type)) { return(create_ui(element, ns)) } - # the labels will be set to element$label which is a code_name, not a - # display_name, but this is okay as the server will update this as the - # language changes (which also happens when the program starts) - # the following allows overwriting the label through ... element_label <- get_disp_name(element$label, init_lang) if (!is.null(override_label)) { element_label <- override_label @@ -189,9 +161,7 @@ create_widget <- function(element, ns = NS(NULL), new_element <- if (element$type == "checkboxInput") { checkboxInput(element_code_name, label = element_label, ...) } else if (element$type == "selectInput") { - # if multiple is defined (=TRUE) then pass that to selectInput multiple <- identical(element$multiple, TRUE) - # we don't enter choices yet, that will be handled by the server selectInput(element_code_name, label = element_label, choices = element_choices, multiple = multiple, selected = override_selected, ...) @@ -199,7 +169,6 @@ create_widget <- function(element, ns = NS(NULL), if (!is.null(element$style) && element$style == "label") { strong(textOutput(element_code_name, ...)) } else { - # these are inteded to look like helpTexts so make text gray tagList( span(textOutput(element_code_name, ...), style = "color:gray"), br() @@ -236,11 +205,6 @@ create_widget <- function(element, ns = NS(NULL), # } - # put the new element in a conditionalPanel. If no condition is specified, - # the element will be visible by default - #new_element <- conditionalPanel(condition = element$condition, new_element) - - # if there are sub-elements to create, do that if (!is.null(element$sub_elements)) { return(list(new_element, create_ui(element$sub_elements, ns))) @@ -252,21 +216,11 @@ create_widget <- function(element, ns = NS(NULL), #' Find the choices for a selectInput given its code name #' #' @param selectInput_code_name The code name of the selectInput -#' @param language The language to show the options in. This will be passed to -#' get_disp_name +#' @param language The language to show the options in. #' #' @return A vector of choices (code names). If language was supplied, the names #' will be the names of the vector. get_selectInput_choices <- function(selectInput_code_name, language) { - # the choices for a selectInput element can be stored in - # three ways: - # 1) the code names of the choices are given as a vector - # 2) for site and block selectors, there is IGNORE: - # this means that the choices should not be updated here (return NULL) - # 3) the category name for the choices is given. - # in the following if-statement, these are handled - # in this same order - element_structure <- structure_lookup_list[[selectInput_code_name]] if (!identical(element_structure$type, "selectInput") || @@ -281,8 +235,6 @@ get_selectInput_choices <- function(selectInput_code_name, language) { } else if (element_structure$choices == "IGNORE") { choices <- NULL } else { - # get_category_names returns both display names and - # code names choices <- c( "", get_category_names(element_structure$choices, @@ -299,22 +251,14 @@ get_selectInput_choices <- function(selectInput_code_name, language) { #' functions. #' @param session Current shiny session #' @param code_name The code name of the UI element to update -#' @param value An atomic vector holding the desired value of the UI element. If -#' NULL, the value of the element is not altered. -#' @param clear_value If set to TRUE, the value of the element is cleared (and -#' any value supplied to value is ignored) -#' @param ... Additional arguments (such as label) to pass to Shiny's update- -#' functions. +#' @param value An atomic vector holding the desired value of the UI element. +#' @param clear_value If set to TRUE, the value of the element is cleared. +#' @param ... Additional arguments to pass to Shiny's update functions. #' @importFrom glue glue update_ui_element <- function(session, code_name, value = NULL, clear_value = FALSE, ...) { - # find the element from the UI structure lookup list, which has been - # generated in ui_builder.R element <- structure_lookup_list[[code_name]] - # didn't find the element corresponding to code_name - # this should not happen if the element is in - # sidebar_ui_structure.json if (is.null(element$type)) { stop("UI element type not found, could not update") } @@ -322,23 +266,17 @@ update_ui_element <- function(session, code_name, value = NULL, stop("The value given to update_ui_element should be an atomic vector") } - # if value is NULL, we need to determine on a widget type basis how to - # clear the value. If it isn't, replace missingvals with "" if (!is.null(value)) { - # replace missingvals with empty strings missing_indexes <- identical(value, missingval) if (any(missing_indexes)) { value[missing_indexes] <- "" } } - if (element$type == "selectInput") { if (clear_value) value <- "" - # setting the selected value to NULL doesn't change the widget's value updateSelectInput(session, code_name, selected = value, ...) } else if (element$type == "dateInput") { - # setting value to NULL will reset the date to the current date value <- if (clear_value) { NULL } else { @@ -349,21 +287,15 @@ update_ui_element <- function(session, code_name, value = NULL, } else if (element$type == "textAreaInput") { if (clear_value) value <- "" updateTextAreaInput(session, code_name, value = value, ...) - #} else if (element$type == "checkboxInput") { - # updateCheckboxInput(session, code_name, value = value, ...) } else if (element$type == "actionButton") { updateActionButton(session, code_name, ...) } else if (element$type == "textInput") { if (clear_value) value <- "" updateTextInput(session, code_name, value = value, ...) } else if (element$type == "numericInput") { - # if we are given a non-numeric value, we don't want to start converting - # it. Let's replace it with an empty string (the default value) - # if (!is.numeric(value)) {value <- ""} if (clear_value) { value <- "" } updateNumericInput(session, code_name, value = value, ...) } else if (element$type == "dateRangeInput") { - if (!is.null(value) & length(value) != 2) { value <- NULL warning(glue("Value supplied to the dateRangeInput was not of ", @@ -378,33 +310,22 @@ update_ui_element <- function(session, code_name, value = NULL, start = start, end = end)) } else if (element$type == "fileInput") { - } } #' Reset the value of input fields #' -#' Set the specified input fields to their default empty values. -#' #' @param session The current Shiny session #' @param fields_to_clear The names of the variables whose corresponding fields #' should be cleared #' @param exceptions Optional vector of variable names which should not be -#' cleared. This is useful if fields_to_clear is supplied with all variable -#' names but there are a few that should not be cleared. +#' cleared. #' @return None, used for side effects. -#' @note This doesn't reset the tables (e.g. harvest_crop_table) -- they reset -#' themselves every time they become hidden. Also doesn't reset fileInputs, -#' they have their own way of clearing their value. -# TODO: is exceptions necessary? reset_input_fields <- function(session, fields_to_clear, exceptions = c("")) { - - # we never want to clear the site or block exceptions <- c(exceptions, "site", "block") for (code_name in fields_to_clear) { if (code_name %in% exceptions) next update_ui_element(session, code_name, clear_value = TRUE) } - } diff --git a/R/mod_event_list.R b/R/mod_event_list.R index 6922552..facc4f9 100644 --- a/R/mod_event_list.R +++ b/R/mod_event_list.R @@ -236,14 +236,14 @@ mod_event_list_server <- function(id, events, language, site) { isTruthy(input$event_list_block_filter) & isTruthy(input$event_list_year_filter))) { default_variables <- c("block", "mgmt_operations_event", - "date", "mgmt_event_notes") + "date", "mgmt_event_short_notes") return(get_data_table(list(), default_variables)) } if (dp()) message("event list table_data reactive running") # determine the columns displayed in the table - table_variables <- c("date", "mgmt_event_notes") + table_variables <- c("date", "mgmt_event_short_notes") if (input$event_list_activity_filter == "activity_choice_all") { table_variables <- c("mgmt_operations_event", table_variables) } @@ -256,16 +256,21 @@ mod_event_list_server <- function(id, events, language, site) { if (input$event_list_activity_filter != "activity_choice_all") { hidden_widget_types <- c("textOutput", "dataTable", "fileInput", "actionButton") - activity_variables <- unlist(rlapply( - activity_options[[input$event_list_activity_filter]], - fun = function(x) { - if (is.null(x$type) || x$type %in% hidden_widget_types || - identical(x$hide_in_event_list, TRUE)) { - NULL - } else { - x$code_name - } - })) + # Use schema registry to get event-specific property names + event_type <- input$event_list_activity_filter + event_entry <- mgmt_schema$event_registry[[event_type]] + if (!is.null(event_entry)) { + activity_variables <- character(0) + for (pn in event_entry$property_names) { + desc <- lookup_property(mgmt_schema$property_registry, pn, + event_type) + if (is.null(desc)) next + if (desc$type %in% c("const", "dataTable")) next + activity_variables <- c(activity_variables, pn) + } + } else { + activity_variables <- character(0) + } table_variables <- c(table_variables, activity_variables) } @@ -283,12 +288,13 @@ mod_event_list_server <- function(id, events, language, site) { # filter by activity type if (input$event_list_activity_filter != "activity_choice_all") { event_list <- rlapply(event_list, fun = function(x) - if (x$mgmt_operations_event == input$event_list_activity_filter) {x}) + if (!is.null(x$mgmt_operations_event) && x$mgmt_operations_event == input$event_list_activity_filter) {x}) } - + # filter by year if (input$event_list_year_filter != "year_choice_all") { event_list <- rlapply(event_list, fun = function(x) { + if (is.null(x$date)) return(NULL) event_year <- format(as.Date(x$date, date_format_json), "%Y") if (event_year == input$event_list_year_filter) {x} }) @@ -355,9 +361,9 @@ mod_event_list_server <- function(id, events, language, site) { rownames = FALSE, # hide row numbers class = "table table-hover", #autoHideNavigation = TRUE, doesn't work properly with dom - colnames = get_disp_name(names(new_data_to_display), - language = language(), - is_variable_name = TRUE), + colnames = unname(get_event_list_colnames( + names(new_data_to_display), + language())), options = list(dom = 'tp', # hide unnecessary controls # order chronologically by hidden column order = list(n_cols - 1, 'desc'), diff --git a/R/mod_form.R b/R/mod_form.R index 88c5a3e..9234e90 100644 --- a/R/mod_form.R +++ b/R/mod_form.R @@ -1,4 +1,4 @@ -# The function of the form modoule is as follows: +# The function of the form module is as follows: # - contains the widgets for entering the actual information about the event # - shows the correct widgets depending on the user's choices # - allows prefilling the widgets with the desired values @@ -20,21 +20,15 @@ #' @importFrom shiny NS tagList mod_form_ui <- function(id){ ns <- NS(id) + iso <- lang_to_iso(init_lang) + tagList( - - # the form contains the widgets for entering information - # about the event fluidRow( column(width = 3, h3(textOutput(ns("form_title")), style = "margin-bottom = 0px; margin-top = 0px; margin-block-start = 0px"), - # in general the choices and labels don't have to be - # defined for selectInputs, as they will be - # populated when the language is changed - # (which also happens when the app starts) - span(textOutput(ns("required_variables_helptext")), style = "color:gray"), br(), @@ -44,36 +38,41 @@ mod_form_ui <- function(id){ choices = ""), selectInput(ns("mgmt_operations_event"), - label = get_disp_name("mgmt_operations_event_label", - init_lang), - choices = get_selectInput_choices( - "mgmt_operations_event", init_lang) - ), + label = schema_get_title( + lookup_property(mgmt_schema$property_registry, + "mgmt_operations_event")$titles, + iso, "event"), + choices = build_event_type_choices(mgmt_schema, iso) + ), - # setting max disallows inputting future events dateInput( ns("date"), format = "dd/mm/yyyy", - label = get_disp_name("date_label", init_lang), + label = schema_get_title( + lookup_property(mgmt_schema$property_registry, "date")$titles, + iso, "date"), max = Sys.Date(), value = Sys.Date(), weekstart = 1 ), textAreaInput( - ns("mgmt_event_notes"), - label = get_disp_name("mgmt_event_notes_label", init_lang), - placeholder = get_disp_name("mgmt_event_notes_placeholder", - init_lang), + ns("mgmt_event_short_notes"), + label = schema_get_title( + lookup_property(mgmt_schema$property_registry, + "mgmt_event_short_notes")$titles, + iso, "description"), + placeholder = schema_get_title( + lookup_property(mgmt_schema$property_registry, + "mgmt_event_short_notes")$placeholders, + iso, ""), resize = "vertical", height = "70px" ) ), column(width = 9, - # show a detailed options panel for the different activities - # activity_options and create_ui is defined in utils_ui.R - create_ui(activity_options, ns) + render_schema_form(mgmt_schema, ns, init_lang) ) ), @@ -81,14 +80,11 @@ mod_form_ui <- function(id){ fluidRow( column(width = 12, actionButton(ns("save"), label = "Save"), - actionButton(ns("cancel"), label = "Cancel"), - shinyjs::hidden(actionButton(ns("delete"), label = "Delete", class = "btn-warning")) ) ) - ) } @@ -122,88 +118,62 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, if (dp()) message("Initialising form server function") - # add input validators - # the idea is that each widget has its own validator. This validator is - # active whenever that widget is in relevant variables. These individual - # validators are then added as subvalidators to main_iv + schema <- mgmt_schema + er <- schema$event_registry + pr <- schema$property_registry + main_iv <- InputValidator$new() - lapply(get_category_names("variable_name"), FUN = function(variable) { - - widget <- structure_lookup_list[[variable]] + + all_props <- get_all_schema_properties(schema) + for (prop_name in all_props) { + # Try to find descriptor from any event/subtype context + desc <- find_any_property_desc(pr, prop_name, schema$property_reverse_index) + if (is.null(desc)) next + if (desc$type %in% c("const", "dataTable")) next + iv <- InputValidator$new() added_rules <- FALSE - # add required rule - if (identical(widget$required, TRUE)) { - - if (widget$type == "dateRangeInput") { - iv$add_rule(variable, sv_required(message = "", - test = valid_dateRangeInput)) - } else { - iv$add_rule(variable, sv_required(message = "")) - } - - added_rules <- TRUE - } - - # add minimum rule - if (!is.null(widget$min)) { - iv$add_rule(variable, sv_gte(widget$min, allow_na = TRUE, - message_fmt = "")) + if (isTRUE(desc$required)) { + iv$add_rule(prop_name, sv_required(message = "")) added_rules <- TRUE } - # add maximum rule - # using [[ here because $ does partial matching and catches onto - # maxlength - if (!is.null(widget[["max"]])) { - iv$add_rule(variable, sv_lte(widget[["max"]], allow_na = TRUE, - message_fmt = "")) + if (!is.null(desc$minimum)) { + iv$add_rule(prop_name, sv_gte(desc$minimum, allow_na = TRUE, + message_fmt = "")) added_rules <- TRUE } - # add integer rule - if (identical(widget$step, as.integer(1))) { - iv$add_rule(variable, sv_integer(message = "", allow_na = TRUE)) + if (!is.null(desc$maximum)) { + iv$add_rule(prop_name, sv_lte(desc$maximum, allow_na = TRUE, + message_fmt = "")) added_rules <- TRUE } - - # add max length rule - if (!is.null(widget$maxlength)) { - iv$add_rule(variable, function(x) { - if (!isTruthy(x)) return(NULL) - if (nchar(x) <= widget$maxlength) NULL - else glue("Max. {widget$maxlength} characters") + + if (isTRUE(desc$is_integer)) { + iv$add_rule(prop_name, function(value) { + if (is.null(value) || is.na(value)) return(NULL) + if (value != floor(value)) return("Must be a whole number") + NULL }) added_rules <- TRUE } if (added_rules) { - # the validator is only active when it is in the current list of - # relevant, regular widgets - iv$condition(reactive({ variable %in% relevant_variables()$regular })) - # add widget validator to main validator + local({ + local_prop <- prop_name + iv$condition(reactive({ + local_prop %in% relevant_variables()$regular + })) + }) main_iv$add_validator(iv) } - - }) - # start showing validation messages + } main_iv$enable() - # go through all fields and set maxLength if requested in ui_structure.json - # TODO: do with validation instead - # for (element in structure_lookup_list) { - # if (!is.null(element$maxlength)) { - # js_message <- "$('##code_name').attr('maxlength', #maxlength)" - # js_message <- gsub("#code_name", ns(element$code_name), js_message) - # js_message <- gsub("#maxlength", element$maxlength, js_message) - # shinyjs::runjs(js_message) - # } - # } - # when site setting is changed, update the block choices on the form observeEvent(site(), ignoreNULL = FALSE, { - if (!isTruthy(site())) { shinyjs::disable("block") shinyjs::disable("save") @@ -213,85 +183,110 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, shinyjs::enable("block") shinyjs::enable("save") - # update block choices block_choices <- subset(sites, sites$site == site())$blocks[[1]] updateSelectInput(session, "block", choices = block_choices) - }) # when set_values is changed, update the values in the form observeEvent(set_values(), { - if (dp()) message("Filling the form with values") values <- set_values() + iso <- lang_to_iso(language()) - # populate the input widgets with the values corresponding to the - # event, and clear others - for (variable in get_category_names("variable_name")) { - - # get the value corresponding to this variable from the event. - # might be NULL - value <- values[[variable]] - widget <- structure_lookup_list[[variable]] + relevant <- get_relevant_properties( + schema, + values$mgmt_operations_event %||% "", + get_subtype_value(values, er) + ) + + for (prop_name in relevant$all) { + desc <- lookup_property( + pr, prop_name, + values$mgmt_operations_event, + get_subtype_value(values, er)) + if (is.null(desc)) next + if (desc$type %in% c("const", "dataTable")) next - # determine if this value should be filled in a table - # for now this is a sufficient condition - variable_table <- get_variable_table(variable) - value_in_table <- !is.null(variable_table) & length(value) > 1 + value <- values[[prop_name]] + # Handle legacy property name mapping + if (is.null(value)) { + value <- get_legacy_value(values, prop_name) + } - if (!(variable %in% names(values)) | value_in_table) { - # clear widget if the event does not contain a value for it - # or value should be shown in a table instead - update_ui_element(session, variable, clear_value = TRUE) - } else if (widget$type == "fileInput") { - files[[variable]]$set_path(value) + if (is.null(value)) { + clear_schema_value(session, prop_name, desc) } else { - update_ui_element(session, variable, value = value) + update_schema_value(session, prop_name, desc, value) } } - # then go through all the variables in the event and see if any of - # them should be displayed in the table. If yes, fill the table. - # Other tables do not need to be cleared, as they do that by - # themselves when they become hidden. - for (variable in names(values)) { - variable_table <- get_variable_table(variable) - - if (!is.null(variable_table)) { - tables[[variable_table]]$set_values(values) - # currently there is only one possible table per event - break + # Handle array/table data (event-level and subtype-level) + subtype_val <- get_subtype_value(values, er) + for (prop_name in c(relevant$event_props, relevant$subtype_props)) { + desc <- lookup_property(pr, prop_name, + values$mgmt_operations_event, + subtype_val) + if (!is.null(desc) && desc$type == "dataTable") { + table_name <- paste0(prop_name, "_table") + if (!is.null(tables[[table_name]])) { + tables[[table_name]]$set_values(values) + } } } - # change set_values back to NULL so that we can catch the next time its - # value is changed. This doesn't re-trigger this observeEvent as - # observeEvent ignores NULL values by default + # Also set common fields explicitly + if (!is.null(values$block)) { + updateSelectInput(session, "block", selected = values$block) + } + if (!is.null(values$mgmt_operations_event)) { + updateSelectInput(session, "mgmt_operations_event", + selected = values$mgmt_operations_event) + } + if (!is.null(values$date)) { + date_val <- tryCatch(as.Date(values$date, format = date_format_json), + warning = function(cnd) NULL) + updateDateInput(session, "date", value = date_val) + } + if (!is.null(values$mgmt_event_short_notes)) { + updateTextAreaInput(session, "mgmt_event_short_notes", + value = values$mgmt_event_short_notes) + } + # Handle legacy field name for short notes + if (!is.null(values$mgmt_event_notes) && + is.null(values$mgmt_event_short_notes)) { + updateTextAreaInput(session, "mgmt_event_short_notes", + value = values$mgmt_event_notes) + } + set_values(NULL) }) # when reset_values is signaled, reset the values of all widgets observeEvent(reset_values(), { - if (identical(reset_values(), FALSE)) return() - if (dp()) message("Resetting form values") - reset_input_fields(session, get_category_names("variable_name")) + # Reset common properties + for (pn in schema$common_properties) { + desc <- lookup_property(pr, pn) + if (!is.null(desc)) clear_schema_value(session, pn, desc) + } + + # Reset all event properties + all_props <- get_all_schema_properties(schema) + for (pn in all_props) { + desc <- find_any_property_desc(pr, pn, schema$property_reverse_index) + if (!is.null(desc) && !(desc$type %in% c("const", "dataTable"))) { + clear_schema_value(session, pn, desc) + } + } - # clear fileInput fields separately + # Reset fileInput fields separately for (fileInput_code_name in fileInput_code_names) { files[[fileInput_code_name]]$reset_path(TRUE) } - # fertilizer_element_table is an exception in that it doesn't clear - # itself (it is in "static mode"). Let's clear it by hand: - # TODO: make this automatic too - tables[["fertilizer_element_table"]]$set_values(list()) - - # set value back to FALSE so this can be triggered later as well - # observeEvent ignores FALSE values by default reset_values(FALSE) }) @@ -300,406 +295,361 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, shinyjs::toggle("delete", condition = edit_mode()) }) - # update each of the text outputs automatically, including language changes - # and the dynamic updating in editing table title etc. - # TODO: refactor + # text outputs (form_title, required_variables_helptext) lapply(text_output_code_names, FUN = function(text_output_code_name) { - - # render text output[[text_output_code_name]] <- renderText({ - if (dp()) message(glue("Rendering text for {text_output_code_name}")) text_to_show <- get_disp_name(text_output_code_name, language()) - #get element from the UI structure lookup list element <- structure_lookup_list[[text_output_code_name]] - #if the text should be updated dynamically, do that if (!is.null(element$dynamic)) { - - # there are currently two modes of dynamic text - if (element$dynamic$mode == "input") { - # # the -1 removes the mode element, we don't want it - # patterns <- names(element$dynamic)[-1] - # # use lapply here to get the dependency on input correctly - # replacements <- lapply(patterns, function(pattern) { - # replacement <- input[[ element$dynamic[[pattern]] ]] - # replacement <- get_disp_name(replacement, - # language()) - # text_to_show <<- gsub(pattern, replacement, - # text_to_show) - # replacement - # }) - # - # # if one of the replacements is empty, we don't want to - # # see the text at all - # if ("" %in% replacements) { text_to_show <- "" } - - } else if (element$dynamic$mode == "edit_mode") { - + if (element$dynamic$mode == "edit_mode") { text_to_show <- if (edit_mode()) { element$dynamic[["TRUE"]] } else { element$dynamic[["FALSE"]] } text_to_show <- get_disp_name(text_to_show, language()) - } } text_to_show }) - }) + # Language switching for schema-driven form fields observeEvent(language(), ignoreInit = TRUE, { - - # get a list of all input elements which we have to relabel - input_element_names <- names(reactiveValuesToList(input)) - - for (code_name in input_element_names) { - - # TODO: update to use the update_ui_element function - - # find element in the UI structure lookup list - element <- structure_lookup_list[[code_name]] + iso <- lang_to_iso(language()) + + # Update event type selector + event_choices <- build_event_type_choices(schema, iso) + current_event <- input[["mgmt_operations_event"]] + updateSelectInput(session, "mgmt_operations_event", + label = schema_get_title( + lookup_property(pr, "mgmt_operations_event")$titles, + iso, "event"), + choices = event_choices, + selected = current_event) + + # Update date label + updateDateInput(session, "date", + label = schema_get_title( + lookup_property(pr, "date")$titles, iso, "date")) + + # Update short notes + short_notes_desc <- lookup_property(pr, "mgmt_event_short_notes") + updateTextAreaInput(session, "mgmt_event_short_notes", + label = schema_get_title( + short_notes_desc$titles, iso, "description"), + placeholder = schema_get_title( + short_notes_desc$placeholders, iso, "")) + + # Update all event-type properties + for (ec in names(er)) { + event_entry <- er[[ec]] + for (pn in event_entry$property_names) { + desc <- lookup_property(pr, pn, ec) + if (is.null(desc)) next + if (desc$type %in% c("const", "dataTable")) next + update_schema_widget(session, pn, desc, iso, input) + } - # didn't find the element corresponding to code_name - # this should not happen if the element is in - # sidebar_ui_structure.json + if (event_entry$has_subtypes) { + # Update subtype discriminator choices + disc <- event_entry$subtype_discriminator + disc_desc <- lookup_property(pr, disc, ec) + if (!is.null(disc_desc)) { + sub_choices <- build_subtype_choices(event_entry, iso) + current_sub <- input[[disc]] + updateSelectInput(session, disc, + label = schema_get_title( + disc_desc$titles, iso, disc), + choices = sub_choices, + selected = current_sub) + } + + for (sc in names(event_entry$subtypes)) { + sub <- event_entry$subtypes[[sc]] + for (spn in sub$property_names) { + sdesc <- lookup_property(pr, spn, ec, sc) + if (is.null(sdesc)) next + if (sdesc$type %in% c("const", "dataTable")) next + update_schema_widget(session, spn, sdesc, iso, input) + } + } + } + } + + # Update app chrome (block label, save/cancel/delete buttons) + for (code_name in names(reactiveValuesToList(input))) { + element <- structure_lookup_list[[code_name]] if (is.null(element$type)) next - label <- get_disp_name(element$label, language()) if (element$type == "selectInput") { - - # fetch choices for the selectInput choices <- get_selectInput_choices(code_name, language()) - - # make sure we don't change the selected value current_value <- input[[code_name]] - if (is.null(choices)) { - updateSelectInput(session, - code_name, - label = ifelse(is.null(label),"",label), + updateSelectInput(session, code_name, + label = ifelse(is.null(label), "", label), selected = current_value) } else { - updateSelectInput(session, - code_name, - label = ifelse(is.null(label),"",label), + updateSelectInput(session, code_name, + label = ifelse(is.null(label), "", label), choices = choices, selected = current_value) } - - - } else if (element$type == "dateInput") { - #language_code <- if (input$language == "disp_name_fin") { - # "fi" - #} else { - # "en" - #} - updateDateInput(session, - code_name, - label = label, - #language = language_code - ) - } else if (element$type == "textAreaInput") { - updateTextAreaInput(session, - code_name, - label = label, - placeholder = - get_disp_name( - element$placeholder, - language())) } else if (element$type == "actionButton") { - updateActionButton(session, - code_name, - label = label) - } else if (element$type == "checkboxInput") { - updateCheckboxInput(session, - code_name, - label = label) - } else if (element$type == "textInput") { - updateTextInput(session, - code_name, - label = label, - placeholder = - get_disp_name( - element$placeholder, - language())) - } else if (element$type == "numericInput") { - updateNumericInput(session, - code_name, - label = label) - } else if (element$type == "dateRangeInput") { - updateDateRangeInput(session, - code_name, - label = label) - } else if (element$type == "fileInput") { - # fileInput modules do their own language changing + updateActionButton(session, code_name, label = label) } - } - - }) - # initialise the tables list (wihout yet starting the table servers) so - # that we can pre-supply the values to the tables - # sapply with simplify = FALSE is equivalent to lapply - tables <- sapply(data_table_code_names, USE.NAMES = TRUE, simplify = FALSE, - FUN = function(table_code_name) { - set_values <- reactiveVal() - list(set_values = set_values) - }) - - # do the same thing with fileInput modules + # Initialise table and fileInput module servers on first use + tables <- list() files <- sapply(fileInput_code_names, USE.NAMES = TRUE, simplify = FALSE, FUN = function(fileInput_code_name) { - set_path <- reactiveVal() reset_path <- reactiveVal() - - list(set_path = set_path, - reset_path = reset_path) + list(set_path = set_path, reset_path = reset_path) }) - # when we get the init_signal, initialise table and fileInput module server - # functions. This "staged" initialisation is done to improve startup speed. + # Build the tables list with set_values reactiveVals for each array table + schema_table_names <- get_schema_table_names(schema) + for (tn in schema_table_names) { + set_values_rv <- reactiveVal() + tables[[tn]] <- list(set_values = set_values_rv) + } + observeEvent(init_signal(), { - if (dp()) message("Initialising table and fileInput server functions") - # initialise the table server for each of the dynamically added tables - # the values from the table can be accessed ilke - # tables[[table_code_name]]$result$values() - sapply(data_table_code_names, FUN = function(table_code_name) { - - table_structure <- - structure_lookup_list[[table_code_name]] - - # are we in static mode, i.e. are all row groups of - # type 'static'? If yes, we won't need to supply the - # row_variable_value reactive. Currently this only - # happens with fertilizer_element_table (the columns - # are not defined) - static_mode <- is.null(table_structure$columns) - - # find the row variable. This will be used in the - # reactive below - if (!static_mode) { - for (row_group in table_structure$rows) { - # there is only one dynamic row group - if (row_group$type == 'dynamic') { - row_variable <- row_group$row_variable - row_variable_type <- - structure_lookup_list[[row_variable]]$type - break - } + for (tn in schema_table_names) { + # Find the array property this table corresponds to + array_prop_name <- sub("_table$", "", tn) + # Find which event/subtype this belongs to + found <- FALSE + for (ec in names(er)) { + # Check event-level properties + desc <- lookup_property(pr, array_prop_name, ec) + if (!is.null(desc) && desc$type == "dataTable") { + tables[[tn]]$result <<- + mod_table_server_schema(tn, array_prop_name, desc, schema, + language, + tables[[tn]]$set_values, + input, main_iv, ns) + found <- TRUE + break } - } - - # If we have row groups which depend on widget values - # in the main app, create a reactive from those values. - # This can either be determined by the choices of - # selectInput with multiple selections, or a - # numericInput which represents the number of rows. - row_variable_value <- reactive({ - - if (static_mode) { - return(NULL) - } - - if (row_variable_type == "numericInput") { - number_of_rows <- input[[row_variable]] - - # check status of validator. If it is NULL all is - # ok - if (!isTruthy(number_of_rows) || - !is.null(isolate( - main_iv$validate()[[ns(row_variable)]]))) { - NULL - } else { - as.integer(number_of_rows) + # Check subtype-level properties + if (er[[ec]]$has_subtypes) { + for (sc in names(er[[ec]]$subtypes)) { + desc <- lookup_property(pr, array_prop_name, ec, sc) + if (!is.null(desc) && desc$type == "dataTable") { + tables[[tn]]$result <<- + mod_table_server_schema(tn, array_prop_name, desc, schema, + language, + tables[[tn]]$set_values, + input, main_iv, ns) + found <- TRUE + break + } } - - } else if (row_variable_type == "selectInput") { - input[[row_variable]] } - - }) - - # start the server function - tables[[table_code_name]]$result <<- - mod_table_server(table_code_name, - row_variable_value, - language, - tables[[table_code_name]]$set_values) - }) + if (found) break + } + } # start server for all fileInput modules sapply(fileInput_code_names, FUN = function(fileInput_code_name) { - files[[fileInput_code_name]]$value <<- mod_fileInput_server(id = fileInput_code_name, language = language, set_path = files[[fileInput_code_name]]$set_path, reset_path = files[[fileInput_code_name]]$reset_path) }) - }) - # when requested, prepare the entered data + # Auto-sum: update total fields from table column values + observe({ + event_type <- input[["mgmt_operations_event"]] + if (!isTruthy(event_type)) return() + + event_entry <- er[[event_type]] + if (is.null(event_entry)) return() + + # Collect all property names including subtypes + subtype <- get_current_subtype(input, er) + all_props <- event_entry$property_names + if (event_entry$has_subtypes && !is.null(subtype) && + !is.null(event_entry$subtypes[[subtype]])) { + all_props <- c(all_props, event_entry$subtypes[[subtype]]$property_names) + } + + for (pn in all_props) { + desc <- lookup_property(pr, pn, event_type, subtype) + if (is.null(desc) || is.null(desc$total_of)) next + + list_name <- desc$total_of$list_name + prop_to_sum <- desc$total_of$property_name + tn <- paste0(list_name, "_table") + + if (is.null(tables[[tn]]$result)) next + + col_values <- tables[[tn]]$result$values()[[prop_to_sum]] + if (is.null(col_values) || all(is.na(col_values))) { + total <- NA + } else { + nums <- suppressWarnings(as.numeric(col_values)) + total <- sum(nums, na.rm = TRUE) + if (total == 0 && all(is.na(nums))) total <- NA + } + + updateNumericInput(session, pn, value = total) + shinyjs::disable(pn) + } + }) + form_data <- reactive({ - if (dp()) message("Calculating form data") relevant <- relevant_variables() - relevant_table <- if (identical(relevant$table_code_name, character(0))) { - NULL - } else { - tables[[relevant$table_code_name]]$result + + relevant_table <- NULL + if (length(relevant$table_name) > 0 && !is.null(tables[[relevant$table_name]])) { + relevant_table <- tables[[relevant$table_name]]$result } - # check that the form and table validation rules have been met if (!main_iv$is_valid() || (!is.null(relevant_table) && !relevant_table$valid())) { return(NULL) } event <- list() - # fill information - for (variable in c(relevant$regular, relevant$table)) { - - # is the variable a fileInput? - is_fileInput <- identical(structure_lookup_list[[variable]]$type, - "fileInput") + + event$mgmt_operations_event <- input[["mgmt_operations_event"]] + event$date <- tryCatch( + format(input[["date"]], date_format_json), + error = function(cnd) "" + ) + event$mgmt_event_short_notes <- trimws(input[["mgmt_event_short_notes"]] %||% "") + event$block <- input[["block"]] + + for (prop_name in relevant$regular) { + if (prop_name %in% c("mgmt_operations_event", "date", + "mgmt_event_short_notes", "block")) next + + desc <- lookup_property( + pr, prop_name, + input[["mgmt_operations_event"]], + get_current_subtype(input, er)) + if (is.null(desc)) next + if (desc$type == "const") next - # read value from table if it is available there, otherwise from either - # a fileInput module or a regular input widget - value_to_save <- if (variable %in% relevant$table) { - relevant_table$values()[[variable]] - } else if (is_fileInput) { - files[[variable]]$value() + is_fileInput <- !is.null(structure_lookup_list[[prop_name]]) && + identical(structure_lookup_list[[prop_name]]$type, "fileInput") + + value <- if (is_fileInput) { + files[[prop_name]]$value() } else { - input[[variable]] + input[[prop_name]] } - # if value is character, trim any whitespace around it - if (is.character(value_to_save)) { - value_to_save <- trimws(value_to_save) - } + if (is.character(value)) value <- trimws(value) - # format Date value to character string and replace with "" if that - # fails for some reason - if (inherits(value_to_save, "Date")) { - value_to_save <- tryCatch( - expr = format(value_to_save, date_format_json), - error = function(cnd) { - message(glue("Unable to format date {value_to_save}", - "into string when saving event,", - "replaced with missingval")) - "" - } - ) + if (inherits(value, "Date")) { + value <- tryCatch(format(value, date_format_json), + error = function(cnd) "") } - # if the value is not defined or empty, replace with missingval - if (length(value_to_save) == 0) { - value_to_save <- missingval + if (length(value) == 0) { + value <- missingval } else { - missing_indexes <- is.na(value_to_save) | value_to_save == "" + missing_indexes <- is.na(value) | value == "" if (any(missing_indexes)) { - value_to_save[missing_indexes] <- missingval + value[missing_indexes] <- missingval } } - event[[variable]] <- value_to_save + event[[prop_name]] <- value } - # return event data - event - }) - - # When requested, calculate a vector with the names of relevant variables. A - # variable is relevant when it is visible in some form, either as a regular - # widget or in a table module. Relevant variables are ones which we want to - # save to a json file given the current choices of the user. For example, - # when the user is making a soil observation event, the variables related - # to that are relevant while other observation variables are not. - # This only works when the form is already open. - relevant_variables <- reactive({ - - if (dp()) message("Calculating relevant variables") - - # these are the variables among which the relevant variables are - all_variables <- get_category_names("variable_name") - - # find all widgets that are currently hidden in the UI. This includes - # regular widgets but also e.g. tables. Note that not all of these are - # irrelevant; the regular form of a widget might be hidden because we want - # to read its values from a table instead. This vector includes also - # tables because that way we can check whether a table is actually hidden. - hidden_widgets <- unlist(rlapply(activity_options, fun = function(x) { - if (!is.null(x$condition)) { - relevant <- evaluate_condition(x$condition, session) - if (!is.null(relevant) && !identical(relevant, TRUE)) { - rlapply(x, fun = function(x) x$code_name) + if (!is.null(relevant_table)) { + table_values <- relevant_table$values() + for (vn in names(table_values)) { + val <- table_values[[vn]] + if (length(val) == 0) { + val <- missingval + } else { + missing_indexes <- is.na(val) | val == "" + if (any(missing_indexes)) val[missing_indexes] <- missingval } + event[[vn]] <- val } - })) - - # find variables which are relevant and being entered through a table - table_variables <- NULL - for (table_code_name in data_table_code_names) { - if (!(table_code_name %in% hidden_widgets)) { - table_variables <- c(table_variables, - get_table_variables(table_code_name)) - # currently only one table is visible at a time - break + } + + # Replace empty common fields + for (fn in c("mgmt_event_short_notes")) { + if (is.null(event[[fn]]) || identical(event[[fn]], "")) { + event[[fn]] <- missingval } } - # Report relevant widgets for regular and table widgets separately. - # We get the relevant variables by removing from all variables the widgets - # that are hidden. - # Also report the name of the table which is currently relevant. - list( - regular = setdiff(all_variables, hidden_widgets), - table = table_variables, - table_code_name = setdiff(data_table_code_names, hidden_widgets) - ) + event }) - # When requested, list as a vector the variables among the currently - # relevant variables which are compulsory to be filled out. - required_variables <- reactive({ + relevant_variables <- reactive({ + if (dp()) message("Calculating relevant variables") - if (dp()) message("Calculating required variables") + event_type <- input[["mgmt_operations_event"]] + if (!isTruthy(event_type)) { + return(list(regular = character(0), table = character(0), + table_name = character(0))) + } - required_widgets <- NULL - required_table_widgets <- NULL + event_entry <- er[[event_type]] + if (is.null(event_entry)) { + return(list(regular = character(0), table = character(0), + table_name = character(0))) + } - relevant <- relevant_variables() + subtype <- get_current_subtype(input, er) + relevant <- get_relevant_properties(schema, event_type, subtype) - for (variable in relevant$regular) { - if (identical(structure_lookup_list[[variable]]$required, TRUE)) { - required_widgets <- c(required_widgets, variable) + regular_props <- character(0) + table_props <- character(0) + table_name <- character(0) + + for (pn in relevant$all) { + desc <- lookup_property(pr, pn, event_type, subtype) + if (is.null(desc)) next + if (desc$type == "const") next + + # Skip fields whose x-ui condition evaluates to FALSE + if (!is.null(desc$xui$condition)) { + cond_result <- evaluate_condition(desc$xui$condition, session) + if (is.null(cond_result) || !isTRUE(cond_result)) next } - } - for (variable in relevant$table) { - if (identical(structure_lookup_list[[variable]]$required, TRUE)) { - required_table_widgets <- c(required_table_widgets, variable) + + if (desc$type == "dataTable") { + tn <- paste0(pn, "_table") + table_name <- c(table_name, tn) + # Get the table column names + if (!is.null(desc$array_columns)) { + table_props <- c(table_props, names(desc$array_columns)) + } + } else { + regular_props <- c(regular_props, pn) } } list( - regular = required_widgets, - table = required_table_widgets + regular = regular_props, + table = table_props, + table_name = if (length(table_name) > 0) table_name[1] else character(0) ) - }) - + ################## RETURN VALUE list( @@ -712,3 +662,82 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, }) } + +# Helper: find a property descriptor trying multiple contexts. +# Uses the reverse index (built in load_schema) for O(1) lookup instead of +# scanning every registry key. +find_any_property_desc <- function(pr, prop_name, reverse_index = NULL) { + # Direct common lookup + if (!is.null(pr[[prop_name]])) return(pr[[prop_name]]) + # Use reverse index if available (O(1) instead of O(n)) + if (!is.null(reverse_index) && !is.null(reverse_index[[prop_name]])) { + return(pr[[reverse_index[[prop_name]]]]) + } + # Fallback: linear scan (for callers without the index) + for (key in names(pr)) { + if (startsWith(key, paste0(prop_name, REGISTRY_KEY_SEP))) { + return(pr[[key]]) + } + } + NULL +} + +# Helper: get the current subtype from input +get_current_subtype <- function(input, er) { + event_type <- input[["mgmt_operations_event"]] + if (!isTruthy(event_type)) return(NULL) + event_entry <- er[[event_type]] + if (is.null(event_entry) || !event_entry$has_subtypes) return(NULL) + disc <- event_entry$subtype_discriminator + if (is.null(disc)) return(NULL) + sub_val <- input[[disc]] + if (!isTruthy(sub_val)) return(NULL) + sub_val +} + +# Helper: get subtype from event values (for populating form) +get_subtype_value <- function(values, er) { + event_type <- values$mgmt_operations_event + if (is.null(event_type)) return(NULL) + event_entry <- er[[event_type]] + if (is.null(event_entry) || !event_entry$has_subtypes) return(NULL) + disc <- event_entry$subtype_discriminator + if (is.null(disc)) return(NULL) + values[[disc]] +} + +# Helper: get schema table names +get_schema_table_names <- function(schema) { + er <- schema$event_registry + pr <- schema$property_registry + table_names <- character(0) + for (ec in names(er)) { + event_entry <- er[[ec]] + for (pn in event_entry$property_names) { + desc <- lookup_property(pr, pn, ec) + if (!is.null(desc) && desc$type == "dataTable") { + table_names <- c(table_names, paste0(pn, "_table")) + } + } + # Also check subtype properties (e.g. soil_layer_list in observation_type_soil) + if (event_entry$has_subtypes) { + for (sc in names(event_entry$subtypes)) { + for (spn in event_entry$subtypes[[sc]]$property_names) { + sdesc <- lookup_property(pr, spn, ec, sc) + if (!is.null(sdesc) && sdesc$type == "dataTable") { + table_names <- c(table_names, paste0(spn, "_table")) + } + } + } + } + } + unique(table_names) +} + +get_legacy_value <- function(values, schema_prop_name) { + legacy_names <- names(legacy_name_map)[legacy_name_map == schema_prop_name] + for (ln in legacy_names) { + if (!is.null(values[[ln]])) return(values[[ln]]) + } + NULL +} diff --git a/R/mod_table.R b/R/mod_table.R index baf471b..153b00c 100644 --- a/R/mod_table.R +++ b/R/mod_table.R @@ -16,6 +16,28 @@ table_log <- FALSE # EDIT: this makes sense also, see datatables API documentation for example js_bind_script <- "function() { Shiny.bindAll(this.api().table().node()); }" +# TODO: Move these labels to display_names.csv (or the schema's x-ui) once the +# CSV gains a Swedish column. Until then, Swedish is hardcoded here. +schema_table_add_row_label <- function(iso) { + if (identical(iso, "fi")) { + "Lis\u00e4\u00e4 rivi" + } else if (identical(iso, "sv")) { + "L\u00e4gg till rad" + } else { + "Add row" + } +} + +schema_table_remove_row_label <- function(iso) { + if (identical(iso, "fi")) { + "Poista rivi" + } else if (identical(iso, "sv")) { + "Ta bort rad" + } else { + "Remove row" + } +} + #' Shiny module for data input in table format #' #' @description A shiny Module. @@ -619,8 +641,357 @@ mod_table_server <- function(id, row_variable_value, values = table_values, valid = reactive(iv$is_valid()) ) - + }) - + +} + +# -- Helpers for mod_table_server_schema ------------------------------------ + +#' Build a single table cell widget as an HTML string +#' @noRd +build_schema_cell_widget <- function(variable, col_desc, ns, iso, + current_row, value) { + code_name <- paste(variable, current_row, sep = "_") + + if (!isTruthy(value) || identical(value, missingval)) value <- "" + + choices <- NULL + if (identical(col_desc$type, "selectInput")) { + choices <- schema_get_choices(col_desc$choices, iso) + } + + placeholder <- NULL + if (!is.null(col_desc$placeholders)) { + placeholder <- schema_get_title(col_desc$placeholders, iso, "") + } + + width <- if (col_desc$type == "numericInput") 100 else NULL + + widget_html <- as.character( + render_property_widget(variable, col_desc, ns, iso, + override_code_name = code_name, + override_label = "", + override_value = value, + override_choices = choices, + override_selected = value, + override_placeholder = placeholder, + width = width)) + + list(html = widget_html, code_name = code_name) +} + +#' Build a remove-row button as an HTML string +#' @noRd +build_remove_row_button <- function(ns, iso, row_idx, can_remove) { + as.character( + tags$button( + type = "button", + class = "btn btn-default btn-sm schema-array-table__remove-row", + title = schema_table_remove_row_label(iso), + `aria-label` = schema_table_remove_row_label(iso), + onclick = sprintf( + "Shiny.setInputValue('%s', %d, {priority: 'event'})", + ns("remove_row_index"), + row_idx + ), + disabled = if (!can_remove) "disabled" else NULL, + icon("trash") + ) + ) } +#' Schema-driven table server module +#' +#' @param id Module ID (must match the table_id used in render_array_table) +#' @param array_prop_name The property name of the array in the schema +#' @param desc The property descriptor for the array +#' @param schema The loaded schema +#' @param language Reactive language value +#' @param override_values ReactiveVal for setting table values +#' @param parent_input The parent module's input +#' @param parent_iv The parent module's InputValidator +#' @param parent_ns The parent module's namespace function +#' +#' @return A list with values() and valid() reactives +#' @import shinyvalidate +#' @noRd +mod_table_server_schema <- function(id, array_prop_name, desc, schema, + language, override_values, + parent_input, parent_iv, parent_ns) { + + stopifnot(is.reactive(language)) + stopifnot(is.reactive(override_values)) + + moduleServer(id, function(input, output, session) { + ns <- session$ns + + columns <- desc$array_columns + if (is.null(columns)) return(list(values = reactiveVal(list()), + valid = reactive(TRUE))) + + column_names <- names(columns) + action_column_name <- "..remove_row.." + + iv <- InputValidator$new() + iv$enable() + rules_added <- NULL + + add_schema_validation_rules <- function(widgets, variables) { + lapply(seq_along(widgets), FUN = function(i) { + widget_name <- widgets[i] + col_desc <- columns[[variables[i]]] + + if (widget_name %in% rules_added) return() + + if (isTRUE(col_desc$required)) { + iv$add_rule(widget_name, sv_required(message = "")) + } + if (!is.null(col_desc$minimum)) { + iv$add_rule(widget_name, sv_gte(col_desc$minimum, allow_na = TRUE, + message_fmt = "")) + } + if (!is.null(col_desc$maximum)) { + iv$add_rule(widget_name, sv_lte(col_desc$maximum, allow_na = TRUE, + message_fmt = "")) + } + if (isTRUE(col_desc$is_integer)) { + iv$add_rule(widget_name, function(value) { + if (is.null(value) || is.na(value)) return(NULL) + if (value != floor(value)) return("") + NULL + }) + } + }) + rules_added <<- c(rules_added, widgets) + } + + n_cols <- length(column_names) + old_values <- reactiveVal() + table_values <- reactiveVal() + rendered <- reactiveVal(FALSE) + dynamic_rows <- reactiveVal() + + observeEvent(input$rendered, { rendered(TRUE) }) + + visible <- reactive({ + rows <- dynamic_rows() + !is.null(rows) && length(rows) > 0 + }) + + observeEvent(visible(), ignoreNULL = FALSE, ignoreInit = TRUE, + priority = 1, { + if (!visible()) { + rendered(FALSE) + old_values(list()) + } + }) + + override_trigger <- reactiveVal(0) + row_trigger <- reactiveVal(0) + + observeEvent(override_values(), { + values <- override_values() + if (is.null(values)) return() + + # Determine rows from the data + first_col <- column_names[1] + col_data <- values[[first_col]] + if (!is.null(col_data) && length(col_data) > 0) { + dynamic_rows(as.integer(seq_along(col_data))) + } else { + dynamic_rows(1L) + } + override_trigger(override_trigger() + 1) + }) + + # Initialize with one row when first accessed (no override data) + observe({ + if (is.null(dynamic_rows())) { + dynamic_rows(1L) + } + }, priority = -1) + + # Add row handler + observeEvent(input$add_row, { + current <- dynamic_rows() + if (is.null(current) || length(current) == 0) { + dynamic_rows(1L) + } else { + dynamic_rows(c(current, max(current) + 1L)) + } + row_trigger(row_trigger() + 1) + }) + + # Remove a specific row while keeping stable row ids. + observeEvent(input$remove_row_index, { + current <- dynamic_rows() + row_id <- input$remove_row_index + if (is.null(current) || length(current) <= 1) return() + if (is.null(row_id) || !(row_id %in% current)) return() + dynamic_rows(current[current != row_id]) + row_trigger(row_trigger() + 1) + }) + + # Update button labels on language change + observeEvent(language(), { + iso <- lang_to_iso(language()) + updateActionButton(session, "add_row", + label = schema_table_add_row_label(iso)) + }) + + # Unbind before re-render + observe(priority = 2, { + language() + visible() + row_trigger() + override_trigger() + req(isolate(rendered())) + session$sendCustomMessage("unbind-table", ns("table")) + }) + + # Sum calculation for schema tables is handled by the parent form module's + # auto-sum observer, not inside the table module itself. + + table_data <- reactive({ + override_trigger() + row_trigger() + + iso <- lang_to_iso(language()) + override_vals <- isolate(override_values()) + do_override <- !is.null(override_vals) + + table_to_display <- data.frame( + matrix("", nrow = 0, ncol = n_cols + 1L), + stringsAsFactors = FALSE + ) + names(table_to_display) <- c(column_names, action_column_name) + + if (do_override && identical(override_vals, list())) { + override_values(NULL) + do_override <- FALSE + old_values(list()) + } + + rows <- isolate(dynamic_rows()) + if (is.null(rows) || length(rows) == 0) rows <- integer(0) + can_remove_rows <- length(rows) > 1L + + current_row <- 1 + for (row_idx in rows) { + for (variable in column_names) { + col_desc <- columns[[variable]] + + value <- if (do_override) { + override_vals[[variable]][row_idx] + } else { + old_row_number <- which( + isolate(old_values())[["DYNAMIC_ROWS"]] == rows[current_row]) + isolate(old_values())[[variable]][old_row_number] + } + + cell <- build_schema_cell_widget(variable, col_desc, ns, iso, + current_row, value) + add_schema_validation_rules(cell$code_name, variable) + table_to_display[current_row, variable] <- cell$html + } + + table_to_display[current_row, action_column_name] <- + build_remove_row_button(ns, iso, row_idx, can_remove_rows) + + rownames(table_to_display)[current_row] <- as.character(row_idx) + current_row <- current_row + 1 + } + + override_values(NULL) + table_to_display + }) + + output$table <- DT::renderDataTable({ + req(visible()) + rendered(FALSE) + table_to_display <- table_data() + + if (nrow(table_to_display) == 0) return() + + iso <- lang_to_iso(language()) + # Use unitless titles or regular titles for column headers + col_labels <- vapply(column_names, function(cn) { + col_desc <- columns[[cn]] + if (!is.null(col_desc$unitless_titles)) { + schema_get_title(col_desc$unitless_titles, iso, cn) + } else { + schema_get_title(col_desc$titles, iso, cn) + } + }, character(1)) + names(table_to_display) <- c(col_labels, "") + + table_to_display <- + DT::datatable( + table_to_display, + escape = FALSE, + selection = "none", + class = "table table-hover", + rownames = FALSE, + options = + list(dom = "t", + ordering = FALSE, + autoWidth = FALSE, + drawCallback = htmlwidgets::JS(js_bind_script), + initComplete = + htmlwidgets::JS(paste0( + "function(settings, json) {", + "do_selectize('", ns("table"), "'); ", + "rendering_done('", ns("rendered"), "'); }" + )), + columnDefs = list( + list( + orderable = FALSE, + targets = ncol(table_to_display) - 1L, + className = "schema-array-table__actions-cell", + width = "1%" + ) + ) + )) + table_to_display + }, server = FALSE) + + observe({ + value_list <- list() + + if (!rendered()) { + table_values(value_list) + return() + } + + table_data() + + rows <- dynamic_rows() + if (is.null(rows) || length(rows) == 0) { + table_values(value_list) + return() + } + + row_numbers <- seq_along(rows) + + for (variable in column_names) { + values <- NULL + for (row_number in row_numbers) { + element_name <- paste(variable, row_number, sep = "_") + values <- c(values, input[[element_name]]) + } + value_list[[variable]] <- values + } + + table_values(value_list) + + value_list <- c(value_list, list(DYNAMIC_ROWS = isolate(dynamic_rows()))) + old_values(value_list) + }) + + list( + values = table_values, + valid = reactive(iv$is_valid()) + ) + }) +} diff --git a/R/utils_global.R b/R/utils_global.R index 6165389..c30c18d 100644 --- a/R/utils_global.R +++ b/R/utils_global.R @@ -1,29 +1,44 @@ +# null-coalescing operator (not importing rlang just for this) +`%||%` <- function(a, b) if (!is.null(a)) a else b + # missing value in the ICASA standard missingval <- "-99.0" date_format_json <- "%Y-%m-%d" date_format_display <- "%d/%m/%Y" # read the csv file containing the sites -#sites_file_path <- "data/FOsites.csv" -# the path is wrapped inside a function because of this: -# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html -# see: “Paths hard-coded in R code” sites_file_path <- function() system.file("extdata", "FOsites.csv", package = "fieldactivity") -sites <- read.csv(sites_file_path(), na.strings = c("", "NaN", "NULL")) +sites <- read.csv(sites_file_path()) # converts block info from csv (e.g. "[0;1]") to vectors of strings ("0" "1") blocks_to_vector <- function(x) strsplit(substr(x, start = 2, stop = nchar(x)-1), ";") sites$blocks <- sapply(sites$blocks, blocks_to_vector) # options for UI languages -# languages match the names of columns in display_names.csv -# when you give a named vector as the choices for selectInput, the names -# rather than the values will be displayed -# the \U codes are UTF-8 flag emojis languages <- c("English \U0001f1ec\U0001f1e7" = "disp_name_eng", - "suomi \U0001f1eb\U0001f1ee" = "disp_name_fin") + "suomi \U0001f1eb\U0001f1ee" = "disp_name_fin", + "svenska \U0001f1f8\U0001f1ea" = "disp_name_swe") init_lang <- languages[1] +# Load and parse the management-event schema at package load time. +# Wrapped in tryCatch so the package can still load if the schema file is +# missing or malformed (e.g. during development or testing). +mgmt_schema <- tryCatch( + load_schema(), + error = function(e) { + message("Failed to load management-event schema: ", conditionMessage(e)) + message("The application may not function correctly without the schema.") + list( + raw = list(), + event_registry = list(), + property_registry = list(), + property_reverse_index = list(), + common_properties = character(0), + event_type_choices = list() + ) + } +) + # whether to print debug information (short for debug print) # set the boolean value below to FALSE to suppress prints -dp <- function() TRUE #&& golem::app_dev() \ No newline at end of file +dp <- function() TRUE #&& golem::app_dev() diff --git a/inst/app/www/schema.css b/inst/app/www/schema.css new file mode 100644 index 0000000..a4ef97a --- /dev/null +++ b/inst/app/www/schema.css @@ -0,0 +1,49 @@ +/* Styles for schema-driven UI components */ + +.schema-array-table .dataTables_wrapper { + margin-bottom: 0; + overflow-x: auto; +} + +.schema-array-table > br { + display: none; +} + +.schema-array-table__footer { + padding: 12px 0 14px; + border-bottom: 1px solid #d9d9d9; +} + +.schema-array-table table.dataTable tbody tr:last-child td { + border-bottom: none; +} + +.schema-array-table__actions-cell { + white-space: nowrap; + text-align: right; + vertical-align: middle !important; +} + +.schema-array-table__remove-row { + min-width: 36px; + padding-left: 10px; + padding-right: 10px; +} + +.selectize-dropdown { + z-index: 2000; +} + +.required-asterisk { + color: #e74c3c; + font-weight: bold; +} + +.schema-array-table td { + overflow: visible; + white-space: normal; +} + +.schema-array-table td .selectize-control { + min-width: 200px; +} diff --git a/inst/app/www/script.js b/inst/app/www/script.js index f3a8919..35aa60d 100644 --- a/inst/app/www/script.js +++ b/inst/app/www/script.js @@ -2,7 +2,9 @@ // your browser cache! It might be using an older version of this file. function do_selectize(table_id) { - return $('#'+table_id).find('select').selectize(); + return $('#'+table_id).find('select').selectize({ + dropdownParent: 'body' + }); } var renderCounter = 0; diff --git a/inst/extdata/management-event.schema.json b/inst/extdata/management-event.schema.json new file mode 100644 index 0000000..2bc7f03 --- /dev/null +++ b/inst/extdata/management-event.schema.json @@ -0,0 +1,3938 @@ +{ + "$schema": "http://json-schema.org/draft-07/schema", + "$id": "management-event.schema.json", + "@context": { + "@language": "en", + "title": { + "@id": "dc:title", + "@language": "en" + }, + "title_fi": { + "@id": "dc:title", + "@language": "fi" + }, + "title_sv": { + "@id": "dc:title", + "@language": "sv" + }, + "unitless_title": { + "@id": "fo:unitless_title", + "@language": "en" + }, + "unitless_title_fi": { + "@id": "fo:unitless_title", + "@language": "fi" + }, + "unitless_title_sv": { + "@id": "fo:unitless_title", + "@language": "sv" + }, + "description": { + "@id": "dc:description", + "@language": "en" + }, + "description_fi": { + "@id": "dc:description", + "@language": "fi" + }, + "description_sv": { + "@id": "dc:description", + "@language": "sv" + }, + "form-placeholder": { + "@id": "fo:form-placeholder", + "@language": "en" + }, + "form-placeholder_fi": { + "@id": "fo:form-placeholder", + "@language": "fi" + }, + "form-placeholder_sv": { + "@id": "fo:form-placeholder", + "@language": "sv" + } + }, + "title": "management event", + "title_fi": "tilanhoitotapahtuma", + "title_sv": "inträffande av metoden", + "type": "object", + "properties": { + "$schema": { + "type": "string", + "format": "url", + "const": "https://raw.githubusercontent.com/hamk-uas/fieldobservatory-data-schemas/main/management-event.schema.json" + }, + "mgmt_operations_event": { + "title": "event", + "title_en": "event", + "title_fi": "tapahtuma", + "type": "string", + "x-ui": { + "discriminator": true + } + }, + "date": { + "title": "date", + "title_en": "the date when the activity was performed", + "title_fi": "päivä jolloin tapahtuma tapahtui", + "type": "string", + "format": "date" + }, + "mgmt_event_short_notes": { + "title": "description", + "title_en": "description", + "title_fi": "kuvaus", + "type": "string", + "x-ui": { + "placeholder": "A high level description of the event, e.g. \"first harvest of the year\" or \"spring fertilization\". This will appear on the event list.", + "placeholder_fi": "Yleinen kuvaus tapahtumasta, esim. \"vuoden ensimmäinen sadonkorjuu\" tai \"kevätlannoitus\". Tämä tulee näkyviin tapahtumalistaan." + } + } + }, + "oneOf": [ + { + "$id": "#planting", + "title": "sowing", + "title2": "planting", + "title_fi": "kylvö", + "title_sv": "sådd", + "properties": { + "mgmt_operations_event": { + "title": "sowing", + "title2": "planting", + "title_fi": "kylvö", + "title_sv": "sådd", + "const": "planting" + }, + "planting_list": { + "type": "array", + "title": "planting list", + "title_fi": "kylvölista", + "items": { + "type": "object", + "properties": { + "planted_crop": { + "allOf": [ + { + "title": "planted crop", + "title_fi": "kylvetty laji", + "title_sv": "sådd gröda" + }, + { + "$ref": "#/$defs/crop_ident_ICASA" + } + ] + }, + "planting_material_weight": { + "title": "weight of seeds (kg/ha)", + "title2": "planting material weight (kg/ha)", + "title_fi": "siementen määrä (kg/ha)", + "title2_fi": "kylvetyn materiaalin paino (kg/ha)", + "title_sv": "vikt av sådd material (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "weight of seeds", + "unitless_title2": "planting material weight", + "unitless_title_fi": "siementen määrä", + "unitless_title2_fi": "kylvetyn materiaalin paino", + "unitless_title_sv": "vikt av sådd material" + } + }, + "planting_depth": { + "title": "sowing depth (mm)", + "title2": "planting depth (mm)", + "title_fi": "kylvösyvyys (mm)", + "title2_fi": "sådjup (mm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "mm", + "unitless_title": "sowing depth", + "unitless_title2": "planting depth", + "unitless_title_fi": "kylvösyvyys", + "unitless_title2_fi": "sådjup" + } + }, + "planting_material_source": { + "title": "source of seeds", + "title2": "planting material source", + "title_fi": "siementen alkuperä", + "title2_fi": "kylvetyn materiaalin alkuperä", + "title_sv": "ursprung på sådda materialet", + "type": "string", + "x-ui": { + "form-type": "textInput", + "form-placeholder": "commercial / own seeds, seed cultivar, etc.", + "form-placeholder_fi": "ostetut / omat siemenet, lajike, jne." + } + } + }, + "required": [ + "planted_crop" + ] + }, + "minItems": 1 + }, + "mgmt_event_long_notes": { + "title": "sowing notes", + "title2": "planting notes", + "title_fi": "kylvömuistiinpanoja", + "title2_fi": "kylvömuistiinpanot", + "title_sv": "såddanteckningar", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"soil was drier than usual at the time of sowing\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"maa oli tavallista kuivempi\"" + } + } + }, + "required": [ + "date", + "planting_list" + ] + }, + { + "$id": "#fertilizer", + "title": "fertilizer application", + "title_fi": "lannoitteen levitys", + "title_sv": "spridning av gödslingsmedel", + "properties": { + "mgmt_operations_event": { + "title": "fertilizer application", + "title_fi": "lannoitteen levitys", + "title_sv": "spridning av gödslingsmedel", + "const": "fertilizer" + }, + "N_in_applied_fertilizer": { + "title": "amount of total nitrogen (N) in fertilizer (kg/ha)", + "title2": "amount of nitrogen (N) in fertilizer (kg/ha)", + "title_fi": "typen (N) määrä lannoitteessa (kg/ha)", + "title_sv": "mängden lväve (N) i gödseln (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of total nitrogen (N) in fertilizer", + "unitless_title2": "amount of nitrogen (N) in fertilizer", + "unitless_title_fi": "typen (N) määrä lannoitteessa", + "unitless_title_sv": "mängden lväve (N) i gödseln" + } + }, + "N_in_soluble_fertilizer": { + "title": "amount of soluble nitrogen (N) in fertilizer (kg/ha)", + "title_fi": "liukenevan typen (N) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of soluble nitrogen (N) in fertilizer", + "unitless_title_fi": "liukenevan typen (N) määrä lannoitteessa" + } + }, + "phosphorus_applied_fert": { + "title": "amount of phosphorus (P) in fertilizer (kg/ha)", + "title_fi": "fosforin (P) määrä lannoitteessa (kg/ha)", + "title_sv": "mängden fosfor (P) i gödseln (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of phosphorus (P) in fertilizer", + "unitless_title_fi": "fosforin (P) määrä lannoitteessa", + "unitless_title_sv": "mängden fosfor (P) i gödseln" + } + }, + "fertilizer_K_applied": { + "title": "amount of potassium (K) in fertilizer (kg/ha)", + "title_fi": "kaliumin (K) määrä lannoitteessa (kg/ha)", + "title_sv": "mängden kalium (K) i gödseln (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of potassium (K) in fertilizer", + "unitless_title_fi": "kaliumin (K) määrä lannoitteessa", + "unitless_title_sv": "mängden kalium (K) i gödseln" + } + }, + "S_in_applied_fertilizer": { + "title": "amount of sulphur (S) in fertilizer (kg/ha)", + "title_fi": "rikin (S) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of sulphur (S) in fertilizer", + "unitless_title_fi": "rikin (S) määrä lannoitteessa" + } + }, + "Ca_in_applied_fertilizer": { + "title": "amount of calcium (Ca) in fertilizer (kg/ha)", + "title_fi": "kalsiumin (Ca) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of calcium (Ca) in fertilizer", + "unitless_title_fi": "kalsiumin (Ca) määrä lannoitteessa" + } + }, + "Mg_in_applied_fertilizer": { + "title": "amount of magnesium (Mg) in fertilizer (kg/ha)", + "title_fi": "magnesiumin (Mg) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of magnesium (Mg) in fertilizer", + "unitless_title_fi": "magnesiumin (Mg) määrä lannoitteessa" + } + }, + "Na_in_applied_fertilizer": { + "title": "amount of sodium (Na) in fertilizer (kg/ha)", + "title_fi": "natriumin (Na) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of sodium (Na) in fertilizer", + "unitless_title_fi": "natriumin (Na) määrä lannoitteessa" + } + }, + "Cu_in_applied_fertilizer": { + "title": "amount of copper (Cu) in fertilizer (kg/ha)", + "title_fi": "kuparin (Cu) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of copper (Cu) in fertilizer", + "unitless_title_fi": "kuparin (Cu) määrä lannoitteessa" + } + }, + "Zn_in_applied_fertilizer": { + "title": "amount of zinc (Zn) in fertilizer (kg/ha)", + "title_fi": "sinkin (Zn) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of zinc (Zn) in fertilizer", + "unitless_title_fi": "sinkin (Zn) määrä lannoitteessa" + } + }, + "B_in_applied_fertilizer": { + "title": "amount of boron (B) in fertilizer (kg/ha)", + "title_fi": "boorin (B) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of boron (B) in fertilizer", + "unitless_title_fi": "boorin (B) määrä lannoitteessa" + } + }, + "Mn_in_applied_fertilizer": { + "title": "amount of manganese (Mn) in fertilizer (kg/ha)", + "title_fi": "mangaanin (Mn) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of manganese (Mn) in fertilizer", + "unitless_title_fi": "mangaanin (Mn) määrä lannoitteessa" + } + }, + "Se_in_applied_fertilizer": { + "title": "amount of selenium (Se) in fertilizer (kg/ha)", + "title_fi": "seleenin (Se) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of selenium (Se) in fertilizer", + "unitless_title_fi": "seleenin (Se) määrä lannoitteessa" + } + }, + "Fe_in_applied_fertilizer": { + "title": "amount of iron (Fe) in fertilizer (kg/ha)", + "title_fi": "raudan (Fe) määrä lannoitteessa (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "amount of iron (Fe) in fertilizer", + "unitless_title_fi": "raudan (Fe) määrä lannoitteessa" + } + }, + "other_element_in_applied_fertilizer": { + "title": "other elements in fertilizer (kg/ha)", + "title_fi": "muut ravinteet lannoitteessa (kg/ha)", + "type": "string" + }, + "fertilizer_type": { + "title": "fertilizer type", + "title_fi": "lannoitteen tyyppi", + "type": "string", + "x-ui": { + "discriminator": true + } + }, + "fertilizer_applic_method": { + "allOf": [ + { + "title": "application method", + "title_fi": "levitystapa" + }, + { + "$ref": "#/$defs/fertilizer_applic_method" + } + ] + }, + "application_depth_fert": { + "title": "application depth (cm)", + "title_fi": "levityssyvyys (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "application depth", + "unitless_title_fi": "levityssyvyys" + } + }, + "fertilizer_total_amount": { + "title": "total amount of fertilizer (kg/ha)", + "title_fi": "lannoitteen kokonaismäärä (kg/ha)", + "title_sv": "totala mändgen gödsel (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "total amount of fertilizer", + "unitless_title_fi": "lannoitteen kokonaismäärä", + "unitless_title_sv": "totala mändgen gödsel" + } + }, + "mgmt_event_long_notes": { + "title": "notes on fertilizer application", + "title_fi": "muistiinpanoja lannoitteen levityksestä", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"biostimulant was added because the field suffered from drought\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"lisäsin biostimulanttia pellon kuivuuden vuoksi\"" + } + } + }, + "oneOf": [ + { + "title": "mineral", + "title_fi": "väkilannoite", + "properties": { + "fertilizer_type": { + "title": "mineral", + "title_fi": "väkilannoite", + "const": "fertilizer_type_mineral" + }, + "fertilizer_product_name" : { + "title": "name of fertilizer", + "title_fi": "lannoitteen nimi", + "type" : "string" + } + } + }, + { + "title": "soil amendment", + "title_fi": "maanparannusaine", + "properties": { + "fertilizer_type": { + "title": "soil amendment", + "title_fi": "maanparannusaine", + "const": "fertilizer_type_soil_amendment" + }, + "fertilizer_material": { + "title": "soil amendment substance", + "title_fi": "maanparannusaine", + "type": "string", + "oneOf": [ + { + "title": "Bio char", + "title_fi": "Biohiili", + "const": "FE996" + }, + { + "title": "Peat", + "title_fi": "Turve", + "const": "FE997" + }, + { + "title": "Sawdust", + "title_fi": "Sahanpuru", + "const": "FE998" + }, + { + "title": "Wood chip", + "title_fi": "Puulastu", + "const": "FE999" + } + ] + }, + "fertilizer_material_source": { + "title": "fertilizer material source", + "title_fi": "Lannoitteen alkuperä", + "type" : "string", + "x-ui": { + "placeholder" : "e.g. local stables or own farm or Commercial (brand)", + "placeholder_fi" : "esim. paikallinen talli, oma tila tai kaupallinen (tuotteen nimi)" + } + } + } + }, + { + "title": "organic material application", + "title_fi": "eloperäisen lannoitteen levitys", + "title_sv": "applicering av organiskt material", + "properties": { + "fertilizer_type": { + "title": "organic material", + "title_fi": "eloperäinen aine", + "title_sv": "organisk material", + "const": "fertilizer_type_organic" + }, + "organic_material": { + "title": "organic material", + "title_fi": "eloperäinen aine", + "title_sv": "organisk material", + "type": "string", + "oneOf": [ + { + "title": "generic crop residue", + "title_fi": "yleinen kasvijäte", + "title_sv": "allmänna växtrester", + "const": "RE001" + }, + { + "title": "green manure", + "title_fi": "viherlannoitus", + "title_sv": "gröngödsel", + "const": "RE002" + }, + { + "title": "barnyard manure", + "title_fi": "kuivalanta", + "title_sv": "gårdsgödsel", + "const": "RE003" + }, + { + "title": "liquid manure", + "title_fi": "lietelanta", + "title_sv": "slamgödsel", + "const": "RE004" + }, + { + "title": "compost", + "title_fi": "komposti", + "title_sv": "kompost", + "const": "RE005" + }, + { + "title": "bark", + "title_fi": "puun kuori", + "title_sv": "bark", + "const": "RE006" + }, + { + "title": "generic legume residue", + "title_fi": "palkokasvijäte", + "title_sv": "baljväxtrester", + "const": "RE101" + }, + { + "title": "faba bean", + "title_fi": "härkäpapu", + "title_sv": "bondböna", + "const": "RE109" + }, + { + "title": "pea residue", + "title_fi": "hernejäte", + "title_sv": "ärtavfall", + "const": "RE110" + }, + { + "title": "hairy vetch", + "title_fi": "ruisvirna", + "title_sv": "luddvicker", + "const": "RE111" + }, + { + "title": "generic cereal crop residue", + "title_fi": "viljakasvijäte", + "title_sv": "spannmålsavfall", + "const": "RE201" + }, + { + "title": "wheat residue", + "title_fi": "vehnäjäte", + "title_sv": "veteavfall", + "const": "RE205" + }, + { + "title": "barley", + "title_fi": "ohra", + "title_sv": "korn", + "const": "RE206" + }, + { + "title": "rye", + "title_fi": "ruis", + "title_sv": "råg", + "const": "RE208" + }, + { + "title": "generic grass", + "title_fi": "ruohokasvi", + "title_sv": "gräsväxti", + "const": "RE301" + }, + { + "title": "bermudagrass", + "title_fi": "varvasheinä", + "title_sv": "hundtandsgräs", + "const": "RE303" + }, + { + "title": "switchgrass", + "title_fi": "lännenhirssi", + "title_sv": "jungfruhirs", + "const": "RE304" + }, + { + "title": "brachiaria", + "title_fi": "viittaheinät", + "title_sv": "brachiaria", + "const": "RE305" + }, + { + "title": "forage grasses", + "title_fi": "nurmikasvit", + "title_sv": "vallväxter", + "const": "RE306" + }, + { + "title": "decomposed crop residue", + "title_fi": "maatunut kasvijäte", + "title_sv": "nedbrutet växtavfall", + "const": "RE999" + }, + { + "title": "other", + "title_fi": "muu", + "const": "REOTHER" + } + ] + }, + "org_matter_moisture_conc" : { + "title": "moisture concentration (%)", + "title_fi": "aineen kosteus (%)", + "x-ui": { + "unitless_title": "moisture concentration", + "unitless_title_fi": "aineen kosteus", + "unit": "%" + }, + "type" : "number", + "minimum" : 0, + "maximum" : 100 + }, + "org_matter_carbon_conc" : { + "title": "carbon (C) concentration in material (%)", + "title_fi": "hiilen (C) määrä aineessa (%)", + "x-ui": { + "unitless_title": "carbon (C) concentration", + "unitless_title_fi": "hiilen (C) määrä aineessa", + "unit": "%" + }, + "type": "number", + "minimum" : 0, + "maximum" : 100 + }, + "org_material_c_to_n": { + "title": "C:N ratio in material", + "title_fi": "C:N suhde aineessa", + "type": "number", + "minimum": 0 + }, + "fertilizer_material_source" : { + "title": "fertilizer material source", + "title_fi": "Lannoitteen alkuperä", + "type" : "string", + "x-ui": { + "placeholder" : "e.g. local stables or own farm or Commercial (brand)", + "placeholder_fi" : "esim. paikallinen talli, oma tila tai kaupallinen (tuotteen nimi)" + } + }, + "animal_fert_usage": { + "title": "animal fertilizer", + "title_fi": "eläimen lannoite", + "type": "string", + "x-ui": { + "placeholder": "which animal fertilizer, e.g. pig, horse, cow", + "placeholder_fi": "minkä eläimen lannoitetta, esim. sika, hevonen, lehmä", + "condition": "input.organic_material == 'RE003' || input.organic_material == 'RE004'" + } + } + } + } + ], + "required": [ + "date", + "fertilizer_type", + "fertilizer_total_amount" + ] + }, + { + "$id": "#tillage", + "title": "tillage", + "title2": "tillage application", + "title_fi": "maanmuokkaus", + "title2_fi": "maan muokkaus", + "title_sv": "markens bearbetning", + "properties": { + "mgmt_operations_event": { + "title": "tillage", + "title2": "tillage application", + "title_fi": "maanmuokkaus", + "title2_fi": "maan muokkaus", + "title_sv": "markens bearbetning", + "const": "tillage" + }, + "tillage_practice": { + "title": "tillage type", + "title_fi": "muokkaustyyppi", + "type": "string", + "oneOf": [ + { + "title": "primary (residue incorporation)", + "title_fi": "perusmuokkaus", + "const": "tillage_practice_primary" + }, + { + "title": "secondary (seedbed)", + "title_fi": "kylvömuokkaus", + "const": "tillage_practice_secondary" + }, + { + "title": "tertiary (weed control)", + "title_fi": "rikkakasvien torjunta", + "const": "tillage_practice_tertiary" + } + ] + }, + "tillage_implement": { + "title": "tillage implement", + "title_fi": "muokkausväline", + "title_sv": "bearbetningsredskap", + "type": "string", + "oneOf": [ + { + "title": "subsoiler", + "title_fi": "jankkuri", + "const": "TI002" + }, + { + "title": "mould-board plough", + "title_fi": "kyntöaura", + "const": "TI003" + }, + { + "title": "disk, tandem", + "title_fi": "lautasäes", + "const": "TI009" + }, + { + "title": "cultivator, field", + "title_fi": "kultivaattori", + "const": "TI011" + }, + { + "title": "harrow, tine", + "title_fi": "joustopiikkiäes", + "const": "TI015" + }, + { + "title": "lister", + "title_fi": "multain", + "const": "TI016" + }, + { + "title": "blade cultivator", + "title_fi": "hara", + "const": "TI018" + }, + { + "title": "manure injector", + "title_fi": "lannansijoituskone (Manure injector?)", + "const": "TI020" + }, + { + "title": "roller packer", + "title_fi": "jyrä (roller packer?)", + "const": "TI024" + }, + { + "title": "drill, double-disk", + "title_fi": "suorakylvökone, kaksoiskiekot (drill, double disk?)", + "const": "TI025" + }, + { + "title": "drill, no-till", + "title_fi": "suorakylvökone, ei muokkausta (drill, no-till?)", + "const": "TI031" + }, + { + "title": "planter, row", + "title_fi": "kylvökone (planter, row?)", + "const": "TI033" + }, + { + "title": "rotary hoe", + "title_fi": "maanjyrsin (rotary hoe?)", + "const": "TI038" + }, + { + "title": "tine weeder", + "title_fi": "rikkaäes", + "const": "TI044" + }, + { + "title": "spade disk harrow", + "title_fi": "lapiorullaäes", + "const": "TI045" + }, + { + "title": "tume harrow", + "title_fi": "lapiorullaäes", + "const": "TI045" + }, + { + "title": "other", + "title_fi": "muu", + "const": "TI999" + } + ] + }, + "tillage_operations_depth": { + "title": "tillage depth (cm)", + "title_fi": "muokkaussyvyys (cm)", + "title_sv": "bearbetningsdjup (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "tillage depth", + "unitless_title_fi": "muokkaussyvyys", + "unitless_title_sv": "bearbetningsdjup" + } + }, + "mgmt_event_long_notes": { + "title": "tillage notes", + "title_fi": "muistiinpanot muokkauksesta", + "title_sv": "anteckningar på bearbetning", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"had to stop tillage and continue the next day\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"jatkoin muokkausta seuraavana päivänä\"" + } + } + }, + "required": [ + "date", + "tillage_practice" + ] + }, + { + "$id": "#harvest", + "title": "harvest", + "title_fi": "sadonkorjuu", + "title_sv": "skörd", + "description": "If you left the harvest residue on the field, please add a new event (fertilizer application or tillage) accordingly.", + "description_en": "If you left the harvest residue on the field, please add a new event (fertilizer application or tillage) accordingly.", + "description_fi": "Jos jätit korjuutähteet pellolle, tee tästä uusi soveltuva tapahtuma (lannoitus- tai maanmuokkaus-).", + "properties": { + "mgmt_operations_event": { + "title": "harvest", + "title_fi": "sadonkorjuu", + "title_sv": "skörd", + "const": "harvest" + }, + "harvest_area": { + "title": "harvest area (ha)", + "title_fi": "pinta-ala (ha)", + "title2_fi": "korjattu pinta-ala (ha)", + "title_sv": "skördat område (ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "ha", + "unitless_title": "harvest area", + "unitless_title_fi": "pinta-ala", + "unitless_title2_fi": "korjattu pinta-ala", + "unitless_title_sv": "skördat område" + } + }, + "harvest_list": { + "type": "array", + "title": "harvested items", + "title_fi": "sadonkorjuun kohteet", + "items": { + "type": "object", + "properties": { + "harvest_crop": { + "allOf": [ + { + "title": "harvest crop", + "title_fi": "korjattu laji", + "title_sv": "skördad gröda" + }, + { + "$ref": "#/$defs/crop_ident_ICASA" + } + ] + }, + "harvest_moisture": { + "title": "yield moisture (%)", + "title_fi": "sadon kosteus (%)", + "type": "number", + "minimum": 0, + "maximum": 100, + "x-ui": { + "unit": "%", + "unitless_title": "yield moisture", + "unitless_title_fi": "sadon kosteus" + } + }, + "harvest_method": { + "title": "harvest method", + "title_fi": "korjuutapa", + "title_sv": "skördemetod", + "type": "string", + "oneOf": [ + { + "title": "combined", + "title_fi": "leikkuupuimuri", + "title_sv": "skördetröska", + "const": "HM001" + }, + { + "title": "hand picked, no further processing", + "title_fi": "poimittu käsin, ei muuta prosessointia", + "title_sv": "handplockat, ingen övrig bearbetning", + "const": "HM004" + }, + { + "title": "hand picked, machine processing", + "title_fi": "poimittu käsin, prosessoitu koneella", + "title_sv": "handplockat, maskin bearbetat", + "const": "HM005" + }, + { + "title": "hay", + "title_fi": "heinä", + "const": "HM007" + }, + { + "title": "silage", + "title_fi": "säilörehu", + "const": "HM008" + }, + { + "title": "potato harvester", + "title_fi": "perunannostokone", + "const": "HM009" + }, + { + "title": "sugar beet harvester", + "title_fi": "juurikkaannostokone", + "const": "HM010" + } + ] + }, + "harvest_operat_component": { + "title": "crop component harvested", + "title_fi": "kerätty kasvinosa", + "title2_fi": "korjattu kasvinosa", + "title_sv": "skördad växtdel", + "type": "string", + "oneOf": [ + { + "title": "canopy", + "title_fi": "latvusto", + "title_sv": "krontak", + "const": "canopy" + }, + { + "title": "leaves", + "title_fi": "lehdet", + "title_sv": "blad", + "const": "leaf" + }, + { + "title": "grain, legume seeds", + "title_fi": "jyvä, palkokasvin siemen", + "title_sv": "korn, baljväxtens frö", + "const": "grain" + }, + { + "title": "silage", + "title_fi": "säilörehu", + "title_sv": "ensilage", + "const": "silage" + }, + { + "title": "tuber, root, etc.", + "title_fi": "mukula, juuri, yms.", + "title_sv": "knöl, rot, etc.", + "const": "tuber" + }, + { + "title": "fruit", + "title_fi": "hedelmä", + "title_sv": "frukt", + "const": "fruit" + }, + { + "title": "stem", + "title_fi": "varsi", + "title_sv": "stjälk", + "const": "stem" + } + ] + }, + "canopy_height_harvest": { + "title": "canopy height (m)", + "title_fi": "kasvuston korkeus (m)", + "title_sv": "växtlighetens höjd (m)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m", + "unitless_title": "canopy height", + "unitless_title_fi": "kasvuston korkeus", + "unitless_title_sv": "växtlighetens höjd" + } + }, + "harvest_cut_height": { + "title": "height of cut (cm)", + "title_fi": "leikkuukorkeus (cm)", + "title_sv": "klipphöjd (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "height of cut", + "unitless_title_fi": "leikkuukorkeus", + "unitless_title_sv": "klipphöjd" + } + }, + "plant_density_harvest": { + "title": "plant density at harvest (plants/m²)", + "title_fi": "kasvitiheys korjuuhetkellä (kasveja/m²)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m⁻²", + "unitless_title": "plant density at harvest", + "unitless_title_fi": "kasvitiheys korjuuhetkellä" + } + }, + "harvest_residue_placement": { + "title": "harvest residue placement", + "title_fi": "korjuutähteiden sijoituspaikka", + "title2_fi": "korjatun kasvinosan sijoituspaikka", + "type": "string", + "oneOf": [ + { + "title": "left in the field as green manure", + "title_fi": "jätetty pellolle viherlannoitukseksi", + "const": "harvest_residue_placement_green_manure" + }, + { + "title": "left in the field for tillage incorporation", + "title_fi": "jätetty pellolle kyntämällä sekoittamista varten", + "const": "harvest_residue_placement_tillage" + }, + { + "title": "burned", + "title_fi": "poltettu", + "const": "harvest_residue_placement_burned" + }, + { + "title": "removed from the field", + "title_fi": "poistettu pellolta", + "const": "harvest_residue_placement_removed" + } + ] + }, + "harvest_yield_harvest_dw": { + "title": "yield, dry weight (kg/ha)", + "title_fi": "sato, kuivapaino (kg/ha)", + "title_sv": "skörd, torrvikt (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "yield, dry weight", + "unitless_title_fi": "sato, kuivapaino", + "unitless_title_sv": "skörd, torrvikt" + } + }, + "harv_yield_harv_f_wt": { + "title": "yield, fresh weight (t/ha)", + "title_fi": "sato, märkäpaino (t/ha)", + "title2_fi": "sato, tuorepaino (t/ha)", + "title_sv": "skörd, färskvikt (t/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "t/ha", + "unitless_title": "yield, fresh weight", + "unitless_title_fi": "sato, märkäpaino", + "unitless_title2_fi": "sato, tuorepaino", + "unitless_title_sv": "skörd, färskvikt" + } + }, + "yield_C_at_harvest": { + "title": "carbon (C) in yield (kg/ha)", + "title_fi": "hiilen (C) määrä sadossa (kg/ha)", + "title_sv": "mängden kol (C) i skörden (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "carbon (C) in yield", + "unitless_title_fi": "hiilen (C) määrä sadossa", + "unitless_title_sv": "mängden kol (C) i skörden" + } + } + }, + "required": [ + "harvest_crop" + ] + }, + "minItems": 1 + }, + "harvest_yield_harvest_dw_total": { + "title": "yield, total dry weight (kg/ha)", + "title2": "total yield, dry weight (kg/ha)", + "title_fi": "sato, kuivapaino yhteensä (kg/ha)", + "title2_fi": "kokonaissato, kuivapaino (kg/ha)", + "title_sv": "totala skörden, torrvikt (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "yield, total dry weight", + "unitless_title2": "total yield, dry weight", + "unitless_title_fi": "sato, kuivapaino yhteensä", + "unitless_title2_fi": "kokonaissato, kuivapaino", + "unitless_title_sv": "totala skörden, torrvikt", + "total_of_list": "harvest_list", + "total_of_property": "harvest_yield_harvest_dw" + } + }, + "harv_yield_harv_f_wt_total": { + "title": "yield, total fresh weight (t/ha)", + "title_fi": "sato, märkäpaino yhteensä (t/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "t/ha", + "unitless_title": "yield, total fresh weight", + "unitless_title_fi": "sato, märkäpaino yhteensä", + "total_of_list": "harvest_list", + "total_of_property": "harv_yield_harv_f_wt" + } + }, + "yield_C_at_harvest_total": { + "title": "carbon (C) in yield, total (kg/ha)", + "title2": "total carbon (C) in yield (kg/ha)", + "title_fi": "hiilen (C) määrä sadossa yhteensä (kg/ha)", + "title2_fi": "hiilen (C) kokonaismäärä sadossa (kg/ha)", + "title_sv": "totala mängden kol (C) i skörden (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "carbon (C) in yield, total", + "unitless_title2": "total carbon (C) in yield", + "unitless_title_fi": "hiilen (C) määrä sadossa yhteensä", + "unitless_title2_fi": "hiilen (C) kokonaismäärä sadossa", + "unitless_title_sv": "totala mängden kol (C) i skörden", + "total_of_list": "harvest_list", + "total_of_property": "yield_C_at_harvest" + } + }, + "mgmt_event_long_notes": { + "title": "harvest comments", + "title2": "comments", + "title_fi": "sadonkorjuukommentit", + "title_sv": "kommentarer", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"cutting height was not uniform\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"leikkuukorkeus ei ollut sama kaikkialla\"" + } + } + }, + "required": [ + "date", + "harvest_list" + ] + }, + { + "$id": "#chemicals", + "title": "chemicals application", + "title_fi": "kemikaalin levitys", + "title_sv": "applicering av kemikalier", + "properties": { + "mgmt_operations_event": { + "title": "chemicals application", + "title_fi": "kemikaalin levitys", + "title_sv": "applicering av kemikalier", + "const": "chemicals" + }, + "chemical_type": { + "title": "chemical type", + "title_fi": "kemikaalin tyyppi", + "type": "string", + "oneOf": [ + { + "title": "insecticide", + "title_fi": "hyönteistorjunta-aine", + "const": "chemical_type_insecticide" + }, + { + "title": "herbicide", + "title_fi": "rikkakasvien torjunta-aine", + "const": "chemical_type_herbicide" + }, + { + "title": "fungicide", + "title_fi": "sienitautien torjunta-aine", + "const": "chemical_type_fungicide" + }, + { + "title": "growth regulator", + "title_fi": "kasvunsääde", + "const": "chemical_type_growth_regulator" + }, + { + "title": "lime application", + "title_fi": "kalkin levitys", + "const": "chemical_type_lime_application" + }, + { + "title": "gypsum application", + "title_fi": "kipsin levitys", + "const": "chemical_type_gypsum_application" + } + ] + }, + "chemical_product_name": { + "title": "chemical product name", + "title_fi": "kemikaalivalmisteen nimi", + "type": "string" + }, + "chemical_applic_material_list": { + "title": "list of active substances in chemical", + "title_fi": "lista kemikaalin tehoaineista", + "type": "array", + "x-ui": { + "condition": "input.chemical_type != 'chemical_type_lime_application'" + }, + "items": { + "type": "object", + "properties": { + "chemical_applic_material": { + "title": "active substance in chemical", + "title_fi": "kemikaalin tehoaine", + "type": "string", + "oneOf": [ + { + "title": "(E,E)-8,10-dodekadien-1-oli", + "title_fi": "(E,E)-8,10-dodekadien-1-oli", + "const": "AS001" + }, + { + "title": "(Z)-11-tetradeken-1-yyliasetaatti", + "title_fi": "(Z)-11-tetradeken-1-yyliasetaatti", + "const": "AS002" + }, + { + "title": "1,4-dimetyylinaftaleeni", + "title_fi": "1,4-dimetyylinaftaleeni", + "const": "AS003" + }, + { + "title": "2,4-D", + "title_fi": "2,4-D", + "const": "AS004" + }, + { + "title": "6-bentsyyliadeniini", + "title_fi": "6-bentsyyliadeniini", + "const": "AS005" + }, + { + "title": "Abamektiini", + "title_fi": "Abamektiini", + "const": "AS006" + }, + { + "title": "aklonifeeni", + "title_fi": "aklonifeeni", + "const": "AS007" + }, + { + "title": "Alfa-sypermetriini", + "title_fi": "Alfa-sypermetriini", + "const": "AS008" + }, + { + "title": "Alumiinifosfidi", + "title_fi": "Alumiinifosfidi", + "const": "AS009" + }, + { + "title": "Amidosulfuroni", + "title_fi": "Amidosulfuroni", + "const": "AS010" + }, + { + "title": "Aminopyralidi", + "title_fi": "Aminopyralidi", + "const": "AS011" + }, + { + "title": "Amisulbromi (ISO)", + "title_fi": "Amisulbromi (ISO)", + "const": "AS012" + }, + { + "title": "Asetamipridi", + "title_fi": "Asetamipridi", + "const": "AS013" + }, + { + "title": "Atsoksistrobiini (ISO)", + "title_fi": "Atsoksistrobiini (ISO)", + "const": "AS014" + }, + { + "title": "Bacillus amyloliquefaciens (kanta MBI 600)", + "title_fi": "Bacillus amyloliquefaciens (kanta MBI 600)", + "const": "AS015" + }, + { + "title": "Bacillus subtilis QST 713", + "title_fi": "Bacillus subtilis QST 713", + "const": "AS016" + }, + { + "title": "Bacillus thuringiensis subsp. aizawai (kanta GC-91)", + "title_fi": "Bacillus thuringiensis subsp. aizawai (kanta GC-91)", + "const": "AS017" + }, + { + "title": "Beauveria bassiana GHA", + "title_fi": "Beauveria bassiana GHA", + "const": "AS018" + }, + { + "title": "Bentatsoni", + "title_fi": "Bentatsoni", + "const": "AS019" + }, + { + "title": "Bentsoehappo", + "title_fi": "Bentsoehappo", + "const": "AS020" + }, + { + "title": "Bentsovindiflupyyri (ISO)", + "title_fi": "Bentsovindiflupyyri (ISO)", + "const": "AS021" + }, + { + "title": "Bifenatsaatti (ISO)", + "title_fi": "Bifenatsaatti (ISO)", + "const": "AS022" + }, + { + "title": "Bifenoksi", + "title_fi": "Bifenoksi", + "const": "AS023" + }, + { + "title": "Biksafeeni", + "title_fi": "Biksafeeni", + "const": "AS024" + }, + { + "title": "Boskalidi", + "title_fi": "Boskalidi", + "const": "AS025" + }, + { + "title": "Bromoksiniili", + "title_fi": "Bromoksiniili", + "const": "AS026" + }, + { + "title": "Buprofetsiini", + "title_fi": "Buprofetsiini", + "const": "AS027" + }, + { + "title": "Coniothyrium minitans, strain CON/M/91-08", + "title_fi": "Coniothyrium minitans, strain CON/M/91-08", + "const": "AS028" + }, + { + "title": "Cydia pomonella granulovirus (CpGV)", + "title_fi": "Cydia pomonella granulovirus (CpGV)", + "const": "AS029" + }, + { + "title": "Daminotsidi", + "title_fi": "Daminotsidi", + "const": "AS030" + }, + { + "title": "Deltametriini", + "title_fi": "Deltametriini", + "const": "AS031" + }, + { + "title": "Difenokonatsoli", + "title_fi": "Difenokonatsoli", + "const": "AS032" + }, + { + "title": "Diflufenikaani", + "title_fi": "Diflufenikaani", + "const": "AS033" + }, + { + "title": "Dikamba", + "title_fi": "Dikamba", + "const": "AS034" + }, + { + "title": "Diklorproppi-P", + "title_fi": "Diklorproppi-P", + "const": "AS035" + }, + { + "title": "Dikvatti", + "title_fi": "Dikvatti", + "const": "AS036" + }, + { + "title": "Dimetenamidi-P (ISO)", + "title_fi": "Dimetenamidi-P (ISO)", + "const": "AS037" + }, + { + "title": "Dimetomorfi", + "title_fi": "Dimetomorfi", + "const": "AS038" + }, + { + "title": "Ditianoni", + "title_fi": "Ditianoni", + "const": "AS039" + }, + { + "title": "dodiini", + "title_fi": "dodiini", + "const": "AS040" + }, + { + "title": "Esfenvaleraatti", + "title_fi": "Esfenvaleraatti", + "const": "AS041" + }, + { + "title": "etefoni", + "title_fi": "etefoni", + "const": "AS042" + }, + { + "title": "Etikkahappo", + "title_fi": "Etikkahappo", + "const": "AS043" + }, + { + "title": "Etofumesaatti (ISO)", + "title_fi": "Etofumesaatti (ISO)", + "const": "AS044" + }, + { + "title": "Fenheksamidi", + "title_fi": "Fenheksamidi", + "const": "AS045" + }, + { + "title": "Fenmedifaami", + "title_fi": "Fenmedifaami", + "const": "AS046" + }, + { + "title": "Fenoksaproppi-P-etyyli (ISO)", + "title_fi": "Fenoksaproppi-P-etyyli (ISO)", + "const": "AS047" + }, + { + "title": "Fenpyratsamiini", + "title_fi": "Fenpyratsamiini", + "const": "AS048" + }, + { + "title": "fenpyroksimaatti (ISO)", + "title_fi": "fenpyroksimaatti (ISO)", + "const": "AS049" + }, + { + "title": "Flonikamidi (ISO)", + "title_fi": "Flonikamidi (ISO)", + "const": "AS050" + }, + { + "title": "Florasulaami", + "title_fi": "Florasulaami", + "const": "AS051" + }, + { + "title": "Fluatsifoppi-P-butyyli", + "title_fi": "Fluatsifoppi-P-butyyli", + "const": "AS052" + }, + { + "title": "Fluatsinami", + "title_fi": "Fluatsinami", + "const": "AS053" + }, + { + "title": "Fludioksiniili (ISO)", + "title_fi": "Fludioksiniili (ISO)", + "const": "AS054" + }, + { + "title": "Fludioksoniili", + "title_fi": "Fludioksoniili", + "const": "AS055" + }, + { + "title": "fluksapyroksadi", + "title_fi": "fluksapyroksadi", + "const": "AS056" + }, + { + "title": "Fluopikolidi", + "title_fi": "Fluopikolidi", + "const": "AS057" + }, + { + "title": "Fluopyraami (ISO)", + "title_fi": "Fluopyraami (ISO)", + "const": "AS058" + }, + { + "title": "Flupyradifuroni", + "title_fi": "Flupyradifuroni", + "const": "AS059" + }, + { + "title": "fluroksipyyri", + "title_fi": "fluroksipyyri", + "const": "AS060" + }, + { + "title": "fluroksipyyri-meptyyli (ISO)", + "title_fi": "fluroksipyyri-meptyyli (ISO)", + "const": "AS061" + }, + { + "title": "Flutolaniili", + "title_fi": "Flutolaniili", + "const": "AS062" + }, + { + "title": "Foramsulfuroni", + "title_fi": "Foramsulfuroni", + "const": "AS063" + }, + { + "title": "Fosetyyli", + "title_fi": "Fosetyyli", + "const": "AS064" + }, + { + "title": "Fosetyyli-alumiini", + "title_fi": "Fosetyyli-alumiini", + "const": "AS065" + }, + { + "title": "Gamma-syhalotriini", + "title_fi": "Gamma-syhalotriini", + "const": "AS066" + }, + { + "title": "Gibberelliini (GA4 ja GA7 seos)", + "title_fi": "Gibberelliini (GA4 ja GA7 seos)", + "const": "AS067" + }, + { + "title": "Gliocladium catenulatum -sienen rihmastoa ja itiöitä", + "title_fi": "Gliocladium catenulatum -sienen rihmastoa ja itiöitä", + "const": "AS068" + }, + { + "title": "Glyfosaatti (glyfosaatin ammoniumsuolana)", + "title_fi": "Glyfosaatti (glyfosaatin ammoniumsuolana)", + "const": "AS069" + }, + { + "title": "Glyfosaatti (Glyfosaatin dimetyyliamiinisuolana)", + "title_fi": "Glyfosaatti (Glyfosaatin dimetyyliamiinisuolana)", + "const": "AS070" + }, + { + "title": "Glyfosaatti (glyfosaatin isopropyyliamiinisuolana)", + "title_fi": "Glyfosaatti (glyfosaatin isopropyyliamiinisuolana)", + "const": "AS071" + }, + { + "title": "Glyfosaatti (glyfosaatin kaliumsuolana)", + "title_fi": "Glyfosaatti (glyfosaatin kaliumsuolana)", + "const": "AS072" + }, + { + "title": "Halauksifeeni-metyyli", + "title_fi": "Halauksifeeni-metyyli", + "const": "AS073" + }, + { + "title": "Harmaaorvakka-sienen itiöitä", + "title_fi": "Harmaaorvakka-sienen itiöitä", + "const": "AS074" + }, + { + "title": "heksytiatsoksi (ISO)", + "title_fi": "heksytiatsoksi (ISO)", + "const": "AS075" + }, + { + "title": "hymeksatsoli (ISO)", + "title_fi": "hymeksatsoli (ISO)", + "const": "AS076" + }, + { + "title": "Imatsaliili", + "title_fi": "Imatsaliili", + "const": "AS077" + }, + { + "title": "Imatsamoksi", + "title_fi": "Imatsamoksi", + "const": "AS078" + }, + { + "title": "Imidaklopridi", + "title_fi": "Imidaklopridi", + "const": "AS079" + }, + { + "title": "Indoksakarbi", + "title_fi": "Indoksakarbi", + "const": "AS080" + }, + { + "title": "Isaria fumosorosea, kanta Apopka 97", + "title_fi": "Isaria fumosorosea, kanta Apopka 97", + "const": "AS081" + }, + { + "title": "Isoksabeeni", + "title_fi": "Isoksabeeni", + "const": "AS082" + }, + { + "title": "Isopyratsaami", + "title_fi": "Isopyratsaami", + "const": "AS083" + }, + { + "title": "Jodosulfuroni-metyyli-natrium", + "title_fi": "Jodosulfuroni-metyyli-natrium", + "const": "AS084" + }, + { + "title": "Kaliumfosfonaatit (kaliumvetyfosfonaatti + dikaliumfosfonaatti)", + "title_fi": "Kaliumfosfonaatit (kaliumvetyfosfonaatti + dikaliumfosfonaatti)", + "const": "AS085" + }, + { + "title": "Kapriinihappo", + "title_fi": "Kapriinihappo", + "const": "AS086" + }, + { + "title": "Kapryylihappo", + "title_fi": "Kapryylihappo", + "const": "AS087" + }, + { + "title": "Kaptaani", + "title_fi": "Kaptaani", + "const": "AS088" + }, + { + "title": "Karfentratsoni-etyyli", + "title_fi": "Karfentratsoni-etyyli", + "const": "AS089" + }, + { + "title": "Kletodiimi (ISO)", + "title_fi": "Kletodiimi (ISO)", + "const": "AS090" + }, + { + "title": "Klomatsoni", + "title_fi": "Klomatsoni", + "const": "AS091" + }, + { + "title": "Klopyralidi", + "title_fi": "Klopyralidi", + "const": "AS092" + }, + { + "title": "Klorantraniliproli", + "title_fi": "Klorantraniliproli", + "const": "AS093" + }, + { + "title": "Klormekvattikloridi", + "title_fi": "Klormekvattikloridi", + "const": "AS094" + }, + { + "title": "Kresoksiimi-metyyli", + "title_fi": "Kresoksiimi-metyyli", + "const": "AS095" + }, + { + "title": "Kvinmerakki", + "title_fi": "Kvinmerakki", + "const": "AS096" + }, + { + "title": "Kvitsalofoppi-P-etyyli", + "title_fi": "Kvitsalofoppi-P-etyyli", + "const": "AS097" + }, + { + "title": "Lambda-syhalotriini", + "title_fi": "Lambda-syhalotriini", + "const": "AS098" + }, + { + "title": "Lampaanrasva", + "title_fi": "Lampaanrasva", + "const": "AS099" + }, + { + "title": "Magnesiumfosfidi", + "title_fi": "Magnesiumfosfidi", + "const": "AS100" + }, + { + "title": "Maleiinihydratsidi", + "title_fi": "Maleiinihydratsidi", + "const": "AS101" + }, + { + "title": "Mandipropamidi (ISO)", + "title_fi": "Mandipropamidi (ISO)", + "const": "AS102" + }, + { + "title": "Mankotsebi", + "title_fi": "Mankotsebi", + "const": "AS103" + }, + { + "title": "MCPA", + "title_fi": "MCPA", + "const": "AS104" + }, + { + "title": "mefentriflukonatsoli", + "title_fi": "mefentriflukonatsoli", + "const": "AS105" + }, + { + "title": "Mekoproppi-P", + "title_fi": "Mekoproppi-P", + "const": "AS106" + }, + { + "title": "Mepanipyriimi", + "title_fi": "Mepanipyriimi", + "const": "AS107" + }, + { + "title": "mepikvattikloridi", + "title_fi": "mepikvattikloridi", + "const": "AS108" + }, + { + "title": "Mesosulfuroni-metyyli (ISO)", + "title_fi": "Mesosulfuroni-metyyli (ISO)", + "const": "AS109" + }, + { + "title": "Metalaksyyli-M", + "title_fi": "Metalaksyyli-M", + "const": "AS110" + }, + { + "title": "metamitroni", + "title_fi": "metamitroni", + "const": "AS111" + }, + { + "title": "Metatsakloori", + "title_fi": "Metatsakloori", + "const": "AS112" + }, + { + "title": "Metkonatsoli", + "title_fi": "Metkonatsoli", + "const": "AS113" + }, + { + "title": "Metobromuroni", + "title_fi": "Metobromuroni", + "const": "AS114" + }, + { + "title": "Metributsiini", + "title_fi": "Metributsiini", + "const": "AS115" + }, + { + "title": "Metsulfuroni-metyyli", + "title_fi": "Metsulfuroni-metyyli", + "const": "AS116" + }, + { + "title": "Napropamidi", + "title_fi": "Napropamidi", + "const": "AS117" + }, + { + "title": "Oksatiapiproliini", + "title_fi": "Oksatiapiproliini", + "const": "AS118" + }, + { + "title": "Paklobutratsoli (ISO)", + "title_fi": "Paklobutratsoli (ISO)", + "const": "AS119" + }, + { + "title": "Parafiiniöljy (CAS-nro 64742-46-7)", + "title_fi": "Parafiiniöljy (CAS-nro 64742-46-7)", + "const": "AS120" + }, + { + "title": "Parafiiniöljy (CAS-nro 8042-47-5)", + "title_fi": "Parafiiniöljy (CAS-nro 8042-47-5)", + "const": "AS121" + }, + { + "title": "Pelargonihappo", + "title_fi": "Pelargonihappo", + "const": "AS122" + }, + { + "title": "Pendimetaliini", + "title_fi": "Pendimetaliini", + "const": "AS123" + }, + { + "title": "penflufeeni", + "title_fi": "penflufeeni", + "const": "AS124" + }, + { + "title": "Penkonatsoli", + "title_fi": "Penkonatsoli", + "const": "AS125" + }, + { + "title": "Pepinon mosaiikkivirus (kannan CH2 isolaatti 1906)", + "title_fi": "Pepinon mosaiikkivirus (kannan CH2 isolaatti 1906)", + "const": "AS126" + }, + { + "title": "Pikloraami", + "title_fi": "Pikloraami", + "const": "AS127" + }, + { + "title": "Pinoksadeeni (ISO)", + "title_fi": "Pinoksadeeni (ISO)", + "const": "AS128" + }, + { + "title": "Proheksadionikalsium", + "title_fi": "Proheksadionikalsium", + "const": "AS129" + }, + { + "title": "Prokinatsidi", + "title_fi": "Prokinatsidi", + "const": "AS130" + }, + { + "title": "Propakvitsafoppi", + "title_fi": "Propakvitsafoppi", + "const": "AS131" + }, + { + "title": "Propamokarbi", + "title_fi": "Propamokarbi", + "const": "AS132" + }, + { + "title": "Propamokarbi-hydrokloridi", + "title_fi": "Propamokarbi-hydrokloridi", + "const": "AS133" + }, + { + "title": "Propoksikarbatsoni-natrium", + "title_fi": "Propoksikarbatsoni-natrium", + "const": "AS134" + }, + { + "title": "Prosulfokarbi", + "title_fi": "Prosulfokarbi", + "const": "AS135" + }, + { + "title": "Protiokonatsoli", + "title_fi": "Protiokonatsoli", + "const": "AS136" + }, + { + "title": "Pseudomonas chlororaphis MA 342", + "title_fi": "Pseudomonas chlororaphis MA 342", + "const": "AS137" + }, + { + "title": "Pyraflufeeni-etyyli (ISO)", + "title_fi": "Pyraflufeeni-etyyli (ISO)", + "const": "AS138" + }, + { + "title": "Pyraklostrobiini", + "title_fi": "Pyraklostrobiini", + "const": "AS139" + }, + { + "title": "Pyretriinit", + "title_fi": "Pyretriinit", + "const": "AS140" + }, + { + "title": "Pyridaatti (ISO)", + "title_fi": "Pyridaatti (ISO)", + "const": "AS141" + }, + { + "title": "Pyrimetaniili", + "title_fi": "Pyrimetaniili", + "const": "AS142" + }, + { + "title": "Pyriofenoni", + "title_fi": "Pyriofenoni", + "const": "AS143" + }, + { + "title": "Pyroksulaami", + "title_fi": "Pyroksulaami", + "const": "AS144" + }, + { + "title": "Rapsiöljy", + "title_fi": "Rapsiöljy", + "const": "AS145" + }, + { + "title": "Rasvahappojen kaliumsuoloja", + "title_fi": "Rasvahappojen kaliumsuoloja", + "const": "AS146" + }, + { + "title": "Rautafosfaatti", + "title_fi": "Rautafosfaatti", + "const": "AS147" + }, + { + "title": "Rautasulfaatti", + "title_fi": "Rautasulfaatti", + "const": "AS148" + }, + { + "title": "Rimsulfuroni", + "title_fi": "Rimsulfuroni", + "const": "AS149" + }, + { + "title": "Rypsiöljy", + "title_fi": "Rypsiöljy", + "const": "AS150" + }, + { + "title": "Sedaksaani", + "title_fi": "Sedaksaani", + "const": "AS151" + }, + { + "title": "Spirodiklofeeni (ISO)", + "title_fi": "Spirodiklofeeni (ISO)", + "const": "AS152" + }, + { + "title": "spiroksamiini", + "title_fi": "spiroksamiini", + "const": "AS153" + }, + { + "title": "Spirotetramaatti (ISO)", + "title_fi": "Spirotetramaatti (ISO)", + "const": "AS154" + }, + { + "title": "Streptomyces K61 -sädebakteerin rihmastoa ja itiöitä", + "title_fi": "Streptomyces K61 -sädebakteerin rihmastoa ja itiöitä", + "const": "AS155" + }, + { + "title": "Sulfosulfuroni", + "title_fi": "Sulfosulfuroni", + "const": "AS156" + }, + { + "title": "Syantraniiliproli", + "title_fi": "Syantraniiliproli", + "const": "AS157" + }, + { + "title": "Syatsofamidi", + "title_fi": "Syatsofamidi", + "const": "AS158" + }, + { + "title": "Sykloksidiimi", + "title_fi": "Sykloksidiimi", + "const": "AS159" + }, + { + "title": "symoksaniili", + "title_fi": "symoksaniili", + "const": "AS160" + }, + { + "title": "Sypermetriini", + "title_fi": "Sypermetriini", + "const": "AS161" + }, + { + "title": "Syprodiniili", + "title_fi": "Syprodiniili", + "const": "AS162" + }, + { + "title": "Syprokonatsoli", + "title_fi": "Syprokonatsoli", + "const": "AS163" + }, + { + "title": "tau-fluvalinaatti", + "title_fi": "tau-fluvalinaatti", + "const": "AS164" + }, + { + "title": "Tebukonatsoli", + "title_fi": "Tebukonatsoli", + "const": "AS165" + }, + { + "title": "Terpenoidien seos QRD 460", + "title_fi": "Terpenoidien seos QRD 460", + "const": "AS166" + }, + { + "title": "Tiaklopridi", + "title_fi": "Tiaklopridi", + "const": "AS167" + }, + { + "title": "Tieenikarbatsoni-metyyli", + "title_fi": "Tieenikarbatsoni-metyyli", + "const": "AS168" + }, + { + "title": "Tifensulfuroni-metyyli", + "title_fi": "Tifensulfuroni-metyyli", + "const": "AS169" + }, + { + "title": "Tiofanaatti-metyyli", + "title_fi": "Tiofanaatti-metyyli", + "const": "AS170" + }, + { + "title": "Tolklofossi-metyyli", + "title_fi": "Tolklofossi-metyyli", + "const": "AS171" + }, + { + "title": "Tribenuronimetyyli (ISO)", + "title_fi": "Tribenuronimetyyli (ISO)", + "const": "AS172" + }, + { + "title": "Trichoderma harzianum (kanta T-22)", + "title_fi": "Trichoderma harzianum (kanta T-22)", + "const": "AS173" + }, + { + "title": "Trifloksistrobiini", + "title_fi": "Trifloksistrobiini", + "const": "AS174" + }, + { + "title": "Triflusulfuroni-metyyli", + "title_fi": "Triflusulfuroni-metyyli", + "const": "AS175" + }, + { + "title": "Trineksapakki-etyyli", + "title_fi": "Trineksapakki-etyyli", + "const": "AS176" + }, + { + "title": "Tritikonatsoli", + "title_fi": "Tritikonatsoli", + "const": "AS177" + }, + { + "title": "Tritosulfuroni", + "title_fi": "Tritosulfuroni", + "const": "AS178" + }, + { + "title": "Urea", + "title_fi": "Urea", + "const": "AS179" + }, + { + "title": "viherminttuöljy", + "title_fi": "viherminttuöljy", + "const": "AS180" + } + ] + } + } + } + }, + "chemical_applic_target": { + "title": "chemical application target", + "title_fi": "kemikaalinlevityksen kohde", + "description": "source (in Finnish): https://www.kemidigi.fi/kasvinsuojeluainerekisteri/haku", + "type": "string", + "oneOf": [ + { + "title": "defoliation %", + "title_fi": "lehtikato", + "const": "PCLA" + }, + { + "title": "diseased leaf area %", + "title_fi": "tautia lehdissä", + "const": "PDLA" + }, + { + "title": "general pest and diseases losses (due to rot, tikka, leafminer, etc.)", + "title_fi": "yleiset tuhoeläin- ja tautivahingot (mätä, miinaajat jne.)", + "const": "PSTDS" + }, + { + "title": "reduction in photosynthetic rate %", + "title_fi": "lasku yhteyttämisnopeudessa %", + "const": "PRP" + }, + { + "title": "worm (generic)", + "title_fi": "madot", + "const": "WORM" + }, + { + "title": "leafminer", + "title_fi": "miinaajat", + "const": "LEAF_MIN" + }, + { + "title": "stink bug", + "title_fi": "typpyluteet (Stink bug?)", + "const": "STINKB" + }, + { + "title": "looper", + "title_fi": "yökkösentoukat (Looper?)", + "const": "LOOPER" + }, + { + "title": "caterpillar", + "title_fi": "perhostoukat", + "const": "CATERP" + }, + { + "title": "insect (generic)", + "title_fi": "hyönteiset", + "const": "INSECT" + }, + { + "title": "rabbit", + "title_fi": "jänikset", + "const": "RABBIT" + }, + { + "title": "deer", + "title_fi": "hirvieläimet", + "const": "DEER" + }, + { + "title": "mammal (generic)", + "title_fi": "yleiset nisäkkäät", + "const": "MAMMAL" + }, + { + "title": "root-knot nematode", + "title_fi": "meloidogyne spp.", + "const": "RKN" + }, + { + "title": "nematode (generic)", + "title_fi": "sukkulamadot", + "const": "NEMATODE" + }, + { + "title": "potato spindle tuber viroid", + "title_fi": "perunan sukkulamukulaviroidi", + "const": "PSTVd" + }, + { + "title": "viroid (generic)", + "title_fi": "viroidit", + "const": "VIROID" + }, + { + "title": "bean common mosaic virus", + "title_fi": "bean common mosaic virus", + "const": "BCMV" + }, + { + "title": "virus (generic)", + "title_fi": "yleiset virukset", + "const": "VIRUS" + }, + { + "title": "hail storm damage", + "title_fi": "raekuurovahingot", + "const": "HAIL" + }, + { + "title": "wind damage", + "title_fi": "tuulivahingot", + "const": "WIND" + }, + { + "title": "drought", + "title_fi": "kuivuus", + "const": "DROUGHT" + }, + { + "title": "weather damage (generic)", + "title_fi": "yleiset säävahingot", + "const": "WEATHER" + }, + { + "title": "broad-leafed weeds", + "title_fi": "leveälehtiset rikkakasvit", + "const": "BRLFWD" + }, + { + "title": "weeds (generic)", + "title_fi": "yleiset rikkakasvit", + "const": "WEED" + }, + { + "title": "acidity (pH)", + "title_fi": "happamuus (pH)", + "const": "ACIDITY" + } + ] + }, + "chemical_applic_method": { + "allOf": [ + { + "title": "chemical application method", + "title_fi": "kemikaalinlevitystapa" + }, + { + "$ref": "#/$defs/fertilizer_applic_method" + } + ] + }, + "chemical_applic_amount": { + "title": "chemical amount (kg/ha)", + "title_fi": "kemikaalin määrä (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "chemical amount", + "unitless_title_fi": "kemikaalin määrä" + } + }, + "application_depth_chem": { + "title": "chemical application depth (cm)", + "title_fi": "kemikaalinlevityssyvyys (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "chemical application depth", + "unitless_title_fi": "kemikaalinlevityssyvyys" + } + }, + "application_ph_start" : { + "title" : "pH before the application", + "title_fi" : "pH ennen toimenpidettä", + "type": "number", + "minimum" : 0, + "maximum" : 14, + "x-ui": { + "condition": "input.chemical_type == 'chemical_type_lime_application'" + } + }, + "application_ph_end" : { + "title": "pH after the application", + "title_fi": "pH jälkeen toimenpiteen", + "type": "number", + "minimum" : 0, + "maximum" : 14, + "x-ui": { + "condition": "input.chemical_type == 'chemical_type_lime_application'" + } + }, + "mgmt_event_long_notes": { + "title": "chemical application notes", + "title_fi": "kemikaalinlevitysmuistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"rot affecting X % of plants\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"mätää X % kasveista\"" + } + } + }, + "required": [ + "date", + "chemical_type", + "chemical_product_name", + "chemical_applic_target" + ] + }, + { + "$id": "#grazing", + "title": "grazing", + "title_fi": "laidunnus", + "title_sv": "betning", + "properties": { + "mgmt_operations_event": { + "title": "grazing", + "title_fi": "laidunnus", + "title_sv": "betning", + "const": "grazing" + }, + "grazing_species": { + "title": "grazing species", + "title_fi": "laiduntava laji", + "title_sv": "betande art", + "type": "string", + "oneOf": [ + { + "title": "cattle", + "title_fi": "nautakarja", + "title_sv": "nötkreatur", + "const": "grazing_species_cattle" + }, + { + "title": "sheep", + "title_fi": "lampaat", + "const": "grazing_species_sheep" + }, + { + "title": "goats", + "title_fi": "vuohet", + "const": "grazing_species_goat" + }, + { + "title": "mix", + "title_fi": "useita", + "const": "grazing_species_mix" + }, + { + "title": "other", + "title_fi": "muu", + "const": "grazing_species_other" + } + ] + }, + "grazing_species_age_group": { + "title": "livestock age group (yr)", + "title_fi": "eläinten ikäryhmä (v)", + "type": "string", + "oneOf": [ + { + "title": "0-1", + "const": "0-1" + }, + { + "title": "1-2", + "const": "1-2" + }, + { + "title": "2-3", + "const": "2-3" + }, + { + "title": "3-5", + "const": "3-5" + }, + { + "title": "5-10", + "const": "5-10" + }, + { + "title": "10+", + "const": "10+" + }, + { + "title": "mix", + "title_fi": "useita", + "const": "grazing_species_age_group_mix" + } + ] + }, + "livestock_density": { + "title": "livestock density (number/ha)", + "title_fi": "eläinten tiheys (eläintä/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "ha⁻¹", + "unitless_title": "livestock density", + "unitless_title_fi": "eläinten tiheys" + } + }, + "grazing_intensity": { + "title": "grazing intensity (kg/ha)", + "title_fi": "laidunnusintensiteetti (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "grazing intensity", + "unitless_title_fi": "laidunnusintensiteetti" + } + }, + "date": { + "title": "start date", + "title_fi": "alkamispäivä", + "title_sv": "startdatum", + "type": "string", + "format": "date" + }, + "end_date": { + "title": "end date", + "title_fi": "päättymispäivä", + "title_sv": "slutdatum", + "type": "string", + "format": "date" + }, + "grazing_type": { + "title": "grazing type", + "title_fi": "laidunnuksen tyyppi", + "title_sv": "betstyp", + "type": "string", + "oneOf": [ + { + "title": "continuous", + "title_fi": "jatkuva", + "const": "grazing_type_continuous" + }, + { + "title": "rotation", + "title_fi": "lohkosyöttö", + "title_sv": "rotationsbetning", + "const": "grazing_type_rotation" + }, + { + "title": "mob grazing", + "title_fi": "intensiivinen lohkosyöttö", + "const": "grazing_type_mob_grazing" + }, + { + "title": "strip", + "title_fi": "kaistasyöttö", + "const": "grazing_type_strip" + }, + { + "title": "multi-species", + "title_fi": "sekalaidunnus", + "const": "grazing_type_multi_species" + }, + { + "title": "creep", + "title_fi": "nuoret eläimet paremmalle lohkolle (Creep?)", + "const": "grazing_type_creep" + }, + { + "title": "forward", + "title_fi": "kaksoislaidunnus", + "const": "grazing_type_forward" + }, + { + "title": "other", + "title_fi": "muu", + "const": "grazing_type_other" + } + ] + }, + "grazing_area": { + "title": "grazing area (ha)", + "title_fi": "laidunnettava ala (ha)", + "type": "number", + "minimum": 1, + "x-ui": { + "unit": "ha", + "unitless_title": "grazing area", + "unitless_title_fi": "laidunnettava ala" + } + }, + "grazing_material_removed_prop": { + "title": "proportion of material removed (%)", + "title_fi": "syödyn aineksen määrä (%)", + "type": "number", + "minimum": 0, + "maximum": 100, + "x-ui": { + "unit": "%", + "unitless_title": "proportion of material removed", + "unitless_title_fi": "syödyn aineksen määrä" + } + }, + "grazing_starting_height": { + "title": "starting height (cm)", + "title_fi": "aloituspituus (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "starting height", + "unitless_title_fi": "aloituspituus" + } + }, + "grazing_end_height": { + "title": "end height (cm)", + "title_fi": "lopetuspituus (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "end height", + "unitless_title_fi": "lopetuspituus" + } + }, + "mgmt_event_long_notes": { + "title": "grazing notes", + "title_fi": "laidunnusmuistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"animals were too late to the field\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"eläimet vietiin pellolle liian myöhään\"" + } + } + }, + "required": [ + "grazing_species", + "date", + "end_date" + ] + }, + { + "$id": "#weeding", + "title": "mechanical extraction of weeds", + "title_fi": "rikkaruohojen kitkeminen", + "title_sv": "rensning av ogräs", + "properties": { + "mgmt_operations_event": { + "title": "mechanical extraction of weeds", + "title_fi": "rikkaruohojen kitkeminen", + "title_sv": "rensning av ogräs", + "const": "weeding" + }, + "mgmt_event_long_notes": { + "title": "notes on the extraction of weeds", + "title_fi": "muistiinpanot rikkakasvien kitkemisestä", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"the weeds had very deep roots\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"rikkakasvien juuret olivat syvällä\"" + } + } + }, + "required": [ + "date" + ] + }, + { + "$id": "#irrigation", + "title": "irrigation", + "title2": "irrigation application", + "title_fi": "kastelu", + "title_sv": "bevattning", + "properties": { + "mgmt_operations_event": { + "title": "irrigation", + "title2": "irrigation application", + "title_fi": "kastelu", + "title_sv": "bevattning", + "const": "irrigation" + }, + "irrigation_operation": { + "title": "irrigation method", + "title_fi": "kastelujärjestelmä", + "type": "string", + "oneOf": [ + { + "title": "furrow", + "title_fi": "vakokastelu", + "const": "IR001" + }, + { + "title": "alternating furrows", + "title_fi": "vuorotteleva vakokastelu (alternating furrows?)", + "const": "IR002" + }, + { + "title": "flood", + "title_fi": "tulva", + "const": "IR003" + }, + { + "title": "sprinkler", + "title_fi": "sadetin", + "const": "IR004" + }, + { + "title": "drip or trickle", + "title_fi": "tihkukastelu", + "const": "IR005" + }, + { + "title": "subsurface (buried) drip", + "title_fi": "maanalainen tihkukastelu", + "const": "IR012" + } + ] + }, + "irrig_amount_depth": { + "title": "irrigation amount (depth, mm)", + "title_fi": "kastelun määrä (veden syvyys, mm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "mm", + "unitless_title": "irrigation amount", + "unitless_title_fi": "kastelun määrä" + } + }, + "irrigation_applic_depth": { + "title": "irrigation depth (cm)", + "title_fi": "kastelusyvyys (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "irrigation depth", + "unitless_title_fi": "kastelusyvyys" + } + }, + "mgmt_event_long_notes": { + "title": "irrigation notes", + "title_fi": "kastelumuistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"drip line flow rate seems a bit low\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"tippukasteluletkun virtausnopeus vaikuttaa melko hitaalta\"" + } + } + }, + "required": [ + "date", + "irrig_amount_depth" + ] + }, + { + "$id": "#mowing", + "title": "mowing", + "title_fi": "niitto", + "title2_fi": "ruohonleikkuu", + "title_sv": "gräsklippning", + "properties": { + "mgmt_operations_event": { + "title": "mowing", + "title_fi": "niitto", + "title2_fi": "ruohonleikkuu", + "title_sv": "gräsklippning", + "const": "mowing" + }, + "mowed_crop": { + "allOf": [ + { + "title": "mowed crop", + "title_fi": "leikattu kasvi" + }, + { + "$ref": "#/$defs/crop_ident_ICASA" + } + ] + }, + "mowed_area": { + "title": "mowed area (ha)", + "title_fi": "leikattu ala (ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "ha", + "unitless_title": "mowed area", + "unitless_title_fi": "leikattu ala" + } + }, + "mowing_canopy_height": { + "title": "canopy height before mowing (m)", + "title_fi": "kasvuston korkeus ennen leikkuuta (m)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m", + "unitless_title": "canopy height before mowing", + "unitless_title_fi": "kasvuston korkeus ennen leikkuuta" + } + }, + "mowing_cut_height": { + "title": "cut height (cm)", + "title_fi": "leikkuukorkeus (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "cut height", + "unitless_title_fi": "leikkuukorkeus" + } + }, + "mowing_method": { + "title": "mowing method", + "title_fi": "leikkuutapa", + "type": "string", + "oneOf": [ + { + "title": "rotary mower", + "title_fi": "pyöröleikkuri", + "const": "mowing_method_rotary" + }, + { + "title": "flail mower", + "title_fi": "kelamurskain", + "const": "mowing_method_flail" + }, + { + "title": "disc mower", + "title_fi": "lautasniittokone", + "const": "mowing_method_disc" + }, + { + "title": "sickle bar mower", + "title_fi": "sorminiittokone", + "const": "mowing_method_sickle_bar" + }, + { + "title": "other", + "title_fi": "muu", + "const": "mowing_method_other" + } + ] + }, + "mgmt_event_long_notes": { + "title": "mowing notes", + "title_fi": "muistiinpanot leikkuusta", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"mowing height was not uniform\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havaintoja, esim. \"leikkuukorkeus ei ollut sama kaikkialla\"" + } + } + }, + "required": [ + "date", + "mowed_crop" + ] + }, + { + "$id": "#observation", + "title": "observation", + "title_fi": "havainto", + "title_sv": "observation", + "properties": { + "mgmt_operations_event": { + "title": "observation", + "title_fi": "havainto", + "title_sv": "observation", + "const": "observation" + }, + "observation_type": { + "title": "observation type", + "title_fi": "havainnon tyyppi", + "type": "string", + "x-ui": { + "discriminator": true + } + }, + "mgmt_event_long_notes": { + "title": "observations", + "title_fi": "havainnot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput" + } + } + }, + "required": [ + "date", + "observation_type" + ], + "oneOf": [ + { + "title": "soil observation", + "title_fi": "maaperähavainto", + "properties": { + "observation_type": { + "title": "soil", + "title_fi": "maaperä", + "const": "observation_type_soil" + }, + "soil_layer_list": { + "type": "array", + "title": "soil layers", + "title_fi": "maakerrokset", + "items": { + "type": "object", + "properties": { + "soil_layer_top_depth": { + "type": "number", + "minimum": 0, + "title": "soil layer depth, top (cm)", + "title_fi": "kerroksen yläosan syvyys (cm)", + "x-ui": { + "unit": "cm", + "unitless_title": "soil layer depth, top", + "unitless_title_fi": "kerroksen yläosan syvyys" + } + }, + "soil_layer_base_depth": { + "type": "number", + "minimum": 0, + "title": "soil layer depth, bottom (cm)", + "title_fi": "kerroksen alaosan syvyys (cm)", + "x-ui": { + "unit": "cm", + "unitless_title": "soil layer depth, top", + "unitless_title_fi": "kerroksen yläosan syvyys" + } + }, + "soil_classification_by_layer": { + "type": "string", + "title": "soil structure (VESS or MARA score card)", + "title_fi": "maan rakenne (MARA-kortti)", + "description": "visual evaluation of soil structure (Ball et al. 2007, Franco et al. 2019)", + "oneOf": [ + { + "const": "soil_classification_1", + "title": "structure quality 1 friable", + "title_fi": "luokka 1 erittäin tiivis", + "title_sv": "klass 1 mycket kompakt" + }, + { + "const": "soil_classification_2", + "title": "structure quality 2 intact", + "title_fi": "luokka 2 tiivis", + "title_sv": "klass 2 kompakt" + }, + { + "const": "soil_classification_3", + "title": "structure quality 3 firm", + "title_fi": "luokka 3 kiinteä", + "title_sv": "klass 3 fast" + }, + { + "const": "soil_classification_4", + "title": "structure quality 4 compact", + "title_fi": "luokka 4 tiivistymätön", + "title_sv": "klass 4 opackad" + }, + { + "const": "soil_classification_5", + "title": "structure quality 5 very compact", + "title_fi": "luokka 5 mureneva", + "title_sv": "klass 5 lucker" + } + ] + }, + "soil_bulk_density_moist": { + "title": "bulk density (g/cm³)", + "title_fi": "irtotiheys (g/cm³)", + "x-ui": { + "unitless_title": "bulk density", + "unitless_title_fi": "irtotiheys", + "unit": "g/cm³" + }, + "type": "number", + "minimum": 0 + }, + "soil_water_wilting_pt": { + "title": "soil water content at wilting point (cm³/cm³)", + "title_fi": "nuutumispiste (cm³/cm³)", + "x-ui": { + "unitless_title": "soil water content at wilting point", + "unitless_title_fi": "nuutumispiste", + "unit": "cm³/cm³" + }, + "type": "number", + "minimum": 0 + }, + "soil_water_field_cap_1": { + "title": "soil water content at field capacity, 30 kPA (cm³/cm³)", + "title_fi": "kenttäkapasiteetti, 30 kPA (cm³/cm³)", + "x-ui": { + "unitless_title": "soil water content at field capacity, 30 kPA", + "unitless_title_fi": "kenttäkapasiteetti, 30 kPA", + "unit": "cm³/cm³" + }, + "type": "number", + "minimum": 0 + }, + "soil_water_saturated": { + "title": "soil water content at saturation (cm³/cm³)", + "title_fi": "kylläisyyspiste (cm³/cm³)", + "x-ui": { + "unitless_title": "soil water content at saturation", + "unitless_title_fi": "kylläisyyspiste", + "unit": "cm³/cm³" + }, + "type": "number", + "minimum": 0 + }, + "soil_silt_fraction": { + "title": "soil silt fraction (%)", + "title_fi": "maaperän lietteen osuus (%)", + "x-ui": { + "unitless_title": "soil silt fraction", + "unitless_title_fi": "maaperän lietteen osuus", + "unit": "%" + }, + "type": "number", + "minimum": 0 + }, + "soil_sand_fraction": { + "title": "soil sand fraction (%)", + "title_fi": "maaperän hiekan osuus (%)", + "x-ui": { + "unitless_title": "soil sand fraction", + "unitless_title_fi": "maaperän hiekan osuus", + "unit": "%" + }, + "type": "number", + "minimum": 0 + }, + "soil_clay_fraction": { + "title": "soil clay fraction (%)", + "title_fi": "maaperän saven osuus (%)", + "x-ui": { + "unitless_title": "soil clay fraction", + "unitless_title_fi": "maaperän saven osuus", + "unit": "%" + }, + "type": "number", + "minimum": 0 + }, + "soil_organic_matter_layer": { + "title": "total soil organic matter (kg/ha)", + "title_fi": "maaperän orgaaninen aines (kg/ha)", + "x-ui": { + "unitless_title": "total soil organic matter", + "unitless_title_fi": "maaperän orgaaninen aines", + "unit": "kg/ha" + }, + "type": "number", + "minimum": 0 + }, + "soil_organic_C_perc_layer": { + "title": "total soil organic carbon content (%)", + "title_fi": "orgaanisen hiilen osuus (%)", + "x-ui": { + "unitless_title": "total soil organic carbon content", + "unitless_title_fi": "orgaanisen hiilen osuus", + "unit": "%" + }, + "type": "number", + "minimum": 0 + } + } + } + }, + "root_depth": { + "title": "root depth (m)", + "title_fi": "juurten syvyys (m)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m", + "unitless_title": "root depth", + "unitless_title_fi": "juurten syvyys" + } + }, + "soil_compactification_depth": { + "title": "soil compactification depth (cm)", + "title_fi": "tiivistymän syvyys (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "soil compactification depth", + "unitless_title_fi": "tiivistymän syvyys" + } + }, + "earthworm_count": { + "title": "number of earthworms", + "title_fi": "lierojen lukumäärä", + "type": "integer", + "minimum": 0 + } + } + }, + { + "title": "vegetation observation", + "title_fi": "kasvillisuushavainto", + "properties": { + "observation_type": { + "title": "vegetation", + "title_fi": "kasvillisuus", + "const": "observation_type_vegetation" + }, + "growth_stage": { + "title": "plant growth stage", + "title_fi": "kasvuaste", + "type": "string", + "oneOf": [ + { + "title": "germination", + "title_fi": "itäminen", + "const": "growth_stage_germination" + }, + { + "title": "first pod", + "title_fi": "first pod -käännös", + "const": "growth_stage_first_pod" + }, + { + "title": "pegging", + "title_fi": "pegging-käännös", + "const": "growth_stage_pegging" + }, + { + "title": "budding", + "title_fi": "budding-käännös", + "const": "growth_stage_budding" + }, + { + "title": "blooming", + "title_fi": "blooming-käännös", + "const": "growth_stage_blooming" + }, + { + "title": "seeding", + "title_fi": "seeding-käännös", + "const": "growth_stage_seeding" + }, + { + "title": "maturity", + "title_fi": "maturity-käännös", + "const": "growth_stage_maturity" + } + ] + }, + "plant_density": { + "title": "plant density (plants/m²)", + "title_fi": "kasvitiheys (kasveja/m²)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m⁻²", + "unitless_title": "plant density", + "unitless_title_fi": "kasvitiheys" + } + }, + "specific_leaf_area": { + "title": "specific leaf area (cm²/g)", + "title_fi": "ominaislehtiala (cm²/g)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm²/g", + "unitless_title": "specific leaf area", + "unitless_title_fi": "ominaislehtiala" + } + }, + "leaf_area_index": { + "title": "leaf area index (m²/m²)", + "title_fi": "lehtialaindeksi (m²/m²)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m²/m²", + "unitless_title": "leaf area index", + "unitless_title_fi": "lehtialaindeksi" + } + }, + "total_biomass_dw": { + "title": "total biomass, dry weight (kg/ha)", + "title_fi": "kokonaisbiomassa, kuivapaino (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "total biomass, dry weight", + "unitless_title_fi": "kokonaisbiomassa, kuivapaino" + } + }, + "tops_C": { + "title": "carbon (C) in aboveground biomass (kg/ha)", + "title_fi": "hiilen määrä (C) biomassassa maanpinnalla (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "carbon (C) in aboveground biomass", + "unitless_title_fi": "hiilen määrä (C) biomassa maanpinnalla" + } + }, + "tops_C_std": { + "title": "standard deviation of carbon (C) in aboveground biomass (meas.) (kg/ha)", + "title_fi": "maanpäällisen biomassan C (mittausten) keskihajonta (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "standard deviation of carbon (C) in aboveground biomass (meas.)", + "unitless_title_fi": "maanpäällisen biomassan hiilen (C) mittausten keskihajonta" + } + }, + "roots_C": { + "title": "carbon (C) in belowground biomass (kg/ha)", + "title_fi": "hiilen määrä (C) biomassassa maanpinnan alapuolella (kg[C]/ha):", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "carbon (C) in belowground biomass", + "unitless_title_fi": "hiilen määrä (C) biomassassa maanpinnan alapuolella" + } + }, + "roots_C_std": { + "title": "standard deviation of carbon (C) in belowground biomass (kg/ha)", + "title_fi": "maanalaisen hiilibiomassan hiilen (C) mittausten keskihajonta: (kg/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/ha", + "unitless_title": "standard deviation of belowground biomass C (meas.)", + "unitless_title_fi": "maanalaisen hiilibiomassan C (mittausten) keskihajonta" + } + }, + "canopy_height": { + "title": "canopy height (m)", + "title_fi": "latvuston korkeus (m)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "m", + "unitless_title": "canopy height", + "unitless_title_fi": "latvuston korkeus" + } + }, + "canopeo_reading": { + "title": "canopeo reading", + "title_fi": "canopeo-lukema", + "type": "number", + "minimum": 0 + } + } + }, + { + "title": "water observation", + "title_fi": "vesihavainto", + "properties": { + "observation_type": { + "title": "water observation", + "title_fi": "vesihavainto", + "const": "observation_type_water" + }, + "floodwater_depth": { + "title": "floodwater depth (mm)", + "title_fi": "tulvaveden syvyys (mm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "mm", + "unitless_title": "floodwater depth", + "unitless_title_fi": "tulvaveden syvyys" + } + }, + "water_table_depth": { + "title": "water table level (cm)", + "title_fi": "pohjaveden pinnan syvyys (cm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "cm", + "unitless_title": "water table level", + "unitless_title_fi": "pohjaveden pinnan syvyys" + } + } + } + }, + { + "title": "animals", + "title_fi": "eläimet", + "properties": { + "observation_type": { + "title": "animals", + "title_fi": "eläimet", + "const": "observation_type_animals" + } + } + }, + { + "title": "pests", + "title_fi": "tuholaiset", + "properties": { + "observation_type": { + "title": "pests", + "title_fi": "tuholaiset", + "const": "observation_type_pests" + }, + "plant_pop_reduct_cum": { + "title": "amount of plants eaten (%, cumulative)", + "title_fi": "syötyjen kasvien määrä (%, kumulatiivinen)", + "type": "number", + "minimum": 0, + "maximum": 0, + "x-ui": { + "unit": "%", + "unitless_title": "amount of plants eaten", + "unitless_title_fi": "syötyjen kasvien määrä" + } + } + } + }, + { + "title": "disturbance", + "title_fi": "häiriö", + "properties": { + "observation_type": { + "title": "disturbance", + "title_fi": "häiriö", + "const": "observation_type_disturbance" + } + } + }, + { + "title": "management", + "title_fi": "tilanhoito", + "properties": { + "observation_type": { + "title": "management", + "title_fi": "tilanhoito", + "const": "observation_type_management" + }, + "fuel_amount": { + "title": "fuel used (liters/ha)", + "title_fi": "käytetty polttoaine (litraa/ha)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "L/ha", + "unitless_title": "fuel used", + "unitless_title_fi": "käytetty polttoaine" + } + } + } + }, + { + "title": "other", + "title_fi": "muu", + "properties": { + "observation_type": { + "title": "other", + "title_fi": "muu", + "const": "observation_type_other" + } + } + } + ] + }, + { + "$id": "#bed_prep", + "title": "raised bed preparation", + "title_fi": "kasvatuslaatikoiden valmistelu", + "title2_fi": "kohopenkki", + "title_sv": "upphöjd odlingsbädd", + "properties": { + "mgmt_operations_event": { + "title": "raised bed preparation", + "title_fi": "kasvatuslaatikoiden valmistelu", + "title2_fi": "kohopenkki", + "title_sv": "upphöjd odlingsbädd", + "const": "bed_prep" + }, + "mgmt_event_long_notes": { + "title": "notes on the preparation of raised beds", + "title_fi": "muistiinpanot kasvatuslaatikoiden valmistelusta", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"used the beds from last year\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"käytettiin samoja kasvatuslaatikoita kuin edellisenä vuonna\"" + } + } + }, + "required": [ + "date" + ] + }, + { + "$id": "#inorg_mulch", + "title": "placement of mulch", + "title2": "placement of inorganic mulch", + "title_fi": "katteen levitys", + "title_sv": "applicering av oorganisk kompost", + "properties": { + "mgmt_operations_event": { + "title": "placement of mulch", + "title2": "placement of inorganic mulch", + "title_fi": "katteen levitys", + "title_sv": "applicering av oorganisk kompost", + "const": "inorg_mulch" + }, + "mulch_type": { + "allOf": [ + { + "title": "mulch type", + "title_fi": "katteen tyyppi" + }, + { + "$ref": "#/$defs/mulch_type" + } + ] + }, + "mulch_thickness": { + "title": "mulch thickness (mm)", + "title_fi": "katteen paksuus (mm)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "mm", + "unitless_title": "mulch thickness", + "unitless_title_fi": "katteen paksuus" + } + }, + "mulch_cover_fraction": { + "title": "fraction of surface covered (%)", + "title_fi": "peitto-osuus (%)", + "type": "number", + "minimum": 0, + "maximum": 100, + "x-ui": { + "unit": "%", + "unitless_title": "fraction of surface covered", + "unitless_title_fi": "peitto-osuus" + } + }, + "mulch_color": { + "title": "mulch colour", + "title_fi": "katteen väri", + "type": "string", + "oneOf": [ + { + "title": "transparent", + "title_fi": "läpinäkyvä", + "const": "MC001" + }, + { + "title": "white", + "title_fi": "valkoinen", + "const": "MC002" + }, + { + "title": "black", + "title_fi": "musta", + "const": "MC003" + }, + { + "title": "brown", + "title_fi": "ruskea", + "const": "MC004" + }, + { + "title": "grey", + "title_fi": "harmaa", + "const": "MC005" + }, + { + "title": "light straw color", + "title_fi": "olki", + "const": "MC006" + } + ] + }, + "mgmt_event_long_notes": { + "title": "mulch placement notes", + "title_fi": "katteenlevitysmuistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"mulch was placed only on the northern half of the field\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"kate levitettiin ainoastaan pellon pohjoiselle puoliskolle\"" + } + } + }, + "required": [ + "date", + "mulch_type" + ] + }, + { + "$id": "#Inorg_mul_rem", + "title": "removal of mulch", + "title2": "removal of inorganic mulch", + "title_fi": "katteen poisto", + "title_sv": "borttagning av oorganisk kompost", + "properties": { + "mgmt_operations_event": { + "title": "removal of mulch", + "title2": "removal of inorganic mulch", + "title_fi": "katteen poisto", + "title_sv": "borttagning av oorganisk kompost", + "const": "Inorg_mul_rem" + }, + "mulch_type_remove": { + "allOf": [ + { + "title": "type of removed mulch", + "title_fi": "poistetun katteen tyyppi" + }, + { + "$ref": "#/$defs/mulch_type" + } + ] + }, + "mgmt_event_long_notes": { + "title": "mulch removal notes", + "title_fi": "katteenpoistomuistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput", + "form-placeholder": "any notes or observations about the event, e.g. \"the mulch was recycled\"", + "form-placeholder_fi": "mitä tahansa tapahtumaan liittyviä muistiinpanoja tai havintoja, esim. \"kate kierrätettiin\"" + } + } + }, + "required": [ + "date", + "mulch_type_remove" + ] + }, + { + "$id": "#measurement", + "title": "measurement", + "title_fi": "mittaus", + "properties": { + "mgmt_operations_event": { + "title": "measurement", + "title_fi": "mittaus", + "const": "measurement" + }, + "carbon_soil_tot": { + "title": "average carbon in 1 m soil column (kg/m²)", + "title_fi": "hiiltä keskimäärin 1 m maakolonnissa (kg/m²)", + "title_sv": "kol i medeltal i 1 m markpelare (kg/m²)", + "type": "number", + "minimum": 0, + "x-ui": { + "unit": "kg/m²", + "unitless_title": "average carbon in 1 m soil column", + "unitless_title_fi": "hiiltä keskimäärin 1 m maakolonnissa", + "unitless_title_sv": "kol i medeltal i 1 m markpelare" + } + }, + "carbon_soil_tot_sd": { + "title": "standard deviation", + "title_fi": "keskihajonta", + "title_sv": "standardavvikelse", + "type": "number", + "minimum": 0 + } + } + }, + { + "$id": "#other", + "title": "other", + "title2": "other management event", + "title_fi": "muu", + "title2_fi": "muu toimenpide", + "title_sv": "annan åtgärd", + "properties": { + "mgmt_operations_event": { + "title": "other", + "title2": "other management event", + "title_fi": "muu", + "title2_fi": "muu toimenpide", + "title_sv": "annan åtgärd", + "const": "other" + }, + "mgmt_event_long_notes": { + "title": "notes", + "title_fi": "muistiinpanot", + "type": "string", + "x-ui": { + "form-type": "textAreaInput" + } + } + }, + "required": [ + "date", + "mgmt_event_long_notes" + ] + } + ], + "$defs": { + "crop_ident_ICASA": { + "type": "string", + "oneOf": [ + { + "title": "timothy (Phleum pratense)", + "title_fi": "timotei (Phleum pratense)", + "title_sv": "timotej (Phleum pratense)", + "const": "FRG" + }, + { + "title": "wheat (Triticum spp.)", + "title_fi": "vehnä (Triticum spp.)", + "title_sv": "vete (Triticum spp.)", + "const": "WHT" + }, + { + "title": "oats (Avena sativa)", + "title_fi": "kaura (Avena sativa)", + "title_sv": "havre (Avena sativa)", + "const": "OAT" + }, + { + "title": "rye (Secale cereale)", + "title_fi": "ruis (Secale cereale)", + "const": "RYE" + }, + { + "title": "barley (Hordeum vulgare)", + "title_fi": "ohra (Hordeum vulgare)", + "title_sv": "korn (Hordeum vulgare)", + "const": "BAR" + }, + { + "title": "Triticale (x Triticosecale)", + "title_fi": "ruisvehnä (x Triticosecale)", + "const": "TRT" + }, + { + "title": "Emmer wheat (Triticum dicoccon)", + "title_fi": "Emmervehnä (Triticum dicoccon)", + "const": "EMW" + }, + { + "title": "mixed grain", + "title_fi": "seosvilja", + "const": "ZZ1" + }, + { + "title": "Mixed grass", + "title_fi": "Seosruoho", + "const": "ZZ3" + }, + { + "title": "buckwheat (Fagopyrum esculentum)", + "title_fi": "tattari (Fagopyrum esculentum)", + "const": "BWH" + }, + { + "title": "potato (Solanum tuberosum)", + "title_fi": "peruna (Solanum tuberosum)", + "const": "POT" + }, + { + "title": "sugar beet (Beta vulgaris var. altissima)", + "title_fi": "sokerijuurikas (Beta vulgaris var. altissima)", + "const": "SBT" + }, + { + "title": "pea (Pisum sativum)", + "title_fi": "herne (Pisum sativum)", + "const": "PEA" + }, + { + "title": "faba bean (Vicia faba)", + "title_fi": "härkäpapu (Vicia faba)", + "const": "FBN" + }, + { + "title": "hemp seed oil (Finola)", + "title_fi": "Öljyhamppu (Finola)", + "const": "FHSO" + }, + { + "title": "turnip rape (Brassica rapa subsp. oleifera)", + "title_fi": "rypsi (Brassica rapa subsp. oleifera)", + "const": "RYP" + }, + { + "title": "rapeseed (Brassica napus subsp. napus)", + "title_fi": "rapsi (Brassica napus subsp. napus)", + "const": "RAP" + }, + { + "title": "flax (Linum usitatissimum)", + "title_fi": "pellava (Linum usitatissimum)", + "const": "FLX" + }, + { + "title": "caraway (Carum carvi)", + "title_fi": "kumina (Carum carvi)", + "const": "CCA" + }, + { + "title": "reed canary grass (Phalaris arundinacea)", + "title_fi": "ruokohelpi (Phalaris arundinacea)", + "const": "PHA" + }, + { + "title": "red clover (Trifolium pratense)", + "title_fi": "puna-apila (Trifolium pratense)", + "const": "RCL" + }, + { + "title": "white clover (Trifolium repens)", + "title_fi": "valkoapila (Trifolium repens)", + "const": "WCL" + }, + { + "title": "white sweetclover (Melilotus albus)", + "title_fi": "valkomesikkä (Melilotus albus)", + "const": "WSC" + }, + { + "title": "bird's-foot trefoil (Lotus corniculatus)", + "title_fi": "keltamaite (Lotus corniculatus)", + "const": "BFT" + }, + { + "title": "crimson glover (Trifolium incarnatum)", + "title_fi": "veriapila (Trifolium incarnatum)", + "const": "CRC" + }, + { + "title": "alsike clover (Trifolium hybridum)", + "title_fi": "alsikeapila (Trifolium hybridum)", + "const": "ACL" + }, + { + "title": "Aleksandria clover (Trifolium Alexandrinum L)", + "title_fi": "Aleksandrian apila (Trifolium Alexandrinum L)", + "const": "ALC" + }, + { + "title": "alfalfa (Medicago sativa)", + "title_fi": "sinimailanen (Medicago sativa)", + "const": "ALF" + }, + { + "title": "oilseed radish (Raphanus sativus var. oleiformis)", + "title_fi": "öljyretikka (Raphanus sativus var. oleiformis)", + "const": "RSO" + }, + { + "title": "(Tillage) radish (Raphanus sativus)", + "title_fi": "muokkausretikka (Raphanus sativus)", + "const": "RAD" + }, + { + "title": "common vetch (Vicia sativa)", + "title_fi": "rehuvirna (Vicia sativa)", + "const": "VSA" + }, + { + "title": "smooth brome (Bromus inermis)", + "title_fi": "rehukattara (Bromus inermis)", + "const": "BRI" + }, + { + "title": "meadow fescue (Festuca pratensis)", + "title_fi": "nurminata (Festuca pratensis)", + "title_sv": "ängssvingel (Festuca pratensis)", + "const": "FEP" + }, + { + "title": "Camelina (Camelina sativa)", + "title_fi": "ruistankio (Camelina sativa)", + "const": "CAM" + }, + { + "title": "cat grass (Dactylis glomerata)", + "title_fi": "koiranheinä (Dactylis glomerata)", + "const": "CAG" + }, + { + "title": "sickle medic (Medicago falcata)", + "title_fi": "rehumailanen (Medicago falcata)", + "const": "SIM" + }, + { + "title": "perennial ryegrass (Lolium perenne)", + "title_fi": "englanninraiheinä (Lolium perenne)", + "const": "RGP" + }, + { + "title": "kentucky bluegrass (Poa pratensis)", + "title_fi": "niittynurmikka (Poa pratensis)", + "const": "POA" + }, + { + "title": "sudan grass (Sorghum × drummondii)", + "title_fi": "sudaninruoho (Sorghum × drummondii)", + "const": "SDR" + }, + { + "title": "spelt (Triticum spelta)", + "title_fi": "speltti (Triticum spelta)", + "const": "SPE" + }, + { + "title": "sunflower (Helianthus annuus)", + "title_fi": "auringonkukka (Helianthus annuus)", + "const": "SUN" + }, + { + "title": "annual ryegrass (Festuca perennis / Lolium multiflorum)", + "title_fi": "italianraiheinä (Festuca perennis / Lolium multiflorum)", + "const": "RGA" + }, + { + "title": "tall fescue (Festuca arundinacea / Schedonorus arundinaceus)", + "title_fi": "ruokonata (Festuca arundinacea / Schedonorus arundinaceus)", + "const": "TFS" + }, + { + "title": "hairy vetch (Vicia villosa)", + "title_fi": "ruisvirna (Vicia villosa)", + "const": "HVT" + }, + { + "title": "persian clover (Trifolium resupinatum var. majus)", + "title_fi": "persianapila (Trifolium resupinatum var. majus)", + "const": "TRM" + }, + { + "title": "hybrid fescue (x Festulolium loliaceum)", + "title_fi": "rainata (x Festulolium loliaceum)", + "const": "XFL" + }, + { + "title": "common chicory (Cichorium intybus)", + "title_fi": "sikuri (Cichorium intybus)", + "const": "CII" + }, + { + "title": "lacy phacelia (Phacelia tanacetifolia)", + "title_fi": "aitohunajakukka (Phacelia tanacetifolia)", + "const": "PHT" + } + ] + }, + "fertilizer_applic_method": { + "type": "string", + "oneOf": [ + { + "title": "broadcast, not incorporated", + "title_fi": "levitetty pinnalle, ei sekoitettu", + "const": "AP001" + }, + { + "title": "broadcast, incorporated", + "title_fi": "levitetty ja sekoitettu", + "const": "AP002" + }, + { + "title": "banded on surface", + "title_fi": "nauhoina pinnalla", + "const": "AP003" + }, + { + "title": "banded beneath surface", + "title_fi": "sijoituslannoitus", + "const": "AP004" + }, + { + "title": "applied in irrigation water", + "title_fi": "kasteluveden mukana", + "const": "AP005" + }, + { + "title": "foliar spray", + "title_fi": "suihkutettu lehdelle", + "const": "AP006" + }, + { + "title": "bottom of hole", + "title_fi": "bottom of hole -käännös", + "const": "AP007" + }, + { + "title": "on the seed", + "title_fi": "siemenen pinnassa", + "const": "AP008" + }, + { + "title": "injected", + "title_fi": "ruiskutettu pinnan alle", + "const": "AP009" + } + ] + }, + "mulch_type": { + "type": "string", + "oneOf": [ + { + "title": "polyethylene sheet - solid", + "title_fi": "katemuovi (PE)", + "const": "MT001" + }, + { + "title": "polyethylene sheet - perforated", + "title_fi": "rei'itetty katemuovi (PE)", + "const": "MT002" + }, + { + "title": "landscape fabric", + "title_fi": "maisemointikangas", + "const": "MT003" + }, + { + "title": "paper", + "title_fi": "paperi", + "const": "MT004" + }, + { + "title": "grass clippings", + "title_fi": "leikattu ruoho", + "const": "MT005" + }, + { + "title": "pine needles", + "title_fi": "männynneulaset", + "const": "MT006" + }, + { + "title": "straw", + "title_fi": "olki", + "const": "MT007" + }, + { + "title": "foil", + "title_fi": "folio (foil?)", + "const": "MT008" + }, + { + "title": "foil coated plastic", + "title_fi": "muovipäällysteinen folio (foil coated with plastic?)", + "const": "MT009" + }, + { + "title": "photodegradable plastic", + "title_fi": "valohajoava muovi", + "const": "MT010" + } + ] + } + }, + "required": [ + "mgmt_operations_event" + ] +} \ No newline at end of file diff --git a/inst/extdata/ui_structure.json b/inst/extdata/ui_structure.json index 58adbb6..4dc6625 100644 --- a/inst/extdata/ui_structure.json +++ b/inst/extdata/ui_structure.json @@ -125,1252 +125,6 @@ "required": true }, - "mgmt_operations_event": { - "code_name": "mgmt_operations_event", - "type" : "selectInput", - "label" : "mgmt_operations_event_label", - "choices": "mgmt_operations_event_choice", - "required" : true, - "sub_elements": { - - "planting" : { - "condition" : "input.mgmt_operations_event == 'planting'", - - "planted_crop" : { - "code_name" : "planted_crop", - "type" : "selectInput", - "choices" : "CRID", - "label" : "planted_crop_label", - "multiple" : true, - "required" : true, - "sub_elements" : { - - "multiple" : { - "condition" : "input.planted_crop.length > 1", - - "planted_crop_table" : { - "code_name" : "planted_crop_table", - "type" : "dataTable", - "columns" : ["planting_material_weight", "planting_depth", - "planting_material_source"], - "rows" : { - "crops" : { - "row_variable" : "planted_crop", - "type" : "dynamic" - } - } - } - }, - - "single" : { - "condition" : "input.planted_crop.length <= 1", - - "planting_material_weight" : { - "code_name" : "planting_material_weight", - "type" : "numericInput", - "min" : 0, - "label" : "planting_material_weight_label" - }, - - "planting_depth" : { - "code_name" : "planting_depth", - "type" : "numericInput", - "min" : 0, - "label" : "planting_depth_label" - }, - - "planting_material_source" : { - "code_name" : "planting_material_source", - "type" : "textInput", - "label" : "planting_material_source_label", - "placeholder" : "planting_material_source_placeholder" - } - - } - } - }, - - "planting_notes" : { - "code_name" : "planting_notes", - "type" : "textAreaInput", - "label" : "planting_notes_label", - "placeholder" : "planting_notes_placeholder" - } - }, - - "harvest": { - "condition": "input.mgmt_operations_event == 'harvest'", - - "harvest_area" : { - "code_name" : "harvest_area", - "type" : "numericInput", - "label" : "harvest_area_label", - "min" : 0 - //"required" : true - }, - - "harvest_crop" : { - "code_name" : "harvest_crop", - "type" : "selectInput", - "choices" : "CRID", - "label" : "harvest_crop_label", - "multiple" : true, - "required" : true, - "sub_elements" : { - - "multiple" : { - "condition" : "input.harvest_crop.length > 1", - - "harvest_crop_table" : { - "code_name" : "harvest_crop_table", - "type" : "dataTable", - "columns" : ["harvest_yield_harvest_dw", - "harv_yield_harv_f_wt", "yield_C_at_harvest", - "harvest_moisture", "harvest_method", - "harvest_operat_component", "canopy_height_harvest", - "harvest_cut_height", "plant_density_harvest", - "harvest_residue_placement"], - "rows" : { - "crops" : { - "row_variable" : "harvest_crop", - "type" : "dynamic" - }, - - "total" : { - "variables" : ["harvest_yield_harvest_dw_total", - "harv_yield_harv_f_wt_total", - "yield_C_at_harvest_total"], - "type" : "static", - "name" : "total_row_name", - "hide_labels" : true - } - } - } - - }, - - "single" : { - "condition" : "input.harvest_crop.length <= 1", - - "harvest_yield_harvest_dw_total" : { - "code_name" : "harvest_yield_harvest_dw_total", - "type" : "numericInput", - "label" : "harvest_yield_harvest_dw_total_label", - "min" : 0, - "sum_of" : "harvest_yield_harvest_dw" - //"required" : true - }, - - "harv_yield_harv_f_wt_total" : { - "code_name" : "harv_yield_harv_f_wt_total", - "type" : "numericInput", - "label" : "harv_yield_harv_f_wt_total_label", - "min" : 0, - "sum_of" : "harv_yield_harv_f_wt" - }, - - "yield_C_at_harvest_total" : { - "code_name" : "yield_C_at_harvest_total", - "type" : "numericInput", - "label" : "yield_C_at_harvest_total_label", - "min" : 0, - "sum_of" : "yield_C_at_harvest" - }, - - "harvest_moisture" : { - "code_name" : "harvest_moisture", - "type" : "numericInput", - "label" : "harvest_moisture_label", - "min" : 0, - "max" : 100 - }, - - "harvest_method" : { - "code_name" : "harvest_method", - "type" : "selectInput", - "label" : "harvest_method_label", - "choices" : "HARM" - }, - - "harvest_operat_component" : { - "code_name" : "harvest_operat_component", - "type" : "selectInput", - "choices" : "HACOM", - "label" : "harvest_operat_component_label", - "hide_in_event_list" : true - }, - - "canopy_height_harvest" : { - "code_name" : "canopy_height_harvest", - "type" : "numericInput", - "label" : "canopy_height_harvest_label", - "min" : 0 - }, - - "harvest_cut_height" : { - "code_name" : "harvest_cut_height", - "type" : "numericInput", - "label" : "harvest_cut_height_label", - "min" : 0 - }, - - "plant_density_harvest" : { - "code_name" : "plant_density_harvest", - "type" : "numericInput", - "label" : "plant_density_harvest_label", - "min" : 0 - }, - - "harvest_residue_placement" : { - "code_name" : "harvest_residue_placement", - "type" : "selectInput", - "label" : "harvest_residue_placement_label", - "choices" : "harvest_residue_placement_choice" - } - }, - - "hidden" : { - - "condition" : "false", - - "harvest_yield_harvest_dw" : { - "code_name" : "harvest_yield_harvest_dw", - "type" : "numericInput", - "label" : "harvest_yield_harvest_dw_label", - "min" : 0, - "hide_in_event_list" : true, - "sum_to" : "harvest_yield_harvest_dw_total" - }, - - "harv_yield_harv_f_wt" : { - "code_name" : "harv_yield_harv_f_wt", - "type" : "numericInput", - "label" : "harv_yield_harv_f_wt_label", - "min" : 0, - "hide_in_event_list" : true, - "sum_to" : "harv_yield_harv_f_wt_total" - }, - - "yield_C_at_harvest" : { - "code_name" : "yield_C_at_harvest", - "type" : "numericInput", - "label" : "yield_C_at_harvest_label", - "min" : 0, - "hide_in_event_list" : true, - "sum_to" : "yield_C_at_harvest_total" - } - - } - } - }, - - "harvest_residue_help_text" : { - "code_name" : "harvest_residue_help_text", - "type" : "textOutput" - }, - - "harvest_comments" : { - "code_name" : "harvest_comments", - "type" : "textAreaInput", - "label" : "harvest_comments_label", - "placeholder" : "harvest_comments_placeholder", - "hide_in_event_list" : true - } - - }, - - "tillage" : { - "condition" : "input.mgmt_operations_event == 'tillage'", - - "tillage_practice" : { - "code_name" : "tillage_practice", - "type" : "selectInput", - "label" : "tillage_practice_label", - "choices" : "tillage_practice_choice", - "required" : true - }, - - "tillage_implement" : { - "code_name" : "tillage_implement", - "type" : "selectInput", - "label" : "tillage_implement_label", - "choices" : "TIIMP" - }, - - "tillage_operations_depth" : { - "code_name" : "tillage_operations_depth", - "type" : "numericInput", - "label" : "tillage_operations_depth_label", - "min" : 0 - }, - - "tillage_treatment_notes" : { - "code_name" : "tillage_treatment_notes", - "type" : "textAreaInput", - "label" : "tillage_treatment_notes_label", - "placeholder" : "tillage_treatment_notes_placeholder" - } - }, - - "fertilizer" : { - "condition" : "input.mgmt_operations_event == 'fertilizer'", - - "fertilizer_type" : { - "code_name" : "fertilizer_type", - "type" : "selectInput", - "label" : "fertilizer_type_label", - "choices" : "fertilizer_type_choice", - "required" : true, - "sub_elements" : { - "organic" : { - "condition" : "input.fertilizer_type == 'fertilizer_type_organic'", - - "organic_material" : { - "code_name" : "organic_material", - "type" : "selectInput", - "label" : "organic_material_label", - "choices" : "OMCD" - }, - - "fert_animal" : { - "condition" : "input.organic_material == 'RE003' | input.organic_material == 'RE004'", - - "animal_fert_usage" : { - "code_name" : "animal_fert_usage", - "type" : "textInput", - "label" : "animal_fert_usage_label", - "placeholder" : "animal_fert_usage_placeholder" - } - }, - - "org_matter_moisture_conc" : { - "code_name" : "org_matter_moisture_conc", - "type" : "numericInput", - "label" : "org_matter_moisture_conc_label", - "min" : 0, - "max" : 100 - }, - - "org_matter_carbon_conc" : { - "code_name" : "org_matter_carbon_conc", - "type": "numericInput", - "label" : "org_matter_carbon_conc_label", - "min" : 0, - "max" : 100 - } - }, - - "mineral" : { - "condition" : "input.fertilizer_type == 'fertilizer_type_mineral'", - - "fertilizer_product_name" : { - "code_name" : "fertilizer_product_name", - "type" : "textInput", - "label" : "fertilizer_product_name_label" - } - - }, - - "soil_amendment" : { - "condition" : "input.fertilizer_type == 'fertilizer_type_soil_amendment'", - - "fertilizer_material" : { - "code_name" : "fertilizer_material", - "type" : "selectInput", - "label" : "fertilizer_material_label", - "choices" : "FECD" - } - }, - - "organic_or_soil_amendment" : { - "condition" : "input.fertilizer_type == 'fertilizer_type_organic' | input.fertilizer_type == 'fertilizer_type_soil_amendment'", - - "fertilizer_material_source" : { - "code_name" : "fertilizer_material_source", - "type" : "textInput", - "label" : "fertilizer_material_source_label", - "placeholder" : "fertilizer_material_source_placeholder" - } - } - } - }, - - "fertilizer_applic_method" : { - "code_name" : "fertilizer_applic_method", - "type" : "selectInput", - "choices" : "FEACD", - "label" : "fertilizer_applic_method_label" - }, - - "application_depth_fert" : { - "code_name" : "application_depth_fert", - "type" : "numericInput", - "label" : "application_depth_fert_label", - "min" : 0 - }, - - "fertilizer_total_amount" : { - "code_name" : "fertilizer_total_amount", - "type" : "numericInput", - "label" : "fertilizer_total_amount_label", - "min" : 0, - "required" : true - }, - - "fertilizer_element_table_title" : { - "code_name" : "fertilizer_element_table_title", - "type" : "textOutput", - "style" : "label" - }, - - "fertilizer_element_table" : { - "code_name" : "fertilizer_element_table", - "type" : "dataTable", - "rows" : { - - "row1" : { - "variables" : ["N_in_applied_fertilizer", "N_in_soluble_fertilizer", - "phosphorus_applied_fert", "fertilizer_K_applied", - "S_in_applied_fertilizer", "Ca_in_applied_fertilizer", - "Mg_in_applied_fertilizer", "Na_in_applied_fertilizer"], - "type" : "static" - }, - - "row2" : { - "variables" : ["Cu_in_applied_fertilizer", - "Zn_in_applied_fertilizer", "B_in_applied_fertilizer", - "Mn_in_applied_fertilizer", "Se_in_applied_fertilizer", - "Fe_in_applied_fertilizer", - "other_element_in_applied_fertilizer"], - "type" : "static" - } - - } - - }, - - "hidden" : { - "condition" : "false", - - "N_in_applied_fertilizer" : { - "code_name" : "N_in_applied_fertilizer", - "type" : "numericInput", - "label" : "N_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "N_in_soluble_fertilizer" : { - "code_name" : "N_in_soluble_fertilizer", - "type" : "numericInput", - "label" : "N_in_soluble_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "phosphorus_applied_fert" : { - "code_name" : "phosphorus_applied_fert", - "type" : "numericInput", - "label" : "phosphorus_applied_fert_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "fertilizer_K_applied" : { - "code_name" : "fertilizer_K_applied", - "type" : "numericInput", - "label" : "fertilizer_K_applied_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "S_in_applied_fertilizer" : { - "code_name" : "S_in_applied_fertilizer", - "type" : "numericInput", - "label" : "S_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Ca_in_applied_fertilizer" : { - "code_name" : "Ca_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Ca_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Mg_in_applied_fertilizer" : { - "code_name" : "Mg_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Mg_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Na_in_applied_fertilizer" : { - "code_name" : "Na_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Na_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Cu_in_applied_fertilizer" : { - "code_name" : "Cu_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Cu_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Zn_in_applied_fertilizer" : { - "code_name" : "Zn_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Zn_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "B_in_applied_fertilizer" : { - "code_name" : "B_in_applied_fertilizer", - "type" : "numericInput", - "label" : "B_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Mn_in_applied_fertilizer" : { - "code_name" : "Mn_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Mn_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Se_in_applied_fertilizer" : { - "code_name" : "Se_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Se_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "Fe_in_applied_fertilizer" : { - "code_name" : "Fe_in_applied_fertilizer", - "type" : "numericInput", - "label" : "Fe_in_applied_fertilizer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "other_element_in_applied_fertilizer" : { - "code_name" : "other_element_in_applied_fertilizer", - "type" : "textInput", - "label" : "other_element_in_applied_fertilizer_label", - "hide_in_event_list" : true - } - - }, - - "fertilizer_notes" : { - "code_name" : "fertilizer_notes", - "type" : "textAreaInput", - "label" : "fertilizer_notes_label", - "placeholder" : "fertilizer_notes_placeholder" - } - - }, - - "grazing" : { - "condition" : "input.mgmt_operations_event == 'grazing'", - - "grazing_species" : { - "code_name" : "grazing_species", - "type" : "selectInput", - "label" : "grazing_species_label", - "choices" : "grazing_species_choice", - "required" : true - }, - - "grazing_species_age_group" : { - "code_name" : "grazing_species_age_group", - "type" : "selectInput", - "label" : "grazing_species_age_group_label", - "choices" : ["0-1","1-2","2-3","3-5","5-10","10+", - "grazing_species_age_group_mix"] - }, - - "livestock_density" : { - "code_name" : "livestock_density", - "type" : "numericInput", - "label" : "livestock_density_label", - "min" : 0 - }, - - "grazing_intensity" : { - "code_name" : "grazing_intensity", - "type" : "numericInput", - "label" : "grazing_intensity_label", - "min" : 0 - }, - - "grazing_period" : { - "code_name" : "grazing_period", - "type" : "dateRangeInput", - "label" : "grazing_period_label", - "required" : true - }, - - "grazing_type" : { - "code_name" : "grazing_type", - "type" : "selectInput", - "label" : "grazing_type_label", - "choices" : "grazing_type_choice" - }, - - "grazing_area" : { - "code_name" : "grazing_area", - "type" : "numericInput", - "label" : "grazing_area_label", - "min" : 1 - }, - - "grazing_material_removed_prop" : { - "code_name" : "grazing_material_removed_prop", - "type" : "numericInput", - "label" : "grazing_material_removed_prop_label", - "min" : 0, - "max" : 100 - }, - - "grazing_starting_height" : { - "code_name" : "grazing_starting_height", - "type" : "numericInput", - "label" : "grazing_starting_height_label", - "min" : 0 - }, - - "grazing_end_height" : { - "code_name" : "grazing_end_height", - "type" : "numericInput", - "label" : "grazing_end_height_label", - "min" : 0 - }, - - "grazing_notes" : { - "code_name" : "grazing_notes", - "type" : "textAreaInput", - "label" : "grazing_notes_label", - "placeholder" : "grazing_notes_placeholder" - } - }, - - "mowing" : { - "condition" : "input.mgmt_operations_event == 'mowing'", - - "mowed_crop" : { - "code_name" : "mowed_crop", - "type" : "selectInput", - "label" : "mowed_crop_label", - "choices" : "CRID", - "required" : true - }, - - "mowed_area" : { - "code_name" : "mowed_area", - "type" : "numericInput", - "label" : "mowed_area_label", - "min" : 0 - }, - - "mowing_method" : { - "code_name" : "mowing_method", - "type" : "selectInput", - "label" : "mowing_method_label", - "choices" : "mowing_method_choices" - }, - - "mowing_canopy_height" : { - "code_name" : "mowing_canopy_height", - "type" : "numericInput", - "label" : "mowing_canopy_height_label", - "min" : 0 - }, - - "mowing_cut_height" : { - "code_name" : "mowing_cut_height", - "type" : "numericInput", - "label" : "mowing_cut_height_label", - "min" : 0 - }, - - "mowing_notes" : { - "code_name" : "mowing_notes", - "type" : "textAreaInput", - "label" : "mowing_notes_label", - "placeholder" : "mowing_notes_placeholder" - } - }, - - "chemicals" : { - "condition" : "input.mgmt_operations_event == 'chemicals'", - - "chemical_type" : { - "code_name" : "chemical_type", - "type" : "selectInput", - "label" : "chemical_type_label", - "choices" : "chemical_type_choice", - "required" : true - }, - - "chemical_product_name" : { - "code_name" : "chemical_product_name", - "type" : "textInput", - "label" : "chemical_product_name_label", - "required" : true - }, - - "chemical_type_substance" : { - "condition" : "input.chemical_type != 'chemical_type_lime_application'", - - "chemical_applic_material" : { - "code_name" : "chemical_applic_material", - "type" : "selectInput", - "label" : "chemical_applic_material_label", - "choices" : "active_substance", - "multiple" : true - } - }, - - "chemical_applic_target" : { - "code_name" : "chemical_applic_target", - "type" : "selectInput", - "label" : "chemical_applic_target_label", - "required" : true, - "choices" : "CH_TARGETS" - }, - - "chemical_applic_method" : { - "code_name" : "chemical_applic_method", - "type" : "selectInput", - "label" : "chemical_applic_method_label", - "choices" : "FEACD" - }, - - "chemical_applic_amount" : { - "code_name" : "chemical_applic_amount", - "type" : "numericInput", - "label" : "chemical_applic_amount_label", - "min" : 0 - }, - - "application_depth_chem" : { - "code_name" : "application_depth_chem", - "type" : "numericInput", - "label" : "application_depth_chem_label", - "min" : 0 - }, - - "pH_change_in_application" : { - "condition" : "input.chemical_type == 'chemical_type_lime_application'", - - "application_ph_start" : { - "code_name" : "application_ph_start", - "type" : "numericInput", - "label" : "application_ph_start_label", - "min" : 0, - "max" : 14 - }, - - "application_ph_end" : { - "code_name" : "application_ph_end", - "type" : "numericInput", - "label" : "application_ph_end_label", - "min" : 0, - "max" : 14 - } - }, - - "chemical_applic_notes" : { - "code_name" : "chemical_applic_notes", - "type" : "textAreaInput", - "label" : "chemical_applic_notes_label", - "placeholder" : "chemical_applic_notes_placeholder" - } - }, - - "observation" : { - "condition" : "input.mgmt_operations_event == 'observation'", - - "observation_type" : { - "code_name" : "observation_type", - "type" : "selectInput", - "label" : "observation_type_label", - "choices" : "observation_type_choice", - "required" : true - }, - - "soil" : { - "condition" : "input.observation_type == 'observation_type_soil'", - - "soil_layer_count" : { - "code_name" : "soil_layer_count", - "type" : "numericInput", - "label" : "soil_layer_count_label", - "min" : 1, - "max" : 10, - "step" : 1, - "hide_in_event_list" : true, - "sub_elements" : { - - "multiple" : { - "condition" : "input.soil_layer_count >= 2", - - "soil_layer_count_table" : { - "code_name" : "soil_layer_count_table", - "type" : "dataTable", - "columns" : ["soil_layer_top_depth", - "soil_layer_base_depth", "soil_classification_by_layer", - "soil_bulk_density_moist", "soil_water_wilting_pt", - "soil_water_field_cap_1", "soil_water_saturated", - "soil_silt_fraction", "soil_sand_fraction", - "soil_clay_fraction", "soil_organic_matter_layer", - "soil_organic_C_perc_layer"], - "rows" : { - "soil_layers" : { - "row_variable" : "soil_layer_count", - "type" : "dynamic" - } - } - } - }, - - "single" : { - "condition" : "input.soil_layer_count == 1", - - "soil_layer_top_depth" : { - "code_name" : "soil_layer_top_depth", - "type" : "numericInput", - "label" : "soil_layer_top_depth_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_layer_base_depth" : { - "code_name" : "soil_layer_base_depth", - "type" : "numericInput", - "label" : "soil_layer_base_depth_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_classification_by_layer" : { - "code_name" : "soil_classification_by_layer", - "type" : "selectInput", - "label" : "soil_classification_by_layer_label", - "choices" : "soil_classification_by_layer_choice", - "hide_in_event_list" : true - }, - - "soil_bulk_density_moist" : { - "code_name" : "soil_bulk_density_moist", - "type" : "numericInput", - "label" : "soil_bulk_density_moist_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_water_wilting_pt" : { - "code_name" : "soil_water_wilting_pt", - "type" : "numericInput", - "label" : "soil_water_wilting_pt_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_water_field_cap_1" : { - "code_name" : "soil_water_field_cap_1", - "type" : "numericInput", - "label" : "soil_water_field_cap_1_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_water_saturated" : { - "code_name" : "soil_water_saturated", - "type" : "numericInput", - "label" : "soil_water_saturated_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_silt_fraction" : { - "code_name" : "soil_silt_fraction", - "type" : "numericInput", - "label" : "soil_silt_fraction_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_sand_fraction" : { - "code_name" : "soil_sand_fraction", - "type" : "numericInput", - "label" : "soil_sand_fraction_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_clay_fraction" : { - "code_name" : "soil_clay_fraction", - "type" : "numericInput", - "label" : "soil_clay_fraction_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_organic_matter_layer" : { - "code_name" : "soil_organic_matter_layer", - "type" : "numericInput", - "label" : "soil_organic_matter_layer_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "soil_organic_C_perc_layer" : { - "code_name" : "soil_organic_C_perc_layer", - "type" : "numericInput", - "label" : "soil_organic_C_perc_layer_label", - "min" : 0, - "hide_in_event_list" : true - } - - } - } - }, - - "root_depth" : { - "code_name" : "root_depth", - "type" : "numericInput", - "label" : "root_depth_label", - "min" : 0 - }, - - "soil_compactification_depth" : { - "code_name" : "soil_compactification_depth", - "type" : "numericInput", - "label" : "soil_compactification_depth_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "earthworm_count" : { - "code_name" : "earthworm_count", - "type" : "numericInput", - "label" : "earthworm_count_label", - "min" : 0, - "step" : 1, - "hide_in_event_list" : true - }, - - "soil_image" : { - "code_name" : "soil_image", - "type" : "fileInput", - "filetype" : "image/*", - "label" : "soil_image_label" - } - - }, - - "vegetation" : { - "condition" : "input.observation_type == 'observation_type_vegetation'", - - "growth_stage" : { - "code_name" : "growth_stage", - "type" : "selectInput", - "label" : "growth_stage_label", - "choices" : "growth_stage_choice", - "hide_in_event_list" : true - }, - - "plant_density" : { - "code_name" : "plant_density", - "type" : "numericInput", - "label" : "plant_density_label", - "min" : 0 - }, - - "specific_leaf_area" : { - "code_name" : "specific_leaf_area", - "type" : "numericInput", - "label" : "specific_leaf_area_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "leaf_area_index" : { - "code_name" : "leaf_area_index", - "type" : "numericInput", - "label" : "leaf_area_index_label", - "min" : 0 - }, - - "total_biomass_dw" : { - "code_name" : "total_biomass_dw", - "type" : "numericInput", - "label" : "total_biomass_dw_label", - "min" : 0 - }, - - "tops_C" : { - "code_name" : "tops_C", - "type" : "numericInput", - "label" : "tops_C_label", - "min" : 0 - }, - - "tops_C_std" : { - "code_name" : "tops_C_std", - "type" : "numericInput", - "label" : "tops_C_std_label", - "min" : 0 - }, - - "roots_C" : { - "code_name" : "roots_C", - "type" : "numericInput", - "label" : "roots_C_label", - "min" : 0 - }, - - "roots_C_std" : { - "code_name" : "roots_C_std", - "type" : "numericInput", - "label" : "roots_C_std_label", - "min" : 0 - }, - - "canopy_height" : { - "code_name" : "canopy_height", - "type" : "numericInput", - "label" : "canopy_height_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "canopeo_reading" : { - "code_name" : "canopeo_reading", - "type" : "numericInput", - "label" : "canopeo_reading_label", - "min" : 0 - }, - - "canopeo_image" : { - "code_name" : "canopeo_image", - "type" : "fileInput", - "filetype" : "image/*", - "label" : "canopeo_image_label" - } - - }, - - "water" : { - "condition" : "input.observation_type == 'observation_type_water'", - - "floodwater_depth" : { - "code_name" : "floodwater_depth", - "type" : "numericInput", - "label" : "floodwater_depth_label", - "min" : 0, - "hide_in_event_list" : true - }, - - "water_table_depth" : { - "code_name" : "water_table_depth", - "type" : "numericInput", - "label" : "water_table_depth_label", - "min" : 0, - "hide_in_event_list" : true - } - }, - - "pests" : { - "condition" : "input.observation_type == 'observation_type_pests'", - - "plant_pop_reduct_cum" : { - "code_name" : "plant_pop_reduct_cum", - "type" : "numericInput", - "label" : "plant_pop_reduct_cum_label", - "min" : 0, - "max" : 0, - "hide_in_event_list" : true - } - }, - - "management" : { - "condition" : "input.observation_type == 'observation_type_management'", - - "fuel_amount" : { - "code_name" : "fuel_amount", - "type" : "numericInput", - "label" : "fuel_amount_label", - "min" : 0 - } - }, - - "observation_notes" : { - "code_name" : "observation_notes", - "type" : "textAreaInput", - "label" : "observation_notes_label" - } - - }, - - "irrigation" : { - "condition" : "input.mgmt_operations_event == 'irrigation'", - - "irrigation_operation" : { - "code_name" : "irrigation_operation", - "type" : "selectInput", - "label" : "irrigation_operation_label", - "choices" : "IROP" - }, - - "irrig_amount_depth" : { - "code_name" : "irrig_amount_depth", - "type" : "numericInput", - "label" : "irrig_amount_depth_label", - "min" : 0, - "required" : true - }, - - "irrigation_applic_depth" : { - "code_name" : "irrigation_applic_depth", - "type" : "numericInput", - "label" : "irrigation_applic_depth_label", - "min" : 0 - }, - - "irrigation_notes" : { - "code_name" : "irrigation_notes", - "type" : "textAreaInput", - "label" : "irrigation_notes_label", - "placeholder" : "irrigation_notes_placeholder" - } - - }, - - "inorg_mulch" : { - "condition" : "input.mgmt_operations_event == 'inorg_mulch'", - - "mulch_type" : { - "code_name" : "mulch_type", - "type" : "selectInput", - "label" : "mulch_type_label", - "required" : true, - "choices" : "MLTP" - }, - - "mulch_thickness" : { - "code_name" : "mulch_thickness", - "type" : "numericInput", - "label" : "mulch_thickness_label", - "min" : 0 - }, - - "mulch_cover_fraction" : { - "code_name" : "mulch_cover_fraction", - "type" : "numericInput", - "label" : "mulch_cover_fraction_label", - "min" : 0, - "max" : 100 - }, - - "mulch_color" : { - "code_name" : "mulch_color", - "type" : "selectInput", - "label" : "mulch_color_label", - "choices" : "MLCOL" - }, - - "mulch_placement_notes" : { - "code_name" : "mulch_placement_notes", - "type" : "textAreaInput", - "label" : "mulch_placement_notes_label", - "placeholder" : "mulch_placement_notes_placeholder" - } - }, - - "Inorg_mul_rem" : { - "condition" : "input.mgmt_operations_event == 'Inorg_mul_rem'", - - "mulch_type_remove" : { - "code_name" : "mulch_type_remove", - "type" : "selectInput", - "label" : "mulch_type_remove_label", - "choices" : "MLTP", - "required" : true - }, - - "mulch_removal_notes" : { - "code_name" : "mulch_removal_notes", - "type" : "textAreaInput", - "label" : "mulch_removal_notes_label", - "placeholder" : "mulch_removal_notes_placeholder" - } - }, - - "weeding" : { - "condition" : "input.mgmt_operations_event == 'weeding'", - - "weeding_notes" : { - "code_name" : "weeding_notes", - "type" : "textAreaInput", - "label" : "weeding_notes_label", - "placeholder" : "weeding_notes_placeholder" - } - }, - - "bed_prep" : { - "condition" : "input.mgmt_operations_event == 'bed_prep'", - - "bed_prep_notes" : { - "code_name" : "bed_prep_notes", - "type" : "textAreaInput", - "label" : "bed_prep_notes_label", - "placeholder" : "bed_prep_notes_placeholder" - } - }, - - "other" : { - "condition" : "input.mgmt_operations_event == 'other'", - - "other_notes" : { - "code_name" : "other_notes", - "type" : "textAreaInput", - "label" : "other_notes_label", - "required" : true - } - } - - } - }, - - "date" : { - "code_name": "date", - "type" : "dateInput", - "label" : "date_label", - "required" : true - }, - - "mgmt_event_notes" : { - "code_name" : "mgmt_event_notes", - "type" : "textAreaInput", - "label" : "mgmt_event_notes_label", - "placeholder" : "mgmt_event_notes_placeholder", - "maxlength" : 80 - }, - "save" : { "code_name" : "save", "type" : "actionButton", @@ -1388,6 +142,5 @@ "type" : "actionButton", "label" : "delete_label" } - } } diff --git a/man/build_event_type_choices.Rd b/man/build_event_type_choices.Rd new file mode 100644 index 0000000..17a10cb --- /dev/null +++ b/man/build_event_type_choices.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{build_event_type_choices} +\alias{build_event_type_choices} +\title{Build event type selectInput choices from the schema} +\usage{ +build_event_type_choices(schema, iso) +} +\arguments{ +\item{schema}{Loaded schema} + +\item{iso}{ISO language code} +} +\value{ +Named character vector for selectInput +} +\description{ +Build event type selectInput choices from the schema +} diff --git a/man/build_property_descriptor.Rd b/man/build_property_descriptor.Rd new file mode 100644 index 0000000..9990945 --- /dev/null +++ b/man/build_property_descriptor.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{build_property_descriptor} +\alias{build_property_descriptor} +\title{Build a property descriptor for the property registry} +\usage{ +build_property_descriptor(name, prop, required, event_type, is_array_item) +} +\arguments{ +\item{name}{Property name (used as input ID)} + +\item{prop}{Resolved property definition} + +\item{required}{Whether this property is required} + +\item{event_type}{The event type this property belongs to} + +\item{is_array_item}{Whether this property is inside an array items} +} +\value{ +A named list describing the property +} +\description{ +Build a property descriptor for the property registry +} diff --git a/man/build_subtype_choices.Rd b/man/build_subtype_choices.Rd new file mode 100644 index 0000000..b83f00c --- /dev/null +++ b/man/build_subtype_choices.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{build_subtype_choices} +\alias{build_subtype_choices} +\title{Build subtype selectInput choices} +\usage{ +build_subtype_choices(event_entry, iso) +} +\arguments{ +\item{event_entry}{An event registry entry} + +\item{iso}{ISO language code} +} +\value{ +Named character vector for selectInput +} +\description{ +Build subtype selectInput choices +} diff --git a/man/clear_schema_value.Rd b/man/clear_schema_value.Rd new file mode 100644 index 0000000..ff53cde --- /dev/null +++ b/man/clear_schema_value.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{clear_schema_value} +\alias{clear_schema_value} +\title{Clear a schema-driven widget} +\usage{ +clear_schema_value(session, prop_name, desc) +} +\description{ +Clear a schema-driven widget +} diff --git a/man/convert_condition_to_js.Rd b/man/convert_condition_to_js.Rd new file mode 100644 index 0000000..a902a6d --- /dev/null +++ b/man/convert_condition_to_js.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{convert_condition_to_js} +\alias{convert_condition_to_js} +\title{Convert a condition string from schema x-ui format to JavaScript for conditionalPanel +Replaces input.FIELD with input['ns-FIELD'] for namespaced Shiny modules} +\usage{ +convert_condition_to_js(condition, ns) +} +\arguments{ +\item{condition}{The condition string (e.g. "input.organic_material == 'RE003'")} + +\item{ns}{Namespace function} +} +\value{ +A JavaScript condition string with namespaced input references +} +\description{ +Convert a condition string from schema x-ui format to JavaScript for conditionalPanel +Replaces input.FIELD with input['ns-FIELD'] for namespaced Shiny modules +} diff --git a/man/determine_widget_type.Rd b/man/determine_widget_type.Rd new file mode 100644 index 0000000..4486905 --- /dev/null +++ b/man/determine_widget_type.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{determine_widget_type} +\alias{determine_widget_type} +\title{Determine the Shiny widget type from a schema property} +\usage{ +determine_widget_type(prop) +} +\arguments{ +\item{prop}{A resolved property descriptor} +} +\value{ +A string: "selectInput", "numericInput", "dateInput", etc. +} +\description{ +Determine the Shiny widget type from a schema property +} diff --git a/man/extract_oneof_choices.Rd b/man/extract_oneof_choices.Rd new file mode 100644 index 0000000..c844e0d --- /dev/null +++ b/man/extract_oneof_choices.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{extract_oneof_choices} +\alias{extract_oneof_choices} +\title{Extract selectInput choices from a oneOf array} +\usage{ +extract_oneof_choices(one_of_array) +} +\arguments{ +\item{one_of_array}{A list of oneOf entries each with const and title} +} +\value{ +A list of choice descriptors with const, titles +} +\description{ +Extract selectInput choices from a oneOf array +} diff --git a/man/get_all_schema_properties.Rd b/man/get_all_schema_properties.Rd new file mode 100644 index 0000000..9aa58d6 --- /dev/null +++ b/man/get_all_schema_properties.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{get_all_schema_properties} +\alias{get_all_schema_properties} +\title{Get all schema property names as a flat vector (for registry iteration) +Used to find all properties that need validation, value collection, etc.} +\usage{ +get_all_schema_properties(schema) +} +\description{ +Get all schema property names as a flat vector (for registry iteration) +Used to find all properties that need validation, value collection, etc. +} diff --git a/man/get_event_list_colnames.Rd b/man/get_event_list_colnames.Rd new file mode 100644 index 0000000..8925745 --- /dev/null +++ b/man/get_event_list_colnames.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_list.R +\name{get_event_list_colnames} +\alias{get_event_list_colnames} +\title{Get display names for event list table column headers +Tries display_names.csv first, then schema titles as fallback} +\usage{ +get_event_list_colnames(col_names, language) +} +\arguments{ +\item{col_names}{Vector of column names} + +\item{language}{Language code or column name} +} +\value{ +Vector of display names +} +\description{ +Get display names for event list table column headers +Tries display_names.csv first, then schema titles as fallback +} diff --git a/man/get_relevant_properties.Rd b/man/get_relevant_properties.Rd new file mode 100644 index 0000000..1bc32c0 --- /dev/null +++ b/man/get_relevant_properties.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{get_relevant_properties} +\alias{get_relevant_properties} +\title{Get properties relevant to the currently selected event/subtype} +\usage{ +get_relevant_properties(schema, event_type, subtype = NULL) +} +\arguments{ +\item{schema}{The loaded schema (from load_schema)} + +\item{event_type}{The selected event type const} + +\item{subtype}{The selected subtype const (or NULL)} +} +\value{ +A list with: common, event_props, subtype_props, all +} +\description{ +Get properties relevant to the currently selected event/subtype +} diff --git a/man/lang_to_iso.Rd b/man/lang_to_iso.Rd new file mode 100644 index 0000000..dfa4bf5 --- /dev/null +++ b/man/lang_to_iso.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{lang_to_iso} +\alias{lang_to_iso} +\title{Convert language column name to ISO code} +\usage{ +lang_to_iso(language) +} +\arguments{ +\item{language}{Either an ISO code or a display_names.csv column name} +} +\value{ +ISO language code +} +\description{ +Convert language column name to ISO code +} diff --git a/man/load_schema.Rd b/man/load_schema.Rd new file mode 100644 index 0000000..410ad93 --- /dev/null +++ b/man/load_schema.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{load_schema} +\alias{load_schema} +\title{Load and parse the management-event schema} +\usage{ +load_schema() +} +\value{ +A list with components: raw (the full parsed schema), event_registry, + property_registry, common_properties, event_type_choices +} +\description{ +Load and parse the management-event schema +} diff --git a/man/lookup_property.Rd b/man/lookup_property.Rd new file mode 100644 index 0000000..26a9733 --- /dev/null +++ b/man/lookup_property.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{lookup_property} +\alias{lookup_property} +\title{Look up a property descriptor from the registry} +\usage{ +lookup_property(registry, prop_name, event_type = NULL, subtype = NULL) +} +\arguments{ +\item{registry}{The property registry} + +\item{prop_name}{Property name} + +\item{event_type}{Event type const (or NULL for common)} + +\item{subtype}{Subtype const (or NULL)} +} +\value{ +The property descriptor, or NULL +} +\description{ +Look up a property descriptor from the registry +} diff --git a/man/make_required_label.Rd b/man/make_required_label.Rd new file mode 100644 index 0000000..bb8dcbf --- /dev/null +++ b/man/make_required_label.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{make_required_label} +\alias{make_required_label} +\title{Create a label with a required asterisk indicator} +\usage{ +make_required_label(label, required) +} +\arguments{ +\item{label}{The label text} + +\item{required}{Whether the field is required} +} +\value{ +The label, optionally with a red asterisk appended +} +\description{ +Create a label with a required asterisk indicator +} diff --git a/man/normalize_legacy_event.Rd b/man/normalize_legacy_event.Rd new file mode 100644 index 0000000..124415d --- /dev/null +++ b/man/normalize_legacy_event.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_files.R +\name{normalize_legacy_event} +\alias{normalize_legacy_event} +\title{Normalize a legacy event to use schema property names} +\usage{ +normalize_legacy_event(event) +} +\arguments{ +\item{event}{An event list} +} +\value{ +The event with legacy names mapped to schema names +} +\description{ +Normalize a legacy event to use schema property names +} diff --git a/man/render_array_table.Rd b/man/render_array_table.Rd new file mode 100644 index 0000000..feb2aa9 --- /dev/null +++ b/man/render_array_table.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_array_table} +\alias{render_array_table} +\title{Render a schema array property as a table module placeholder} +\usage{ +render_array_table(prop_name, desc, ns, iso) +} +\arguments{ +\item{prop_name}{The array property name (e.g. "planting_list")} + +\item{desc}{The property descriptor} + +\item{ns}{Namespace function} + +\item{iso}{ISO language code} +} +\value{ +A tagList with the table module UI +} +\description{ +Render a schema array property as a table module placeholder +} diff --git a/man/render_event_panel.Rd b/man/render_event_panel.Rd new file mode 100644 index 0000000..8dda8c1 --- /dev/null +++ b/man/render_event_panel.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_event_panel} +\alias{render_event_panel} +\title{Render the panel for a single event type} +\usage{ +render_event_panel(event_entry, pr, ns, iso, event_const) +} +\arguments{ +\item{event_entry}{An event registry entry} + +\item{pr}{Property registry} + +\item{ns}{Namespace function} + +\item{iso}{ISO language code} + +\item{event_const}{The event type const value} +} +\value{ +A tagList +} +\description{ +Render the panel for a single event type +} diff --git a/man/render_property_widget.Rd b/man/render_property_widget.Rd new file mode 100644 index 0000000..056b3c1 --- /dev/null +++ b/man/render_property_widget.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_property_widget} +\alias{render_property_widget} +\title{Render a single Shiny input widget from a property descriptor} +\usage{ +render_property_widget( + prop_name, + desc, + ns, + iso, + override_code_name = NULL, + override_label = NULL, + override_value = NULL, + override_choices = NULL, + override_selected = NULL, + override_placeholder = NULL, + width = NULL +) +} +\arguments{ +\item{prop_name}{Property name (used as input ID)} + +\item{desc}{Property descriptor from the registry} + +\item{ns}{Namespace function} + +\item{iso}{ISO language code} + +\item{override_code_name}{Optional code name override (for table cells)} + +\item{override_label}{Optional label override} + +\item{override_value}{Optional value override} + +\item{override_choices}{Optional choices override} + +\item{override_selected}{Optional selected value override} + +\item{override_placeholder}{Optional placeholder override} + +\item{width}{Optional width} +} +\value{ +A Shiny widget tag +} +\description{ +Render a single Shiny input widget from a property descriptor +} diff --git a/man/render_schema_form.Rd b/man/render_schema_form.Rd new file mode 100644 index 0000000..d254469 --- /dev/null +++ b/man/render_schema_form.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_schema_form} +\alias{render_schema_form} +\title{Render the full schema-driven form} +\usage{ +render_schema_form(schema, ns, language) +} +\arguments{ +\item{schema}{The loaded schema (from load_schema)} + +\item{ns}{Shiny namespace function} + +\item{language}{Language code or column name} +} +\value{ +A tagList of Shiny UI elements +} +\description{ +Render the full schema-driven form +} diff --git a/man/render_subtype_section.Rd b/man/render_subtype_section.Rd new file mode 100644 index 0000000..73cd784 --- /dev/null +++ b/man/render_subtype_section.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_subtype_section} +\alias{render_subtype_section} +\title{Render a subtype discriminator and its conditional panels} +\usage{ +render_subtype_section(pn, desc, event_entry, pr, ns, iso, event_const) +} +\description{ +Render a subtype discriminator and its conditional panels +} diff --git a/man/resolve_property.Rd b/man/resolve_property.Rd new file mode 100644 index 0000000..6e40d38 --- /dev/null +++ b/man/resolve_property.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{resolve_property} +\alias{resolve_property} +\title{Resolve $ref and allOf in a property definition} +\usage{ +resolve_property(prop, defs) +} +\arguments{ +\item{prop}{The property definition (list)} + +\item{defs}{The $defs section from the schema} +} +\value{ +The resolved property with refs inlined +} +\description{ +Resolve $ref and allOf in a property definition +} diff --git a/man/resolve_ref.Rd b/man/resolve_ref.Rd new file mode 100644 index 0000000..9f16e12 --- /dev/null +++ b/man/resolve_ref.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{resolve_ref} +\alias{resolve_ref} +\title{Resolve a $ref pointer within the schema $defs} +\usage{ +resolve_ref(obj, defs) +} +\arguments{ +\item{obj}{A list that may contain a $ref key} + +\item{defs}{The $defs section from the schema} +} +\value{ +The resolved object +} +\description{ +Resolve a $ref pointer within the schema $defs +} diff --git a/man/schema_get_choices.Rd b/man/schema_get_choices.Rd new file mode 100644 index 0000000..ba72139 --- /dev/null +++ b/man/schema_get_choices.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{schema_get_choices} +\alias{schema_get_choices} +\title{Build a named choice vector for selectInput from schema choices} +\usage{ +schema_get_choices(choices, language) +} +\arguments{ +\item{choices}{A list of choice descriptors from extract_oneof_choices} + +\item{language}{Language code or column name} +} +\value{ +A named character vector suitable for selectInput choices +} +\description{ +Build a named choice vector for selectInput from schema choices +} diff --git a/man/schema_get_title.Rd b/man/schema_get_title.Rd new file mode 100644 index 0000000..4d3d6d3 --- /dev/null +++ b/man/schema_get_title.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{schema_get_title} +\alias{schema_get_title} +\title{Get title in the requested language with fallback} +\usage{ +schema_get_title(titles, language = "en", fallback = "") +} +\arguments{ +\item{titles}{A list with keys en, fi, sv} + +\item{language}{Language code: "en", "fi", or "sv"} + +\item{fallback}{A fallback string if all titles are empty} +} +\value{ +The title string +} +\description{ +Get title in the requested language with fallback +} diff --git a/man/update_schema_value.Rd b/man/update_schema_value.Rd new file mode 100644 index 0000000..ce51c31 --- /dev/null +++ b/man/update_schema_value.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{update_schema_value} +\alias{update_schema_value} +\title{Update a schema-driven widget value (for populating forms)} +\usage{ +update_schema_value(session, prop_name, desc, value) +} +\arguments{ +\item{session}{Shiny session} + +\item{prop_name}{Property name} + +\item{desc}{Property descriptor} + +\item{value}{The value to set} +} +\description{ +Update a schema-driven widget value (for populating forms) +} diff --git a/man/update_schema_widget.Rd b/man/update_schema_widget.Rd new file mode 100644 index 0000000..bb9e8bd --- /dev/null +++ b/man/update_schema_widget.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{update_schema_widget} +\alias{update_schema_widget} +\title{Update a single schema widget's label and choices} +\usage{ +update_schema_widget(session, prop_name, desc, iso, input) +} +\description{ +Update a single schema widget's label and choices +} diff --git a/tests/testthat/test-fct_schema.R b/tests/testthat/test-fct_schema.R new file mode 100644 index 0000000..5d0a443 --- /dev/null +++ b/tests/testthat/test-fct_schema.R @@ -0,0 +1,331 @@ +# Unit tests for schema parsing and helper functions +# Uses inline fixtures for pure function testing + +# --- resolve_ref / resolve_property ------------------------------------------- + +test_that("resolve_ref resolves a $defs pointer", { + defs <- list(my_type = list(type = "string", oneOf = list(list(const = "a")))) + obj <- list("$ref" = "#/$defs/my_type") + result <- resolve_ref(obj, defs) + expect_equal(result$type, "string") + expect_length(result$oneOf, 1) + expect_null(result[["$ref"]]) +}) + +test_that("resolve_ref returns obj unchanged when no $ref", { + obj <- list(type = "string", title = "x") + result <- resolve_ref(obj, list()) + expect_identical(result, obj) +}) + +test_that("resolve_ref returns obj unchanged for unresolvable $ref", { + obj <- list("$ref" = "#/$defs/nonexistent") + result <- resolve_ref(obj, list()) + expect_identical(result, obj) +}) + +test_that("resolve_property merges allOf and carries top-level keys", { + defs <- list(test_def = list(type = "string", oneOf = list(list(const = "v1")))) + prop <- list( + allOf = list( + list(title = "My Title", title_fi = "Otsikko"), + list("$ref" = "#/$defs/test_def") + ), + "x-ui" = list(foo = TRUE) + ) + result <- resolve_property(prop, defs) + expect_equal(result$title, "My Title") + expect_equal(result$type, "string") + expect_length(result$oneOf, 1) + expect_true(result[["x-ui"]]$foo) +}) + +test_that("resolve_property recursively resolves array items", { + defs <- list(item_def = list( + type = "object", + properties = list( + name = list(type = "string"), + weight = list("$ref" = "#/$defs/weight_def") + ) + )) + defs$weight_def <- list(type = "number", minimum = 0) + prop <- list(type = "array", items = list("$ref" = "#/$defs/item_def")) + result <- resolve_property(prop, defs) + expect_equal(result$items$type, "object") + expect_equal(result$items$properties$name$type, "string") + expect_equal(result$items$properties$weight$type, "number") + expect_equal(result$items$properties$weight$minimum, 0) +}) + +# --- determine_widget_type --------------------------------------------------- + +test_that("determine_widget_type maps schema types correctly", { + expect_equal(determine_widget_type(list(type = "string")), "textInput") + expect_equal(determine_widget_type(list(type = "string", format = "date")), + "dateInput") + expect_equal(determine_widget_type( + list(type = "string", oneOf = list(list(const = "a")))), "selectInput") + expect_equal(determine_widget_type( + list(type = "string", "x-ui" = list(discriminator = TRUE))), "selectInput") + expect_equal(determine_widget_type(list(type = "number")), "numericInput") + expect_equal(determine_widget_type(list(type = "integer")), "numericInput") + expect_equal(determine_widget_type( + list(type = "array", items = list(type = "object"))), "dataTable") + expect_equal(determine_widget_type(list(const = "planting")), "const") + expect_equal(determine_widget_type( + list(type = "string", "x-ui" = list("form-type" = "textAreaInput"))), + "textAreaInput") +}) + +# --- extract_titles / extract_oneof_choices ----------------------------------- + +test_that("extract_titles with partial languages defaults to empty string", { + result <- extract_titles(list(title = "A", title_fi = "B")) + expect_equal(result, list(en = "A", fi = "B", sv = "")) + + result2 <- extract_titles(list()) + expect_equal(result2, list(en = "", fi = "", sv = "")) +}) + +test_that("extract_oneof_choices extracts const/titles and skips entries without const", { + input <- list( + list(const = "A", title = "Label A", title_fi = "Fin A"), + list(title = "No const here"), + list(const = "B", title = "Label B") + ) + result <- extract_oneof_choices(input) + expect_length(result, 2) + expect_equal(result[[1]]$value, "A") + expect_equal(result[[1]]$titles$en, "Label A") + expect_equal(result[[1]]$titles$fi, "Fin A") + expect_equal(result[[2]]$value, "B") +}) + +# --- schema_get_title --------------------------------------------------------- + +test_that("schema_get_title fallback chain: language -> en -> fallback", { + expect_equal(schema_get_title(list(en = "E", fi = "F", sv = "S"), "fi"), "F") + # empty fi falls back to en + expect_equal(schema_get_title(list(en = "E", fi = "", sv = ""), "fi"), "E") + # all empty, use fallback + expect_equal(schema_get_title(list(en = "", fi = "", sv = ""), "sv", "default"), + "default") + # NULL titles + expect_equal(schema_get_title(NULL, "en", "fallback"), "fallback") +}) + +# --- lang_to_iso -------------------------------------------------------------- + +test_that("lang_to_iso converts column names and passes through ISO codes", { + expect_equal(lang_to_iso("disp_name_eng"), "en") + expect_equal(lang_to_iso("disp_name_fin"), "fi") + expect_equal(lang_to_iso("disp_name_swe"), "sv") + expect_equal(lang_to_iso("en"), "en") + expect_equal(lang_to_iso("fi"), "fi") + # NOTE: unknown language codes cause subscript out of bounds error because + # mapping is a named character vector, not a list. The NULL fallback on + # line 427 of fct_schema.R is unreachable. Consider using match() or + # switching to a list. For now, test the actual behavior: + expect_error(lang_to_iso("unknown"), "subscript out of bounds") +}) + +# --- schema_get_choices ------------------------------------------------------- + +test_that("schema_get_choices builds named vector with empty first option", { + choices <- extract_oneof_choices(list( + list(const = "A", title = "Aa"), + list(const = "B", title = "Bb") + )) + result <- schema_get_choices(choices, "en") + expect_equal(length(result), 3) + expect_equal(unname(result[1]), "") + expect_equal(unname(result[2]), "A") + expect_equal(names(result)[2], "Aa") + expect_equal(unname(result[3]), "B") + expect_equal(names(result)[3], "Bb") +}) + +test_that("schema_get_choices returns NULL for NULL/empty input", { + expect_null(schema_get_choices(NULL, "en")) + expect_null(schema_get_choices(list(), "en")) +}) + +# --- build_property_descriptor ------------------------------------------------ + +test_that("build_property_descriptor populates fields for numeric property", { + prop <- list(type = "number", minimum = 0, maximum = 100, + title = "Weight", title_fi = "Paino") + desc <- build_property_descriptor("test_prop", prop, + required = TRUE, + event_type = "harvest", + is_array_item = FALSE) + expect_equal(desc$name, "test_prop") + expect_equal(desc$type, "numericInput") + expect_true(desc$required) + expect_equal(desc$minimum, 0) + expect_equal(desc$maximum, 100) + expect_equal(desc$titles$en, "Weight") + expect_equal(desc$titles$fi, "Paino") + expect_equal(desc$event_type, "harvest") + expect_false(desc$is_integer) +}) + +test_that("build_property_descriptor builds array_columns for dataTable", { + prop <- list( + type = "array", + items = list( + type = "object", + required = list("col_a"), + properties = list( + col_a = list(type = "string", title = "Column A"), + col_b = list(type = "number", title = "Column B", minimum = 0) + ) + ) + ) + desc <- build_property_descriptor("my_table", prop, + required = FALSE, + event_type = "planting", + is_array_item = FALSE) + expect_equal(desc$type, "dataTable") + expect_length(desc$array_columns, 2) + expect_equal(desc$array_columns$col_a$type, "textInput") + expect_true(desc$array_columns$col_a$required) + expect_equal(desc$array_columns$col_b$type, "numericInput") + expect_false(desc$array_columns$col_b$required) + expect_equal(desc$array_columns$col_b$minimum, 0) +}) + +# --- lookup_property ---------------------------------------------------------- + +test_that("lookup_property resolves subtype > event > common priority", { + reg <- list() + reg[["my_prop"]] <- list(name = "common") + reg[[paste0("my_prop", REGISTRY_KEY_SEP, "fertilizer")]] <- list(name = "event") + reg[[paste0("my_prop", REGISTRY_KEY_SEP, "fertilizer", REGISTRY_KEY_SEP, + "mineral")]] <- list(name = "subtype") + + expect_equal(lookup_property(reg, "my_prop", "fertilizer", "mineral")$name, + "subtype") + expect_equal(lookup_property(reg, "my_prop", "fertilizer")$name, "event") + expect_equal(lookup_property(reg, "my_prop")$name, "common") + expect_null(lookup_property(reg, "nonexistent")) +}) + +test_that("lookup_property falls through missing subtype to event level", { + reg <- list() + reg[[paste0("prop", REGISTRY_KEY_SEP, "harvest")]] <- list(name = "event") + + result <- lookup_property(reg, "prop", "harvest", "some_subtype") + expect_equal(result$name, "event") +}) + +# --- normalize_legacy_event / get_legacy_value -------------------------------- + +test_that("normalize_legacy_event maps old names to new", { + event <- normalize_legacy_event(list(mgmt_event_notes = "hello")) + expect_equal(event$mgmt_event_short_notes, "hello") + expect_null(event$mgmt_event_notes) + + event2 <- normalize_legacy_event(list(planting_notes = "pn")) + expect_equal(event2$mgmt_event_long_notes, "pn") + expect_null(event2$planting_notes) + + event3 <- normalize_legacy_event(list(harvest_comments = "hc")) + expect_equal(event3$mgmt_event_long_notes, "hc") +}) + +test_that("normalize_legacy_event does not overwrite existing new-name values", { + event <- normalize_legacy_event(list( + mgmt_event_notes = "old", + mgmt_event_short_notes = "new" + )) + expect_equal(event$mgmt_event_short_notes, "new") + # old name is preserved because new name already existed + expect_equal(event$mgmt_event_notes, "old") +}) + +test_that("get_legacy_value retrieves value via reverse mapping", { + expect_equal(get_legacy_value(list(planting_notes = "val"), + "mgmt_event_long_notes"), "val") + expect_null(get_legacy_value(list(other_field = "x"), + "mgmt_event_long_notes")) +}) + +# --- find_any_property_desc --------------------------------------------------- + +test_that("find_any_property_desc uses reverse index for O(1) lookup", { + reg <- list() + reg[["date"]] <- list(name = "date", type = "dateInput") + reg[[paste0("crop_name", REGISTRY_KEY_SEP, "planting")]] <- + list(name = "crop_name", type = "selectInput") + + rev_idx <- list(crop_name = paste0("crop_name", REGISTRY_KEY_SEP, "planting")) + + expect_equal(find_any_property_desc(reg, "date", rev_idx)$name, "date") + expect_equal(find_any_property_desc(reg, "crop_name", rev_idx)$name, + "crop_name") + expect_null(find_any_property_desc(reg, "nonexistent", rev_idx)) +}) + +test_that("find_any_property_desc falls back to linear scan without index", { + reg <- list() + reg[[paste0("crop_name", REGISTRY_KEY_SEP, "planting")]] <- + list(name = "crop_name") + + result <- find_any_property_desc(reg, "crop_name", NULL) + expect_equal(result$name, "crop_name") +}) + +# --- get_subtype_value -------------------------------------------------------- + +test_that("get_subtype_value extracts discriminator from event values", { + er <- mgmt_schema$event_registry + + result <- get_subtype_value( + list(mgmt_operations_event = "fertilizer", + fertilizer_type = "fertilizer_type_mineral"), er) + expect_equal(result, "fertilizer_type_mineral") + + # planting has no subtypes + expect_null(get_subtype_value( + list(mgmt_operations_event = "planting"), er)) + + # empty values + expect_null(get_subtype_value(list(), er)) +}) + +# --- get_schema_table_names --------------------------------------------------- + +test_that("get_schema_table_names lists all array table names", { + table_names <- get_schema_table_names(mgmt_schema) + expect_true("planting_list_table" %in% table_names) + expect_true("harvest_list_table" %in% table_names) + expect_true(all(grepl("_table$", table_names))) + # should not be empty + + expect_true(length(table_names) >= 3) +}) + +# --- UI helpers (fct_schema_ui.R) --------------------------------------------- + +test_that("convert_condition_to_js namespaces input references", { + ns <- shiny::NS("form") + result <- convert_condition_to_js( + "input.organic_material == 'RE003'", ns) + expect_equal(result, "input['form-organic_material'] == 'RE003'") + + result2 <- convert_condition_to_js( + "input.chemical_type != 'lime'", ns) + expect_equal(result2, "input['form-chemical_type'] != 'lime'") +}) + +test_that("make_required_label adds asterisk only for required non-empty labels", { + result <- make_required_label("Name", TRUE) + expect_s3_class(result, "shiny.tag.list") + html <- as.character(result) + expect_true(grepl("\\*", html)) + + expect_equal(make_required_label("Name", FALSE), "Name") + expect_equal(make_required_label("", TRUE), "") + expect_null(make_required_label(NULL, TRUE)) +}) diff --git a/tests/testthat/test-schema_integration.R b/tests/testthat/test-schema_integration.R new file mode 100644 index 0000000..c82284e --- /dev/null +++ b/tests/testthat/test-schema_integration.R @@ -0,0 +1,332 @@ +# Integration tests against the real management-event schema +# These test that load_schema() correctly parses the bundled schema and that +# cross-cutting concerns (lookup chains, language, choices) work end-to-end. + +# --- load_schema structure ---------------------------------------------------- + +test_that("load_schema returns all expected components", { + expect_true(is.list(mgmt_schema)) + expected_names <- c("raw", "event_registry", "property_registry", + "property_reverse_index", "common_properties", + "event_type_choices") + for (nm in expected_names) { + expect_true(nm %in% names(mgmt_schema), + info = paste("missing component:", nm)) + } + expect_true(is.list(mgmt_schema$event_registry)) + expect_true(is.list(mgmt_schema$property_registry)) + expect_true(is.character(mgmt_schema$common_properties)) +}) + +test_that("load_schema registers all 15 event types", { + event_names <- names(mgmt_schema$event_registry) + expected <- c("planting", "fertilizer", "tillage", "harvest", "chemicals", + "grazing", "weeding", "irrigation", "mowing", "observation", + "bed_prep", "inorg_mulch", "Inorg_mul_rem", "measurement", + "other") + for (ev in expected) { + expect_true(ev %in% event_names, + info = paste("missing event type:", ev)) + } + expect_equal(length(event_names), 15) +}) + +test_that("common properties include date and mgmt_operations_event but not $schema", { + cp <- mgmt_schema$common_properties + expect_true("date" %in% cp) + expect_true("mgmt_operations_event" %in% cp) + expect_true("mgmt_event_short_notes" %in% cp) + expect_false("$schema" %in% cp) +}) + +test_that("event_type_choices has titles for all events", { + etc <- mgmt_schema$event_type_choices + expect_equal(length(etc), length(mgmt_schema$event_registry)) + for (ev in names(etc)) { + expect_true(!is.null(etc[[ev]]$en), + info = paste("missing en title for", ev)) + } +}) + +# --- Subtype structure -------------------------------------------------------- + +test_that("fertilizer has 3 subtypes with discriminator fertilizer_type", { + fert <- mgmt_schema$event_registry[["fertilizer"]] + expect_true(fert$has_subtypes) + expect_equal(fert$subtype_discriminator, "fertilizer_type") + expect_equal(length(fert$subtypes), 3) + sub_consts <- vapply(fert$subtypes, function(s) s$const, character(1)) + expect_true("fertilizer_type_mineral" %in% sub_consts) + expect_true("fertilizer_type_soil_amendment" %in% sub_consts) + expect_true("fertilizer_type_organic" %in% sub_consts) +}) + +test_that("observation has 8 subtypes with discriminator observation_type", { + obs <- mgmt_schema$event_registry[["observation"]] + expect_true(obs$has_subtypes) + expect_equal(obs$subtype_discriminator, "observation_type") + expect_equal(length(obs$subtypes), 8) + sub_consts <- vapply(obs$subtypes, function(s) s$const, character(1)) + expect_true("observation_type_soil" %in% sub_consts) + expect_true("observation_type_vegetation" %in% sub_consts) +}) + +test_that("planting has no subtypes", { + pl <- mgmt_schema$event_registry[["planting"]] + expect_false(pl$has_subtypes) + expect_null(pl$subtype_discriminator) +}) + +# --- Property registry -------------------------------------------------------- + +test_that("common properties registered with bare keys, correct types", { + pr <- mgmt_schema$property_registry + date_desc <- pr[["date"]] + expect_false(is.null(date_desc)) + expect_equal(date_desc$type, "dateInput") + + event_desc <- pr[["mgmt_operations_event"]] + expect_false(is.null(event_desc)) + expect_true(event_desc$is_discriminator) +}) + +test_that("event properties use REGISTRY_KEY_SEP namespacing", { + pr <- mgmt_schema$property_registry + key <- paste0("planting_list", REGISTRY_KEY_SEP, "planting") + expect_false(is.null(pr[[key]])) + expect_equal(pr[[key]]$type, "dataTable") +}) + +test_that("$ref properties resolved with choices", { + desc <- lookup_property(mgmt_schema$property_registry, + "fertilizer_applic_method", "fertilizer") + expect_false(is.null(desc)) + expect_equal(desc$type, "selectInput") + expect_true(length(desc$choices) > 0) + choice_values <- vapply(desc$choices, function(ch) ch$value, character(1)) + expect_true("AP001" %in% choice_values) +}) + +test_that("dataTable properties have resolved array_columns", { + pl_desc <- lookup_property(mgmt_schema$property_registry, + "planting_list", "planting") + expect_equal(pl_desc$type, "dataTable") + expect_true("planted_crop" %in% names(pl_desc$array_columns)) + expect_true("planting_material_weight" %in% names(pl_desc$array_columns)) + + # planted_crop should be selectInput (resolved from $ref via allOf) + expect_equal(pl_desc$array_columns$planted_crop$type, "selectInput") + + # planting_material_weight should be numericInput with min >= 0 + pmw <- pl_desc$array_columns$planting_material_weight + expect_equal(pmw$type, "numericInput") + expect_true(!is.null(pmw$minimum) && pmw$minimum >= 0) +}) + +# --- Cross-cutting ------------------------------------------------------------ + +test_that("get_relevant_properties returns correct sets", { + # planting event_props should include planting_list + rel <- get_relevant_properties(mgmt_schema, "planting") + expect_true("planting_list" %in% rel$event_props) + expect_equal(rel$common, mgmt_schema$common_properties) + expect_length(rel$subtype_props, 0) + + # fertilizer with subtype should populate subtype_props + rel2 <- get_relevant_properties(mgmt_schema, "fertilizer", + "fertilizer_type_mineral") + expect_true(length(rel2$subtype_props) > 0) + expect_true("fertilizer_product_name" %in% rel2$subtype_props) + + # all should be the union + expect_true(all(rel2$common %in% rel2$all)) + expect_true(all(rel2$event_props %in% rel2$all)) + expect_true(all(rel2$subtype_props %in% rel2$all)) + + # unknown event type returns empty event/subtype but still has common + rel3 <- get_relevant_properties(mgmt_schema, "nonexistent") + expect_length(rel3$event_props, 0) + expect_length(rel3$subtype_props, 0) + expect_equal(rel3$common, mgmt_schema$common_properties) +}) + +test_that("build_event_type_choices and build_subtype_choices produce valid selectInput vectors", { + choices <- build_event_type_choices(mgmt_schema, "en") + expect_equal(unname(choices[1]), "") + expect_true("planting" %in% choices) + # planting's English title is "sowing" + planting_idx <- which(choices == "planting") + expect_equal(names(choices)[planting_idx], "sowing") + + # subtype choices for fertilizer + fert <- mgmt_schema$event_registry[["fertilizer"]] + sub_choices <- build_subtype_choices(fert, "en") + expect_equal(unname(sub_choices[1]), "") + expect_true("fertilizer_type_mineral" %in% sub_choices) + + # planting has no subtypes + expect_null(build_subtype_choices( + mgmt_schema$event_registry[["planting"]], "en")) + + # Finnish subtype choices + sub_fi <- build_subtype_choices(fert, "fi") + expect_true(length(sub_fi) > 1) +}) + +# --- Schema-specific edge cases ----------------------------------------------- + +test_that("harvest total_of descriptors are parsed correctly", { + # harvest has 3 properties with total_of_list/total_of_property for auto-sum + pr <- mgmt_schema$property_registry + total_desc <- lookup_property(pr, "harvest_yield_harvest_dw_total", "harvest") + expect_false(is.null(total_desc)) + expect_false(is.null(total_desc$total_of)) + expect_equal(total_desc$total_of$list_name, "harvest_list") + expect_equal(total_desc$total_of$property_name, "harvest_yield_harvest_dw") + + total_desc2 <- lookup_property(pr, "harv_yield_harv_f_wt_total", "harvest") + expect_false(is.null(total_desc2$total_of)) + expect_equal(total_desc2$total_of$list_name, "harvest_list") +}) + +test_that("minItems is captured in array property descriptors", { + pl <- lookup_property(mgmt_schema$property_registry, "planting_list", "planting") + expect_equal(pl$min_items, 1) + + hl <- lookup_property(mgmt_schema$property_registry, "harvest_list", "harvest") + expect_equal(hl$min_items, 1) +}) + +test_that("x-ui conditions are preserved in property descriptors", { + # chemicals/chemical_applic_material_list has a condition on chemical_type + pr <- mgmt_schema$property_registry + chem_list <- lookup_property(pr, "chemical_applic_material_list", "chemicals") + expect_false(is.null(chem_list)) + expect_false(is.null(chem_list$xui$condition)) + expect_true(grepl("chemical_type", chem_list$xui$condition)) + + # application_ph_start also has a condition + ph_start <- lookup_property(pr, "application_ph_start", "chemicals") + expect_false(is.null(ph_start$xui$condition)) +}) + +test_that("allOf in array items resolves $ref choices (planted_crop, harvest_crop)", { + # planted_crop inside planting_list uses allOf to merge title with $ref to + # crop_ident_ICASA. The resolved descriptor must have selectInput choices. + pl <- lookup_property(mgmt_schema$property_registry, "planting_list", "planting") + planted_crop <- pl$array_columns$planted_crop + expect_equal(planted_crop$type, "selectInput") + expect_true(length(planted_crop$choices) > 10) + # Should contain common crop codes + crop_values <- vapply(planted_crop$choices, function(ch) ch$value, character(1)) + expect_true("WHT" %in% crop_values) # wheat + + # Same for harvest_crop + hl <- lookup_property(mgmt_schema$property_registry, "harvest_list", "harvest") + harvest_crop <- hl$array_columns$harvest_crop + expect_equal(harvest_crop$type, "selectInput") + expect_true(length(harvest_crop$choices) > 10) +}) + +test_that("chemicals event has no subtypes but has conditional properties", { + chem <- mgmt_schema$event_registry[["chemicals"]] + expect_false(chem$has_subtypes) + expect_null(chem$subtype_discriminator) + # chemical_type is a regular selectInput, not a discriminator + ct <- lookup_property(mgmt_schema$property_registry, "chemical_type", "chemicals") + expect_equal(ct$type, "selectInput") + expect_false(isTRUE(ct$is_discriminator)) + expect_true(length(ct$choices) >= 6) +}) + +test_that("minimal events (weeding, other, bed_prep) register correctly", { + for (ev in c("weeding", "other", "bed_prep")) { + entry <- mgmt_schema$event_registry[[ev]] + expect_false(is.null(entry), info = paste(ev, "not registered")) + expect_false(entry$has_subtypes, info = paste(ev, "should have no subtypes")) + # Should have at least mgmt_event_long_notes + expect_true("mgmt_event_long_notes" %in% entry$property_names, + info = paste(ev, "missing mgmt_event_long_notes")) + } +}) + +# --- Nested cases ------------------------------------------------------------- + +test_that("array table inside subtype: soil_layer_list in observation_type_soil", { + # soil_layer_list is a dataTable property belonging to the observation_type_soil + # subtype, not the observation event itself. It must be registered with the + # triple-key (prop___event___subtype) and have resolved array_columns. + pr <- mgmt_schema$property_registry + key <- paste0("soil_layer_list", REGISTRY_KEY_SEP, "observation", + REGISTRY_KEY_SEP, "observation_type_soil") + desc <- pr[[key]] + expect_false(is.null(desc), info = "soil_layer_list not registered under subtype key") + expect_equal(desc$type, "dataTable") + expect_true(length(desc$array_columns) >= 5) + # Should have soil_layer_top_depth as a numericInput column + expect_false(is.null(desc$array_columns$soil_layer_top_depth)) + expect_equal(desc$array_columns$soil_layer_top_depth$type, "numericInput") + + # Should also be discoverable via lookup_property with subtype context + desc2 <- lookup_property(pr, "soil_layer_list", "observation", + "observation_type_soil") + expect_identical(desc, desc2) + + # Should appear in get_schema_table_names + table_names <- get_schema_table_names(mgmt_schema) + expect_true("soil_layer_list_table" %in% table_names) +}) + +test_that("subtype property with x-ui condition: animal_fert_usage in organic fertilizer", { + pr <- mgmt_schema$property_registry + desc <- lookup_property(pr, "animal_fert_usage", "fertilizer", + "fertilizer_type_organic") + expect_false(is.null(desc)) + expect_false(is.null(desc$xui$condition)) + expect_true(grepl("organic_material", desc$xui$condition)) +}) + +test_that("subtype properties with oneOf choices resolve correctly", { + pr <- mgmt_schema$property_registry + + # organic_material selectInput inside fertilizer_type_organic subtype + # has 21 oneOf choices (RE001, RE002, etc.) + om <- lookup_property(pr, "organic_material", "fertilizer", + "fertilizer_type_organic") + expect_false(is.null(om)) + expect_equal(om$type, "selectInput") + expect_true(length(om$choices) >= 20) + om_values <- vapply(om$choices, function(ch) ch$value, character(1)) + expect_true("RE003" %in% om_values) + + # fertilizer_material inside fertilizer_type_soil_amendment has 4 choices + fm <- lookup_property(pr, "fertilizer_material", "fertilizer", + "fertilizer_type_soil_amendment") + expect_false(is.null(fm)) + expect_equal(fm$type, "selectInput") + expect_true(length(fm$choices) >= 4) +}) + +test_that("get_relevant_properties includes subtype array tables", { + # observation with soil subtype should include soil_layer_list + rel <- get_relevant_properties(mgmt_schema, "observation", + "observation_type_soil") + expect_true("soil_layer_list" %in% rel$subtype_props) + expect_true("soil_layer_list" %in% rel$all) + # But without subtype, soil_layer_list should NOT appear + rel2 <- get_relevant_properties(mgmt_schema, "observation") + expect_false("soil_layer_list" %in% rel2$event_props) + expect_false("soil_layer_list" %in% rel2$all) +}) + +# --- Remaining edge cases ----------------------------------------------------- + +test_that("tillage event has no subtypes despite having a selectInput practice field", { + till <- mgmt_schema$event_registry[["tillage"]] + expect_false(till$has_subtypes) + expect_null(till$subtype_discriminator) + # tillage_practice is a regular selectInput + tp <- lookup_property(mgmt_schema$property_registry, "tillage_practice", "tillage") + expect_equal(tp$type, "selectInput") + expect_true(length(tp$choices) > 0) +}) From d987a7902dee85c031d5b7287cf95a63dc761c92 Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Wed, 25 Mar 2026 00:50:13 +0530 Subject: [PATCH 2/6] fix: if we add and remove empty rows the validator still checks for the deleted row's data --- R/mod_form.R | 12 ++++++------ R/mod_table.R | 28 +++++++++++++++++++++------- man/build_structure_lookup_list.Rd | 2 +- man/copy_file.Rd | 25 ++++++++++--------------- man/create_ui.Rd | 3 ++- man/delete_file.Rd | 9 +++------ man/get_selectInput_choices.Rd | 3 +-- man/read_json_file.Rd | 6 +++--- man/reset_input_fields.Rd | 10 ++-------- man/update_ui_element.Rd | 9 +++------ 10 files changed, 52 insertions(+), 55 deletions(-) diff --git a/R/mod_form.R b/R/mod_form.R index 9234e90..73909ed 100644 --- a/R/mod_form.R +++ b/R/mod_form.R @@ -135,19 +135,19 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, added_rules <- FALSE if (isTRUE(desc$required)) { - iv$add_rule(prop_name, sv_required(message = "")) + iv$add_rule(prop_name, sv_required(message = "Required")) added_rules <- TRUE } - + if (!is.null(desc$minimum)) { - iv$add_rule(prop_name, sv_gte(desc$minimum, allow_na = TRUE, - message_fmt = "")) + iv$add_rule(prop_name, sv_gte(desc$minimum, allow_na = TRUE, + message_fmt = "Must be >= {rhs}")) added_rules <- TRUE } - + if (!is.null(desc$maximum)) { iv$add_rule(prop_name, sv_lte(desc$maximum, allow_na = TRUE, - message_fmt = "")) + message_fmt = "Must be <= {rhs}")) added_rules <- TRUE } diff --git a/R/mod_table.R b/R/mod_table.R index 153b00c..344698b 100644 --- a/R/mod_table.R +++ b/R/mod_table.R @@ -744,24 +744,38 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, if (widget_name %in% rules_added) return() + # Extract the row number from the widget name (e.g. "crop_name_2" -> 2) + row_num <- as.integer(sub(paste0("^", variables[i], "_"), "", widget_name)) + + child_iv <- InputValidator$new() + if (isTRUE(col_desc$required)) { - iv$add_rule(widget_name, sv_required(message = "")) + child_iv$add_rule(widget_name, sv_required(message = "Required")) } if (!is.null(col_desc$minimum)) { - iv$add_rule(widget_name, sv_gte(col_desc$minimum, allow_na = TRUE, - message_fmt = "")) + child_iv$add_rule(widget_name, sv_gte(col_desc$minimum, allow_na = TRUE, + message_fmt = "Must be >= {rhs}")) } if (!is.null(col_desc$maximum)) { - iv$add_rule(widget_name, sv_lte(col_desc$maximum, allow_na = TRUE, - message_fmt = "")) + child_iv$add_rule(widget_name, sv_lte(col_desc$maximum, allow_na = TRUE, + message_fmt = "Must be <= {rhs}")) } if (isTRUE(col_desc$is_integer)) { - iv$add_rule(widget_name, function(value) { + child_iv$add_rule(widget_name, function(value) { if (is.null(value) || is.na(value)) return(NULL) - if (value != floor(value)) return("") + if (value != floor(value)) return("Must be a whole number") NULL }) } + + # Only validate when this row still exists + local({ + local_row <- row_num + child_iv$condition(reactive({ + local_row %in% dynamic_rows() + })) + }) + iv$add_validator(child_iv) }) rules_added <<- c(rules_added, widgets) } diff --git a/man/build_structure_lookup_list.Rd b/man/build_structure_lookup_list.Rd index 85d9835..182ed4a 100644 --- a/man/build_structure_lookup_list.Rd +++ b/man/build_structure_lookup_list.Rd @@ -12,5 +12,5 @@ The lookup list. \description{ Build a list where the names are the code names of UI elements and the values are the corresponding element structures (lists) found in -ui_structure.json +ui_structure.json. Now only contains app chrome elements. } diff --git a/man/copy_file.Rd b/man/copy_file.Rd index 68ba4c3..6605a2d 100644 --- a/man/copy_file.Rd +++ b/man/copy_file.Rd @@ -24,31 +24,26 @@ copy_file( \item{block}{The block where the event took place} -\item{date}{The day of the event as a character string, the format must be -yyyy-mm-dd} +\item{date}{The day of the event as a character string, format yyyy-mm-dd} -\item{filepath_is_relative}{If TRUE, json_file_base_folder will be added to -the beginning of filepath} +\item{filepath_is_relative}{If TRUE, json_file_base_folder will be added} \item{delete_original}{Should the original file be deleted after copying?} -\item{base_folder}{Included for testing reasons, the default value should -otherwise be used} +\item{base_folder}{Included for testing reasons} } \value{ -A path to the new location of the file relative to the events.json - file. +A path to the new location of the file relative to events.json. } \description{ When a file (image) is uploaded through a fileInput widget, it is saved to a temporary folder. This function copies that file to an appropriate directory -and name. The file does not have to be originally in a temporary -folder, any file path is ok. Therefore this function can also be used e.g. -when cloning and event and the images associated with it need to be -duplicated. +and name. The file does not have to be originally in a temporary folder — +any file path is valid. This allows the function to also be used when cloning +an event and its associated images need to be duplicated. } \details{ -The name will be of the format -yyyy-mm-dd_site_block_variable_name_# where # is a number (0, 1, 2, ...) to -ensure that files have unique names. +The new file name has the format + `yyyy-mm-dd_site_block_variable_name_#.ext` where `#` is an incrementing + number (0, 1, 2, ...) to ensure uniqueness within the target folder. } diff --git a/man/create_ui.Rd b/man/create_ui.Rd index 482c239..fc1d3ba 100644 --- a/man/create_ui.Rd +++ b/man/create_ui.Rd @@ -18,5 +18,6 @@ A list of Shiny widgets } \description{ For a given list of widget structures as read from ui_structure.json, -create_ui applies create_widget to each widget in the list +create_ui applies create_widget to each widget in the list. +Still used for app chrome rendering and by mod_table.R for legacy tables. } diff --git a/man/delete_file.Rd b/man/delete_file.Rd index 826c962..22db662 100644 --- a/man/delete_file.Rd +++ b/man/delete_file.Rd @@ -20,13 +20,10 @@ delete_file( \item{block}{The block where the event took place} \item{filepath_relative}{Set to TRUE and supply site and block if filepath is -relative to the events.json file. This allows the function to figure out -the correct path to the file.} +relative to the events.json file.} -\item{base_folder}{Included for testing reasons, the default value should -otherwise be used} +\item{base_folder}{Included for testing reasons} } \description{ -Delete the file with the path filepath. Used to delete files (images) -associated with events, e.g. canopeo_image +Delete a file } diff --git a/man/get_selectInput_choices.Rd b/man/get_selectInput_choices.Rd index e0e6541..927b01c 100644 --- a/man/get_selectInput_choices.Rd +++ b/man/get_selectInput_choices.Rd @@ -9,8 +9,7 @@ get_selectInput_choices(selectInput_code_name, language) \arguments{ \item{selectInput_code_name}{The code name of the selectInput} -\item{language}{The language to show the options in. This will be passed to -get_disp_name} +\item{language}{The language to show the options in.} } \value{ A vector of choices (code names). If language was supplied, the names diff --git a/man/read_json_file.Rd b/man/read_json_file.Rd index 776a99c..fb1c1ab 100644 --- a/man/read_json_file.Rd +++ b/man/read_json_file.Rd @@ -15,10 +15,10 @@ read_json_file(site, block, base_folder = json_file_base_folder()) otherwise be used} } \value{ -A list of events, which are themselves lists. If the corresponding - file does not exist or there are no events, returns an empty list. +A list with $events and $rotation components. } \description{ Reads the events from the events.json file specific to this site and block -combination and returns as a list of events. +combination and returns as a list of events. Applies backward-compatible +normalization for legacy events. } diff --git a/man/reset_input_fields.Rd b/man/reset_input_fields.Rd index 1774e7e..98c3527 100644 --- a/man/reset_input_fields.Rd +++ b/man/reset_input_fields.Rd @@ -13,17 +13,11 @@ reset_input_fields(session, fields_to_clear, exceptions = c("")) should be cleared} \item{exceptions}{Optional vector of variable names which should not be -cleared. This is useful if fields_to_clear is supplied with all variable -names but there are a few that should not be cleared.} +cleared.} } \value{ None, used for side effects. } \description{ -Set the specified input fields to their default empty values. -} -\note{ -This doesn't reset the tables (e.g. harvest_crop_table) -- they reset - themselves every time they become hidden. Also doesn't reset fileInputs, - they have their own way of clearing their value. +Reset the value of input fields } diff --git a/man/update_ui_element.Rd b/man/update_ui_element.Rd index af39ed5..8dcb38d 100644 --- a/man/update_ui_element.Rd +++ b/man/update_ui_element.Rd @@ -11,14 +11,11 @@ update_ui_element(session, code_name, value = NULL, clear_value = FALSE, ...) \item{code_name}{The code name of the UI element to update} -\item{value}{An atomic vector holding the desired value of the UI element. If -NULL, the value of the element is not altered.} +\item{value}{An atomic vector holding the desired value of the UI element.} -\item{clear_value}{If set to TRUE, the value of the element is cleared (and -any value supplied to value is ignored)} +\item{clear_value}{If set to TRUE, the value of the element is cleared.} -\item{...}{Additional arguments (such as label) to pass to Shiny's update- -functions.} +\item{...}{Additional arguments to pass to Shiny's update functions.} } \description{ Determines the type of the element and updates its value using shiny's update From 54f549cb8b64fcfb39a2aab710191a6bd7b92c01 Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Wed, 25 Mar 2026 01:12:40 +0530 Subject: [PATCH 3/6] chore: revert comments --- R/app_server.R | 17 ++++++++-- R/fct_files.R | 62 ++++++++++++++++++++++++++--------- R/fct_language.R | 3 ++ R/fct_ui.R | 53 +++++++++++++++++++++++++----- R/mod_form.R | 85 ++++++++++++++++++++++++++++++++++++------------ R/utils_global.R | 11 +++++-- 6 files changed, 183 insertions(+), 48 deletions(-) diff --git a/R/app_server.R b/R/app_server.R index bde3e45..1b28225 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -667,17 +667,28 @@ app_server <- function(input, output, session) { observeEvent(input$language, ignoreInit = TRUE, { if (dp()) message("input$language changed") - + + # get a list of all input elements which we have to relabel input_element_names <- names(reactiveValuesToList(input)) - + for (code_name in input_element_names) { - element <- structure_lookup_list[[code_name]] + + # find element in the UI structure lookup list + element <- structure_lookup_list[[code_name]] + + # didn't find the element corresponding to code_name + # this should not happen if the element is in + # sidebar_ui_structure.json if (is.null(element$type)) next label <- get_disp_name(element$label, input$language) if (element$type == "selectInput") { + + # fetch choices for the selectInput choices <- get_selectInput_choices(code_name, input$language) + + # make sure we don't change the selected value current_value <- input[[code_name]] if (is.null(choices)) { diff --git a/R/fct_files.R b/R/fct_files.R index 6495624..04e0bd3 100644 --- a/R/fct_files.R +++ b/R/fct_files.R @@ -36,8 +36,10 @@ legacy_name_map <- c( #' #' @return TRUE if the directory was created successfully or already exists, #' FALSE otherwise. -create_file_folder <- function(site, block, +create_file_folder <- function(site, block, base_folder = json_file_base_folder()) { + # if the events directory (stored in json_file_base_folder) doesn't exist, + # stop if (!dir.exists(base_folder)) { stop(glue("Could not find folder {json_file_base_folder}")) } @@ -60,11 +62,15 @@ create_file_folder <- function(site, block, #' otherwise be used write_json_file <- function(site, block, event_list, rotation_list, base_folder = json_file_base_folder()) { - + + # this ensures that the folder to store this file exists create_file_folder(site, block) - + file_path <- file.path(base_folder, site, block, "events.json") - + + # if there are events in the list, do the following: + # - erase block information in each event + # - apply other exceptions if (length(event_list) > 0) { for (i in 1:length(event_list)) { event_list[[i]]$block <- NULL @@ -86,18 +92,23 @@ write_json_file <- function(site, block, event_list, rotation_list, ##### } } - + + # If rotations on the list --> erase the block information like with events if (length(rotation_list) > 0) { for (j in 1:length(rotation_list)) { rotation_list[[j]]$block <- NULL } } - + + # create appropriate structure experiment <- list() experiment$management <- list() + + # rotation will be part of the management experiment$management$rotation <- rotation_list experiment$management$events <- event_list + # create file jsonlite::write_json(experiment, path = file_path, pretty = TRUE, null = "list", auto_unbox = TRUE) } @@ -118,7 +129,8 @@ read_json_file <- function(site, block, base_folder = json_file_base_folder()) { file_path <- file.path(base_folder, site, block, "events.json") - + + # if file doesn't exist or given names are empty, can't read it if (!file.exists(file_path)) { return(list()) } @@ -130,11 +142,13 @@ read_json_file <- function(site, block, rotation <- jsonlite::fromJSON(file_path, simplifyDataFrame = FALSE)$management$rotation - + + # if there are no events, return an empty list if (length(events) == 0) { return(list()) } - + + # add block information and apply exceptions to each event for (i in 1:length(events)) { events[[i]]$block <- block @@ -150,13 +164,16 @@ read_json_file <- function(site, block, ##### } - + + # add block info for rotations if (length(rotation) != 0){ for (j in 1:length(rotation)) { rotation[[j]]$block <- block } } - + + # Add events and rotation as a list objects which both will be returned + # when function is called management$events <- events management$rotation <- rotation @@ -204,33 +221,44 @@ normalize_legacy_event <- function(event) { copy_file <- function(orig_filepath, variable_name, site, block, date, filepath_is_relative = FALSE, delete_original = FALSE, base_folder = json_file_base_folder()) { + # ensures the folder for this site-block combo is there create_file_folder(site, block) - + + # add json_file_base_folder to filepath if requested if (filepath_is_relative) { orig_filepath <- file.path(base_folder, orig_filepath) } - + + # check that the temporary file actually exists if (!file.exists(orig_filepath)) { stop(glue("The file {orig_filepath} to copy does not exist")) } file_extension <- tolower(tools::file_ext(orig_filepath)) allowed_extensions <- c("jpg", "jpeg", "tif", "tiff", "png") + # if the image format is not supported, stop if (!(file_extension %in% allowed_extensions)) { stop("This file extension is not supported") } - + + # base of the new file name file_base <- paste(date, site, block, variable_name, sep = "_") + + # path to the final file folder filepath <- file.path(base_folder, site, block, variable_name) if (!dir.exists(filepath)) { dir.create(filepath) } - + + # determine the number to add to the end of the file name to keep file names + # in the folder unique number <- 0 while (TRUE) { file_name <- paste(file_base, number, sep = "_") file_name <- paste(file_name, file_extension, sep = ".") if (!file.exists(file.path(filepath, file_name))) { + # we found a unique name. It will be available in file_name after + # the loop break } number <- number + 1 @@ -247,6 +275,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, warning = function(cnd) {message(cnd); FALSE}, error = function(cnd) {message(cnd); FALSE}) + # if we succeeded in renaming, delete the original file if requested if (success & delete_original) { deleted_original <- tryCatch(expr = file.remove(orig_filepath), warning = function(cnd) {message(cnd)}, @@ -264,6 +293,9 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, #' Delete a file #' +#' Delete the file with the path filepath. Used to delete files (images) +#' associated with events, e.g. canopeo_image +#' #' @param filepath The path to the file which should be deleted. #' @param filepath_relative Set to TRUE and supply site and block if filepath is #' relative to the events.json file. diff --git a/R/fct_language.R b/R/fct_language.R index 1ddc2ae..676b59c 100644 --- a/R/fct_language.R +++ b/R/fct_language.R @@ -155,6 +155,8 @@ replace_with_display_names <- function(events_with_code_names, language) { } if (element$type == "selectInput") { + # the pasting is done to ensure we get a nicely formatted name + # when x is a character vector events_with_display_names[[variable_name]] <- sapply(events_with_code_names[[variable_name]], FUN = function(x) { @@ -208,6 +210,7 @@ set_login_language <- function(language) { if (identical(language, "disp_name_fin")) { shinymanager::set_labels( language = "en", + # the \U codes are UTF-8 codes for Finnish letters a and o with dots "Please authenticate" = "Kirjaudu sy\U00f6tt\U00e4\U00e4ksesi tapahtumia", "Username:" = "Sijainti", "Password:" = "Salasana", diff --git a/R/fct_ui.R b/R/fct_ui.R index c1b743b..c482302 100644 --- a/R/fct_ui.R +++ b/R/fct_ui.R @@ -1,4 +1,5 @@ # Builds the ui based on a json file +# e.g. builds additional options for the different activity types # Otto Kuusela 2021 structure_file_path <- function() system.file("extdata", "ui_structure.json", @@ -24,10 +25,13 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { if (!is.list(element)) { next } - + + # x is a list, so let's test it result <- fun(element, ...) - + if (!is.null(result)) { + # if we have a naming function defined, use that + # index is either an actual index or name of the element if (is.null(name_fun)) { index <- length(results) + 1 } else { @@ -36,7 +40,9 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { results[[index]] <- result } - + + # more results might lurk on lower levels of the list. + # So let's investigate those more_results <- rlapply(element, fun, name_fun, ...) if (length(more_results) > 0) { @@ -62,6 +68,7 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { build_structure_lookup_list <- function() { element_fetcher <- function(x) { if (!is.null(x$code_name)) { + # we don't need the sub_elements listed, those will come separately x$sub_elements <- NULL return(x) } else { @@ -78,7 +85,12 @@ build_structure_lookup_list <- function() { structure_lookup_list <- build_structure_lookup_list() -# Categorize code names by type for text outputs, tables, and fileInputs +# help texts (technically textOutputs) have a different method of updating +# when the language is changed because they are outputs rather than inputs, +# and for that we need a list of the code names of these objects. +# The same goes for data tables (excluding event table). +# We also need the code names of fileInput delete buttons to set up observers +# for them text_output_code_names <- NULL data_table_code_names <- NULL fileInput_code_names <- NULL @@ -117,6 +129,10 @@ create_ui <- function(widget_structure_list, ns) { return(new_elements) } +# creates the individual elements +# the override_label and ... functionalities are used for creating elements +# in dynamic (e.g. multi-crop) data tables. Do NOT supply the label argument in +# the unnamed arguments (...)! create_widget <- function(element, ns = NS(NULL), override_label = NULL, override_code_name = NULL, @@ -125,14 +141,22 @@ create_widget <- function(element, ns = NS(NULL), override_selected = NULL, override_placeholder = NULL, ...) { + # element is a string, i.e. a visibility condition for a element set + # it has already been handled in create_ui if (!is.list(element)) { return() } - + + # element is a list of elements, because it doesn't have the type + # attribute. In that case we want to create all of the elements in that list if (is.null(element$type)) { return(create_ui(element, ns)) } - + + # the labels will be set to element$label which is a code_name, not a + # display_name, but this is okay as the server will update this as the + # language changes (which also happens when the program starts) + # the following allows overwriting the label through ... element_label <- get_disp_name(element$label, init_lang) if (!is.null(override_label)) { element_label <- override_label @@ -161,14 +185,17 @@ create_widget <- function(element, ns = NS(NULL), new_element <- if (element$type == "checkboxInput") { checkboxInput(element_code_name, label = element_label, ...) } else if (element$type == "selectInput") { + # if multiple is defined (=TRUE) then pass that to selectInput multiple <- identical(element$multiple, TRUE) - selectInput(element_code_name, label = element_label, + # we don't enter choices yet, that will be handled by the server + selectInput(element_code_name, label = element_label, choices = element_choices, multiple = multiple, selected = override_selected, ...) } else if (element$type == "textOutput") { if (!is.null(element$style) && element$style == "label") { strong(textOutput(element_code_name, ...)) } else { + # these are inteded to look like helpTexts so make text gray tagList( span(textOutput(element_code_name, ...), style = "color:gray"), br() @@ -204,7 +231,8 @@ create_widget <- function(element, ns = NS(NULL), } else if (element$type == "actionButton") { # } - + + # if there are sub-elements to create, do that if (!is.null(element$sub_elements)) { return(list(new_element, create_ui(element$sub_elements, ns))) @@ -221,6 +249,15 @@ create_widget <- function(element, ns = NS(NULL), #' @return A vector of choices (code names). If language was supplied, the names #' will be the names of the vector. get_selectInput_choices <- function(selectInput_code_name, language) { + # the choices for a selectInput element can be stored in + # three ways: + # 1) the code names of the choices are given as a vector + # 2) for site and block selectors, there is IGNORE: + # this means that the choices should not be updated here (return NULL) + # 3) the category name for the choices is given. + # in the following if-statement, these are handled + # in this same order + element_structure <- structure_lookup_list[[selectInput_code_name]] if (!identical(element_structure$type, "selectInput") || diff --git a/R/mod_form.R b/R/mod_form.R index 73909ed..8c14eb4 100644 --- a/R/mod_form.R +++ b/R/mod_form.R @@ -23,17 +23,25 @@ mod_form_ui <- function(id){ iso <- lang_to_iso(init_lang) tagList( + + # the form contains the widgets for entering information + # about the event fluidRow( column(width = 3, h3(textOutput(ns("form_title")), style = "margin-bottom = 0px; margin-top = 0px; margin-block-start = 0px"), - span(textOutput(ns("required_variables_helptext")), + # in general the choices and labels don't have to be + # defined for selectInputs, as they will be + # populated when the language is changed + # (which also happens when the app starts) + + span(textOutput(ns("required_variables_helptext")), style = "color:gray"), br(), - - selectInput(ns("block"), label = get_disp_name("block_label", + + selectInput(ns("block"), label = get_disp_name("block_label", init_lang), choices = ""), @@ -44,7 +52,8 @@ mod_form_ui <- function(id){ iso, "event"), choices = build_event_type_choices(mgmt_schema, iso) ), - + + # setting max disallows inputting future events dateInput( ns("date"), format = "dd/mm/yyyy", @@ -122,8 +131,12 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, er <- schema$event_registry pr <- schema$property_registry + # add input validators + # the idea is that each widget has its own validator. This validator is + # active whenever that widget is in relevant variables. These individual + # validators are then added as subvalidators to main_iv main_iv <- InputValidator$new() - + all_props <- get_all_schema_properties(schema) for (prop_name in all_props) { # Try to find descriptor from any event/subtype context @@ -133,24 +146,28 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, iv <- InputValidator$new() added_rules <- FALSE - + + # add required rule if (isTRUE(desc$required)) { iv$add_rule(prop_name, sv_required(message = "Required")) added_rules <- TRUE } + # add minimum rule if (!is.null(desc$minimum)) { iv$add_rule(prop_name, sv_gte(desc$minimum, allow_na = TRUE, message_fmt = "Must be >= {rhs}")) added_rules <- TRUE } + # add maximum rule if (!is.null(desc$maximum)) { iv$add_rule(prop_name, sv_lte(desc$maximum, allow_na = TRUE, message_fmt = "Must be <= {rhs}")) added_rules <- TRUE } + # add integer rule if (isTRUE(desc$is_integer)) { iv$add_rule(prop_name, function(value) { if (is.null(value) || is.na(value)) return(NULL) @@ -161,15 +178,19 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, } if (added_rules) { + # the validator is only active when it is in the current list of + # relevant, regular widgets local({ local_prop <- prop_name - iv$condition(reactive({ - local_prop %in% relevant_variables()$regular + iv$condition(reactive({ + local_prop %in% relevant_variables()$regular })) }) + # add widget validator to main validator main_iv$add_validator(iv) } } + # start showing validation messages main_iv$enable() # when site setting is changed, update the block choices on the form @@ -182,7 +203,8 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, shinyjs::enable("block") shinyjs::enable("save") - + + # update block choices block_choices <- subset(sites, sites$site == site())$blocks[[1]] updateSelectInput(session, "block", choices = block_choices) }) @@ -193,7 +215,9 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, values <- set_values() iso <- lang_to_iso(language()) - + + # populate the input widgets with the values corresponding to the + # event, and clear others relevant <- get_relevant_properties( schema, values$mgmt_operations_event %||% "", @@ -259,9 +283,12 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, value = values$mgmt_event_notes) } + # change set_values back to NULL so that we can catch the next time its + # value is changed. This doesn't re-trigger this observeEvent as + # observeEvent ignores NULL values by default set_values(NULL) }) - + # when reset_values is signaled, reset the values of all widgets observeEvent(reset_values(), { if (identical(reset_values(), FALSE)) return() @@ -295,14 +322,18 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, shinyjs::toggle("delete", condition = edit_mode()) }) - # text outputs (form_title, required_variables_helptext) + # update each of the text outputs automatically, including language changes + # and the dynamic updating in editing table title etc. lapply(text_output_code_names, FUN = function(text_output_code_name) { + # render text output[[text_output_code_name]] <- renderText({ if (dp()) message(glue("Rendering text for {text_output_code_name}")) text_to_show <- get_disp_name(text_output_code_name, language()) + #get element from the UI structure lookup list element <- structure_lookup_list[[text_output_code_name]] + #if the text should be updated dynamically, do that if (!is.null(element$dynamic)) { if (element$dynamic$mode == "edit_mode") { text_to_show <- if (edit_mode()) { @@ -510,23 +541,25 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, } }) + # when requested, prepare the entered data form_data <- reactive({ if (dp()) message("Calculating form data") - + relevant <- relevant_variables() - + relevant_table <- NULL if (length(relevant$table_name) > 0 && !is.null(tables[[relevant$table_name]])) { relevant_table <- tables[[relevant$table_name]]$result } - - if (!main_iv$is_valid() || + + # check that the form and table validation rules have been met + if (!main_iv$is_valid() || (!is.null(relevant_table) && !relevant_table$valid())) { return(NULL) } event <- list() - + # fill information event$mgmt_operations_event <- input[["mgmt_operations_event"]] event$date <- tryCatch( format(input[["date"]], date_format_json), @@ -555,13 +588,17 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, input[[prop_name]] } + # if value is character, trim any whitespace around it if (is.character(value)) value <- trimws(value) - + + # format Date value to character string and replace with "" if that + # fails for some reason if (inherits(value, "Date")) { value <- tryCatch(format(value, date_format_json), error = function(cnd) "") } - + + # if the value is not defined or empty, replace with missingval if (length(value) == 0) { value <- missingval } else { @@ -595,9 +632,17 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, } } + # return event data event }) - + + # When requested, calculate a vector with the names of relevant variables. A + # variable is relevant when it is visible in some form, either as a regular + # widget or in a table module. Relevant variables are ones which we want to + # save to a json file given the current choices of the user. For example, + # when the user is making a soil observation event, the variables related + # to that are relevant while other observation variables are not. + # This only works when the form is already open. relevant_variables <- reactive({ if (dp()) message("Calculating relevant variables") diff --git a/R/utils_global.R b/R/utils_global.R index c30c18d..a6323eb 100644 --- a/R/utils_global.R +++ b/R/utils_global.R @@ -6,8 +6,11 @@ missingval <- "-99.0" date_format_json <- "%Y-%m-%d" date_format_display <- "%d/%m/%Y" -# read the csv file containing the sites -sites_file_path <- function() system.file("extdata", "FOsites.csv", +# read the csv file containing the sites +# the path is wrapped inside a function because of this: +# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html +# see: "Paths hard-coded in R code" +sites_file_path <- function() system.file("extdata", "FOsites.csv", package = "fieldactivity") sites <- read.csv(sites_file_path()) # converts block info from csv (e.g. "[0;1]") to vectors of strings ("0" "1") @@ -15,6 +18,10 @@ blocks_to_vector <- function(x) strsplit(substr(x, start = 2, stop = nchar(x)-1) sites$blocks <- sapply(sites$blocks, blocks_to_vector) # options for UI languages +# languages match the names of columns in display_names.csv +# when you give a named vector as the choices for selectInput, the names +# rather than the values will be displayed +# the \U codes are UTF-8 flag emojis languages <- c("English \U0001f1ec\U0001f1e7" = "disp_name_eng", "suomi \U0001f1eb\U0001f1ee" = "disp_name_fin", "svenska \U0001f1f8\U0001f1ea" = "disp_name_swe") From baac4387739f921c4af22a3b483c9259b50cf2ab Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Wed, 25 Mar 2026 02:14:01 +0530 Subject: [PATCH 4/6] refactor: remove code that was related to ui_structure.json --- DESCRIPTION | 5 - NAMESPACE | 1 - R/fct_schema.R | 4 +- R/fct_ui.R | 225 ----------- R/mod_download.R | 29 +- R/mod_rotation_cycle.R | 4 +- R/mod_table.R | 591 ----------------------------- R/mod_table_utils.R | 72 ---- R/utils_validation.R | 13 - inst/extdata/display_names.csv | 1 + man/create_ui.Rd | 23 -- man/delete_file.Rd | 3 +- man/get_dynamic_rows_from_value.Rd | 23 -- man/get_table_variables.Rd | 22 -- man/get_variable_table.Rd | 18 - man/reset_input_fields.Rd | 23 -- man/update_ui_element.Rd | 23 -- man/valid_dateRangeInput.Rd | 18 - tests/testthat/test-fct_schema.R | 7 +- 19 files changed, 9 insertions(+), 1096 deletions(-) delete mode 100644 R/mod_table_utils.R delete mode 100644 R/utils_validation.R delete mode 100644 man/create_ui.Rd delete mode 100644 man/get_dynamic_rows_from_value.Rd delete mode 100644 man/get_table_variables.Rd delete mode 100644 man/get_variable_table.Rd delete mode 100644 man/reset_input_fields.Rd delete mode 100644 man/update_ui_element.Rd delete mode 100644 man/valid_dateRangeInput.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 92d2243..c9ea355 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -10,19 +10,14 @@ Description: An app for keeping track of field activity in the Field ICASA standards for agricultural data. License: BSD_3_clause + file LICENSE Imports: - attempt, bslib, callr, config (>= 0.3.1), DT (>= 0.25), - ggplot2, glue, golem (>= 0.3.1), htmlwidgets, jsonlite, - methods, - pkgload, - processx, rmarkdown, shiny (>= 1.6.0), shinyjs, diff --git a/NAMESPACE b/NAMESPACE index 056b67a..d8c9885 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,6 @@ # Generated by roxygen2: do not edit by hand export(run_app) -import(ggplot2) import(rmarkdown) import(shiny) import(shinyvalidate) diff --git a/R/fct_schema.R b/R/fct_schema.R index f284c94..12742ed 100644 --- a/R/fct_schema.R +++ b/R/fct_schema.R @@ -423,8 +423,8 @@ lang_to_iso <- function(language) { "fi" = "fi", "sv" = "sv" ) - result <- mapping[[language]] - if (is.null(result)) "en" else result + result <- mapping[language] + if (is.na(result) || is.null(result)) "en" else unname(result) } #' Build a named choice vector for selectInput from schema choices diff --git a/R/fct_ui.R b/R/fct_ui.R index c482302..abce53e 100644 --- a/R/fct_ui.R +++ b/R/fct_ui.R @@ -88,159 +88,18 @@ structure_lookup_list <- build_structure_lookup_list() # help texts (technically textOutputs) have a different method of updating # when the language is changed because they are outputs rather than inputs, # and for that we need a list of the code names of these objects. -# The same goes for data tables (excluding event table). # We also need the code names of fileInput delete buttons to set up observers # for them text_output_code_names <- NULL -data_table_code_names <- NULL fileInput_code_names <- NULL for (element in structure_lookup_list) { if (element$type == "textOutput") { text_output_code_names <- c(text_output_code_names, element$code_name) - } else if (element$type == "dataTable") { - data_table_code_names <- c(data_table_code_names, element$code_name) } else if (element$type == "fileInput") { fileInput_code_names <- c(fileInput_code_names, element$code_name) } } -#' Generate the UI for a list of elements in the structure file. -#' -#' For a given list of widget structures as read from ui_structure.json, -#' create_ui applies create_widget to each widget in the list. -#' Still used for app chrome rendering and by mod_table.R for legacy tables. -#' -#' @param widget_structure_list The list of widget structures (from -#' ui_structure.json) to generate as UI -#' @param ns A namespacing function generated by shiny::NS to apply to the id's -#' of each generated widget -#' -#' @return A list of Shiny widgets -create_ui <- function(widget_structure_list, ns) { - new_elements <- lapply(widget_structure_list, create_widget, ns = ns) - - if (!is.null(widget_structure_list$condition)) { - new_elements <- conditionalPanel( - condition = widget_structure_list$condition, - new_elements, - ns = ns) - } - - return(new_elements) -} - -# creates the individual elements -# the override_label and ... functionalities are used for creating elements -# in dynamic (e.g. multi-crop) data tables. Do NOT supply the label argument in -# the unnamed arguments (...)! -create_widget <- function(element, ns = NS(NULL), - override_label = NULL, - override_code_name = NULL, - override_value = NULL, - override_choices = NULL, - override_selected = NULL, - override_placeholder = NULL, ...) { - - # element is a string, i.e. a visibility condition for a element set - # it has already been handled in create_ui - if (!is.list(element)) { - return() - } - - # element is a list of elements, because it doesn't have the type - # attribute. In that case we want to create all of the elements in that list - if (is.null(element$type)) { - return(create_ui(element, ns)) - } - - # the labels will be set to element$label which is a code_name, not a - # display_name, but this is okay as the server will update this as the - # language changes (which also happens when the program starts) - # the following allows overwriting the label through ... - element_label <- get_disp_name(element$label, init_lang) - if (!is.null(override_label)) { - element_label <- override_label - } - - element_code_name <- ns(element$code_name) - if (!is.null(override_code_name)) { - element_code_name <- ns(override_code_name) - } - - element_value <- "" - if (!is.null(override_value)) { - element_value <- override_value - } - - element_choices <- get_selectInput_choices(element$code_name, init_lang) - if (!is.null(override_choices)) { - element_choices <- override_choices - } - - element_placeholder <- get_disp_name(element$placeholder, init_lang) - if (!is.null(override_placeholder)) { - element_placeholder <- override_placeholder - } - - new_element <- if (element$type == "checkboxInput") { - checkboxInput(element_code_name, label = element_label, ...) - } else if (element$type == "selectInput") { - # if multiple is defined (=TRUE) then pass that to selectInput - multiple <- identical(element$multiple, TRUE) - # we don't enter choices yet, that will be handled by the server - selectInput(element_code_name, label = element_label, - choices = element_choices, multiple = multiple, - selected = override_selected, ...) - } else if (element$type == "textOutput") { - if (!is.null(element$style) && element$style == "label") { - strong(textOutput(element_code_name, ...)) - } else { - # these are inteded to look like helpTexts so make text gray - tagList( - span(textOutput(element_code_name, ...), style = "color:gray"), - br() - ) - } - } else if (element$type == "textInput") { - textInput(inputId = element_code_name, label = element_label, - value = element_value, placeholder = element_placeholder, ...) - } else if (element$type == "numericInput") { - numericInput(inputId = element_code_name, - label = element_label, - min = element$min, - max = ifelse(is.null(element$max),NA,element$max), - value = element_value, - step = ifelse(is.null(element$step),"any",element$step), - ...) - } else if (element$type == "textAreaInput") { - textAreaInput(element_code_name, - label = element_label, - resize = "vertical", - value = element_value, - placeholder = element_placeholder, ...) - } else if (element$type == "dataTable") { - mod_table_ui(element_code_name) - } else if (element$type == "fileInput") { - mod_fileInput_ui(element_code_name, element) - } else if (element$type == "dateRangeInput") { - dateRangeInput(element_code_name, - label = element_label, - separator = "-", - weekstart = 1, - max = Sys.Date()) - } else if (element$type == "actionButton") { - # - } - - # if there are sub-elements to create, do that - if (!is.null(element$sub_elements)) { - return(list(new_element, - create_ui(element$sub_elements, ns))) - } - - return(new_element) -} - #' Find the choices for a selectInput given its code name #' #' @param selectInput_code_name The code name of the selectInput @@ -282,87 +141,3 @@ get_selectInput_choices <- function(selectInput_code_name, language) { return(choices) } -#' Update value, label etc. of a UI element. -#' -#' Determines the type of the element and updates its value using shiny's update -#' functions. -#' @param session Current shiny session -#' @param code_name The code name of the UI element to update -#' @param value An atomic vector holding the desired value of the UI element. -#' @param clear_value If set to TRUE, the value of the element is cleared. -#' @param ... Additional arguments to pass to Shiny's update functions. -#' @importFrom glue glue -update_ui_element <- function(session, code_name, value = NULL, - clear_value = FALSE, ...) { - element <- structure_lookup_list[[code_name]] - - if (is.null(element$type)) { - stop("UI element type not found, could not update") - } - if (!is.atomic(value)) { - stop("The value given to update_ui_element should be an atomic vector") - } - - if (!is.null(value)) { - missing_indexes <- identical(value, missingval) - if (any(missing_indexes)) { - value[missing_indexes] <- "" - } - } - - if (element$type == "selectInput") { - if (clear_value) value <- "" - updateSelectInput(session, code_name, selected = value, ...) - } else if (element$type == "dateInput") { - value <- if (clear_value) { - NULL - } else { - tryCatch(expr = as.Date(value, format = date_format_json), - warning = function(cnd) NULL) - } - updateDateInput(session, code_name, value = value, ...) - } else if (element$type == "textAreaInput") { - if (clear_value) value <- "" - updateTextAreaInput(session, code_name, value = value, ...) - } else if (element$type == "actionButton") { - updateActionButton(session, code_name, ...) - } else if (element$type == "textInput") { - if (clear_value) value <- "" - updateTextInput(session, code_name, value = value, ...) - } else if (element$type == "numericInput") { - if (clear_value) { value <- "" } - updateNumericInput(session, code_name, value = value, ...) - } else if (element$type == "dateRangeInput") { - if (!is.null(value) & length(value) != 2) { - value <- NULL - warning(glue("Value supplied to the dateRangeInput was not of ", - "length 2, resetting it")) - } - - start <- if (is.null(value) | clear_value) NULL else value[1] - end <- if (is.null(value) | clear_value) NULL else value[2] - - tryCatch(warning = function(cnd) {shinyjs::reset(code_name)}, - updateDateRangeInput(session, code_name, - start = start, end = end)) - } else if (element$type == "fileInput") { - - } -} - -#' Reset the value of input fields -#' -#' @param session The current Shiny session -#' @param fields_to_clear The names of the variables whose corresponding fields -#' should be cleared -#' @param exceptions Optional vector of variable names which should not be -#' cleared. -#' @return None, used for side effects. -reset_input_fields <- function(session, fields_to_clear, exceptions = c("")) { - exceptions <- c(exceptions, "site", "block") - - for (code_name in fields_to_clear) { - if (code_name %in% exceptions) next - update_ui_element(session, code_name, clear_value = TRUE) - } -} diff --git a/R/mod_download.R b/R/mod_download.R index a7eb776..906c7ef 100644 --- a/R/mod_download.R +++ b/R/mod_download.R @@ -43,8 +43,6 @@ mod_download_server_inst <- function(id) { # Name for the downloaded file filename = "guideFieldactivity.html", content = function(file) { - params <- list(n = input$n) - if(dp()) message("Copying instructions to temp file") # Paths to the rendered document + used images @@ -63,19 +61,12 @@ mod_download_server_inst <- function(id) { file.copy(system.file("user_doc/images_user_instructions", "Addevent.png", package = "fieldactivity"), report_img_4, overwrite = TRUE) file.copy(system.file("user_doc/images_user_instructions", "eventexample_1.png", package = "fieldactivity"), report_img_5, overwrite = TRUE) - # id <- showNotification( - # "Rendering report...", - # duration = 8, - # closeButton = FALSE - # ) - # on.exit(removeNotification(id), add = TRUE) - if (dp()) message("Moving to rendering the .md file") # Path to the instructions .md which will be rendered callr::r( render_report, - list(input = report_path, output = file, params = params) + list(input = report_path, output = file, params = list()) ) } ) @@ -262,21 +253,3 @@ mod_download_server_json <- function(id, user_auth, base_folder = json_file_base -#' download Server Function -#' -#' @noRd -# mod_download_serverxx <- function(input, output, session){ -# ns <- session$ns -# data_xi <- "string" -# -# output$report <- downloadHandler( -# -# filename = function(){ -# paste("sitemxt", "csv", sep = ".") -# }, -# -# content = function(file){ -# write.csv(data_xi, file) -# } -# ) -# } diff --git a/R/mod_rotation_cycle.R b/R/mod_rotation_cycle.R index 09446c9..9b9bf9c 100644 --- a/R/mod_rotation_cycle.R +++ b/R/mod_rotation_cycle.R @@ -19,9 +19,7 @@ mod_rotation_cycle_ui <- function(id){ #' rotation_cycle Server Functions #' -#' @noRd -#' -#' @import ggplot2 +#' @noRd mod_rotation_cycle_server <- function(id, rotation, site, block){ # site needs to be added at some point stopifnot(is.reactive(rotation)) diff --git a/R/mod_table.R b/R/mod_table.R index 344698b..2974da7 100644 --- a/R/mod_table.R +++ b/R/mod_table.R @@ -54,597 +54,6 @@ mod_table_ui <- function(id) { br() ) } - -#' table Server Functions -#' -#' @param id The id of the corresponding UI element -#' @param row_variable_value A reactive expression holding the value of the -#' variable which determines the rows in a dynamic row group. If there are no -#' dynamic row groups in the table, a reactive expression holding the value -#' NULL. -#' @param language A reactive expression holding the current UI language -#' @param override_values Changing the value of this reactive expression sets -#' the values in the table -#' -#' @import shinyvalidate -#' @noRd -mod_table_server <- function(id, row_variable_value, - language, override_values) { - - stopifnot(is.reactive(row_variable_value)) - stopifnot(is.reactive(language)) - stopifnot(is.reactive(override_values)) - - moduleServer(id, function(input, output, session) { - ns <- session$ns - - # This is used to slow things down when the value changes rapidly. - # throttle lets the first invalidation through but holds the subsequent - # ones for 800ms - row_variable_value <- throttle(row_variable_value, millis = 800) - - #### Validate inputs in the table - - iv <- InputValidator$new() - # start showing validation messages - iv$enable() - # which widgets have we already added rules for? - rules_added <- NULL - # Add validation rules for the specified set of widgets. widgets and - # variables should have the same length; the latter has "pure" variable - # names which correspond to the former row-numbered widget names. - # This function will be called when generating the widgets. - add_validation_rules <- function(widgets, variables) { - lapply(1:length(widgets), FUN = function(i) { - - widget_name <- widgets[i] - widget <- structure_lookup_list[[variables[i]]] - - if (widget_name %in% rules_added) return() - - # add required rule - if (identical(widget$required, TRUE)) { - iv$add_rule(widget_name, sv_required(message = "")) - } - - # add minimum rule - if (!is.null(widget$min)) { - iv$add_rule(widget_name, sv_gte(widget$min, allow_na = TRUE, - message_fmt = "")) - } - - # add maximum rule - # using [[ here because $ does partial matching and catches onto - # maxlength - if (!is.null(widget[["max"]])) { - iv$add_rule(widget_name, sv_lte(widget[["max"]], allow_na = TRUE, - message_fmt = "")) - } - - }) - rules_added <- c(rules_added, widgets) - } - - #### Find out useful information about the table - - table_structure <- structure_lookup_list[[id]] - row_groups <- table_structure$rows - # can be NULL, in which case all row groups are of type 'static' - column_names <- table_structure$columns - static_mode <- is.null(column_names) - - if (!static_mode) { - # find the row variable - for (row_group in row_groups) { - if (row_group$type == 'dynamic') { - # row_variable will be available outside this loop - row_variable <- row_group$row_variable - # there is only one dynamic row group - break - } - } - } - - n_cols <- if (static_mode) { - max(sapply(row_groups, FUN = function(x) length(x$variables))) - } else { - length(column_names) - } - - # entered values before we e.g. add rows. This allows us to get the - # values back when generating a new table - old_values <- reactiveVal() - # current values of the table - table_values <- reactiveVal() - - # whether the table is currently rendered or not - rendered <- reactiveVal(FALSE) - - # when the client sends a message that rendering is done, set rendered - # to TRUE - observeEvent(input$rendered, { - rendered(TRUE) - if (table_log) message(glue("input$rendered is {input$rendered}, ", - "rendered set to TRUE ({id})")) - }) - - # when we go hidden, set rendered to FALSE and clear old values - observeEvent(visible(), ignoreNULL = FALSE, ignoreInit = TRUE, - priority = 1, { - if (!visible()) { - if (table_log) message(glue("Rendered set to FALSE. ", - "Clearing old values ({id})")) - rendered(FALSE) - old_values(list()) - } - }) - - # Determine when the table is visible - visible <- reactive({ - if (static_mode) { - # tables in static mode are always "visible" - TRUE - } else { - length(dynamic_rows()) > 1 - } - }) - - - # this triggers the update of table_data when override_values are - # supplied and not when they are reset to NULL. The triggering - # behaviour is controller in the observeEvent below - override_trigger <- reactiveVal(0) - - # this is a trigger for updating the table widgets when rows change - row_trigger <- reactiveVal(0) - - # observeEvent ignores NULL values by default - observeEvent(override_values(), { - if (table_log) { - message(glue("Triggering value pre-filling, ", - "values are ({id})")) - utils::str(override_values()) - } - # update dynamic rows (if any) - if (!static_mode) { - dynamic_rows( - get_dynamic_rows_from_value(row_variable, - override_values()[[row_variable]]) - ) - } - override_trigger(override_trigger() + 1) - }) - - # this allows blocking extra updates caused by the widget in the main - # app changing its value after override_values have just been supplied. - observeEvent(row_variable_value(), ignoreNULL = FALSE, ignoreInit = TRUE, { - # there is no row variable in static mode - if (static_mode) return() - - new_dynamic_rows <- get_dynamic_rows_from_value(row_variable, - row_variable_value()) - - # as.character is needed because sometimes rows are numeric and that - # makes comparison simpler - if (!identical(as.character(new_dynamic_rows), - as.character(dynamic_rows()))) { - if (table_log) message(glue("Triggering the row_trigger because new ", - "rows are ", - "{paste(new_dynamic_rows, collapse = ', ')} ", - "and old ones are ", - "{paste(dynamic_rows(), collapse = ', ')} ", - "({id})")) - dynamic_rows(new_dynamic_rows) - row_trigger(row_trigger() + 1) - } else { - if (table_log) message(glue("Rows are identical so didn't ", - "trigger an update ({id})")) - } - }) - - if (!static_mode) { - # holds the current rows in the dynamic row group as a vector - dynamic_rows <- reactiveVal() - } - - # this unbinds the table elements before they are re-rendered. - # Setting a higher priority ensures this runs before the table render - observe(priority = 2, { - # when to run observer - language() # table is re-generated when language changes - visible() # required, because this updates before row_trigger - row_trigger() - override_trigger() - # require this so that we know the table has already rendered and - # is still visible. - # requiring rendered adds a layer of distance from visible: - # when visibility first goes to FALSE, rendered is still TRUE - # here because this observer has a higher priority than the one - # which sets rendered to FALSE. - req(isolate(rendered())) - session$sendCustomMessage("unbind-table", ns("table")) - if (table_log) message(glue("Sent unbind message ({id})")) - }) - - # this is a flag which, when set to TRUE, blocks the calculation of - # sums on the total row (present on harvest_crop_table). - # This is used to prevent the calculation when the widgets are first created - # and get their initial values in the table_data reactive. - block_sum_calculation <- reactiveVal(FALSE) - - calculate_sum <- function(total_variable) { - if (!static_mode) { - row_value <- isolate(dynamic_rows()) - row_numbers <- if (is.numeric(row_value)) { - row_value - } else { - 1:length(row_value) - } - } - - variable_to_sum <- structure_lookup_list[[total_variable]]$sum_of - values <- NULL - for (row_number in row_numbers) { - element_name <- paste(variable_to_sum, row_number, sep = "_") - values <- c(values, isolate(input[[element_name]])) - } - - value <- sum(values[!is.na(values)]) - update_ui_element(session, total_variable, value = value) - } - - # calculates the widgets that should be in the table - table_data <- reactive({ - # when the widgets should be re-calculated. - # table_data also re-calculates when language changes if table has - # selectInputs, text fields with placeholders or widgets - # with labels (see below) - override_trigger() - row_trigger() - - if (table_log) message(glue("Table calculation begins ({id})")) - - override_vals <- isolate(override_values()) - do_override <- !is.null(override_vals) - - table_to_display <- data.frame(matrix(nrow = 0, ncol = n_cols)) - # column_names can be NULL - names(table_to_display) <- if (is.null(column_names)) { - rep("", n_cols) - } else { - column_names - } - - if (do_override) { - # if we just want to clear the table, let's do that - if (identical(override_vals, list())) { - if (table_log) message(glue("Clearing table ({id})")) - override_values(NULL) - do_override <- FALSE - old_values(list()) - } - } - - # get all the column numbers with numericInputs so we can adjust - # the widths for these columns - #numericInput_columns <- NULL - current_row <- 1 - for (row_group in row_groups) { - - if (row_group$type == 'static') { - - current_col <- 1 - for (variable in row_group$variables) { - - element <- structure_lookup_list[[variable]] - - # if (element$type == "numericInput") { - # numericInput_columns <- - # c(numericInput_columns, - # current_col) - # } - - code_name <- variable - - value <- if (do_override) { - override_vals[[variable]] - } else { - isolate(old_values())[[variable]] - } - - if (!isTruthy(value) || value == missingval) { - value <- "" - } - - #message(glue("Value for {code_name} is {value}")) - - # add choices in the correct language for selectInputs - choices <- NULL - if (identical(element$type, "selectInput")) { - choices <- get_selectInput_choices(variable, language()) - } - - placeholder <- NULL - if (!is.null(element$placeholder)) { - placeholder <- get_disp_name(element$placeholder, - language()) - } - - label <- "" - if (!identical(row_group$hide_labels, TRUE)) { - label <- get_disp_name(element$label, language()) - } - - width <- if (element$type == "numericInput") { - 100 - } else { - 150 - } - - # as character makes the element HTML, which can then be - # not escaped when rendering the table - widget <- as.character( - create_widget(element, - ns = ns, - width = width, - override_code_name = code_name, - override_label = label, - override_value = value, - override_choices = choices, - override_selected = value, - override_placeholder = placeholder - )) - - add_validation_rules(code_name, variable) - - - table_to_display[current_row, current_col] <- widget - current_col <- current_col + 1 - } - - row_name <- ifelse(is.null(row_group$name), current_row, - row_group$name) - rownames(table_to_display)[current_row] <- row_name - - current_row <- current_row + 1 - - } else if (row_group$type == 'dynamic') { - - # the rows in the dynamic row group - rows <- isolate(dynamic_rows()) - - for (row in rows) { - # For dynamic row groups the variables on each row are - # determined by the columns of the table. - # Go through each column and add widgets to the row. - for (variable in column_names) { - - element <- structure_lookup_list[[variable]] - - # if (element$type == "numericInput") { - # numericInput_columns <- - # c(numericInput_columns, - # which(column_names == variable)) - # } - - # the code names for these elements are - # variablename_rownumber - code_name <- paste(variable, current_row, sep = "_") - - # value to show in the widget initially - value <- if (do_override) { - override_vals[[variable]][current_row] - } else { - # fetch old value to show it after rows have changed - old_row_number <- which( - isolate(old_values())[["DYNAMIC_ROWS"]] == - rows[current_row]) - isolate(old_values())[[variable]][old_row_number] - } - - if (!isTruthy(value) || value == missingval) { - value <- "" - } - - #message(glue("Value for {code_name} is {value}")) - - # add choices in the correct language for selectInputs - choices <- NULL - if (identical(element$type, "selectInput")) { - choices <- get_selectInput_choices(variable, language()) - } - - placeholder <- NULL - if (!is.null(element$placeholder)) { - placeholder <- get_disp_name(element$placeholder, - language()) - } - - width <- if (element$type == "numericInput") { - 100 - } else { - 150 - } - - # as character makes the element HTML, which can then be - # not escaped when rendering the table - widget <- as.character( - create_widget(element, - ns = ns, - width = width, - override_code_name = code_name, - override_label = "", - override_value = value, - override_choices = choices, - override_selected = value, - override_placeholder = placeholder - )) - - add_validation_rules(code_name, variable) - - table_to_display[current_row, variable] <- widget - } - - rownames(table_to_display)[current_row] <- row - current_row <- current_row + 1 - } - - } - - } - - # block calculation of sums once when the table becomes visible - block_sum_calculation(TRUE) - if (table_log) message(glue("Calculated table, has ", - "{nrow(table_to_display)} rows ({id})")) - # clear override_values - override_values(NULL) - table_to_display - }) - - output$table <- DT::renderDataTable({ - req(visible()) - if (table_log) message(glue("Starting render, rendered set to FALSE ({id})")) - - rendered(FALSE) - table_to_display <- table_data() - - if (nrow(table_to_display) == 0) { - if (table_log) message(glue("No rows, didn't render ({id})")) - return() - } - - names(table_to_display) <- get_disp_name(names(table_to_display), - language = language(), - is_variable_name = TRUE) - rownames(table_to_display) <- get_disp_name( - rownames(table_to_display), - language = language()) - - # numericInput_columns <- table_data()$numericInput_columns - # if (static_mode) { - # numericInput_columns <- numericInput_columns - 1 - # } - table_to_display <- - DT::datatable( - table_to_display, - escape = FALSE, # makes widgets actual widgets, IMPORTANT - selection = "none", - class = "table table-hover table-condensed", - rownames = !static_mode, # show rownames if not static mode - options = - list(dom = "t", # hide everything except table - # hide sorting arrows - ordering = FALSE, - # binds the inputs when drawing is done - drawCallback = htmlwidgets::JS(js_bind_script), - # calls selectize() on all selectInputs, which - # makes them look the way they should. Also asks - # the client to send the rendering done message. - initComplete = - htmlwidgets::JS(paste0( - "function(settings, json) {", - "do_selectize('", ns("table"), "'); ", - "rendering_done('", ns("rendered"), "'); }" - )), - scrollX = TRUE - )) - # if we are in custom mode, align cells vertically so that the - # widgets are always in line - if (static_mode) { - DT::formatStyle(table_to_display, 0:(n_cols-1), - 'vertical-align' = 'bottom') - } else { - table_to_display - } - - }, server = FALSE) - - - # return the values of the table widgets - # has to run when visibility changes because input values are not - # available otherwise. - # This observer also calculates the sum on the total row in - # harvest_crop_table - observe({ - - value_list <- list() - - if (!rendered()) { - if (table_log) message(glue("Values observe blocked, table not ", - "rendered yet ({id})")) - table_values(value_list) - return() - } - - # Add dependency on table_data() at this point. - # Needed, so that when new widgets are calculated, we add a - # dependency on them - table_data() - - if (table_log) message(glue("Values observe running ({id})")) - - # fetch values from widgets in static row groups - for (row_group in row_groups) { - if (row_group$type == 'static') { - for (variable in row_group$variables) { - value_list[[variable]] <- input[[variable]] - } - } - } - - if (!static_mode) { - row_value <- dynamic_rows() - row_numbers <- if (is.numeric(row_value)) { - row_value - } else { - 1:length(row_value) - } - } - # does not do anything if column names are undefined - for (variable in column_names) { - values <- NULL - - for (row_number in row_numbers) { - element_name <- paste(variable, row_number, sep = "_") - values <- c(values, input[[element_name]]) - } - - # handle calculating the total values when new values are entered - previous_vals <- isolate(table_values())[[variable]] - total_variable <- structure_lookup_list[[variable]]$sum_to - if (!is.null(total_variable) && - !identical(previous_vals, values) && - !isolate(block_sum_calculation())) { - if (table_log) message(glue("Initiating sum calculation for ", - "{total_variable}")) - calculate_sum(total_variable) - } - - value_list[[variable]] <- values - } - - block_sum_calculation(FALSE) - table_values(value_list) - # if there is a dynamic row group, let's add the current rows to old - # values so we can access them when rows change - if (!static_mode) { - value_list <- c(value_list, list(DYNAMIC_ROWS = isolate(dynamic_rows()))) - } - old_values(value_list) - - }) - - ################## RETURN VALUE - - list( - values = table_values, - valid = reactive(iv$is_valid()) - ) - - }) - -} # -- Helpers for mod_table_server_schema ------------------------------------ diff --git a/R/mod_table_utils.R b/R/mod_table_utils.R deleted file mode 100644 index 4b211f7..0000000 --- a/R/mod_table_utils.R +++ /dev/null @@ -1,72 +0,0 @@ -#' Find the table matching a variable name -#' -#' If a variable's value is entered in a table, return the name of that table -#' @param variable_name The name of the variable of interest -#' @return The code name of the table where the variable is entered, or NULL -#' if not found. -get_variable_table <- function(variable_name) { - - for (table_code_name in data_table_code_names) { - table <- structure_lookup_list[[table_code_name]] - - table_variables <- get_table_variables(table_code_name) - - if (variable_name %in% table_variables) { - return(table_code_name) - } - } - - return(NULL) -} - -#' Find the variables whose value can be entered through a given table -#' -#' @param table_code_name The name of the table whose variables to fetch. -#' @return A vector of variable names whose values are entered in a table. -#' @note If a table has a dynamic row group whose rows are determined by an -#' input widget's value, that widget's variable name will not be returned even -#' though it could be read from the list returned by the table module. -get_table_variables <- function(table_code_name) { - structure <- structure_lookup_list[[table_code_name]] - variables <- NULL - - # if a table has a dynamic row group, add the variables present on the columns - if (!is.null(structure$columns)) { - variables <- c(variables, structure$columns) - } - - # add the variables from all static row groups - for (row_group in structure$rows) { - if (row_group$type == "static") { - variables <- c(variables, row_group$variables) - } - } - - return(variables) -} - -#' Determine the dynamic rows based on row variable value -#' -#' This is used to go from the value of a variable determining the rows in a -#' dynamic row group to the rows themselves. If the row variable is a -#' selectInput, the rows equal the value, but if the row variable is a -#' numericInput, a vector of rows is generated instead -#' -#' @param variable The name of the variable which functions as a row variable in -#' a table -#' @param value The value of the variable -#' -#' @return An atomic vector of rows, either option code names or numbers -get_dynamic_rows_from_value <- function(variable, value) { - row_variable_structure <- structure_lookup_list[[variable]] - - if (row_variable_structure$type == "numericInput") { - if (!isTruthy(value) || value == missingval) { - NULL - } else { - 1:as.integer(value) - } - } else if (row_variable_structure$type == "selectInput") { - value - } -} \ No newline at end of file diff --git a/R/utils_validation.R b/R/utils_validation.R deleted file mode 100644 index c06480e..0000000 --- a/R/utils_validation.R +++ /dev/null @@ -1,13 +0,0 @@ -#' Check whether the value of a dateRangeInput is valid -#' -#' @description Both dates need to be supplied for the value to be considered -#' valid, and the start date needs to be on or before the end date -#' -#' @param value The value of the dataRangeInput to validate -#' -#' @return TRUE if value is valid, FALSE if not -valid_dateRangeInput <- function(value) { - date1 = value[1] - date2 = value[2] - isTruthy(date1) && isTruthy(date2) && date1 <= date2 -} \ No newline at end of file diff --git a/inst/extdata/display_names.csv b/inst/extdata/display_names.csv index eec51e5..ed4b28f 100644 --- a/inst/extdata/display_names.csv +++ b/inst/extdata/display_names.csv @@ -13,6 +13,7 @@ mgmt_operations_event_choice,bed_prep,raised bed preparation,kasvatuslaatikoiden mgmt_operations_event_choice,inorg_mulch,placement of mulch,katteen levitys mgmt_operations_event_choice,Inorg_mul_rem,removal of mulch,katteen poisto # mgmt_operations_event_choice,organic_material,organic material application,eloperäisen aineen levitys +mgmt_operations_event_choice,measurement,measurement,mittaus mgmt_operations_event_choice,other,other,muu # # the following are the “all” choices for frontpage table filters diff --git a/man/create_ui.Rd b/man/create_ui.Rd deleted file mode 100644 index fc1d3ba..0000000 --- a/man/create_ui.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_ui.R -\name{create_ui} -\alias{create_ui} -\title{Generate the UI for a list of elements in the structure file.} -\usage{ -create_ui(widget_structure_list, ns) -} -\arguments{ -\item{widget_structure_list}{The list of widget structures (from -ui_structure.json) to generate as UI} - -\item{ns}{A namespacing function generated by shiny::NS to apply to the id's -of each generated widget} -} -\value{ -A list of Shiny widgets -} -\description{ -For a given list of widget structures as read from ui_structure.json, -create_ui applies create_widget to each widget in the list. -Still used for app chrome rendering and by mod_table.R for legacy tables. -} diff --git a/man/delete_file.Rd b/man/delete_file.Rd index 22db662..5587b2a 100644 --- a/man/delete_file.Rd +++ b/man/delete_file.Rd @@ -25,5 +25,6 @@ relative to the events.json file.} \item{base_folder}{Included for testing reasons} } \description{ -Delete a file +Delete the file with the path filepath. Used to delete files (images) +associated with events, e.g. canopeo_image } diff --git a/man/get_dynamic_rows_from_value.Rd b/man/get_dynamic_rows_from_value.Rd deleted file mode 100644 index aa1135e..0000000 --- a/man/get_dynamic_rows_from_value.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_table_utils.R -\name{get_dynamic_rows_from_value} -\alias{get_dynamic_rows_from_value} -\title{Determine the dynamic rows based on row variable value} -\usage{ -get_dynamic_rows_from_value(variable, value) -} -\arguments{ -\item{variable}{The name of the variable which functions as a row variable in -a table} - -\item{value}{The value of the variable} -} -\value{ -An atomic vector of rows, either option code names or numbers -} -\description{ -This is used to go from the value of a variable determining the rows in a -dynamic row group to the rows themselves. If the row variable is a -selectInput, the rows equal the value, but if the row variable is a -numericInput, a vector of rows is generated instead -} diff --git a/man/get_table_variables.Rd b/man/get_table_variables.Rd deleted file mode 100644 index d9be700..0000000 --- a/man/get_table_variables.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_table_utils.R -\name{get_table_variables} -\alias{get_table_variables} -\title{Find the variables whose value can be entered through a given table} -\usage{ -get_table_variables(table_code_name) -} -\arguments{ -\item{table_code_name}{The name of the table whose variables to fetch.} -} -\value{ -A vector of variable names whose values are entered in a table. -} -\description{ -Find the variables whose value can be entered through a given table -} -\note{ -If a table has a dynamic row group whose rows are determined by an - input widget's value, that widget's variable name will not be returned even - though it could be read from the list returned by the table module. -} diff --git a/man/get_variable_table.Rd b/man/get_variable_table.Rd deleted file mode 100644 index da769f7..0000000 --- a/man/get_variable_table.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_table_utils.R -\name{get_variable_table} -\alias{get_variable_table} -\title{Find the table matching a variable name} -\usage{ -get_variable_table(variable_name) -} -\arguments{ -\item{variable_name}{The name of the variable of interest} -} -\value{ -The code name of the table where the variable is entered, or NULL - if not found. -} -\description{ -If a variable's value is entered in a table, return the name of that table -} diff --git a/man/reset_input_fields.Rd b/man/reset_input_fields.Rd deleted file mode 100644 index 98c3527..0000000 --- a/man/reset_input_fields.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_ui.R -\name{reset_input_fields} -\alias{reset_input_fields} -\title{Reset the value of input fields} -\usage{ -reset_input_fields(session, fields_to_clear, exceptions = c("")) -} -\arguments{ -\item{session}{The current Shiny session} - -\item{fields_to_clear}{The names of the variables whose corresponding fields -should be cleared} - -\item{exceptions}{Optional vector of variable names which should not be -cleared.} -} -\value{ -None, used for side effects. -} -\description{ -Reset the value of input fields -} diff --git a/man/update_ui_element.Rd b/man/update_ui_element.Rd deleted file mode 100644 index 8dcb38d..0000000 --- a/man/update_ui_element.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_ui.R -\name{update_ui_element} -\alias{update_ui_element} -\title{Update value, label etc. of a UI element.} -\usage{ -update_ui_element(session, code_name, value = NULL, clear_value = FALSE, ...) -} -\arguments{ -\item{session}{Current shiny session} - -\item{code_name}{The code name of the UI element to update} - -\item{value}{An atomic vector holding the desired value of the UI element.} - -\item{clear_value}{If set to TRUE, the value of the element is cleared.} - -\item{...}{Additional arguments to pass to Shiny's update functions.} -} -\description{ -Determines the type of the element and updates its value using shiny's update - functions. -} diff --git a/man/valid_dateRangeInput.Rd b/man/valid_dateRangeInput.Rd deleted file mode 100644 index 990a830..0000000 --- a/man/valid_dateRangeInput.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_validation.R -\name{valid_dateRangeInput} -\alias{valid_dateRangeInput} -\title{Check whether the value of a dateRangeInput is valid} -\usage{ -valid_dateRangeInput(value) -} -\arguments{ -\item{value}{The value of the dataRangeInput to validate} -} -\value{ -TRUE if value is valid, FALSE if not -} -\description{ -Both dates need to be supplied for the value to be considered - valid, and the start date needs to be on or before the end date -} diff --git a/tests/testthat/test-fct_schema.R b/tests/testthat/test-fct_schema.R index 5d0a443..2551675 100644 --- a/tests/testthat/test-fct_schema.R +++ b/tests/testthat/test-fct_schema.R @@ -122,11 +122,8 @@ test_that("lang_to_iso converts column names and passes through ISO codes", { expect_equal(lang_to_iso("disp_name_swe"), "sv") expect_equal(lang_to_iso("en"), "en") expect_equal(lang_to_iso("fi"), "fi") - # NOTE: unknown language codes cause subscript out of bounds error because - # mapping is a named character vector, not a list. The NULL fallback on - # line 427 of fct_schema.R is unreachable. Consider using match() or - # switching to a list. For now, test the actual behavior: - expect_error(lang_to_iso("unknown"), "subscript out of bounds") + # Unknown language codes fall back to "en" + expect_equal(lang_to_iso("unknown"), "en") }) # --- schema_get_choices ------------------------------------------------------- From 5e168e1a7eb7d0eda714e93a4361ffda757fd07d Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Tue, 29 Sep 2026 17:37:01 +0530 Subject: [PATCH 5/6] fix(form): save events in the nested schema format - upgrade legacy events on read: nest per-species vectors into harvest_list/planting_list, split grazing_period, map old notes names - drop -99.0 and other empty values when writing events - keep keys unknown to the schema when an event is edited - give each event field its own input id and validate it per event type - require event type, block and, where the schema says so, date - clear tables and dates of a previous event when filling or resetting - validate table rows by display position after a row is removed - show units and sentence-case labels from the schema - fix csv and json exports for the nested format - restore the icos_agri_user login - fail at startup if the schema cannot be loaded --- DESCRIPTION | 3 +- R/app_server.R | 9 + R/fct_event_format.R | 193 ++++++ R/fct_event_list.R | 3 +- R/fct_files.R | 73 +-- R/fct_language.R | 3 +- R/fct_schema.R | 147 +++-- R/fct_schema_ui.R | 198 +++---- R/mod_download.R | 117 ++-- R/mod_form.R | 725 ++++++++--------------- R/mod_table.R | 101 +--- R/utils_global.R | 21 +- man/clear_schema_value.Rd | 11 - man/condition_to_field_ids.Rd | 23 + man/drop_empty_values.Rd | 18 + man/events_to_table.Rd | 19 + man/field_validator.Rd | 20 + man/find_property_by_name.Rd | 20 + man/get_all_schema_properties.Rd | 13 - man/get_relevant_fields.Rd | 21 + man/is_missing_value.Rd | 18 + man/lift_array_fields.Rd | 22 + man/load_schema.Rd | 5 +- man/lookup_property_key.Rd | 23 + man/normalize_legacy_event.Rd | 13 +- man/render_array_table.Rd | 6 +- man/render_property_widget.Rd | 2 +- man/render_subtype_section.Rd | 2 +- man/schema_table_id.Rd | 17 + man/split_grazing_period.Rd | 19 + man/to_sentence_case.Rd | 18 + man/update_schema_value.Rd | 6 +- man/update_schema_widget.Rd | 13 +- tests/testthat/helper-events.R | 71 +++ tests/testthat/test-download.R | 65 +- tests/testthat/test-fct_event_format.R | 187 ++++++ tests/testthat/test-fct_schema.R | 198 ++----- tests/testthat/test-mod_form.R | 117 ++++ tests/testthat/test-mod_table.R | 78 +-- tests/testthat/test-schema_integration.R | 351 ++--------- 40 files changed, 1565 insertions(+), 1404 deletions(-) create mode 100644 R/fct_event_format.R delete mode 100644 man/clear_schema_value.Rd create mode 100644 man/condition_to_field_ids.Rd create mode 100644 man/drop_empty_values.Rd create mode 100644 man/events_to_table.Rd create mode 100644 man/field_validator.Rd create mode 100644 man/find_property_by_name.Rd delete mode 100644 man/get_all_schema_properties.Rd create mode 100644 man/get_relevant_fields.Rd create mode 100644 man/is_missing_value.Rd create mode 100644 man/lift_array_fields.Rd create mode 100644 man/lookup_property_key.Rd create mode 100644 man/schema_table_id.Rd create mode 100644 man/split_grazing_period.Rd create mode 100644 man/to_sentence_case.Rd create mode 100644 tests/testthat/helper-events.R create mode 100644 tests/testthat/test-fct_event_format.R create mode 100644 tests/testthat/test-mod_form.R diff --git a/DESCRIPTION b/DESCRIPTION index c9ea355..0352265 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,8 @@ LazyData: true RoxygenNote: 7.3.3 URL: https://github.com/PecanProject/fieldactivity BugReports: https://github.com/PecanProject/fieldactivity/issues -Suggests: +Suggests: + jsonvalidate, spelling, testthat (>= 3.0.0), shinytest, diff --git a/R/app_server.R b/R/app_server.R index 1b28225..b33a4cb 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -74,6 +74,15 @@ app_server <- function(input, output, session) { updateSelectInput(session, "site", choices = site_choices, selected = auth_result$user) + } else if (auth_result$user == "icos_agri_user") { + + shinyjs::enable("site") + shinyjs::show("site") + # Subset of site choices for the ICOS agri user + site_choices <- sites[grepl("icos-agri", sites$site_type),]$site + + updateSelectInput(session, "site", choices = site_choices, selected = auth_result$user) + } else { updateSelectInput(session, "site", selected = auth_result$user) diff --git a/R/fct_event_format.R b/R/fct_event_format.R new file mode 100644 index 0000000..237a83c --- /dev/null +++ b/R/fct_event_format.R @@ -0,0 +1,193 @@ +# Canonical event format +# +# In memory and on disk, an event has the shape defined by +# management-event.schema.json: common and event-level properties at the top +# level, per-item properties (e.g. one entry per harvested crop) nested in the +# event's array properties (harvest_list, planting_list, ...), and empty values +# omitted. +# +# Files written before the schema was adopted use the legacy (ICASA-style) +# format. normalize_legacy_event() upgrades those events when they are read, so +# the rest of the app only sees the canonical format, and saving rewrites the +# whole events.json in it. Legacy differences handled: +# - the organic_material event type (now fertilizer with the organic subtype) +# - event notes stored under per-event-type names (see legacy_name_map) +# - per-item values stored flat on the event, either as scalars (one item) or +# as parallel vectors (one element per item) +# - empty values stored as the ICASA missing value "-99.0" +# - the grazing period stored as a start and end date pair (grazing_period) +# instead of date (the start date) and end_date +# Keys the schema does not know about are kept as they are. + +# Legacy property name -> schema property name +legacy_name_map <- c( + "mgmt_event_notes" = "mgmt_event_short_notes", + "bed_prep_notes" = "mgmt_event_long_notes", + "chemical_applic_notes" = "mgmt_event_long_notes", + "fertilizer_notes" = "mgmt_event_long_notes", + "grazing_notes" = "mgmt_event_long_notes", + "harvest_comments" = "mgmt_event_long_notes", + "irrigation_notes" = "mgmt_event_long_notes", + "mowing_notes" = "mgmt_event_long_notes", + "mulch_placement_notes" = "mgmt_event_long_notes", + "mulch_removal_notes" = "mgmt_event_long_notes", + "observation_notes" = "mgmt_event_long_notes", + "other_notes" = "mgmt_event_long_notes", + "planting_notes" = "mgmt_event_long_notes", + "tillage_treatment_notes" = "mgmt_event_long_notes", + "weeding_notes" = "mgmt_event_long_notes" +) + +#' Check which elements of an atomic vector are empty +#' +#' NA, blank strings and the ICASA missing value (stored as "-99.0" or -99) +#' count as empty. +#' @param x An atomic vector +#' @return A logical vector of the same length +is_missing_value <- function(x) { + is.na(x) | trimws(as.character(x)) %in% c("", missingval, "-99") +} + +#' Recursively remove empty values from an event +#' +#' Atomic values that are entirely empty, rows (list items) that become empty +#' and lists that become empty are removed. +#' @param x An event, a list of rows or a single value +#' @return x without empty values, or NULL if nothing is left +drop_empty_values <- function(x) { + if (is.list(x)) { + x <- lapply(x, drop_empty_values) + keep <- !vapply(x, is.null, logical(1)) + return(if (any(keep)) x[keep] else NULL) + } + if (length(x) == 0 || all(is_missing_value(x))) return(NULL) + x +} + +#' Move flat per-item values into the event's array properties +#' +#' Legacy events store item columns (e.g. harvest_crop, harvest_method) on the +#' event itself: a scalar for a single item or parallel vectors for several. +#' This zips them into the rows of the array property (e.g. harvest_list). +#' Which columns belong to which array is read from the schema. +#' @param event An event list +#' @param schema The loaded schema (from load_schema) +#' @return The event with item columns nested under array properties +lift_array_fields <- function(event, schema) { + event_type <- event$mgmt_operations_event + if (is.null(event_type)) return(event) + entry <- schema$event_registry[[event_type]] + if (is.null(entry)) return(event) + + subtype <- if (isTRUE(entry$has_subtypes)) { + event[[entry$subtype_discriminator]] + } + event_level <- get_relevant_properties(schema, event_type, subtype)$all + + for (desc in get_relevant_fields(schema, event_type, subtype)) { + if (desc$type != "dataTable" || !is.null(event[[desc$name]])) next + + # an item column that is also an event-level property stays where it is + columns <- setdiff(intersect(names(desc$array_columns), names(event)), + event_level) + if (length(columns) == 0) next + + n_items <- max(lengths(event[columns])) + event[[desc$name]] <- lapply(seq_len(n_items), function(i) { + lapply(event[columns], function(values) { + if (i <= length(values)) values[[i]] + }) + }) + event[columns] <- NULL + } + event +} + +#' Split a legacy grazing period into start and end dates +#' +#' The start date becomes the event date if the event has none. If the event +#' date differs from the start date, grazing_period is kept so that the start +#' date is not lost. +#' @param event An event list +#' @return The event with end_date (and date) set from grazing_period +split_grazing_period <- function(event) { + period <- unlist(event$grazing_period) + if (length(period) != 2 || !is.null(event$end_date)) return(event) + event$end_date <- period[[2]] + event$date <- event$date %||% period[[1]] + if (identical(event$date, period[[1]])) event$grazing_period <- NULL + event +} + +#' Upgrade an event read from events.json to the canonical format +#' +#' Events already in the canonical format pass through unchanged apart from +#' dropping empty values. See the top of this file for what is upgraded. +#' @param event An event list +#' @param schema The loaded schema (from load_schema) +#' @return The event in the canonical format +normalize_legacy_event <- function(event, schema = mgmt_schema) { + if (identical(event$mgmt_operations_event, "organic_material")) { + event$mgmt_operations_event <- "fertilizer" + } + + event <- drop_empty_values(event) + + for (old_name in names(legacy_name_map)) { + new_name <- legacy_name_map[[old_name]] + # if both are set, keep the legacy key too rather than lose its value + if (!is.null(event[[old_name]]) && is.null(event[[new_name]])) { + event[[new_name]] <- event[[old_name]] + event[[old_name]] <- NULL + } + } + + if (identical(event$mgmt_operations_event, "grazing")) { + event <- split_grazing_period(event) + } + + drop_empty_values(lift_array_fields(event, schema)) +} + +#' Flatten events into a table with one row per event +#' +#' Array properties are spread into one column per item property, holding the +#' items' values in order separated by "; " (an empty value keeps its place). +#' Vectors are joined the same way. The $schema key is left out. +#' @param events A list of events in the canonical format +#' @return A data frame of character columns +events_to_table <- function(events) { + rows <- lapply(events, function(event) { + event[["$schema"]] <- NULL + row <- list() + for (name in names(event)) { + value <- event[[name]] + if (!is.list(value)) { + row[[name]] <- paste(value, collapse = "; ") + next + } + columns <- unique(unlist(lapply(value, names))) + for (column in columns) { + cells <- vapply(value, function(item) { + paste(item[[column]] %||% "", collapse = " ") + }, character(1)) + # an item property with the same name as an event property gets the + # array's name as a prefix + col_name <- if (column %in% names(event)) { + paste(name, column, sep = ".") + } else { + column + } + row[[col_name]] <- paste(cells, collapse = "; ") + } + } + row + }) + + col_names <- unique(unlist(lapply(rows, names))) + table <- lapply(col_names, function(col_name) { + vapply(rows, function(row) row[[col_name]] %||% "", character(1)) + }) + names(table) <- col_names + as.data.frame(table, stringsAsFactors = FALSE, check.names = FALSE) +} diff --git a/R/fct_event_list.R b/R/fct_event_list.R index f0a247b..778b995 100644 --- a/R/fct_event_list.R +++ b/R/fct_event_list.R @@ -100,8 +100,7 @@ get_event_list_colnames <- function(col_names, language) { if (!identical(dn, cn)) return(dn) # Try schema property titles - desc <- find_any_property_desc(mgmt_schema$property_registry, cn, - mgmt_schema$property_reverse_index) + desc <- find_property_by_name(mgmt_schema, cn) if (!is.null(desc) && !is.null(desc$titles)) { title <- schema_get_title(desc$titles, iso, "") if (nchar(title) > 0) return(title) diff --git a/R/fct_files.R b/R/fct_files.R index 04e0bd3..76f22c5 100644 --- a/R/fct_files.R +++ b/R/fct_files.R @@ -12,16 +12,6 @@ json_file_base_folder <- function() golem::get_golem_options("json_file_path") # consumers that validate events against this schema. schema_url <- "https://raw.githubusercontent.com/hamk-uas/fieldobservatory-data-schemas/main/management-event.schema.json" -# Legacy property name mapping for backward-compatible reading -legacy_name_map <- c( - "mgmt_event_notes" = "mgmt_event_short_notes", - "planting_notes" = "mgmt_event_long_notes", - "harvest_comments" = "mgmt_event_long_notes", - "fertilizer_comments" = "mgmt_event_long_notes", - "tillage_notes" = "mgmt_event_long_notes", - "chemical_notes" = "mgmt_event_long_notes" -) - #' Create a folder for a site-block combination #' #' Given a site and a block on that site, create a folder under @@ -41,7 +31,7 @@ create_file_folder <- function(site, block, # if the events directory (stored in json_file_base_folder) doesn't exist, # stop if (!dir.exists(base_folder)) { - stop(glue("Could not find folder {json_file_base_folder}")) + stop(glue("Could not find folder {base_folder}")) } folder_path <- file.path(base_folder, site, block) @@ -64,34 +54,16 @@ write_json_file <- function(site, block, event_list, rotation_list, base_folder = json_file_base_folder()) { # this ensures that the folder to store this file exists - create_file_folder(site, block) + create_file_folder(site, block, base_folder) file_path <- file.path(base_folder, site, block, "events.json") - # if there are events in the list, do the following: - # - erase block information in each event - # - apply other exceptions - if (length(event_list) > 0) { - for (i in 1:length(event_list)) { - event_list[[i]]$block <- NULL - - # Add $schema field - event_list[[i]][["$schema"]] <- schema_url - - ##### EXCEPTIONS - event <- event_list[[i]] - - # if the event type is fertilizer application and the fertilizer - # type is organic, change mgmt_operations_event to organic_material - # to conform to the ICASA standard - if (identical(event$mgmt_operations_event, "fertilizer") && - identical(event$fertilizer_type, "fertilizer_type_organic")) { - event_list[[i]]$mgmt_operations_event <- "organic_material" - } - - ##### - } - } + # the block is implied by the file location + event_list <- lapply(event_list, function(event) { + event$block <- NULL + event[["$schema"]] <- schema_url + drop_empty_values(event) + }) # If rotations on the list --> erase the block information like with events if (length(rotation_list) > 0) { @@ -148,21 +120,10 @@ read_json_file <- function(site, block, return(list()) } - # add block information and apply exceptions to each event + # add block information and upgrade legacy events to the canonical format for (i in 1:length(events)) { events[[i]]$block <- block - - ##### EXCEPTIONS - - # if mgmt_operations_event is organic_material, change it to fertilizer - if (identical(events[[i]]$mgmt_operations_event, "organic_material")) { - events[[i]]$mgmt_operations_event <- "fertilizer" - } - - # Normalize legacy property names events[[i]] <- normalize_legacy_event(events[[i]]) - - ##### } # add block info for rotations @@ -180,20 +141,6 @@ read_json_file <- function(site, block, return(management) } -#' Normalize a legacy event to use schema property names -#' @param event An event list -#' @return The event with legacy names mapped to schema names -normalize_legacy_event <- function(event) { - for (old_name in names(legacy_name_map)) { - new_name <- legacy_name_map[[old_name]] - if (!is.null(event[[old_name]]) && is.null(event[[new_name]])) { - event[[new_name]] <- event[[old_name]] - event[[old_name]] <- NULL - } - } - event -} - #' Copy a file related to an event and name it appropriately #' #' When a file (image) is uploaded through a fileInput widget, it is saved to a @@ -222,7 +169,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, filepath_is_relative = FALSE, delete_original = FALSE, base_folder = json_file_base_folder()) { # ensures the folder for this site-block combo is there - create_file_folder(site, block) + create_file_folder(site, block, base_folder) # add json_file_base_folder to filepath if requested if (filepath_is_relative) { diff --git a/R/fct_language.R b/R/fct_language.R index 676b59c..7465de5 100644 --- a/R/fct_language.R +++ b/R/fct_language.R @@ -105,8 +105,7 @@ replace_with_display_names <- function(events_with_code_names, language) { # If not in structure_lookup_list, try schema property registry if (is.null(element$type)) { - desc <- find_any_property_desc(mgmt_schema$property_registry, variable_name, - mgmt_schema$property_reverse_index) + desc <- find_property_by_name(mgmt_schema, variable_name) if (!is.null(desc)) { wtype <- desc$type if (wtype == "selectInput") { diff --git a/R/fct_schema.R b/R/fct_schema.R index 12742ed..02b8c0b 100644 --- a/R/fct_schema.R +++ b/R/fct_schema.R @@ -13,6 +13,11 @@ schema_file_path <- function() { } #' Load and parse the management-event schema +#' +#' Every property is registered once per event type (and subtype) it appears +#' in. Its registry key is also its unique input ID in the form, so a property +#' shared by several event types (e.g. mgmt_event_long_notes) gets a separate +#' widget per event type. #' @return A list with components: raw (the full parsed schema), event_registry, #' property_registry, common_properties, event_type_choices load_schema <- function() { @@ -123,8 +128,11 @@ load_schema <- function() { } # Register event-level properties (excluding mgmt_operations_event const - # and properties that only belong to subtypes) + # and properties that only belong to subtypes). An event can redefine a + # common property (e.g. grazing's date is its start date); the common + # widget is then relabelled instead of adding a second widget. event_prop_names <- character(0) + common_overrides <- list() for (pn in names(event_props)) { if (pn == "mgmt_operations_event") next p <- event_props[[pn]] @@ -138,6 +146,10 @@ load_schema <- function() { required = is_req, event_type = event_const, is_array_item = FALSE) + if (pn %in% common_prop_names) { + common_overrides[[pn]] <- desc + next + } # Use a unique key to avoid collision between events sharing property names reg_key <- paste0(pn, REGISTRY_KEY_SEP, event_const) property_registry[[reg_key]] <- desc @@ -151,30 +163,53 @@ load_schema <- function() { required = event_required, has_subtypes = has_subtypes, subtype_discriminator = subtype_discriminator, - subtypes = subtype_registry + subtype_discriminator_id = if (!is.null(subtype_discriminator)) { + paste0(subtype_discriminator, REGISTRY_KEY_SEP, event_const) + }, + subtypes = subtype_registry, + common_overrides = common_overrides ) } - # Build reverse-lookup index: bare prop_name -> first matching registry key. - # Avoids linear scan in find_any_property_desc(). - property_reverse_index <- list() + # The registry key is the property's input ID. x-ui conditions refer to + # other properties by name, so point them at the IDs in the same event type. for (key in names(property_registry)) { - bare_name <- sub(paste0(REGISTRY_KEY_SEP, ".*"), "", key) - if (is.null(property_reverse_index[[bare_name]])) { - property_reverse_index[[bare_name]] <- key + desc <- property_registry[[key]] + desc$id <- key + if (!is.null(desc$xui$condition)) { + desc$condition <- condition_to_field_ids( + desc$xui$condition, property_registry, desc$event_type, desc$subtype) } + property_registry[[key]] <- desc } list( raw = raw, event_registry = event_registry, property_registry = property_registry, - property_reverse_index = property_reverse_index, common_properties = common_prop_names, event_type_choices = event_type_choices ) } +#' Point the input references of an x-ui condition at field IDs +#' @param condition A condition such as "input.chemical_type == 'x'" +#' @param registry The property registry +#' @param event_type Event type of the property the condition belongs to +#' @param subtype Subtype of that property (or NULL) +#' @return The condition with each input.name replaced by input.id +condition_to_field_ids <- function(condition, registry, event_type, subtype) { + names_used <- unique(regmatches( + condition, gregexpr("(?<=input\\.)\\w+", condition, perl = TRUE))[[1]]) + for (name in names_used) { + key <- lookup_property_key(registry, name, event_type, subtype) + if (is.null(key)) next + condition <- gsub(paste0("input\\.", name, "\\b"), paste0("input.", key), + condition, perl = TRUE) + } + condition +} + #' Resolve $ref and allOf in a property definition #' @param prop The property definition (list) #' @param defs The $defs section from the schema @@ -240,14 +275,28 @@ merge_lists <- function(a, b) { a } +# Titles are only used as UI labels, so they are shown in sentence case here +# rather than changing the (all lowercase) titles in the schema itself extract_titles <- function(node) { list( - en = node$title %||% "", - fi = node$title_fi %||% "", - sv = node$title_sv %||% "" + en = to_sentence_case(node$title %||% ""), + fi = to_sentence_case(node$title_fi %||% ""), + sv = to_sentence_case(node$title_sv %||% "") ) } +#' Capitalise the first letter of a label +#' +#' Labels whose first word already contains capitals (e.g. "pH after the +#' application") are left as they are. +#' @param x A character string +#' @return x with its first letter in upper case +to_sentence_case <- function(x) { + first_word <- sub(" .*", "", x) + if (!identical(first_word, tolower(first_word))) return(x) + paste0(toupper(substr(x, 1, 1)), substr(x, 2, nchar(x))) +} + #' Determine the Shiny widget type from a schema property #' @param prop A resolved property descriptor #' @return A string: "selectInput", "numericInput", "dateInput", etc. @@ -322,21 +371,6 @@ build_property_descriptor <- function(name, prop, required, event_type, titles <- extract_titles(prop) - # Unitless titles for table column headers - unitless_titles <- NULL - if (!is.null(xui)) { - ut_en <- xui$unitless_title %||% xui$unitless_title2 - ut_fi <- xui$unitless_title_fi %||% xui$unitless_title2_fi - ut_sv <- xui$unitless_title_sv %||% xui$unitless_title2_sv - if (!is.null(ut_en) || !is.null(ut_fi) || !is.null(ut_sv)) { - unitless_titles <- list( - en = ut_en %||% "", - fi = ut_fi %||% "", - sv = ut_sv %||% "" - ) - } - } - placeholders <- NULL if (!is.null(xui)) { ph_en <- xui[["form-placeholder"]] %||% xui[["placeholder"]] @@ -361,7 +395,6 @@ build_property_descriptor <- function(name, prop, required, event_type, name = name, type = widget_type, titles = titles, - unitless_titles = unitless_titles, choices = choices, required = required, minimum = prop$minimum, @@ -451,21 +484,40 @@ schema_get_choices <- function(choices, language) { #' @return The property descriptor, or NULL lookup_property <- function(registry, prop_name, event_type = NULL, subtype = NULL) { - # Try subtype-specific key first - if (!is.null(subtype) && !is.null(event_type)) { - key <- paste0(prop_name, REGISTRY_KEY_SEP, event_type, REGISTRY_KEY_SEP, subtype) - if (!is.null(registry[[key]])) return(registry[[key]]) - } - # Try event-specific key - if (!is.null(event_type)) { - key <- paste0(prop_name, REGISTRY_KEY_SEP, event_type) - if (!is.null(registry[[key]])) return(registry[[key]]) + key <- lookup_property_key(registry, prop_name, event_type, subtype) + if (is.null(key)) NULL else registry[[key]] +} + +#' Find the registry key (input ID) of a property +#' @inheritParams lookup_property +#' @return The most specific matching key, or NULL +lookup_property_key <- function(registry, prop_name, event_type = NULL, + subtype = NULL) { + candidates <- c( + if (!is.null(event_type) && !is.null(subtype)) { + paste0(prop_name, REGISTRY_KEY_SEP, event_type, REGISTRY_KEY_SEP, subtype) + }, + if (!is.null(event_type)) paste0(prop_name, REGISTRY_KEY_SEP, event_type), + prop_name + ) + for (key in candidates) { + if (!is.null(registry[[key]])) return(key) } - # Try common property - if (!is.null(registry[[prop_name]])) return(registry[[prop_name]]) NULL } +#' Find a property by name in any event type +#' +#' For display purposes where the event type is not known (e.g. event list +#' column headers). Returns the first matching descriptor. +#' @param schema The loaded schema (from load_schema) +#' @param prop_name Property name +#' @return The property descriptor, or NULL +find_property_by_name <- function(schema, prop_name) { + Find(function(desc) identical(desc$name, prop_name), + schema$property_registry) +} + #' Get properties relevant to the currently selected event/subtype #' @param schema The loaded schema (from load_schema) #' @param event_type The selected event type const @@ -494,3 +546,20 @@ get_relevant_properties <- function(schema, event_type, subtype = NULL) { all = unique(c(common, event_props, subtype_props)) ) } + +#' Get the fields shown for the selected event type and subtype +#' +#' Common properties are not included, they have their own widgets. +#' @param schema The loaded schema (from load_schema) +#' @param event_type The selected event type const +#' @param subtype The selected subtype const (or NULL) +#' @return A list of property descriptors, event-level fields first +get_relevant_fields <- function(schema, event_type, subtype = NULL) { + relevant <- get_relevant_properties(schema, event_type, subtype) + fields <- lapply(c(relevant$event_props, relevant$subtype_props), + function(pn) { + lookup_property(schema$property_registry, pn, event_type, + subtype) + }) + Filter(Negate(is.null), fields) +} diff --git a/R/fct_schema_ui.R b/R/fct_schema_ui.R index bf685ee..9a0e209 100644 --- a/R/fct_schema_ui.R +++ b/R/fct_schema_ui.R @@ -20,6 +20,39 @@ convert_condition_to_js <- function(condition, ns) { perl = TRUE) } +#' Build the validator for a schema-driven widget +#' +#' Rules come from the property descriptor: required, minimum, maximum and +#' whole numbers. An empty optional widget skips the other rules. +#' @param desc Property descriptor +#' @param id Input ID of the widget +#' @return An InputValidator, or NULL if the property has no rules +#' @import shinyvalidate +field_validator <- function(desc, id = desc$id) { + rules <- list() + if (!is.null(desc$minimum)) { + rules <- c(rules, sv_gte(desc$minimum, message_fmt = "Must be >= {rhs}")) + } + if (!is.null(desc$maximum)) { + rules <- c(rules, sv_lte(desc$maximum, message_fmt = "Must be <= {rhs}")) + } + if (isTRUE(desc$is_integer)) { + rules <- c(rules, function(value) { + if (value != floor(value)) "Must be a whole number" + }) + } + if (!isTRUE(desc$required) && length(rules) == 0) return(NULL) + + iv <- InputValidator$new() + if (isTRUE(desc$required)) { + iv$add_rule(id, sv_required(message = "Required")) + } else { + iv$add_rule(id, sv_optional()) + } + for (rule in rules) iv$add_rule(id, rule) + iv +} + #' Render the full schema-driven form #' @param schema The loaded schema (from load_schema) #' @param ns Shiny namespace function @@ -60,17 +93,17 @@ render_event_panel <- function(event_entry, pr, ns, iso, event_const) { if (desc$type == "const") next if (desc$type == "dataTable") { - w <- render_array_table(pn, desc, ns, iso) + w <- render_array_table(desc, ns, iso) } else if (desc$is_discriminator && event_entry$has_subtypes) { - w <- render_subtype_section(pn, desc, event_entry, pr, ns, iso, + w <- render_subtype_section(desc, event_entry, pr, ns, iso, event_const) } else { - w <- render_property_widget(pn, desc, ns, iso) + w <- render_property_widget(desc$id, desc, ns, iso) } # Wrap in conditionalPanel if x-ui condition is defined - if (!is.null(desc$xui$condition)) { + if (!is.null(desc$condition)) { w <- conditionalPanel( - condition = convert_condition_to_js(desc$xui$condition, ns), w) + condition = convert_condition_to_js(desc$condition, ns), w) } widgets[[length(widgets) + 1]] <- w } @@ -79,11 +112,11 @@ render_event_panel <- function(event_entry, pr, ns, iso, event_const) { } #' Render a subtype discriminator and its conditional panels -render_subtype_section <- function(pn, desc, event_entry, pr, ns, iso, +render_subtype_section <- function(desc, event_entry, pr, ns, iso, event_const) { # Render the discriminator selectInput with subtype choices subtype_choices <- build_subtype_choices(event_entry, iso) - discriminator_widget <- render_property_widget(pn, desc, ns, iso, + discriminator_widget <- render_property_widget(desc$id, desc, ns, iso, override_choices = subtype_choices) # Build subtype conditional panels @@ -97,18 +130,18 @@ render_subtype_section <- function(pn, desc, event_entry, pr, ns, iso, if (sdesc$type == "const") next if (sdesc$type == "dataTable") { - sw <- render_array_table(spn, sdesc, ns, iso) + sw <- render_array_table(sdesc, ns, iso) } else { - sw <- render_property_widget(spn, sdesc, ns, iso) + sw <- render_property_widget(sdesc$id, sdesc, ns, iso) } - if (!is.null(sdesc$xui$condition)) { + if (!is.null(sdesc$condition)) { sw <- conditionalPanel( - condition = convert_condition_to_js(sdesc$xui$condition, ns), sw) + condition = convert_condition_to_js(sdesc$condition, ns), sw) } sub_widgets[[length(sub_widgets) + 1]] <- sw } - condition <- paste0("input['", ns(pn), "'] == '", sub_const, "'") + condition <- paste0("input['", ns(desc$id), "'] == '", sub_const, "'") conditionalPanel(condition = condition, tagList(sub_widgets)) }) @@ -116,7 +149,7 @@ render_subtype_section <- function(pn, desc, event_entry, pr, ns, iso, } #' Render a single Shiny input widget from a property descriptor -#' @param prop_name Property name (used as input ID) +#' @param prop_name Input ID of the widget (desc$id for form fields) #' @param desc Property descriptor from the registry #' @param ns Namespace function #' @param iso ISO language code @@ -146,7 +179,7 @@ render_property_widget <- function(prop_name, desc, ns, iso, override_label } else { make_required_label( - schema_get_title(desc$titles, iso, prop_name), + schema_get_title(desc$titles, iso, desc$name), desc$required ) } @@ -235,15 +268,14 @@ render_property_widget <- function(prop_name, desc, ns, iso, } #' Render a schema array property as a table module placeholder -#' @param prop_name The array property name (e.g. "planting_list") -#' @param desc The property descriptor +#' @param desc The property descriptor of the array (e.g. planting_list) #' @param ns Namespace function #' @param iso ISO language code #' @return A tagList with the table module UI -render_array_table <- function(prop_name, desc, ns, iso) { - table_id <- paste0(prop_name, "_table") +render_array_table <- function(desc, ns, iso) { + table_id <- schema_table_id(desc) table_ns <- NS(ns(table_id)) - w <- div( + div( class = "schema-array-table", mod_table_ui(ns(table_id)), div( @@ -254,45 +286,44 @@ render_array_table <- function(prop_name, desc, ns, iso) { class = "btn-sm btn-default") ) ) - if (!is.null(desc$xui$condition)) { - w <- conditionalPanel( - condition = convert_condition_to_js(desc$xui$condition, ns), w) - } - w +} + +#' Module ID of the table for an array property +#' @param desc The property descriptor of the array +#' @return The table module ID +schema_table_id <- function(desc) { + paste0(desc$id, "_table") } #' Update a single schema widget's label and choices -update_schema_widget <- function(session, prop_name, desc, iso, input) { +#' @param session Shiny session +#' @param desc Property descriptor +#' @param iso ISO language code +#' @param input The input of the session, to keep the current selection +#' @param override_choices Optional choices (e.g. for a subtype discriminator) +update_schema_widget <- function(session, desc, iso, input, + override_choices = NULL) { + id <- desc$id label <- make_required_label( - schema_get_title(desc$titles, iso, prop_name), + schema_get_title(desc$titles, iso, desc$name), desc$required ) + placeholder <- if (!is.null(desc$placeholders)) { + schema_get_title(desc$placeholders, iso, "") + } if (desc$type == "selectInput") { - choices <- schema_get_choices(desc$choices, iso) - current <- input[[prop_name]] - if (is.null(choices)) { - updateSelectInput(session, prop_name, label = label, selected = current) - } else { - updateSelectInput(session, prop_name, label = label, choices = choices, - selected = current) - } + choices <- override_choices %||% schema_get_choices(desc$choices, iso) + updateSelectInput(session, id, label = label, choices = choices, + selected = input[[id]]) } else if (desc$type == "numericInput") { - updateNumericInput(session, prop_name, label = label) + updateNumericInput(session, id, label = label) } else if (desc$type == "dateInput") { - updateDateInput(session, prop_name, label = label) + updateDateInput(session, id, label = label) } else if (desc$type == "textAreaInput") { - placeholder <- if (!is.null(desc$placeholders)) { - schema_get_title(desc$placeholders, iso, "") - } else { NULL } - updateTextAreaInput(session, prop_name, label = label, - placeholder = placeholder) + updateTextAreaInput(session, id, label = label, placeholder = placeholder) } else if (desc$type == "textInput") { - placeholder <- if (!is.null(desc$placeholders)) { - schema_get_title(desc$placeholders, iso, "") - } else { NULL } - updateTextInput(session, prop_name, label = label, - placeholder = placeholder) + updateTextInput(session, id, label = label, placeholder = placeholder) } } @@ -328,78 +359,33 @@ build_subtype_choices <- function(event_entry, iso) { #' Update a schema-driven widget value (for populating forms) #' @param session Shiny session -#' @param prop_name Property name #' @param desc Property descriptor -#' @param value The value to set -update_schema_value <- function(session, prop_name, desc, value) { +#' @param value The value to set. NULL clears the widget +update_schema_value <- function(session, desc, value) { if (is.null(desc)) return() - - # Replace missingval with empty - if (!is.null(value) && is.atomic(value)) { - value[value == missingval] <- "" - } + id <- desc$id + if (is.atomic(value) && all(is_missing_value(value))) value <- NULL wtype <- desc$type if (wtype == "selectInput") { - if (is.null(value) || identical(value, "")) { - updateSelectInput(session, prop_name, selected = "") - } else { - updateSelectInput(session, prop_name, selected = value) - } + updateSelectInput(session, id, selected = value %||% "") } else if (wtype == "numericInput") { - if (is.null(value) || identical(value, "") || identical(value, missingval)) { - updateNumericInput(session, prop_name, value = NA) - } else { - updateNumericInput(session, prop_name, value = as.numeric(value)) - } + updateNumericInput(session, id, + value = if (is.null(value)) NA else as.numeric(value)) } else if (wtype == "dateInput") { date_val <- tryCatch(as.Date(value, format = date_format_json), warning = function(cnd) NULL, error = function(cnd) NULL) - updateDateInput(session, prop_name, value = date_val) - } else if (wtype == "textAreaInput") { - updateTextAreaInput(session, prop_name, - value = if (is.null(value)) "" else value) - } else if (wtype == "textInput") { - updateTextInput(session, prop_name, - value = if (is.null(value)) "" else value) - } -} - -#' Clear a schema-driven widget -clear_schema_value <- function(session, prop_name, desc) { - if (is.null(desc)) return() - wtype <- desc$type - - if (wtype == "selectInput") { - updateSelectInput(session, prop_name, selected = "") - } else if (wtype == "numericInput") { - updateNumericInput(session, prop_name, value = NA) - } else if (wtype == "dateInput") { - updateDateInput(session, prop_name, value = NULL) + if (length(date_val) != 1 || is.na(date_val)) { + # updateDateInput ignores NULL, a null value clears the input + session$sendInputMessage(id, list(value = NA)) + } else { + updateDateInput(session, id, value = date_val) + } } else if (wtype == "textAreaInput") { - updateTextAreaInput(session, prop_name, value = "") + updateTextAreaInput(session, id, value = value %||% "") } else if (wtype == "textInput") { - updateTextInput(session, prop_name, value = "") + updateTextInput(session, id, value = value %||% "") } } - -#' Get all schema property names as a flat vector (for registry iteration) -#' Used to find all properties that need validation, value collection, etc. -get_all_schema_properties <- function(schema) { - er <- schema$event_registry - all_props <- schema$common_properties - - for (ec in names(er)) { - event_entry <- er[[ec]] - all_props <- c(all_props, event_entry$property_names) - if (event_entry$has_subtypes) { - for (sc in names(event_entry$subtypes)) { - all_props <- c(all_props, event_entry$subtypes[[sc]]$property_names) - } - } - } - - unique(all_props) -} diff --git a/R/mod_download.R b/R/mod_download.R index 906c7ef..6e3b323 100644 --- a/R/mod_download.R +++ b/R/mod_download.R @@ -115,6 +115,10 @@ mod_download_json <- function(id, label) { #' Server side for downloading the csv export #' +#' @param id Internal parameters for {shiny} +#' @param user_auth Site name in order to download correct site files +#' @param base_folder Location of directories in server +#' #' @noRd #' #' @importFrom utils write.csv @@ -131,48 +135,28 @@ mod_download_server_table <- function(id, user_auth, base_folder = json_file_bas filename = "event_table_fa.csv", content = function(file) { + if(dp()) message("Creating an export of the events") - if(dp()) message("Fetching the event table observations") - #user <- NULL - if (golem::app_dev()) { - if(dp()) message("Development state") - file_path <- "dev/dev_events" - user <- "qvidja" - - } else { - if(dp()) message("Data path on production") - file_path <- base_folder - - if(dp()) message("Checking current user") - user <- user_auth() + site <- user_auth() + blocks <- if (isTruthy(site)) { + list.files(file.path(base_folder, site)) } - # Create the file path based on the production status and the user - file_path <- file.path(file_path, user) - events_file <- NULL - if(length(list.files(file_path)) != 0){ - for(i in list.files(file_path)){ - jsontable <- jsonlite::read_json(file.path(file_path, i, "events.json"), simplifyVector = TRUE)[[1]]$events - if(is.null(events_file)){ - if(!identical(list(), jsontable)){ - events_file <- as.data.frame(cbind(block = i, jsontable)) - } - } else { - events_file <- merge(events_file,as.data.frame(cbind(block = i,jsontable)),all = T) - } - } - - # Flattening the lists and removing extra "," that can cause parsing issues - events_file <- as.data.frame(lapply(events_file, as.character)) - # Might not be suitable, if there are only simple event management stored, - # so only try this modification. - events_file <- try(as.data.frame(lapply(events_file, function(x) gsub(",", " ", x)))) - - if (dp()) message("Creating an export of the events") - write.csv(events_file, file, row.names = FALSE, quote=FALSE) - } else { - write.csv("Error with a file path. Have you stored field management events? If yes, then this error should not occur.", file, row.names = FALSE, quote = FALSE) + # events are read the same way as in the app, so legacy events are + # exported in the canonical format too + events <- unlist(lapply(blocks, function(block) { + read_json_file(site, block, base_folder = base_folder)$events + }), recursive = FALSE) + + if (length(events) == 0) { + write.csv("Seems that there isn't any data? Try to create a management event.", + file, row.names = FALSE) + return() } + events_table <- events_to_table(events) + # block first, as in the event list + events_table <- events_table[c("block", setdiff(names(events_table), "block"))] + write.csv(events_table, file, row.names = FALSE, na = "") } ) }) #Moduleserver close @@ -203,53 +187,32 @@ mod_download_server_json <- function(id, user_auth, base_folder = json_file_base }, content = function(file) { + if(dp()) message("Creating a zip file of the json files") - if(dp()) message("Fetching the event table observations (for json export)") + # a fresh directory for each download, so no files are left over from + # an earlier one + zip_root <- tempfile() + tmpdrjson <- file.path(zip_root, "json") + dir.create(tmpdrjson, recursive = TRUE) + on.exit(unlink(zip_root, recursive = TRUE), add = TRUE) - if (golem::app_dev()) { - if(dp()) message("Development state") - file_path <- "dev/dev_events" - user <- "qvidja" - - } else { - if(dp()) message("Data path on production") - file_path <- base_folder - - if(dp()) message("Checking current user") - user <- user_auth() + site <- user_auth() + blocks <- if (isTruthy(site)) { + list.files(file.path(base_folder, site)) + } + for (block_name in blocks) { + file.copy(file.path(base_folder, site, block_name, "events.json"), + file.path(tmpdrjson, paste0("events_", block_name, ".json"))) } - # Create the file path based on the production status and the user - file_path <- file.path(file_path, user) - # tmp directory with sub directory for json files - tmpdr <- tempdir() - if(!file.exists(file.path(tmpdr, "json"))){ - dir.create(paste0(tmpdr, "/json")) - } - - # Path to subdirectory - tmpdrjson <- file.path(tmpdr, "json") - if(length(list.files(file_path)) != 0){ - for(block_name in list.files(file_path)){ - block_json <- file.path(tmpdrjson, paste0("events_", block_name, ".json")) - file.copy(file.path(file_path, block_name, "events.json"), block_json) - } - - if (dp()) message("Creating a zip file of the json files") - zip::zip(zipfile=file, files="json", root = tmpdr) - } else { - #emptydir <- file.path(tmpdr, "Invalid_path.csv") + if (length(list.files(tmpdrjson)) == 0) { if(dp()) message("Return a csv with an error") - write.csv("Seems that there isn't any data? Try to create a management event.", file.path(tmpdrjson, "Error.csv"), row.names = FALSE) - zip::zip(zipfile=file, files="json", root = tmpdr) + write.csv("Seems that there isn't any data? Try to create a management event.", + file.path(tmpdrjson, "Error.csv"), row.names = FALSE) } + zip::zip(zipfile = file, files = "json", root = zip_root) }, contentType = "application/zip" ) }) #Moduleserver close } - - - - - diff --git a/R/mod_form.R b/R/mod_form.R index 8c14eb4..be1a90f 100644 --- a/R/mod_form.R +++ b/R/mod_form.R @@ -3,8 +3,8 @@ # - shows the correct widgets depending on the user's choices # - allows prefilling the widgets with the desired values # - verifies that the information has been supplied correctly -# - returns the values to the main app in the format they will be saved (e.g. -# "" replaced with missingval) +# - returns the values to the main app in the format they will be saved +# (nested array properties, empty values left out) # - contains the save, cancel and delete buttons and sends their signals to # the main app @@ -57,9 +57,7 @@ mod_form_ui <- function(id){ dateInput( ns("date"), format = "dd/mm/yyyy", - label = schema_get_title( - lookup_property(mgmt_schema$property_registry, "date")$titles, - iso, "date"), + label = common_field_label(mgmt_schema, "date", NULL, iso), max = Sys.Date(), value = Sys.Date(), weekstart = 1 @@ -99,6 +97,11 @@ mod_form_ui <- function(id){ #' form Server Functions #' +#' Each schema property has one widget per event type (and subtype) it appears +#' in, identified by the property's registry key (desc$id). The widgets of the +#' selected event type and subtype are the relevant ones: they are validated +#' and their values are saved under the property name (desc$name). +#' #' @param id The id of the corresponding UI element #' @param site A reactive expression holding the current site name #' @param set_values Changing the value of this reactive expression sets the @@ -112,95 +115,106 @@ mod_form_ui <- function(id){ #' #' @import shinyvalidate #' @noRd -mod_form_server <- function(id, site, set_values, reset_values, edit_mode, +mod_form_server <- function(id, site, set_values, reset_values, edit_mode, language, init_signal) { - + stopifnot(is.reactive(site)) stopifnot(is.reactive(set_values)) stopifnot(is.reactive(reset_values)) stopifnot(is.reactive(edit_mode)) stopifnot(is.reactive(language)) stopifnot(is.reactive(init_signal)) - + moduleServer(id, function(input, output, session) { - ns <- session$ns - if (dp()) message("Initialising form server function") - + schema <- mgmt_schema er <- schema$event_registry pr <- schema$property_registry - - # add input validators - # the idea is that each widget has its own validator. This validator is - # active whenever that widget is in relevant variables. These individual - # validators are then added as subvalidators to main_iv - main_iv <- InputValidator$new() - - all_props <- get_all_schema_properties(schema) - for (prop_name in all_props) { - # Try to find descriptor from any event/subtype context - desc <- find_any_property_desc(pr, prop_name, schema$property_reverse_index) - if (is.null(desc)) next - if (desc$type %in% c("const", "dataTable")) next - iv <- InputValidator$new() - added_rules <- FALSE + # the widgets of event and subtype properties, and the tables among them + event_fields <- Filter(function(desc) { + desc$event_type != "__common__" && desc$type != "const" + }, pr) + input_fields <- Filter(function(desc) desc$type != "dataTable", + event_fields) + table_fields <- Filter(function(desc) desc$type == "dataTable", + event_fields) + + # keys the schema knows about. Other keys of an edited event are kept as + # they are when it is saved, so that no data is lost + known_names <- c(vapply(pr, function(desc) desc$name, character(1)), + "block", "$schema") + unknown_values <- reactiveVal(list()) + + # the selected event type and subtype + current_context <- reactive({ + event_type <- input$mgmt_operations_event + if (!isTruthy(event_type) || is.null(er[[event_type]])) return(NULL) + list(event_type = event_type, + subtype = get_current_subtype(input, er[[event_type]])) + }) - # add required rule - if (isTRUE(desc$required)) { - iv$add_rule(prop_name, sv_required(message = "Required")) - added_rules <- TRUE - } + # The fields of the selected event type and subtype that are visible, + # i.e. whose x-ui condition (if any) is met. These are the ones validated + # and saved. + relevant_fields <- reactive({ + context <- current_context() + if (is.null(context)) return(list()) + fields <- get_relevant_fields(schema, context$event_type, + context$subtype) + Filter(function(desc) { + desc$type != "const" && (is.null(desc$condition) || + isTRUE(evaluate_condition(desc$condition, + session))) + }, fields) + }) + relevant_ids <- reactive({ + vapply(relevant_fields(), function(desc) desc$id, character(1)) + }) - # add minimum rule - if (!is.null(desc$minimum)) { - iv$add_rule(prop_name, sv_gte(desc$minimum, allow_na = TRUE, - message_fmt = "Must be >= {rhs}")) - added_rules <- TRUE - } + date_required <- reactive({ + context <- current_context() + !is.null(context) && "date" %in% er[[context$event_type]]$required + }) - # add maximum rule - if (!is.null(desc$maximum)) { - iv$add_rule(prop_name, sv_lte(desc$maximum, allow_na = TRUE, - message_fmt = "Must be <= {rhs}")) - added_rules <- TRUE - } + # add input validators + # each widget has its own validator, which is active whenever that widget + # is relevant. These individual validators are added as subvalidators to + # main_iv + main_iv <- InputValidator$new() - # add integer rule - if (isTRUE(desc$is_integer)) { - iv$add_rule(prop_name, function(value) { - if (is.null(value) || is.na(value)) return(NULL) - if (value != floor(value)) return("Must be a whole number") - NULL - }) - added_rules <- TRUE - } - - if (added_rules) { - # the validator is only active when it is in the current list of - # relevant, regular widgets - local({ - local_prop <- prop_name - iv$condition(reactive({ - local_prop %in% relevant_variables()$regular - })) - }) - # add widget validator to main validator - main_iv$add_validator(iv) - } + common_iv <- InputValidator$new() + common_iv$add_rule("mgmt_operations_event", + sv_required(message = "Required")) + common_iv$add_rule("block", sv_required(message = "Required")) + main_iv$add_validator(common_iv) + + date_iv <- InputValidator$new() + date_iv$add_rule("date", sv_required(message = "Required")) + date_iv$condition(date_required) + main_iv$add_validator(date_iv) + + for (desc in input_fields) { + iv <- field_validator(desc) + if (is.null(iv)) next + local({ + field_id <- desc$id + iv$condition(reactive(field_id %in% relevant_ids())) + }) + main_iv$add_validator(iv) } # start showing validation messages main_iv$enable() - + # when site setting is changed, update the block choices on the form observeEvent(site(), ignoreNULL = FALSE, { if (!isTruthy(site())) { shinyjs::disable("block") shinyjs::disable("save") return() - } - + } + shinyjs::enable("block") shinyjs::enable("save") @@ -208,81 +222,44 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, block_choices <- subset(sites, sites$site == site())$blocks[[1]] updateSelectInput(session, "block", choices = block_choices) }) - - # when set_values is changed, update the values in the form - observeEvent(set_values(), { - if (dp()) message("Filling the form with values") - - values <- set_values() - iso <- lang_to_iso(language()) - # populate the input widgets with the values corresponding to the - # event, and clear others - relevant <- get_relevant_properties( - schema, - values$mgmt_operations_event %||% "", - get_subtype_value(values, er) - ) - - for (prop_name in relevant$all) { - desc <- lookup_property( - pr, prop_name, - values$mgmt_operations_event, - get_subtype_value(values, er)) - if (is.null(desc)) next - if (desc$type %in% c("const", "dataTable")) next - - value <- values[[prop_name]] - # Handle legacy property name mapping - if (is.null(value)) { - value <- get_legacy_value(values, prop_name) - } - - if (is.null(value)) { - clear_schema_value(session, prop_name, desc) - } else { - update_schema_value(session, prop_name, desc, value) - } - } - - # Handle array/table data (event-level and subtype-level) - subtype_val <- get_subtype_value(values, er) - for (prop_name in c(relevant$event_props, relevant$subtype_props)) { - desc <- lookup_property(pr, prop_name, - values$mgmt_operations_event, - subtype_val) - if (!is.null(desc) && desc$type == "dataTable") { - table_name <- paste0(prop_name, "_table") - if (!is.null(tables[[table_name]])) { - tables[[table_name]]$set_values(values) - } - } - } - - # Also set common fields explicitly + # Fill the form with the values of an event and clear all other fields, so + # that nothing is left over from a previously edited event (empty values + # are not saved, so a missing value means an empty field). A new event is + # dated today, as when the form is first shown. + fill_form <- function(values) { + event_type <- values$mgmt_operations_event + subtype <- get_subtype_value(values, er) + values$date <- values$date %||% format(Sys.Date(), date_format_json) + if (!is.null(values$block)) { updateSelectInput(session, "block", selected = values$block) } - if (!is.null(values$mgmt_operations_event)) { - updateSelectInput(session, "mgmt_operations_event", - selected = values$mgmt_operations_event) + for (prop_name in schema$common_properties) { + update_schema_value(session, pr[[prop_name]], values[[prop_name]]) } - if (!is.null(values$date)) { - date_val <- tryCatch(as.Date(values$date, format = date_format_json), - warning = function(cnd) NULL) - updateDateInput(session, "date", value = date_val) + event_ids <- if (!is.null(event_type)) { + vapply(get_relevant_fields(schema, event_type, subtype), + function(desc) desc$id, character(1)) } - if (!is.null(values$mgmt_event_short_notes)) { - updateTextAreaInput(session, "mgmt_event_short_notes", - value = values$mgmt_event_short_notes) + for (desc in input_fields) { + value <- if (desc$id %in% event_ids) values[[desc$name]] + update_schema_value(session, desc, value) } - # Handle legacy field name for short notes - if (!is.null(values$mgmt_event_notes) && - is.null(values$mgmt_event_short_notes)) { - updateTextAreaInput(session, "mgmt_event_short_notes", - value = values$mgmt_event_notes) + for (desc in table_fields) { + rows <- if (desc$id %in% event_ids) values[[desc$name]] + tables[[desc$id]]$set_values(rows %||% list()) } - + + unknown_values(values[setdiff(names(values), known_names)]) + summed_ids <<- character(0) + } + + # when set_values is changed, update the values in the form + observeEvent(set_values(), { + if (dp()) message("Filling the form with values") + fill_form(set_values()) + # change set_values back to NULL so that we can catch the next time its # value is changed. This doesn't re-trigger this observeEvent as # observeEvent ignores NULL values by default @@ -293,44 +270,30 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, observeEvent(reset_values(), { if (identical(reset_values(), FALSE)) return() if (dp()) message("Resetting form values") - - # Reset common properties - for (pn in schema$common_properties) { - desc <- lookup_property(pr, pn) - if (!is.null(desc)) clear_schema_value(session, pn, desc) - } - - # Reset all event properties - all_props <- get_all_schema_properties(schema) - for (pn in all_props) { - desc <- find_any_property_desc(pr, pn, schema$property_reverse_index) - if (!is.null(desc) && !(desc$type %in% c("const", "dataTable"))) { - clear_schema_value(session, pn, desc) - } - } - + fill_form(list()) + # Reset fileInput fields separately for (fileInput_code_name in fileInput_code_names) { files[[fileInput_code_name]]$reset_path(TRUE) } - + reset_values(FALSE) }) - + # show Delete button depending on edit mode observeEvent(edit_mode(), ignoreNULL = FALSE, { shinyjs::toggle("delete", condition = edit_mode()) }) - + # update each of the text outputs automatically, including language changes # and the dynamic updating in editing table title etc. lapply(text_output_code_names, FUN = function(text_output_code_name) { # render text output[[text_output_code_name]] <- renderText({ if (dp()) message(glue("Rendering text for {text_output_code_name}")) - + text_to_show <- get_disp_name(text_output_code_name, language()) - + #get element from the UI structure lookup list element <- structure_lookup_list[[text_output_code_name]] #if the text should be updated dynamically, do that @@ -347,83 +310,55 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, text_to_show }) }) - + + # the date label depends on the event type (e.g. the start date of + # grazing) and whether the event type requires a date + observe({ + updateDateInput(session, "date", label = common_field_label( + schema, "date", input$mgmt_operations_event, lang_to_iso(language()))) + }) + # Language switching for schema-driven form fields observeEvent(language(), ignoreInit = TRUE, { iso <- lang_to_iso(language()) - + # Update event type selector - event_choices <- build_event_type_choices(schema, iso) - current_event <- input[["mgmt_operations_event"]] updateSelectInput(session, "mgmt_operations_event", label = schema_get_title( - lookup_property(pr, "mgmt_operations_event")$titles, - iso, "event"), - choices = event_choices, - selected = current_event) - - # Update date label - updateDateInput(session, "date", - label = schema_get_title( - lookup_property(pr, "date")$titles, iso, "date")) - + pr$mgmt_operations_event$titles, iso, "event"), + choices = build_event_type_choices(schema, iso), + selected = input$mgmt_operations_event) + # Update short notes - short_notes_desc <- lookup_property(pr, "mgmt_event_short_notes") + short_notes_desc <- pr$mgmt_event_short_notes updateTextAreaInput(session, "mgmt_event_short_notes", label = schema_get_title( short_notes_desc$titles, iso, "description"), placeholder = schema_get_title( short_notes_desc$placeholders, iso, "")) - - # Update all event-type properties - for (ec in names(er)) { - event_entry <- er[[ec]] - for (pn in event_entry$property_names) { - desc <- lookup_property(pr, pn, ec) - if (is.null(desc)) next - if (desc$type %in% c("const", "dataTable")) next - update_schema_widget(session, pn, desc, iso, input) - } - - if (event_entry$has_subtypes) { - # Update subtype discriminator choices - disc <- event_entry$subtype_discriminator - disc_desc <- lookup_property(pr, disc, ec) - if (!is.null(disc_desc)) { - sub_choices <- build_subtype_choices(event_entry, iso) - current_sub <- input[[disc]] - updateSelectInput(session, disc, - label = schema_get_title( - disc_desc$titles, iso, disc), - choices = sub_choices, - selected = current_sub) - } - - for (sc in names(event_entry$subtypes)) { - sub <- event_entry$subtypes[[sc]] - for (spn in sub$property_names) { - sdesc <- lookup_property(pr, spn, ec, sc) - if (is.null(sdesc)) next - if (sdesc$type %in% c("const", "dataTable")) next - update_schema_widget(session, spn, sdesc, iso, input) - } - } + + # Update all event and subtype fields + for (desc in input_fields) { + subtype_choices <- if (desc$is_discriminator) { + build_subtype_choices(er[[desc$event_type]], iso) } + update_schema_widget(session, desc, iso, input, + override_choices = subtype_choices) } - + # Update app chrome (block label, save/cancel/delete buttons) for (code_name in names(reactiveValuesToList(input))) { element <- structure_lookup_list[[code_name]] if (is.null(element$type)) next label <- get_disp_name(element$label, language()) - + if (element$type == "selectInput") { choices <- get_selectInput_choices(code_name, language()) current_value <- input[[code_name]] if (is.null(choices)) { updateSelectInput(session, code_name, label = ifelse(is.null(label), "", label), - selected = current_value) + selected = current_value) } else { updateSelectInput(session, code_name, label = ifelse(is.null(label), "", label), @@ -435,109 +370,69 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, } } }) - - # Initialise table and fileInput module servers on first use - tables <- list() - files <- sapply(fileInput_code_names, USE.NAMES = TRUE, simplify = FALSE, + + # Table and fileInput module servers are started on first use. The + # reactiveVals for setting table values exist from the start. + tables <- lapply(table_fields, function(desc) { + list(set_values = reactiveVal()) + }) + files <- sapply(fileInput_code_names, USE.NAMES = TRUE, simplify = FALSE, FUN = function(fileInput_code_name) { set_path <- reactiveVal() reset_path <- reactiveVal() list(set_path = set_path, reset_path = reset_path) }) - - # Build the tables list with set_values reactiveVals for each array table - schema_table_names <- get_schema_table_names(schema) - for (tn in schema_table_names) { - set_values_rv <- reactiveVal() - tables[[tn]] <- list(set_values = set_values_rv) - } - - observeEvent(init_signal(), { + + observeEvent(init_signal(), once = TRUE, { if (dp()) message("Initialising table and fileInput server functions") - - for (tn in schema_table_names) { - # Find the array property this table corresponds to - array_prop_name <- sub("_table$", "", tn) - # Find which event/subtype this belongs to - found <- FALSE - for (ec in names(er)) { - # Check event-level properties - desc <- lookup_property(pr, array_prop_name, ec) - if (!is.null(desc) && desc$type == "dataTable") { - tables[[tn]]$result <<- - mod_table_server_schema(tn, array_prop_name, desc, schema, - language, - tables[[tn]]$set_values, - input, main_iv, ns) - found <- TRUE - break - } - # Check subtype-level properties - if (er[[ec]]$has_subtypes) { - for (sc in names(er[[ec]]$subtypes)) { - desc <- lookup_property(pr, array_prop_name, ec, sc) - if (!is.null(desc) && desc$type == "dataTable") { - tables[[tn]]$result <<- - mod_table_server_schema(tn, array_prop_name, desc, schema, - language, - tables[[tn]]$set_values, - input, main_iv, ns) - found <- TRUE - break - } - } - } - if (found) break - } + + for (desc in table_fields) { + tables[[desc$id]]$result <<- mod_table_server_schema( + schema_table_id(desc), desc, language, tables[[desc$id]]$set_values) } - + # start server for all fileInput modules sapply(fileInput_code_names, FUN = function(fileInput_code_name) { - files[[fileInput_code_name]]$value <<- - mod_fileInput_server(id = fileInput_code_name, + files[[fileInput_code_name]]$value <<- + mod_fileInput_server(id = fileInput_code_name, language = language, set_path = files[[fileInput_code_name]]$set_path, reset_path = files[[fileInput_code_name]]$reset_path) }) }) - - # Auto-sum: update total fields from table column values + + # Auto-sum: update total fields from table column values. A total is only + # computed when the table has values to sum, so a total entered without + # per-item values (as in many legacy events) is kept. summed_ids holds the + # totals currently computed from the tables. + summed_ids <- character(0) observe({ - event_type <- input[["mgmt_operations_event"]] - if (!isTruthy(event_type)) return() - - event_entry <- er[[event_type]] - if (is.null(event_entry)) return() - - # Collect all property names including subtypes - subtype <- get_current_subtype(input, er) - all_props <- event_entry$property_names - if (event_entry$has_subtypes && !is.null(subtype) && - !is.null(event_entry$subtypes[[subtype]])) { - all_props <- c(all_props, event_entry$subtypes[[subtype]]$property_names) - } + context <- current_context() + if (is.null(context)) return() - for (pn in all_props) { - desc <- lookup_property(pr, pn, event_type, subtype) - if (is.null(desc) || is.null(desc$total_of)) next + for (desc in relevant_fields()) { + if (is.null(desc$total_of)) next + table_id <- lookup_property_key(pr, desc$total_of$list_name, + context$event_type, context$subtype) + table <- tables[[table_id %||% ""]]$result + if (is.null(table)) next - list_name <- desc$total_of$list_name prop_to_sum <- desc$total_of$property_name - tn <- paste0(list_name, "_table") - - if (is.null(tables[[tn]]$result)) next - - col_values <- tables[[tn]]$result$values()[[prop_to_sum]] - if (is.null(col_values) || all(is.na(col_values))) { - total <- NA - } else { - nums <- suppressWarnings(as.numeric(col_values)) - total <- sum(nums, na.rm = TRUE) - if (total == 0 && all(is.na(nums))) total <- NA + nums <- suppressWarnings(as.numeric(unlist( + lapply(table$values(), function(row) row[[prop_to_sum]] %||% NA)))) + if (all(is.na(nums))) { + # the values it was computed from have been removed + if (desc$id %in% summed_ids) { + updateNumericInput(session, desc$id, value = NA) + summed_ids <<- setdiff(summed_ids, desc$id) + } + shinyjs::enable(desc$id) + next } - updateNumericInput(session, pn, value = total) - shinyjs::disable(pn) + updateNumericInput(session, desc$id, value = sum(nums, na.rm = TRUE)) + shinyjs::disable(desc$id) + summed_ids <<- union(summed_ids, desc$id) } }) @@ -545,51 +440,40 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, form_data <- reactive({ if (dp()) message("Calculating form data") - relevant <- relevant_variables() - - relevant_table <- NULL - if (length(relevant$table_name) > 0 && !is.null(tables[[relevant$table_name]])) { - relevant_table <- tables[[relevant$table_name]]$result - } + fields <- relevant_fields() + is_table <- vapply(fields, function(desc) desc$type == "dataTable", + logical(1)) + relevant_tables <- lapply(fields[is_table], function(desc) { + tables[[desc$id]]$result + }) + names(relevant_tables) <- vapply(fields[is_table], + function(desc) desc$name, character(1)) + relevant_tables <- Filter(Negate(is.null), relevant_tables) # check that the form and table validation rules have been met - if (!main_iv$is_valid() || - (!is.null(relevant_table) && !relevant_table$valid())) { + tables_valid <- vapply(relevant_tables, function(t) isTRUE(t$valid()), + logical(1)) + if (!main_iv$is_valid() || !all(tables_valid)) { return(NULL) } - + event <- list() # fill information - event$mgmt_operations_event <- input[["mgmt_operations_event"]] - event$date <- tryCatch( - format(input[["date"]], date_format_json), - error = function(cnd) "" - ) - event$mgmt_event_short_notes <- trimws(input[["mgmt_event_short_notes"]] %||% "") - event$block <- input[["block"]] - - for (prop_name in relevant$regular) { - if (prop_name %in% c("mgmt_operations_event", "date", - "mgmt_event_short_notes", "block")) next - - desc <- lookup_property( - pr, prop_name, - input[["mgmt_operations_event"]], - get_current_subtype(input, er)) - if (is.null(desc)) next - if (desc$type == "const") next - - is_fileInput <- !is.null(structure_lookup_list[[prop_name]]) && - identical(structure_lookup_list[[prop_name]]$type, "fileInput") - + event$mgmt_operations_event <- input$mgmt_operations_event + event$date <- tryCatch(format(input$date, date_format_json), + error = function(cnd) "") + event$mgmt_event_short_notes <- input$mgmt_event_short_notes + event$block <- input$block + + for (desc in fields[!is_table]) { + is_fileInput <- !is.null(structure_lookup_list[[desc$name]]) && + identical(structure_lookup_list[[desc$name]]$type, "fileInput") + value <- if (is_fileInput) { - files[[prop_name]]$value() + files[[desc$name]]$value() } else { - input[[prop_name]] + input[[desc$id]] } - - # if value is character, trim any whitespace around it - if (is.character(value)) value <- trimws(value) # format Date value to character string and replace with "" if that # fails for some reason @@ -598,144 +482,53 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, error = function(cnd) "") } - # if the value is not defined or empty, replace with missingval - if (length(value) == 0) { - value <- missingval - } else { - missing_indexes <- is.na(value) | value == "" - if (any(missing_indexes)) { - value[missing_indexes] <- missingval - } - } - - event[[prop_name]] <- value + event[[desc$name]] <- value } - - if (!is.null(relevant_table)) { - table_values <- relevant_table$values() - for (vn in names(table_values)) { - val <- table_values[[vn]] - if (length(val) == 0) { - val <- missingval - } else { - missing_indexes <- is.na(val) | val == "" - if (any(missing_indexes)) val[missing_indexes] <- missingval - } - event[[vn]] <- val - } - } - - # Replace empty common fields - for (fn in c("mgmt_event_short_notes")) { - if (is.null(event[[fn]]) || identical(event[[fn]], "")) { - event[[fn]] <- missingval - } - } - - # return event data - event - }) - # When requested, calculate a vector with the names of relevant variables. A - # variable is relevant when it is visible in some form, either as a regular - # widget or in a table module. Relevant variables are ones which we want to - # save to a json file given the current choices of the user. For example, - # when the user is making a soil observation event, the variables related - # to that are relevant while other observation variables are not. - # This only works when the form is already open. - relevant_variables <- reactive({ - if (dp()) message("Calculating relevant variables") - - event_type <- input[["mgmt_operations_event"]] - if (!isTruthy(event_type)) { - return(list(regular = character(0), table = character(0), - table_name = character(0))) + # each table is saved as an array of row objects under its property + for (array_prop_name in names(relevant_tables)) { + event[[array_prop_name]] <- relevant_tables[[array_prop_name]]$values() } - - event_entry <- er[[event_type]] - if (is.null(event_entry)) { - return(list(regular = character(0), table = character(0), - table_name = character(0))) - } - - subtype <- get_current_subtype(input, er) - relevant <- get_relevant_properties(schema, event_type, subtype) - - regular_props <- character(0) - table_props <- character(0) - table_name <- character(0) - - for (pn in relevant$all) { - desc <- lookup_property(pr, pn, event_type, subtype) - if (is.null(desc)) next - if (desc$type == "const") next - - # Skip fields whose x-ui condition evaluates to FALSE - if (!is.null(desc$xui$condition)) { - cond_result <- evaluate_condition(desc$xui$condition, session) - if (is.null(cond_result) || !isTRUE(cond_result)) next - } - if (desc$type == "dataTable") { - tn <- paste0(pn, "_table") - table_name <- c(table_name, tn) - # Get the table column names - if (!is.null(desc$array_columns)) { - table_props <- c(table_props, names(desc$array_columns)) - } - } else { - regular_props <- c(regular_props, pn) - } - } - - list( - regular = regular_props, - table = table_props, - table_name = if (length(table_name) > 0) table_name[1] else character(0) - ) + # trim whitespace from text and leave out empty values + event <- drop_empty_values( + rapply(event, trimws, classes = "character", how = "replace")) + + # keep the values of the edited event that the form doesn't know about + # as they are + unknown <- unknown_values() + event[names(unknown)] <- unknown + event }) - + ################## RETURN VALUE - + list( data = form_data, save = reactive(input$save), cancel = reactive(input$cancel), delete = reactive(input$delete) ) - + }) - + } -# Helper: find a property descriptor trying multiple contexts. -# Uses the reverse index (built in load_schema) for O(1) lookup instead of -# scanning every registry key. -find_any_property_desc <- function(pr, prop_name, reverse_index = NULL) { - # Direct common lookup - if (!is.null(pr[[prop_name]])) return(pr[[prop_name]]) - # Use reverse index if available (O(1) instead of O(n)) - if (!is.null(reverse_index) && !is.null(reverse_index[[prop_name]])) { - return(pr[[reverse_index[[prop_name]]]]) - } - # Fallback: linear scan (for callers without the index) - for (key in names(pr)) { - if (startsWith(key, paste0(prop_name, REGISTRY_KEY_SEP))) { - return(pr[[key]]) - } - } - NULL +# Helper: label of a common property for the selected event type. An event +# type can retitle a common property (e.g. grazing's date is its start date) +# and require it. +common_field_label <- function(schema, prop_name, event_type, iso) { + entry <- if (isTruthy(event_type)) schema$event_registry[[event_type]] + desc <- entry$common_overrides[[prop_name]] %||% + schema$property_registry[[prop_name]] + make_required_label(schema_get_title(desc$titles, iso, prop_name), + prop_name %in% entry$required) } -# Helper: get the current subtype from input -get_current_subtype <- function(input, er) { - event_type <- input[["mgmt_operations_event"]] - if (!isTruthy(event_type)) return(NULL) - event_entry <- er[[event_type]] - if (is.null(event_entry) || !event_entry$has_subtypes) return(NULL) - disc <- event_entry$subtype_discriminator - if (is.null(disc)) return(NULL) - sub_val <- input[[disc]] +# Helper: get the selected subtype of an event type from input +get_current_subtype <- function(input, event_entry) { + if (!isTRUE(event_entry$has_subtypes)) return(NULL) + sub_val <- input[[event_entry$subtype_discriminator_id]] if (!isTruthy(sub_val)) return(NULL) sub_val } @@ -750,39 +543,3 @@ get_subtype_value <- function(values, er) { if (is.null(disc)) return(NULL) values[[disc]] } - -# Helper: get schema table names -get_schema_table_names <- function(schema) { - er <- schema$event_registry - pr <- schema$property_registry - table_names <- character(0) - for (ec in names(er)) { - event_entry <- er[[ec]] - for (pn in event_entry$property_names) { - desc <- lookup_property(pr, pn, ec) - if (!is.null(desc) && desc$type == "dataTable") { - table_names <- c(table_names, paste0(pn, "_table")) - } - } - # Also check subtype properties (e.g. soil_layer_list in observation_type_soil) - if (event_entry$has_subtypes) { - for (sc in names(event_entry$subtypes)) { - for (spn in event_entry$subtypes[[sc]]$property_names) { - sdesc <- lookup_property(pr, spn, ec, sc) - if (!is.null(sdesc) && sdesc$type == "dataTable") { - table_names <- c(table_names, paste0(spn, "_table")) - } - } - } - } - } - unique(table_names) -} - -get_legacy_value <- function(values, schema_prop_name) { - legacy_names <- names(legacy_name_map)[legacy_name_map == schema_prop_name] - for (ln in legacy_names) { - if (!is.null(values[[ln]])) return(values[[ln]]) - } - NULL -} diff --git a/R/mod_table.R b/R/mod_table.R index 2974da7..019fe11 100644 --- a/R/mod_table.R +++ b/R/mod_table.R @@ -113,21 +113,16 @@ build_remove_row_button <- function(ns, iso, row_idx, can_remove) { #' Schema-driven table server module #' #' @param id Module ID (must match the table_id used in render_array_table) -#' @param array_prop_name The property name of the array in the schema #' @param desc The property descriptor for the array -#' @param schema The loaded schema #' @param language Reactive language value -#' @param override_values ReactiveVal for setting table values -#' @param parent_input The parent module's input -#' @param parent_iv The parent module's InputValidator -#' @param parent_ns The parent module's namespace function +#' @param override_values ReactiveVal for setting table values, as a list of +#' rows (named lists keyed by column name) #' -#' @return A list with values() and valid() reactives +#' @return A list with values() and valid() reactives. values() holds the +#' table contents as a list of rows (named lists keyed by column name) #' @import shinyvalidate #' @noRd -mod_table_server_schema <- function(id, array_prop_name, desc, schema, - language, override_values, - parent_input, parent_iv, parent_ns) { +mod_table_server_schema <- function(id, desc, language, override_values) { stopifnot(is.reactive(language)) stopifnot(is.reactive(override_values)) @@ -156,32 +151,16 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, # Extract the row number from the widget name (e.g. "crop_name_2" -> 2) row_num <- as.integer(sub(paste0("^", variables[i], "_"), "", widget_name)) - child_iv <- InputValidator$new() + child_iv <- field_validator(col_desc, widget_name) + if (is.null(child_iv)) return() - if (isTRUE(col_desc$required)) { - child_iv$add_rule(widget_name, sv_required(message = "Required")) - } - if (!is.null(col_desc$minimum)) { - child_iv$add_rule(widget_name, sv_gte(col_desc$minimum, allow_na = TRUE, - message_fmt = "Must be >= {rhs}")) - } - if (!is.null(col_desc$maximum)) { - child_iv$add_rule(widget_name, sv_lte(col_desc$maximum, allow_na = TRUE, - message_fmt = "Must be <= {rhs}")) - } - if (isTRUE(col_desc$is_integer)) { - child_iv$add_rule(widget_name, function(value) { - if (is.null(value) || is.na(value)) return(NULL) - if (value != floor(value)) return("Must be a whole number") - NULL - }) - } - - # Only validate when this row still exists + # Only validate when this row is displayed. Widgets are numbered by + # display position, so compare with the number of rows rather than + # with the (stable) row ids local({ local_row <- row_num child_iv$condition(reactive({ - local_row %in% dynamic_rows() + local_row <= length(dynamic_rows()) })) }) iv$add_validator(child_iv) @@ -190,6 +169,8 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, } n_cols <- length(column_names) + # the latest entered rows and their dynamic row ids, used to keep the + # entered values when the table is re-rendered old_values <- reactiveVal() table_values <- reactiveVal() rendered <- reactiveVal(FALSE) @@ -217,14 +198,7 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, values <- override_values() if (is.null(values)) return() - # Determine rows from the data - first_col <- column_names[1] - col_data <- values[[first_col]] - if (!is.null(col_data) && length(col_data) > 0) { - dynamic_rows(as.integer(seq_along(col_data))) - } else { - dynamic_rows(1L) - } + dynamic_rows(if (length(values) > 0) seq_along(values) else 1L) override_trigger(override_trigger() + 1) }) @@ -306,11 +280,11 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, col_desc <- columns[[variable]] value <- if (do_override) { - override_vals[[variable]][row_idx] + override_vals[[row_idx]][[variable]] } else { - old_row_number <- which( - isolate(old_values())[["DYNAMIC_ROWS"]] == rows[current_row]) - isolate(old_values())[[variable]][old_row_number] + old <- isolate(old_values()) + old_row_number <- match(row_idx, old$row_ids) + if (!is.na(old_row_number)) old$rows[[old_row_number]][[variable]] } cell <- build_schema_cell_widget(variable, col_desc, ns, iso, @@ -338,14 +312,9 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, if (nrow(table_to_display) == 0) return() iso <- lang_to_iso(language()) - # Use unitless titles or regular titles for column headers + # full titles, as they include the unit col_labels <- vapply(column_names, function(cn) { - col_desc <- columns[[cn]] - if (!is.null(col_desc$unitless_titles)) { - schema_get_title(col_desc$unitless_titles, iso, cn) - } else { - schema_get_title(col_desc$titles, iso, cn) - } + schema_get_title(columns[[cn]]$titles, iso, cn) }, character(1)) names(table_to_display) <- c(col_labels, "") @@ -380,10 +349,8 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, }, server = FALSE) observe({ - value_list <- list() - if (!rendered()) { - table_values(value_list) + table_values(list()) return() } @@ -391,25 +358,21 @@ mod_table_server_schema <- function(id, array_prop_name, desc, schema, rows <- dynamic_rows() if (is.null(rows) || length(rows) == 0) { - table_values(value_list) + table_values(list()) return() } - row_numbers <- seq_along(rows) - - for (variable in column_names) { - values <- NULL - for (row_number in row_numbers) { - element_name <- paste(variable, row_number, sep = "_") - values <- c(values, input[[element_name]]) - } - value_list[[variable]] <- values - } - - table_values(value_list) + # widgets are numbered by display position, not by dynamic row id + row_values <- lapply(seq_along(rows), function(row_number) { + row <- lapply(column_names, function(variable) { + input[[paste(variable, row_number, sep = "_")]] + }) + names(row) <- column_names + row + }) - value_list <- c(value_list, list(DYNAMIC_ROWS = isolate(dynamic_rows()))) - old_values(value_list) + table_values(row_values) + old_values(list(rows = row_values, row_ids = rows)) }) list( diff --git a/R/utils_global.R b/R/utils_global.R index a6323eb..10927a4 100644 --- a/R/utils_global.R +++ b/R/utils_global.R @@ -27,24 +27,9 @@ languages <- c("English \U0001f1ec\U0001f1e7" = "disp_name_eng", "svenska \U0001f1f8\U0001f1ea" = "disp_name_swe") init_lang <- languages[1] -# Load and parse the management-event schema at package load time. -# Wrapped in tryCatch so the package can still load if the schema file is -# missing or malformed (e.g. during development or testing). -mgmt_schema <- tryCatch( - load_schema(), - error = function(e) { - message("Failed to load management-event schema: ", conditionMessage(e)) - message("The application may not function correctly without the schema.") - list( - raw = list(), - event_registry = list(), - property_registry = list(), - property_reverse_index = list(), - common_properties = character(0), - event_type_choices = list() - ) - } -) +# Load and parse the management-event schema at package load time. The form +# is built from it, so the app cannot run without it. +mgmt_schema <- load_schema() # whether to print debug information (short for debug print) # set the boolean value below to FALSE to suppress prints diff --git a/man/clear_schema_value.Rd b/man/clear_schema_value.Rd deleted file mode 100644 index ff53cde..0000000 --- a/man/clear_schema_value.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_schema_ui.R -\name{clear_schema_value} -\alias{clear_schema_value} -\title{Clear a schema-driven widget} -\usage{ -clear_schema_value(session, prop_name, desc) -} -\description{ -Clear a schema-driven widget -} diff --git a/man/condition_to_field_ids.Rd b/man/condition_to_field_ids.Rd new file mode 100644 index 0000000..9ec00f8 --- /dev/null +++ b/man/condition_to_field_ids.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{condition_to_field_ids} +\alias{condition_to_field_ids} +\title{Point the input references of an x-ui condition at field IDs} +\usage{ +condition_to_field_ids(condition, registry, event_type, subtype) +} +\arguments{ +\item{condition}{A condition such as "input.chemical_type == 'x'"} + +\item{registry}{The property registry} + +\item{event_type}{Event type of the property the condition belongs to} + +\item{subtype}{Subtype of that property (or NULL)} +} +\value{ +The condition with each input.name replaced by input.id +} +\description{ +Point the input references of an x-ui condition at field IDs +} diff --git a/man/drop_empty_values.Rd b/man/drop_empty_values.Rd new file mode 100644 index 0000000..d3fb8a9 --- /dev/null +++ b/man/drop_empty_values.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_format.R +\name{drop_empty_values} +\alias{drop_empty_values} +\title{Recursively remove empty values from an event} +\usage{ +drop_empty_values(x) +} +\arguments{ +\item{x}{An event, a list of rows or a single value} +} +\value{ +x without empty values, or NULL if nothing is left +} +\description{ +Atomic values that are entirely empty, rows (list items) that become empty +and lists that become empty are removed. +} diff --git a/man/events_to_table.Rd b/man/events_to_table.Rd new file mode 100644 index 0000000..5d2731e --- /dev/null +++ b/man/events_to_table.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_format.R +\name{events_to_table} +\alias{events_to_table} +\title{Flatten events into a table with one row per event} +\usage{ +events_to_table(events) +} +\arguments{ +\item{events}{A list of events in the canonical format} +} +\value{ +A data frame of character columns +} +\description{ +Array properties are spread into one column per item property, holding the +items' values in order separated by "; " (an empty value keeps its place). +Vectors are joined the same way. The $schema key is left out. +} diff --git a/man/field_validator.Rd b/man/field_validator.Rd new file mode 100644 index 0000000..fd0930d --- /dev/null +++ b/man/field_validator.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{field_validator} +\alias{field_validator} +\title{Build the validator for a schema-driven widget} +\usage{ +field_validator(desc, id = desc$id) +} +\arguments{ +\item{desc}{Property descriptor} + +\item{id}{Input ID of the widget} +} +\value{ +An InputValidator, or NULL if the property has no rules +} +\description{ +Rules come from the property descriptor: required, minimum, maximum and +whole numbers. An empty optional widget skips the other rules. +} diff --git a/man/find_property_by_name.Rd b/man/find_property_by_name.Rd new file mode 100644 index 0000000..64905bc --- /dev/null +++ b/man/find_property_by_name.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{find_property_by_name} +\alias{find_property_by_name} +\title{Find a property by name in any event type} +\usage{ +find_property_by_name(schema, prop_name) +} +\arguments{ +\item{schema}{The loaded schema (from load_schema)} + +\item{prop_name}{Property name} +} +\value{ +The property descriptor, or NULL +} +\description{ +For display purposes where the event type is not known (e.g. event list +column headers). Returns the first matching descriptor. +} diff --git a/man/get_all_schema_properties.Rd b/man/get_all_schema_properties.Rd deleted file mode 100644 index 9aa58d6..0000000 --- a/man/get_all_schema_properties.Rd +++ /dev/null @@ -1,13 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_schema_ui.R -\name{get_all_schema_properties} -\alias{get_all_schema_properties} -\title{Get all schema property names as a flat vector (for registry iteration) -Used to find all properties that need validation, value collection, etc.} -\usage{ -get_all_schema_properties(schema) -} -\description{ -Get all schema property names as a flat vector (for registry iteration) -Used to find all properties that need validation, value collection, etc. -} diff --git a/man/get_relevant_fields.Rd b/man/get_relevant_fields.Rd new file mode 100644 index 0000000..80e9b8f --- /dev/null +++ b/man/get_relevant_fields.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{get_relevant_fields} +\alias{get_relevant_fields} +\title{Get the fields shown for the selected event type and subtype} +\usage{ +get_relevant_fields(schema, event_type, subtype = NULL) +} +\arguments{ +\item{schema}{The loaded schema (from load_schema)} + +\item{event_type}{The selected event type const} + +\item{subtype}{The selected subtype const (or NULL)} +} +\value{ +A list of property descriptors, event-level fields first +} +\description{ +Common properties are not included, they have their own widgets. +} diff --git a/man/is_missing_value.Rd b/man/is_missing_value.Rd new file mode 100644 index 0000000..edd2871 --- /dev/null +++ b/man/is_missing_value.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_format.R +\name{is_missing_value} +\alias{is_missing_value} +\title{Check which elements of an atomic vector are empty} +\usage{ +is_missing_value(x) +} +\arguments{ +\item{x}{An atomic vector} +} +\value{ +A logical vector of the same length +} +\description{ +NA, blank strings and the ICASA missing value (stored as "-99.0" or -99) +count as empty. +} diff --git a/man/lift_array_fields.Rd b/man/lift_array_fields.Rd new file mode 100644 index 0000000..336c46e --- /dev/null +++ b/man/lift_array_fields.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_format.R +\name{lift_array_fields} +\alias{lift_array_fields} +\title{Move flat per-item values into the event's array properties} +\usage{ +lift_array_fields(event, schema) +} +\arguments{ +\item{event}{An event list} + +\item{schema}{The loaded schema (from load_schema)} +} +\value{ +The event with item columns nested under array properties +} +\description{ +Legacy events store item columns (e.g. harvest_crop, harvest_method) on the +event itself: a scalar for a single item or parallel vectors for several. +This zips them into the rows of the array property (e.g. harvest_list). +Which columns belong to which array is read from the schema. +} diff --git a/man/load_schema.Rd b/man/load_schema.Rd index 410ad93..bd45f63 100644 --- a/man/load_schema.Rd +++ b/man/load_schema.Rd @@ -11,5 +11,8 @@ A list with components: raw (the full parsed schema), event_registry, property_registry, common_properties, event_type_choices } \description{ -Load and parse the management-event schema +Every property is registered once per event type (and subtype) it appears +in. Its registry key is also its unique input ID in the form, so a property +shared by several event types (e.g. mgmt_event_long_notes) gets a separate +widget per event type. } diff --git a/man/lookup_property_key.Rd b/man/lookup_property_key.Rd new file mode 100644 index 0000000..94ca937 --- /dev/null +++ b/man/lookup_property_key.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{lookup_property_key} +\alias{lookup_property_key} +\title{Find the registry key (input ID) of a property} +\usage{ +lookup_property_key(registry, prop_name, event_type = NULL, subtype = NULL) +} +\arguments{ +\item{registry}{The property registry} + +\item{prop_name}{Property name} + +\item{event_type}{Event type const (or NULL for common)} + +\item{subtype}{Subtype const (or NULL)} +} +\value{ +The most specific matching key, or NULL +} +\description{ +Find the registry key (input ID) of a property +} diff --git a/man/normalize_legacy_event.Rd b/man/normalize_legacy_event.Rd index 124415d..a1e65fc 100644 --- a/man/normalize_legacy_event.Rd +++ b/man/normalize_legacy_event.Rd @@ -1,17 +1,20 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_files.R +% Please edit documentation in R/fct_event_format.R \name{normalize_legacy_event} \alias{normalize_legacy_event} -\title{Normalize a legacy event to use schema property names} +\title{Upgrade an event read from events.json to the canonical format} \usage{ -normalize_legacy_event(event) +normalize_legacy_event(event, schema = mgmt_schema) } \arguments{ \item{event}{An event list} + +\item{schema}{The loaded schema (from load_schema)} } \value{ -The event with legacy names mapped to schema names +The event in the canonical format } \description{ -Normalize a legacy event to use schema property names +Events already in the canonical format pass through unchanged apart from +dropping empty values. See the top of this file for what is upgraded. } diff --git a/man/render_array_table.Rd b/man/render_array_table.Rd index feb2aa9..0d31b33 100644 --- a/man/render_array_table.Rd +++ b/man/render_array_table.Rd @@ -4,12 +4,10 @@ \alias{render_array_table} \title{Render a schema array property as a table module placeholder} \usage{ -render_array_table(prop_name, desc, ns, iso) +render_array_table(desc, ns, iso) } \arguments{ -\item{prop_name}{The array property name (e.g. "planting_list")} - -\item{desc}{The property descriptor} +\item{desc}{The property descriptor of the array (e.g. planting_list)} \item{ns}{Namespace function} diff --git a/man/render_property_widget.Rd b/man/render_property_widget.Rd index 056b3c1..04f7486 100644 --- a/man/render_property_widget.Rd +++ b/man/render_property_widget.Rd @@ -19,7 +19,7 @@ render_property_widget( ) } \arguments{ -\item{prop_name}{Property name (used as input ID)} +\item{prop_name}{Input ID of the widget (desc$id for form fields)} \item{desc}{Property descriptor from the registry} diff --git a/man/render_subtype_section.Rd b/man/render_subtype_section.Rd index 73cd784..00e1272 100644 --- a/man/render_subtype_section.Rd +++ b/man/render_subtype_section.Rd @@ -4,7 +4,7 @@ \alias{render_subtype_section} \title{Render a subtype discriminator and its conditional panels} \usage{ -render_subtype_section(pn, desc, event_entry, pr, ns, iso, event_const) +render_subtype_section(desc, event_entry, pr, ns, iso, event_const) } \description{ Render a subtype discriminator and its conditional panels diff --git a/man/schema_table_id.Rd b/man/schema_table_id.Rd new file mode 100644 index 0000000..359255f --- /dev/null +++ b/man/schema_table_id.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{schema_table_id} +\alias{schema_table_id} +\title{Module ID of the table for an array property} +\usage{ +schema_table_id(desc) +} +\arguments{ +\item{desc}{The property descriptor of the array} +} +\value{ +The table module ID +} +\description{ +Module ID of the table for an array property +} diff --git a/man/split_grazing_period.Rd b/man/split_grazing_period.Rd new file mode 100644 index 0000000..79b74ba --- /dev/null +++ b/man/split_grazing_period.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_event_format.R +\name{split_grazing_period} +\alias{split_grazing_period} +\title{Split a legacy grazing period into start and end dates} +\usage{ +split_grazing_period(event) +} +\arguments{ +\item{event}{An event list} +} +\value{ +The event with end_date (and date) set from grazing_period +} +\description{ +The start date becomes the event date if the event has none. If the event +date differs from the start date, grazing_period is kept so that the start +date is not lost. +} diff --git a/man/to_sentence_case.Rd b/man/to_sentence_case.Rd new file mode 100644 index 0000000..339be50 --- /dev/null +++ b/man/to_sentence_case.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema.R +\name{to_sentence_case} +\alias{to_sentence_case} +\title{Capitalise the first letter of a label} +\usage{ +to_sentence_case(x) +} +\arguments{ +\item{x}{A character string} +} +\value{ +x with its first letter in upper case +} +\description{ +Labels whose first word already contains capitals (e.g. "pH after the +application") are left as they are. +} diff --git a/man/update_schema_value.Rd b/man/update_schema_value.Rd index ce51c31..38c0dbd 100644 --- a/man/update_schema_value.Rd +++ b/man/update_schema_value.Rd @@ -4,16 +4,14 @@ \alias{update_schema_value} \title{Update a schema-driven widget value (for populating forms)} \usage{ -update_schema_value(session, prop_name, desc, value) +update_schema_value(session, desc, value) } \arguments{ \item{session}{Shiny session} -\item{prop_name}{Property name} - \item{desc}{Property descriptor} -\item{value}{The value to set} +\item{value}{The value to set. NULL clears the widget} } \description{ Update a schema-driven widget value (for populating forms) diff --git a/man/update_schema_widget.Rd b/man/update_schema_widget.Rd index bb9e8bd..7cf9015 100644 --- a/man/update_schema_widget.Rd +++ b/man/update_schema_widget.Rd @@ -4,7 +4,18 @@ \alias{update_schema_widget} \title{Update a single schema widget's label and choices} \usage{ -update_schema_widget(session, prop_name, desc, iso, input) +update_schema_widget(session, desc, iso, input, override_choices = NULL) +} +\arguments{ +\item{session}{Shiny session} + +\item{desc}{Property descriptor} + +\item{iso}{ISO language code} + +\item{input}{The input of the session, to keep the current selection} + +\item{override_choices}{Optional choices (e.g. for a subtype discriminator)} } \description{ Update a single schema widget's label and choices diff --git a/tests/testthat/helper-events.R b/tests/testthat/helper-events.R new file mode 100644 index 0000000..1843d63 --- /dev/null +++ b/tests/testthat/helper-events.R @@ -0,0 +1,71 @@ +# Shared test fixtures for events.json files + +# Legacy events in the shapes found in real events.json files written before +# the schema was adopted +legacy_events <- list( + list( + mgmt_operations_event = "planting", + date = "2023-05-25", + mgmt_event_notes = "-99.0", + planted_crop = c("BAR", "RCL", "ZZ3"), + planting_notes = "Mixed grass", + planting_material_weight = c(240, 3, 20), + planting_depth = c("-99.0", "-99.0", "-99.0"), + planting_material_source = c("-99.0", "own seeds", "-99.0") + ), + list( + mgmt_operations_event = "harvest", + date = "2021-06-15", + mgmt_event_notes = "First cut", + harvest_area = "-99.0", + harvest_yield_harvest_dw_total = 4200, + harvest_crop = "ZZ1", + harvest_operat_component = "silage", + harvest_method = "HM008", + harvest_moisture = "-99.0", + harvest_comments = "-99.0" + ), + list( + mgmt_operations_event = "organic_material", + date = "2023-04-27", + mgmt_event_notes = "-99.0", + fertilizer_type = "fertilizer_type_organic", + organic_material = "RE003", + fertilizer_total_amount = 21000, + fertilizer_notes = "Separator dry fraction", + N_in_applied_fertilizer = 12.9, + fertilizer_K_applied = "-99.0" + ), + list( + mgmt_operations_event = "tillage", + date = "2023-05-25", + mgmt_event_notes = "-99.0", + tillage_practice = "tillage_practice_primary", + tillage_implement = "TI015", + tillage_operations_depth = 15, + tillage_treatment_notes = "Harrowing" + ), + list( + mgmt_operations_event = "other", + date = "2024-10-09", + mgmt_event_notes = "Plowing was done 8.10. and 9.10.", + other_notes = "Plowing." + ), + list( + mgmt_operations_event = "grazing", + date = "2022-06-01", + mgmt_event_notes = "-99.0", + grazing_species = "grazing_species_cattle", + grazing_period = c("2022-06-01", "2022-06-20"), + grazing_notes = "-99.0" + ) +) + +write_events_file <- function(base_folder, site, block, events) { + dir.create(file.path(base_folder, site, block), recursive = TRUE) + jsonlite::write_json( + list(management = list(rotation = list(), events = events)), + file.path(base_folder, site, block, "events.json"), + auto_unbox = TRUE, pretty = TRUE + ) +} diff --git a/tests/testthat/test-download.R b/tests/testthat/test-download.R index fcb58bd..85d4e1c 100644 --- a/tests/testthat/test-download.R +++ b/tests/testthat/test-download.R @@ -1,28 +1,55 @@ test_that("is download functional", { # Check that the size of guide makes sense when it is downloaded testServer(mod_download_server_inst, { - #stopifnot(grepl(".html", output$report)) - print(output$report) expect_true(grepl("guideFieldactivity.html", output$report)) expect_true(file.info(output$report)$size > 10000) }) - - site <- reactive("qvidja") - - # Check that file exist when downloading csv - testServer(mod_download_server_table, args = list(user_auth = site), { - expect_true(file.exists(output$eventtable)) - expect_true(file.size(output$eventtable) > 70) +}) + +test_that("csv export has one row per event in the canonical format", { + base_folder <- tempfile() + on.exit(unlink(base_folder, recursive = TRUE)) + write_events_file(base_folder, "site", "0", legacy_events[1:2]) + write_events_file(base_folder, "site", "1", legacy_events[5]) + + testServer(mod_download_server_table, + args = list(user_auth = reactive("site"), + base_folder = base_folder), { + table <- utils::read.csv(output$eventtable, colClasses = "character") + expect_equal(nrow(table), 3) + expect_equal(names(table)[1], "block") + expect_equal(table$block, c("0", "0", "1")) + expect_equal(table$planted_crop[1], "BAR; RCL; ZZ3") + expect_equal(table$mgmt_event_long_notes[3], "Plowing.") + expect_false(any(grepl("-99", unlist(table), fixed = TRUE))) + }) +}) + +test_that("json export zips the events file of each block", { + base_folder <- tempfile() + on.exit(unlink(base_folder, recursive = TRUE)) + write_events_file(base_folder, "site", "0", legacy_events[1:2]) + write_events_file(base_folder, "site", "1", legacy_events[5]) + write_events_file(base_folder, "other_site", "0", legacy_events[3]) + + testServer(mod_download_server_json, + args = list(user_auth = reactive("site"), + base_folder = base_folder), { + files <- zip::zip_list(output$eventjson)$filename + expect_setequal(files, c("json/", "json/events_0.json", + "json/events_1.json")) + }) +}) + +test_that("exports without data explain that there is none", { + testServer(mod_download_server_table, + args = list(user_auth = reactive(NULL), base_folder = tempfile()), { + expect_match(paste(readLines(output$eventtable), collapse = ""), + "there isn't any data") }) - - - # Check that file exist when downloading zip - testServer(mod_download_server_json, args = list(user_auth = site), { - expect_true(file.exists(output$eventjson)) - expect_true(grepl(".zip", output$eventjson)) - - - data <- unzip(output$eventjson, list=TRUE) - expect_true(length(data) > 1) + testServer(mod_download_server_json, + args = list(user_auth = reactive(NULL), base_folder = tempfile()), { + expect_equal(zip::zip_list(output$eventjson)$filename, + c("json/", "json/Error.csv")) }) }) diff --git a/tests/testthat/test-fct_event_format.R b/tests/testthat/test-fct_event_format.R new file mode 100644 index 0000000..fdf505d --- /dev/null +++ b/tests/testthat/test-fct_event_format.R @@ -0,0 +1,187 @@ +# Tests for the canonical event format and the legacy upgrade on read +# (fixtures in helper-events.R) + +# --- drop_empty_values -------------------------------------------------------- + +test_that("drop_empty_values removes empty values, rows and lists", { + x <- list( + a = "-99.0", b = NA, c = "", d = -99, e = "kept", f = 0, + items = list(list(x = "-99.0"), list(x = "BAR", y = NA)), + empty_items = list(list(x = "")) + ) + expect_equal(drop_empty_values(x), + list(e = "kept", f = 0, items = list(list(x = "BAR")))) +}) + +test_that("drop_empty_values keeps vectors that are only partly empty", { + expect_equal(drop_empty_values(list(v = c("a", "-99.0"))), + list(v = c("a", "-99.0"))) +}) + +# --- normalize_legacy_event --------------------------------------------------- + +test_that("normalize_legacy_event maps legacy notes names", { + event <- normalize_legacy_event(list(mgmt_event_notes = "hello")) + expect_equal(event$mgmt_event_short_notes, "hello") + expect_null(event$mgmt_event_notes) + + for (old_name in c("planting_notes", "harvest_comments", "fertilizer_notes", + "tillage_treatment_notes", "chemical_applic_notes", + "mowing_notes", "observation_notes", "other_notes")) { + event <- normalize_legacy_event(stats::setNames(list("notes"), old_name)) + expect_equal(event$mgmt_event_long_notes, "notes", info = old_name) + expect_null(event[[old_name]]) + } +}) + +test_that("normalize_legacy_event does not overwrite existing new-name values", { + event <- normalize_legacy_event(list( + mgmt_event_notes = "old", + mgmt_event_short_notes = "new" + )) + expect_equal(event$mgmt_event_short_notes, "new") + expect_equal(event$mgmt_event_notes, "old") +}) + +test_that("normalize_legacy_event nests parallel vectors into rows", { + event <- normalize_legacy_event(legacy_events[[1]]) + + expect_equal(event$planting_list, list( + list(planted_crop = "BAR", planting_material_weight = 240), + list(planted_crop = "RCL", planting_material_weight = 3, + planting_material_source = "own seeds"), + list(planted_crop = "ZZ3", planting_material_weight = 20) + )) + expect_null(event$planted_crop) + expect_null(event$planting_depth) + expect_equal(event$mgmt_event_long_notes, "Mixed grass") + expect_null(event$mgmt_event_short_notes) +}) + +test_that("normalize_legacy_event nests single-item scalars into one row", { + event <- normalize_legacy_event(legacy_events[[2]]) + + expect_equal(event$harvest_list, list( + list(harvest_crop = "ZZ1", harvest_method = "HM008", + harvest_operat_component = "silage") + )) + # event-level properties stay on the event + expect_equal(event$harvest_yield_harvest_dw_total, 4200) + expect_null(event$harvest_area) + expect_null(event$harvest_comments) +}) + +test_that("normalize_legacy_event maps organic_material to fertilizer", { + event <- normalize_legacy_event(legacy_events[[3]]) + expect_equal(event$mgmt_operations_event, "fertilizer") + expect_equal(event$fertilizer_type, "fertilizer_type_organic") + expect_equal(event$organic_material, "RE003") + expect_equal(event$mgmt_event_long_notes, "Separator dry fraction") +}) + +test_that("normalize_legacy_event splits the legacy grazing period", { + event <- normalize_legacy_event(legacy_events[[6]]) + expect_equal(event$date, "2022-06-01") + expect_equal(event$end_date, "2022-06-20") + expect_null(event$grazing_period) + + # without a date, the start of the period is the date + event <- normalize_legacy_event(list( + mgmt_operations_event = "grazing", + grazing_period = c("2022-06-01", "2022-06-20") + )) + expect_equal(event$date, "2022-06-01") + expect_null(event$grazing_period) +}) + +test_that("normalize_legacy_event keeps a grazing period that starts on another date", { + event <- normalize_legacy_event(list( + mgmt_operations_event = "grazing", + date = "2022-05-30", + grazing_period = c("2022-06-01", "2022-06-20") + )) + expect_equal(event$date, "2022-05-30") + expect_equal(event$end_date, "2022-06-20") + expect_equal(event$grazing_period, c("2022-06-01", "2022-06-20")) +}) + +test_that("normalize_legacy_event keeps keys unknown to the schema", { + event <- normalize_legacy_event(list( + mgmt_operations_event = "observation", + date = "2022-06-01", + canopeo_image = "canopeo_image/2022-06-01_site_0_canopeo_image_0.jpg" + )) + expect_equal(event$canopeo_image, + "canopeo_image/2022-06-01_site_0_canopeo_image_0.jpg") +}) + +# --- read / write round trip -------------------------------------------------- + +test_that("legacy files are written back in the canonical format", { + base_folder <- tempfile() + on.exit(unlink(base_folder, recursive = TRUE)) + write_events_file(base_folder, "site", "0", legacy_events) + + events <- read_json_file("site", "0", base_folder = base_folder)$events + write_json_file("site", "0", events, list(), base_folder = base_folder) + + file_path <- file.path(base_folder, "site", "0", "events.json") + written <- jsonlite::fromJSON(file_path, + simplifyDataFrame = FALSE)$management$events + + expect_length(written, length(legacy_events)) + expect_false(any(grepl("-99", readLines(file_path), fixed = TRUE))) + expect_length(written[[1]]$planting_list, 3) + expect_length(written[[2]]$harvest_list, 1) + expect_equal(written[[3]]$mgmt_operations_event, "fertilizer") + for (event in written) expect_null(event$block) + + # reading and saving the canonical file again leaves it unchanged + first_write <- readLines(file_path) + events <- read_json_file("site", "0", base_folder = base_folder)$events + write_json_file("site", "0", events, list(), base_folder = base_folder) + expect_identical(readLines(file_path), first_write) +}) + +test_that("written events are valid against the management event schema", { + skip_if_not_installed("jsonvalidate") + + base_folder <- tempfile() + on.exit(unlink(base_folder, recursive = TRUE)) + write_events_file(base_folder, "site", "0", legacy_events) + events <- read_json_file("site", "0", base_folder = base_folder)$events + write_json_file("site", "0", events, list(), base_folder = base_folder) + + schema <- paste(readLines(schema_file_path(), warn = FALSE), collapse = "\n") + validate <- jsonvalidate::json_validator(schema, engine = "ajv") + written <- jsonlite::fromJSON( + file.path(base_folder, "site", "0", "events.json"), + simplifyDataFrame = FALSE)$management$events + + for (event in written) { + json <- jsonlite::toJSON(event, auto_unbox = TRUE) + expect_true(validate(json), info = event$mgmt_operations_event) + } +}) + +# --- events_to_table ---------------------------------------------------------- + +test_that("events_to_table spreads item columns with one row per event", { + events <- list( + list(mgmt_operations_event = "planting", date = "2023-05-25", + planting_list = list( + list(planted_crop = "BAR", planting_material_weight = 240), + list(planted_crop = "RCL"))), + list(mgmt_operations_event = "other", date = "2024-10-09", + mgmt_event_long_notes = "Plowing, twice", + `$schema` = "https://example.com/schema.json") + ) + table <- events_to_table(events) + + expect_equal(nrow(table), 2) + expect_equal(table$planted_crop, c("BAR; RCL", "")) + expect_equal(table$planting_material_weight, c("240; ", "")) + expect_equal(table$mgmt_event_long_notes, c("", "Plowing, twice")) + expect_false("$schema" %in% names(table)) + expect_false("planting_list" %in% names(table)) +}) diff --git a/tests/testthat/test-fct_schema.R b/tests/testthat/test-fct_schema.R index 2551675..0bc2167 100644 --- a/tests/testthat/test-fct_schema.R +++ b/tests/testthat/test-fct_schema.R @@ -1,28 +1,7 @@ # Unit tests for schema parsing and helper functions # Uses inline fixtures for pure function testing -# --- resolve_ref / resolve_property ------------------------------------------- - -test_that("resolve_ref resolves a $defs pointer", { - defs <- list(my_type = list(type = "string", oneOf = list(list(const = "a")))) - obj <- list("$ref" = "#/$defs/my_type") - result <- resolve_ref(obj, defs) - expect_equal(result$type, "string") - expect_length(result$oneOf, 1) - expect_null(result[["$ref"]]) -}) - -test_that("resolve_ref returns obj unchanged when no $ref", { - obj <- list(type = "string", title = "x") - result <- resolve_ref(obj, list()) - expect_identical(result, obj) -}) - -test_that("resolve_ref returns obj unchanged for unresolvable $ref", { - obj <- list("$ref" = "#/$defs/nonexistent") - result <- resolve_ref(obj, list()) - expect_identical(result, obj) -}) +# --- resolve_property --------------------------------------------------------- test_that("resolve_property merges allOf and carries top-level keys", { defs <- list(test_def = list(type = "string", oneOf = list(list(const = "v1")))) @@ -77,15 +56,7 @@ test_that("determine_widget_type maps schema types correctly", { "textAreaInput") }) -# --- extract_titles / extract_oneof_choices ----------------------------------- - -test_that("extract_titles with partial languages defaults to empty string", { - result <- extract_titles(list(title = "A", title_fi = "B")) - expect_equal(result, list(en = "A", fi = "B", sv = "")) - - result2 <- extract_titles(list()) - expect_equal(result2, list(en = "", fi = "", sv = "")) -}) +# --- extract_oneof_choices ---------------------------------------------------- test_that("extract_oneof_choices extracts const/titles and skips entries without const", { input <- list( @@ -114,18 +85,6 @@ test_that("schema_get_title fallback chain: language -> en -> fallback", { expect_equal(schema_get_title(NULL, "en", "fallback"), "fallback") }) -# --- lang_to_iso -------------------------------------------------------------- - -test_that("lang_to_iso converts column names and passes through ISO codes", { - expect_equal(lang_to_iso("disp_name_eng"), "en") - expect_equal(lang_to_iso("disp_name_fin"), "fi") - expect_equal(lang_to_iso("disp_name_swe"), "sv") - expect_equal(lang_to_iso("en"), "en") - expect_equal(lang_to_iso("fi"), "fi") - # Unknown language codes fall back to "en" - expect_equal(lang_to_iso("unknown"), "en") -}) - # --- schema_get_choices ------------------------------------------------------- test_that("schema_get_choices builds named vector with empty first option", { @@ -142,31 +101,8 @@ test_that("schema_get_choices builds named vector with empty first option", { expect_equal(names(result)[3], "Bb") }) -test_that("schema_get_choices returns NULL for NULL/empty input", { - expect_null(schema_get_choices(NULL, "en")) - expect_null(schema_get_choices(list(), "en")) -}) - # --- build_property_descriptor ------------------------------------------------ -test_that("build_property_descriptor populates fields for numeric property", { - prop <- list(type = "number", minimum = 0, maximum = 100, - title = "Weight", title_fi = "Paino") - desc <- build_property_descriptor("test_prop", prop, - required = TRUE, - event_type = "harvest", - is_array_item = FALSE) - expect_equal(desc$name, "test_prop") - expect_equal(desc$type, "numericInput") - expect_true(desc$required) - expect_equal(desc$minimum, 0) - expect_equal(desc$maximum, 100) - expect_equal(desc$titles$en, "Weight") - expect_equal(desc$titles$fi, "Paino") - expect_equal(desc$event_type, "harvest") - expect_false(desc$is_integer) -}) - test_that("build_property_descriptor builds array_columns for dataTable", { prop <- list( type = "array", @@ -204,73 +140,19 @@ test_that("lookup_property resolves subtype > event > common priority", { expect_equal(lookup_property(reg, "my_prop", "fertilizer", "mineral")$name, "subtype") expect_equal(lookup_property(reg, "my_prop", "fertilizer")$name, "event") + expect_equal(lookup_property(reg, "my_prop", "fertilizer", "organic")$name, + "event") expect_equal(lookup_property(reg, "my_prop")$name, "common") expect_null(lookup_property(reg, "nonexistent")) }) -test_that("lookup_property falls through missing subtype to event level", { - reg <- list() - reg[[paste0("prop", REGISTRY_KEY_SEP, "harvest")]] <- list(name = "event") +# --- find_property_by_name ---------------------------------------------------- - result <- lookup_property(reg, "prop", "harvest", "some_subtype") - expect_equal(result$name, "event") -}) - -# --- normalize_legacy_event / get_legacy_value -------------------------------- - -test_that("normalize_legacy_event maps old names to new", { - event <- normalize_legacy_event(list(mgmt_event_notes = "hello")) - expect_equal(event$mgmt_event_short_notes, "hello") - expect_null(event$mgmt_event_notes) - - event2 <- normalize_legacy_event(list(planting_notes = "pn")) - expect_equal(event2$mgmt_event_long_notes, "pn") - expect_null(event2$planting_notes) - - event3 <- normalize_legacy_event(list(harvest_comments = "hc")) - expect_equal(event3$mgmt_event_long_notes, "hc") -}) - -test_that("normalize_legacy_event does not overwrite existing new-name values", { - event <- normalize_legacy_event(list( - mgmt_event_notes = "old", - mgmt_event_short_notes = "new" - )) - expect_equal(event$mgmt_event_short_notes, "new") - # old name is preserved because new name already existed - expect_equal(event$mgmt_event_notes, "old") -}) - -test_that("get_legacy_value retrieves value via reverse mapping", { - expect_equal(get_legacy_value(list(planting_notes = "val"), - "mgmt_event_long_notes"), "val") - expect_null(get_legacy_value(list(other_field = "x"), - "mgmt_event_long_notes")) -}) - -# --- find_any_property_desc --------------------------------------------------- - -test_that("find_any_property_desc uses reverse index for O(1) lookup", { - reg <- list() - reg[["date"]] <- list(name = "date", type = "dateInput") - reg[[paste0("crop_name", REGISTRY_KEY_SEP, "planting")]] <- - list(name = "crop_name", type = "selectInput") - - rev_idx <- list(crop_name = paste0("crop_name", REGISTRY_KEY_SEP, "planting")) - - expect_equal(find_any_property_desc(reg, "date", rev_idx)$name, "date") - expect_equal(find_any_property_desc(reg, "crop_name", rev_idx)$name, - "crop_name") - expect_null(find_any_property_desc(reg, "nonexistent", rev_idx)) -}) - -test_that("find_any_property_desc falls back to linear scan without index", { - reg <- list() - reg[[paste0("crop_name", REGISTRY_KEY_SEP, "planting")]] <- - list(name = "crop_name") - - result <- find_any_property_desc(reg, "crop_name", NULL) - expect_equal(result$name, "crop_name") +test_that("find_property_by_name finds common and event properties", { + expect_equal(find_property_by_name(mgmt_schema, "date")$name, "date") + expect_equal(find_property_by_name(mgmt_schema, "tillage_practice")$name, + "tillage_practice") + expect_null(find_property_by_name(mgmt_schema, "nonexistent")) }) # --- get_subtype_value -------------------------------------------------------- @@ -291,16 +173,44 @@ test_that("get_subtype_value extracts discriminator from event values", { expect_null(get_subtype_value(list(), er)) }) -# --- get_schema_table_names --------------------------------------------------- +# --- field ids ----------------------------------------------------------------- + +test_that("fields shared by event types have one id per event type", { + pr <- mgmt_schema$property_registry + ids <- vapply(pr, function(desc) desc$id, character(1)) + expect_identical(unname(ids), names(pr)) -test_that("get_schema_table_names lists all array table names", { - table_names <- get_schema_table_names(mgmt_schema) - expect_true("planting_list_table" %in% table_names) - expect_true("harvest_list_table" %in% table_names) - expect_true(all(grepl("_table$", table_names))) - # should not be empty + notes_ids <- vapply( + Filter(function(desc) desc$name == "mgmt_event_long_notes", pr), + function(desc) desc$id, character(1)) + expect_true(length(notes_ids) > 1) +}) + +test_that("an event property redefining a common property relabels it", { + er <- mgmt_schema$event_registry + pr <- mgmt_schema$property_registry + expect_equal(er$grazing$common_overrides$date$titles$en, "Start date") + expect_null(pr[[paste0("date", REGISTRY_KEY_SEP, "grazing")]]) + expect_false("date" %in% er$grazing$property_names) +}) + +test_that("x-ui conditions refer to field ids of the same event type", { + desc <- lookup_property(mgmt_schema$property_registry, "animal_fert_usage", + "fertilizer", "fertilizer_type_organic") + expect_match(desc$condition, + "input.organic_material___fertilizer___fertilizer_type_organic", + fixed = TRUE) + expect_false(grepl("input.organic_material ", desc$condition, fixed = TRUE)) +}) - expect_true(length(table_names) >= 3) +test_that("get_relevant_fields returns the fields of the event and subtype", { + fields <- get_relevant_fields(mgmt_schema, "fertilizer", + "fertilizer_type_organic") + ids <- vapply(fields, function(desc) desc$id, character(1)) + expect_true(paste0("fertilizer_type", REGISTRY_KEY_SEP, "fertilizer") %in% ids) + expect_true(paste0("organic_material", REGISTRY_KEY_SEP, "fertilizer", + REGISTRY_KEY_SEP, "fertilizer_type_organic") %in% ids) + expect_false(any(mgmt_schema$common_properties %in% ids)) }) # --- UI helpers (fct_schema_ui.R) --------------------------------------------- @@ -316,13 +226,13 @@ test_that("convert_condition_to_js namespaces input references", { expect_equal(result2, "input['form-chemical_type'] != 'lime'") }) -test_that("make_required_label adds asterisk only for required non-empty labels", { - result <- make_required_label("Name", TRUE) - expect_s3_class(result, "shiny.tag.list") - html <- as.character(result) - expect_true(grepl("\\*", html)) +# --- to_sentence_case --------------------------------------------------------- - expect_equal(make_required_label("Name", FALSE), "Name") - expect_equal(make_required_label("", TRUE), "") - expect_null(make_required_label(NULL, TRUE)) +test_that("to_sentence_case capitalises lowercase labels only", { + expect_equal(to_sentence_case("weight of seeds (kg/ha)"), + "Weight of seeds (kg/ha)") + expect_equal(to_sentence_case("äestys"), "Äestys") + expect_equal(to_sentence_case("pH after the application"), + "pH after the application") + expect_equal(to_sentence_case(""), "") }) diff --git a/tests/testthat/test-mod_form.R b/tests/testthat/test-mod_form.R new file mode 100644 index 0000000..2b62d00 --- /dev/null +++ b/tests/testthat/test-mod_form.R @@ -0,0 +1,117 @@ +# Tests for the schema-driven form module + +form_module_args <- function() { + list(site = reactive(NULL), set_values = reactiveVal(), + reset_values = reactiveVal(), edit_mode = reactive(FALSE), + language = reactive("disp_name_eng"), init_signal = reactiveVal()) +} + +field_id <- function(prop_name, event_type, subtype = NULL) { + lookup_property_key(mgmt_schema$property_registry, prop_name, event_type, + subtype) +} + +# set the value of a field whose id is only known at run time +set_field <- function(session, id, value) { + do.call(session$setInputs, stats::setNames(list(value), id)) +} + +test_that("an event without an event type is not valid", { + testServer(mod_form_server, args = form_module_args(), { + session$setInputs(block = "0", date = Sys.Date()) + expect_null(form_data()) + }) +}) + +test_that("required fields are validated for the selected event type", { + testServer(mod_form_server, args = form_module_args(), { + # long notes are required for "other" but not for planting, which has a + # widget of its own for them + session$setInputs(mgmt_operations_event = "other", block = "0", + date = Sys.Date()) + expect_null(form_data()) + + set_field(session, field_id("mgmt_event_long_notes", "other"), + " Plowing ") + event <- form_data() + expect_equal(event$mgmt_event_long_notes, "Plowing") + expect_equal(event$mgmt_operations_event, "other") + }) +}) + +test_that("only the fields of the selected event type are saved", { + testServer(mod_form_server, args = form_module_args(), { + set_field(session, field_id("mgmt_event_long_notes", "planting"), + "planting notes") + set_field(session, field_id("mgmt_event_long_notes", "weeding"), + "weeding notes") + session$setInputs(mgmt_operations_event = "weeding", block = "0", + date = Sys.Date()) + event <- form_data() + expect_equal(event$mgmt_event_long_notes, "weeding notes") + }) +}) + +test_that("the date is required only when the event type requires it", { + testServer(mod_form_server, args = form_module_args(), { + session$setInputs(mgmt_operations_event = "weeding", block = "0") + expect_null(form_data()) + + session$setInputs(mgmt_operations_event = "measurement") + expect_false(is.null(form_data())) + }) +}) + +test_that("keys the form doesn't know about are kept when saving", { + testServer(mod_form_server, args = form_module_args(), { + set_values(list(mgmt_operations_event = "weeding", date = "2022-06-01", + canopeo_image = "canopeo_image/image.jpg")) + session$flushReact() + session$setInputs(mgmt_operations_event = "weeding", block = "0", + date = as.Date("2022-06-01")) + + expect_equal(form_data()$canopeo_image, "canopeo_image/image.jpg") + + # a new event doesn't inherit them + reset_values(TRUE) + session$flushReact() + expect_null(form_data()$canopeo_image) + }) +}) + +test_that("tables are filled for the edited event and cleared otherwise", { + testServer(mod_form_server, args = form_module_args(), { + harvest_id <- field_id("harvest_list", "harvest") + planting_id <- field_id("planting_list", "planting") + rows <- list(list(harvest_crop = "ZZ1")) + + set_values(list(mgmt_operations_event = "harvest", harvest_list = rows)) + session$flushReact() + expect_equal(tables[[harvest_id]]$set_values(), rows) + expect_equal(tables[[planting_id]]$set_values(), list()) + + reset_values(TRUE) + session$flushReact() + expect_equal(tables[[harvest_id]]$set_values(), list()) + }) +}) + +test_that("table rows are saved nested under the array property", { + testServer(mod_form_server, args = form_module_args(), { + init_signal(TRUE) + session$setInputs(mgmt_operations_event = "harvest", block = "0", + date = Sys.Date()) + table_id <- schema_table_id( + lookup_property(mgmt_schema$property_registry, "harvest_list", + "harvest")) + inputs <- list("rendered" = TRUE, "harvest_crop_1" = "ZZ1", + "harvest_method_1" = "HM008") + names(inputs) <- paste(table_id, names(inputs), sep = "-") + do.call(session$setInputs, inputs) + + event <- form_data() + expect_equal(event$harvest_list, + list(list(harvest_crop = "ZZ1", harvest_method = "HM008"))) + expect_null(event$harvest_crop) + }) +}) diff --git a/tests/testthat/test-mod_table.R b/tests/testthat/test-mod_table.R index f52bb64..9ef266a 100644 --- a/tests/testthat/test-mod_table.R +++ b/tests/testthat/test-mod_table.R @@ -1,34 +1,44 @@ -# library(shinytest) -# -# # a helper function which creates a new app for testing the table module -# create_table_test_app <- function(table_code_name) { -# -# row_variable <- "harvest_crop" -# -# ui <- fluidPage(mod_table_ui(id = table_code_name), -# selectInput(row_variable, label = row_variable, -# choices = c("FRG", "WHT", "BAR"), multiple = TRUE), -# selectInput("language", label = "lang", -# choices = c("disp_name_eng", "disp_name_fin"))) -# -# server <- function(input, output, session) { -# -# override_values <- shiny::reactiveVal() -# -# mod_table_server(table_code_name, -# row_variable_value = reactive(input$harvest_crop), -# language = reactive(input$language), -# override_values = override_values) -# } -# -# shinytest::ShinyDriver$new(shiny::shinyApp(ui, server)) -# -# } -# -# test_that("harvest_crop_table works", { -# app <- create_table_test_app("harvest_crop_table") -# -# app$setInputs(language = "disp_name_fin", harvest_crop = c("FRG", "WHT")) -# -# expect_equal(TRUE, TRUE) -# }) +# Tests for the schema-driven table module + +harvest_list_desc <- function() { + lookup_property(mgmt_schema$property_registry, "harvest_list", "harvest") +} + +table_module_args <- function(override_values) { + list(desc = harvest_list_desc(), language = reactive("disp_name_eng"), + override_values = override_values) +} + +test_that("table is prefilled with one row per item", { + override_values <- reactiveVal() + testServer(mod_table_server_schema, args = table_module_args(override_values), { + override_values(list(list(harvest_crop = "ZZ1", harvest_method = "HM008"), + list(harvest_crop = "BAR"))) + session$flushReact() + + expect_equal(dynamic_rows(), 1:2) + cells <- table_data() + expect_match(cells[1, "harvest_crop"], "ZZ1") + expect_match(cells[1, "harvest_method"], "HM008") + expect_match(cells[2, "harvest_crop"], "BAR") + }) +}) + +test_that("removing a row keeps the other rows and validates them by position", { + override_values <- reactiveVal() + testServer(mod_table_server_schema, args = table_module_args(override_values), { + override_values(list(list(), list())) + session$flushReact() + session$setInputs(rendered = TRUE, harvest_crop_1 = "ZZ1", + harvest_crop_2 = "BAR") + session$setInputs(remove_row_index = 1L) + expect_equal(dynamic_rows(), 2L) + expect_match(table_data()[1, "harvest_crop"], "BAR") + + # the remaining row is now the first displayed row + session$setInputs(harvest_crop_1 = "") + expect_false(session$returned$valid()) + session$setInputs(harvest_crop_1 = "BAR") + expect_true(session$returned$valid()) + }) +}) diff --git a/tests/testthat/test-schema_integration.R b/tests/testthat/test-schema_integration.R index c82284e..c4d1a59 100644 --- a/tests/testthat/test-schema_integration.R +++ b/tests/testthat/test-schema_integration.R @@ -1,332 +1,73 @@ # Integration tests against the real management-event schema -# These test that load_schema() correctly parses the bundled schema and that -# cross-cutting concerns (lookup chains, language, choices) work end-to-end. -# --- load_schema structure ---------------------------------------------------- - -test_that("load_schema returns all expected components", { - expect_true(is.list(mgmt_schema)) - expected_names <- c("raw", "event_registry", "property_registry", - "property_reverse_index", "common_properties", - "event_type_choices") - for (nm in expected_names) { - expect_true(nm %in% names(mgmt_schema), - info = paste("missing component:", nm)) - } - expect_true(is.list(mgmt_schema$event_registry)) - expect_true(is.list(mgmt_schema$property_registry)) - expect_true(is.character(mgmt_schema$common_properties)) -}) - -test_that("load_schema registers all 15 event types", { - event_names <- names(mgmt_schema$event_registry) - expected <- c("planting", "fertilizer", "tillage", "harvest", "chemicals", - "grazing", "weeding", "irrigation", "mowing", "observation", - "bed_prep", "inorg_mulch", "Inorg_mul_rem", "measurement", - "other") - for (ev in expected) { - expect_true(ev %in% event_names, - info = paste("missing event type:", ev)) - } - expect_equal(length(event_names), 15) -}) - -test_that("common properties include date and mgmt_operations_event but not $schema", { - cp <- mgmt_schema$common_properties - expect_true("date" %in% cp) - expect_true("mgmt_operations_event" %in% cp) - expect_true("mgmt_event_short_notes" %in% cp) - expect_false("$schema" %in% cp) +test_that("$schema is not a form field", { + expect_false("$schema" %in% mgmt_schema$common_properties) }) -test_that("event_type_choices has titles for all events", { - etc <- mgmt_schema$event_type_choices - expect_equal(length(etc), length(mgmt_schema$event_registry)) - for (ev in names(etc)) { - expect_true(!is.null(etc[[ev]]$en), - info = paste("missing en title for", ev)) - } -}) - -# --- Subtype structure -------------------------------------------------------- - -test_that("fertilizer has 3 subtypes with discriminator fertilizer_type", { +test_that("an event with a discriminator is registered with subtypes", { fert <- mgmt_schema$event_registry[["fertilizer"]] expect_true(fert$has_subtypes) expect_equal(fert$subtype_discriminator, "fertilizer_type") - expect_equal(length(fert$subtypes), 3) - sub_consts <- vapply(fert$subtypes, function(s) s$const, character(1)) - expect_true("fertilizer_type_mineral" %in% sub_consts) - expect_true("fertilizer_type_soil_amendment" %in% sub_consts) - expect_true("fertilizer_type_organic" %in% sub_consts) -}) - -test_that("observation has 8 subtypes with discriminator observation_type", { - obs <- mgmt_schema$event_registry[["observation"]] - expect_true(obs$has_subtypes) - expect_equal(obs$subtype_discriminator, "observation_type") - expect_equal(length(obs$subtypes), 8) - sub_consts <- vapply(obs$subtypes, function(s) s$const, character(1)) - expect_true("observation_type_soil" %in% sub_consts) - expect_true("observation_type_vegetation" %in% sub_consts) -}) - -test_that("planting has no subtypes", { - pl <- mgmt_schema$event_registry[["planting"]] - expect_false(pl$has_subtypes) - expect_null(pl$subtype_discriminator) -}) - -# --- Property registry -------------------------------------------------------- - -test_that("common properties registered with bare keys, correct types", { - pr <- mgmt_schema$property_registry - date_desc <- pr[["date"]] - expect_false(is.null(date_desc)) - expect_equal(date_desc$type, "dateInput") - - event_desc <- pr[["mgmt_operations_event"]] - expect_false(is.null(event_desc)) - expect_true(event_desc$is_discriminator) + # a select field that isn't a discriminator doesn't create subtypes + expect_false(mgmt_schema$event_registry[["tillage"]]$has_subtypes) }) -test_that("event properties use REGISTRY_KEY_SEP namespacing", { - pr <- mgmt_schema$property_registry - key <- paste0("planting_list", REGISTRY_KEY_SEP, "planting") - expect_false(is.null(pr[[key]])) - expect_equal(pr[[key]]$type, "dataTable") -}) - -test_that("$ref properties resolved with choices", { - desc <- lookup_property(mgmt_schema$property_registry, - "fertilizer_applic_method", "fertilizer") - expect_false(is.null(desc)) - expect_equal(desc$type, "selectInput") - expect_true(length(desc$choices) > 0) - choice_values <- vapply(desc$choices, function(ch) ch$value, character(1)) - expect_true("AP001" %in% choice_values) -}) - -test_that("dataTable properties have resolved array_columns", { - pl_desc <- lookup_property(mgmt_schema$property_registry, - "planting_list", "planting") - expect_equal(pl_desc$type, "dataTable") - expect_true("planted_crop" %in% names(pl_desc$array_columns)) - expect_true("planting_material_weight" %in% names(pl_desc$array_columns)) - - # planted_crop should be selectInput (resolved from $ref via allOf) - expect_equal(pl_desc$array_columns$planted_crop$type, "selectInput") - - # planting_material_weight should be numericInput with min >= 0 - pmw <- pl_desc$array_columns$planting_material_weight - expect_equal(pmw$type, "numericInput") - expect_true(!is.null(pmw$minimum) && pmw$minimum >= 0) -}) - -# --- Cross-cutting ------------------------------------------------------------ - -test_that("get_relevant_properties returns correct sets", { - # planting event_props should include planting_list - rel <- get_relevant_properties(mgmt_schema, "planting") - expect_true("planting_list" %in% rel$event_props) - expect_equal(rel$common, mgmt_schema$common_properties) - expect_length(rel$subtype_props, 0) - - # fertilizer with subtype should populate subtype_props - rel2 <- get_relevant_properties(mgmt_schema, "fertilizer", - "fertilizer_type_mineral") - expect_true(length(rel2$subtype_props) > 0) - expect_true("fertilizer_product_name" %in% rel2$subtype_props) - - # all should be the union - expect_true(all(rel2$common %in% rel2$all)) - expect_true(all(rel2$event_props %in% rel2$all)) - expect_true(all(rel2$subtype_props %in% rel2$all)) - - # unknown event type returns empty event/subtype but still has common - rel3 <- get_relevant_properties(mgmt_schema, "nonexistent") - expect_length(rel3$event_props, 0) - expect_length(rel3$subtype_props, 0) - expect_equal(rel3$common, mgmt_schema$common_properties) -}) - -test_that("build_event_type_choices and build_subtype_choices produce valid selectInput vectors", { +test_that("event type and subtype choices have an empty first option", { choices <- build_event_type_choices(mgmt_schema, "en") expect_equal(unname(choices[1]), "") - expect_true("planting" %in% choices) - # planting's English title is "sowing" - planting_idx <- which(choices == "planting") - expect_equal(names(choices)[planting_idx], "sowing") + # planting's English title is "sowing", shown in sentence case + expect_equal(names(choices)[choices == "planting"], "Sowing") - # subtype choices for fertilizer - fert <- mgmt_schema$event_registry[["fertilizer"]] - sub_choices <- build_subtype_choices(fert, "en") + sub_choices <- build_subtype_choices( + mgmt_schema$event_registry[["fertilizer"]], "en") expect_equal(unname(sub_choices[1]), "") expect_true("fertilizer_type_mineral" %in% sub_choices) - - # planting has no subtypes expect_null(build_subtype_choices( mgmt_schema$event_registry[["planting"]], "en")) - - # Finnish subtype choices - sub_fi <- build_subtype_choices(fert, "fi") - expect_true(length(sub_fi) > 1) }) -# --- Schema-specific edge cases ----------------------------------------------- - -test_that("harvest total_of descriptors are parsed correctly", { - # harvest has 3 properties with total_of_list/total_of_property for auto-sum - pr <- mgmt_schema$property_registry - total_desc <- lookup_property(pr, "harvest_yield_harvest_dw_total", "harvest") - expect_false(is.null(total_desc)) - expect_false(is.null(total_desc$total_of)) - expect_equal(total_desc$total_of$list_name, "harvest_list") - expect_equal(total_desc$total_of$property_name, "harvest_yield_harvest_dw") - - total_desc2 <- lookup_property(pr, "harv_yield_harv_f_wt_total", "harvest") - expect_false(is.null(total_desc2$total_of)) - expect_equal(total_desc2$total_of$list_name, "harvest_list") +test_that("harvest totals know which table column they sum", { + total <- lookup_property(mgmt_schema$property_registry, + "harvest_yield_harvest_dw_total", "harvest") + expect_equal(total$total_of$list_name, "harvest_list") + expect_equal(total$total_of$property_name, "harvest_yield_harvest_dw") }) -test_that("minItems is captured in array property descriptors", { - pl <- lookup_property(mgmt_schema$property_registry, "planting_list", "planting") - expect_equal(pl$min_items, 1) - - hl <- lookup_property(mgmt_schema$property_registry, "harvest_list", "harvest") - expect_equal(hl$min_items, 1) +test_that("table columns defined with allOf and $ref get their choices", { + pl <- lookup_property(mgmt_schema$property_registry, "planting_list", + "planting") + expect_equal(pl$array_columns$planted_crop$type, "selectInput") + expect_true(length(pl$array_columns$planted_crop$choices) > 0) }) -test_that("x-ui conditions are preserved in property descriptors", { - # chemicals/chemical_applic_material_list has a condition on chemical_type - pr <- mgmt_schema$property_registry - chem_list <- lookup_property(pr, "chemical_applic_material_list", "chemicals") - expect_false(is.null(chem_list)) - expect_false(is.null(chem_list$xui$condition)) - expect_true(grepl("chemical_type", chem_list$xui$condition)) - - # application_ph_start also has a condition - ph_start <- lookup_property(pr, "application_ph_start", "chemicals") - expect_false(is.null(ph_start$xui$condition)) -}) - -test_that("allOf in array items resolves $ref choices (planted_crop, harvest_crop)", { - # planted_crop inside planting_list uses allOf to merge title with $ref to - # crop_ident_ICASA. The resolved descriptor must have selectInput choices. - pl <- lookup_property(mgmt_schema$property_registry, "planting_list", "planting") - planted_crop <- pl$array_columns$planted_crop - expect_equal(planted_crop$type, "selectInput") - expect_true(length(planted_crop$choices) > 10) - # Should contain common crop codes - crop_values <- vapply(planted_crop$choices, function(ch) ch$value, character(1)) - expect_true("WHT" %in% crop_values) # wheat - - # Same for harvest_crop - hl <- lookup_property(mgmt_schema$property_registry, "harvest_list", "harvest") - harvest_crop <- hl$array_columns$harvest_crop - expect_equal(harvest_crop$type, "selectInput") - expect_true(length(harvest_crop$choices) > 10) -}) - -test_that("chemicals event has no subtypes but has conditional properties", { - chem <- mgmt_schema$event_registry[["chemicals"]] - expect_false(chem$has_subtypes) - expect_null(chem$subtype_discriminator) - # chemical_type is a regular selectInput, not a discriminator - ct <- lookup_property(mgmt_schema$property_registry, "chemical_type", "chemicals") - expect_equal(ct$type, "selectInput") - expect_false(isTRUE(ct$is_discriminator)) - expect_true(length(ct$choices) >= 6) -}) - -test_that("minimal events (weeding, other, bed_prep) register correctly", { - for (ev in c("weeding", "other", "bed_prep")) { - entry <- mgmt_schema$event_registry[[ev]] - expect_false(is.null(entry), info = paste(ev, "not registered")) - expect_false(entry$has_subtypes, info = paste(ev, "should have no subtypes")) - # Should have at least mgmt_event_long_notes - expect_true("mgmt_event_long_notes" %in% entry$property_names, - info = paste(ev, "missing mgmt_event_long_notes")) - } -}) - -# --- Nested cases ------------------------------------------------------------- - -test_that("array table inside subtype: soil_layer_list in observation_type_soil", { - # soil_layer_list is a dataTable property belonging to the observation_type_soil - # subtype, not the observation event itself. It must be registered with the - # triple-key (prop___event___subtype) and have resolved array_columns. +test_that("a table inside a subtype is registered under the subtype", { pr <- mgmt_schema$property_registry key <- paste0("soil_layer_list", REGISTRY_KEY_SEP, "observation", REGISTRY_KEY_SEP, "observation_type_soil") - desc <- pr[[key]] - expect_false(is.null(desc), info = "soil_layer_list not registered under subtype key") + desc <- lookup_property(pr, "soil_layer_list", "observation", + "observation_type_soil") + expect_identical(desc, pr[[key]]) expect_equal(desc$type, "dataTable") - expect_true(length(desc$array_columns) >= 5) - # Should have soil_layer_top_depth as a numericInput column - expect_false(is.null(desc$array_columns$soil_layer_top_depth)) - expect_equal(desc$array_columns$soil_layer_top_depth$type, "numericInput") - - # Should also be discoverable via lookup_property with subtype context - desc2 <- lookup_property(pr, "soil_layer_list", "observation", - "observation_type_soil") - expect_identical(desc, desc2) - - # Should appear in get_schema_table_names - table_names <- get_schema_table_names(mgmt_schema) - expect_true("soil_layer_list_table" %in% table_names) -}) - -test_that("subtype property with x-ui condition: animal_fert_usage in organic fertilizer", { - pr <- mgmt_schema$property_registry - desc <- lookup_property(pr, "animal_fert_usage", "fertilizer", - "fertilizer_type_organic") - expect_false(is.null(desc)) - expect_false(is.null(desc$xui$condition)) - expect_true(grepl("organic_material", desc$xui$condition)) -}) - -test_that("subtype properties with oneOf choices resolve correctly", { - pr <- mgmt_schema$property_registry - - # organic_material selectInput inside fertilizer_type_organic subtype - # has 21 oneOf choices (RE001, RE002, etc.) - om <- lookup_property(pr, "organic_material", "fertilizer", - "fertilizer_type_organic") - expect_false(is.null(om)) - expect_equal(om$type, "selectInput") - expect_true(length(om$choices) >= 20) - om_values <- vapply(om$choices, function(ch) ch$value, character(1)) - expect_true("RE003" %in% om_values) - - # fertilizer_material inside fertilizer_type_soil_amendment has 4 choices - fm <- lookup_property(pr, "fertilizer_material", "fertilizer", - "fertilizer_type_soil_amendment") - expect_false(is.null(fm)) - expect_equal(fm$type, "selectInput") - expect_true(length(fm$choices) >= 4) -}) - -test_that("get_relevant_properties includes subtype array tables", { - # observation with soil subtype should include soil_layer_list - rel <- get_relevant_properties(mgmt_schema, "observation", - "observation_type_soil") - expect_true("soil_layer_list" %in% rel$subtype_props) - expect_true("soil_layer_list" %in% rel$all) - # But without subtype, soil_layer_list should NOT appear - rel2 <- get_relevant_properties(mgmt_schema, "observation") - expect_false("soil_layer_list" %in% rel2$event_props) - expect_false("soil_layer_list" %in% rel2$all) -}) - -# --- Remaining edge cases ----------------------------------------------------- - -test_that("tillage event has no subtypes despite having a selectInput practice field", { - till <- mgmt_schema$event_registry[["tillage"]] - expect_false(till$has_subtypes) - expect_null(till$subtype_discriminator) - # tillage_practice is a regular selectInput - tp <- lookup_property(mgmt_schema$property_registry, "tillage_practice", "tillage") - expect_equal(tp$type, "selectInput") - expect_true(length(tp$choices) > 0) + expect_equal(schema_table_id(desc), paste0(key, "_table")) +}) + +test_that("a date field without a value is cleared", { + # updateDateInput ignores a NULL value, so the widget must be sent null + sent <- list() + session <- structure( + list(sendInputMessage = function(inputId, message) { + sent[[length(sent) + 1]] <<- message$value + }), + class = "ShinySession") + end_date <- lookup_property(mgmt_schema$property_registry, "end_date", + "grazing") + + update_schema_value(session, end_date, "2022-06-10") + update_schema_value(session, end_date, NULL) + update_schema_value(session, end_date, "-99.0") + + expect_equal(as.character(sent[[1]]), "2022-06-10") + # NA is sent to the browser as null + expect_true(is.na(sent[[2]])) + expect_true(is.na(sent[[3]])) }) From ad090b4593256706dd3927765f857472b43fd75e Mon Sep 17 00:00:00 2001 From: Pratik Pakhale Date: Tue, 29 Sep 2026 18:02:45 +0530 Subject: [PATCH 6/6] feat(form): restore image upload through the schema Add soil_image and canopeo_image to the observation subtypes of the bundled schema as fileInput fields. The form renders them with mod_fileInput and passes the upload state to the main app, which saves, moves and deletes the files as before. The image field names now come from the schema instead of ui_structure.json, and the event list hides image columns. Also simplify the schema-driven form code: - skip const-only properties when the schema is loaded, dropping the const/NULL guards downstream - merge the widget render loops into render_field and replace the override_* params of render_property_widget - rename mod_table_server_schema to mod_table_server - restore na.strings when reading the sites file, so site "NA" is not read as missing - revert whitespace and comment churn unrelated to the schema work --- R/app_server.R | 44 ++-- R/app_ui.R | 1 + R/fct_event_list.R | 16 +- R/fct_files.R | 82 ++++---- R/fct_language.R | 69 ++----- R/fct_schema.R | 68 ++----- R/fct_schema_ui.R | 224 ++++++-------------- R/fct_ui.R | 27 ++- R/mod_download.R | 10 +- R/mod_event_list.R | 28 +-- R/mod_fileInput.R | 14 +- R/mod_form.R | 236 +++++++++++----------- R/mod_rotation_cycle.R | 2 +- R/mod_table.R | 200 ++++++++---------- R/utils_global.R | 18 +- inst/extdata/management-event.schema.json | 18 ++ man/build_property_descriptor.Rd | 4 +- man/build_structure_lookup_list.Rd | 2 +- man/copy_file.Rd | 25 ++- man/delete_file.Rd | 6 +- man/get_selectInput_choices.Rd | 3 +- man/render_field.Rd | 23 +++ man/render_property_widget.Rd | 25 +-- man/update_schema_widget.Rd | 4 +- tests/testthat/test-fct_schema.R | 3 +- tests/testthat/test-mod_form.R | 30 ++- tests/testthat/test-mod_table.R | 4 +- tests/testthat/test-schema_integration.R | 15 ++ 28 files changed, 546 insertions(+), 655 deletions(-) create mode 100644 man/render_field.Rd diff --git a/R/app_server.R b/R/app_server.R index b33a4cb..88acffc 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -75,14 +75,14 @@ app_server <- function(input, output, session) { updateSelectInput(session, "site", choices = site_choices, selected = auth_result$user) } else if (auth_result$user == "icos_agri_user") { - + shinyjs::enable("site") shinyjs::show("site") - # Subset of site choices for the ICOS agri user + # Subset of site choices for the third user site_choices <- sites[grepl("icos-agri", sites$site_type),]$site - + updateSelectInput(session, "site", choices = site_choices, selected = auth_result$user) - + } else { updateSelectInput(session, "site", selected = auth_result$user) @@ -671,48 +671,54 @@ app_server <- function(input, output, session) { }) - # change language when user requests it — only app chrome elements - # (form module handles its own schema-driven language switching) + # change language when user requests it. The form module switches the + # language of its own schema-driven widgets observeEvent(input$language, ignoreInit = TRUE, { if (dp()) message("input$language changed") - + # get a list of all input elements which we have to relabel input_element_names <- names(reactiveValuesToList(input)) - + for (code_name in input_element_names) { - + # find element in the UI structure lookup list - element <- structure_lookup_list[[code_name]] - + element <- structure_lookup_list[[code_name]] + # didn't find the element corresponding to code_name - # this should not happen if the element is in + # this should not happen if the element is in # sidebar_ui_structure.json if (is.null(element$type)) next label <- get_disp_name(element$label, input$language) if (element$type == "selectInput") { - + # fetch choices for the selectInput choices <- get_selectInput_choices(code_name, input$language) - + # make sure we don't change the selected value current_value <- input[[code_name]] if (is.null(choices)) { - updateSelectInput(session, code_name, - label = ifelse(is.null(label), "", label), + updateSelectInput(session, + code_name, + label = ifelse(is.null(label),"",label), selected = current_value) } else { - updateSelectInput(session, code_name, - label = ifelse(is.null(label), "", label), + updateSelectInput(session, + code_name, + label = ifelse(is.null(label),"",label), choices = choices, selected = current_value) } + } else if (element$type == "actionButton") { - updateActionButton(session, code_name, label = label) + updateActionButton(session, + code_name, + label = label) } + } }) diff --git a/R/app_ui.R b/R/app_ui.R index 9ec3d03..1702e52 100644 --- a/R/app_ui.R +++ b/R/app_ui.R @@ -101,3 +101,4 @@ golem_add_external_resources <- function(){ shinyjs::useShinyjs(), # enable shinyjs ) } + diff --git a/R/fct_event_list.R b/R/fct_event_list.R index 778b995..0acea8e 100644 --- a/R/fct_event_list.R +++ b/R/fct_event_list.R @@ -84,9 +84,7 @@ find_event_index <- function(event, event_list) { # We didn't find a match, so return NULL return(NULL) -} - -#' Get display names for event list table column headers +}#' Get display names for event list table column headers #' Tries display_names.csv first, then schema titles as fallback #' @param col_names Vector of column names #' @param language Language code or column name @@ -95,17 +93,11 @@ get_event_list_colnames <- function(col_names, language) { iso <- lang_to_iso(language) vapply(col_names, function(cn) { - # Try display_names.csv first dn <- get_disp_name(cn, language = language, is_variable_name = TRUE) if (!identical(dn, cn)) return(dn) - # Try schema property titles - desc <- find_property_by_name(mgmt_schema, cn) - if (!is.null(desc) && !is.null(desc$titles)) { - title <- schema_get_title(desc$titles, iso, "") - if (nchar(title) > 0) return(title) - } - - cn + title <- schema_get_title(find_property_by_name(mgmt_schema, cn)$titles, + iso, "") + if (nchar(title) > 0) title else cn }, character(1)) } \ No newline at end of file diff --git a/R/fct_files.R b/R/fct_files.R index 76f22c5..14ca62b 100644 --- a/R/fct_files.R +++ b/R/fct_files.R @@ -5,11 +5,8 @@ # path to json file folder json_file_base_folder <- function() golem::get_golem_options("json_file_path") -# LIFECYCLE: This URL is embedded in every persisted event JSON file as "$schema". -# When bumping the schema version or moving the schema repository, update this -# value AND consider backward-compatibility for files already written with the -# old URL. Coordinate changes with write_json_file() below and any external -# consumers that validate events against this schema. +# the schema the saved events follow, written as "$schema" in every event. +# Update it together with the bundled management-event.schema.json schema_url <- "https://raw.githubusercontent.com/hamk-uas/fieldobservatory-data-schemas/main/management-event.schema.json" #' Create a folder for a site-block combination @@ -26,7 +23,7 @@ schema_url <- "https://raw.githubusercontent.com/hamk-uas/fieldobservatory-data- #' #' @return TRUE if the directory was created successfully or already exists, #' FALSE otherwise. -create_file_folder <- function(site, block, +create_file_folder <- function(site, block, base_folder = json_file_base_folder()) { # if the events directory (stored in json_file_base_folder) doesn't exist, # stop @@ -52,33 +49,35 @@ create_file_folder <- function(site, block, #' otherwise be used write_json_file <- function(site, block, event_list, rotation_list, base_folder = json_file_base_folder()) { - + # this ensures that the folder to store this file exists create_file_folder(site, block, base_folder) - + file_path <- file.path(base_folder, site, block, "events.json") - + # the block is implied by the file location event_list <- lapply(event_list, function(event) { event$block <- NULL event[["$schema"]] <- schema_url drop_empty_values(event) }) - + # If rotations on the list --> erase the block information like with events if (length(rotation_list) > 0) { for (j in 1:length(rotation_list)) { rotation_list[[j]]$block <- NULL } } - + # create appropriate structure experiment <- list() experiment$management <- list() - + # rotation will be part of the management experiment$management$rotation <- rotation_list + experiment$management$events <- event_list + # create file jsonlite::write_json(experiment, path = file_path, pretty = TRUE, @@ -101,7 +100,7 @@ read_json_file <- function(site, block, base_folder = json_file_base_folder()) { file_path <- file.path(base_folder, site, block, "events.json") - + # if file doesn't exist or given names are empty, can't read it if (!file.exists(file_path)) { return(list()) @@ -114,25 +113,25 @@ read_json_file <- function(site, block, rotation <- jsonlite::fromJSON(file_path, simplifyDataFrame = FALSE)$management$rotation - + # if there are no events, return an empty list if (length(events) == 0) { return(list()) } - + # add block information and upgrade legacy events to the canonical format for (i in 1:length(events)) { events[[i]]$block <- block events[[i]] <- normalize_legacy_event(events[[i]]) } - + # add block info for rotations if (length(rotation) != 0){ for (j in 1:length(rotation)) { rotation[[j]]$block <- block } } - + # Add events and rotation as a list objects which both will be returned # when function is called management$events <- events @@ -142,27 +141,31 @@ read_json_file <- function(site, block, } #' Copy a file related to an event and name it appropriately -#' +#' #' When a file (image) is uploaded through a fileInput widget, it is saved to a #' temporary folder. This function copies that file to an appropriate directory -#' and name. The file does not have to be originally in a temporary folder — -#' any file path is valid. This allows the function to also be used when cloning -#' an event and its associated images need to be duplicated. -#' -#' @details The new file name has the format -#' `yyyy-mm-dd_site_block_variable_name_#.ext` where `#` is an incrementing -#' number (0, 1, 2, ...) to ensure uniqueness within the target folder. -#' +#' and name. The file does not have to be originally in a temporary +#' folder, any file path is ok. Therefore this function can also be used e.g. +#' when cloning and event and the images associated with it need to be +#' duplicated. #' @param orig_filepath The path of the file to copy #' @param variable_name Which variable is this file for? E.g. canopeo_image #' @param site The site where the event took place #' @param block The block where the event took place -#' @param date The day of the event as a character string, format yyyy-mm-dd -#' @param filepath_is_relative If TRUE, json_file_base_folder will be added +#' @param date The day of the event as a character string, the format must be +#' yyyy-mm-dd +#' @param filepath_is_relative If TRUE, json_file_base_folder will be added to +#' the beginning of filepath #' @param delete_original Should the original file be deleted after copying? -#' @param base_folder Included for testing reasons +#' @param base_folder Included for testing reasons, the default value should +#' otherwise be used +#' +#' @details The name will be of the format +#' yyyy-mm-dd_site_block_variable_name_# where # is a number (0, 1, 2, ...) to +#' ensure that files have unique names. #' -#' @return A path to the new location of the file relative to events.json. +#' @return A path to the new location of the file relative to the events.json +#' file. #' #' @importFrom glue glue copy_file <- function(orig_filepath, variable_name, site, block, date, @@ -170,12 +173,12 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, base_folder = json_file_base_folder()) { # ensures the folder for this site-block combo is there create_file_folder(site, block, base_folder) - + # add json_file_base_folder to filepath if requested if (filepath_is_relative) { orig_filepath <- file.path(base_folder, orig_filepath) } - + # check that the temporary file actually exists if (!file.exists(orig_filepath)) { stop(glue("The file {orig_filepath} to copy does not exist")) @@ -187,7 +190,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, if (!(file_extension %in% allowed_extensions)) { stop("This file extension is not supported") } - + # base of the new file name file_base <- paste(date, site, block, variable_name, sep = "_") @@ -196,7 +199,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, if (!dir.exists(filepath)) { dir.create(filepath) } - + # determine the number to add to the end of the file name to keep file names # in the folder unique number <- 0 @@ -209,6 +212,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, break } number <- number + 1 + # don't loop forever if (number >= 1000) { stop("Could not find a unique name for the file") @@ -222,7 +226,7 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, warning = function(cnd) {message(cnd); FALSE}, error = function(cnd) {message(cnd); FALSE}) - # if we succeeded in renaming, delete the original file if requested + # if we succeeded in renaming, delete the original file if requested if (success & delete_original) { deleted_original <- tryCatch(expr = file.remove(orig_filepath), warning = function(cnd) {message(cnd)}, @@ -242,13 +246,15 @@ copy_file <- function(orig_filepath, variable_name, site, block, date, #' #' Delete the file with the path filepath. Used to delete files (images) #' associated with events, e.g. canopeo_image -#' +#' #' @param filepath The path to the file which should be deleted. #' @param filepath_relative Set to TRUE and supply site and block if filepath is -#' relative to the events.json file. +#' relative to the events.json file. This allows the function to figure out +#' the correct path to the file. #' @param site The site where the event took place #' @param block The block where the event took place -#' @param base_folder Included for testing reasons +#' @param base_folder Included for testing reasons, the default value should +#' otherwise be used #' #' @importFrom glue glue delete_file <- function(filepath, site = NULL, block = NULL, diff --git a/R/fct_language.R b/R/fct_language.R index 7465de5..2863448 100644 --- a/R/fct_language.R +++ b/R/fct_language.R @@ -100,65 +100,30 @@ replace_with_display_names <- function(events_with_code_names, language) { iso <- lang_to_iso(language) for (variable_name in names(events_with_code_names)) { - # First check structure_lookup_list (app chrome elements) + # determine the type of element the variable corresponds to: an app + # chrome element or a schema property element <- structure_lookup_list[[variable_name]] + desc <- if (is.null(element$type)) { + find_property_by_name(mgmt_schema, variable_name) + } + type <- element$type %||% desc$type - # If not in structure_lookup_list, try schema property registry - if (is.null(element$type)) { - desc <- find_property_by_name(mgmt_schema, variable_name) - if (!is.null(desc)) { - wtype <- desc$type - if (wtype == "selectInput") { - events_with_display_names[[variable_name]] <- - sapply(events_with_code_names[[variable_name]], - FUN = function(x) { - if (is.null(x) || identical(x, missingval)) return("") - # Try schema choices first - if (!is.null(desc$choices)) { - for (ch in desc$choices) { - if (identical(ch$value, x)) { - return(schema_get_title(ch$titles, iso, x)) - } - } - } - # Try display_names.csv - name <- get_disp_name(x, language = language) - if (length(name) > 1) { - name <- paste(ifelse(name == "", "-", name), - collapse = ", ") - } - name - }) - } else if (wtype %in% c("textAreaInput", "textInput", "numericInput")) { - events_with_display_names[[variable_name]] <- - sapply(events_with_code_names[[variable_name]], - FUN = function(x) { - if (length(x) > 1) { - paste(ifelse(x == missingval, "-", x), collapse = ", ") - } else { - ifelse(x == missingval, "", x) - } - }) - } else if (wtype == "dateInput") { - events_with_display_names[[variable_name]] <- - sapply(events_with_code_names[[variable_name]], - FUN = function(x) { - paste(format(as.Date(x, format = date_format_json), - date_format_display), - collapse = " - ") - }) - } - next - } + if (is.null(type)) { + # this could be e.g. the date_ordering or event column next } - - if (element$type == "selectInput") { + + if (type == "selectInput") { # the pasting is done to ensure we get a nicely formatted name # when x is a character vector events_with_display_names[[variable_name]] <- sapply(events_with_code_names[[variable_name]], FUN = function(x) { + choice <- Find(function(ch) identical(ch$value, x), + desc$choices) + if (!is.null(choice)) { + return(schema_get_title(choice$titles, iso, x)) + } name <- get_disp_name(x, language = language) if (length(name) > 1) { name <- paste(ifelse(name=="", "-", name), @@ -166,7 +131,7 @@ replace_with_display_names <- function(events_with_code_names, language) { } name }) - } else if (element$type %in% + } else if (type %in% c("textAreaInput", "textInput", "numericInput")) { events_with_display_names[[variable_name]] <- sapply(events_with_code_names[[variable_name]], @@ -178,7 +143,7 @@ replace_with_display_names <- function(events_with_code_names, language) { ifelse(x==missingval,"",x) } }) - } else if (element$type %in% c("dateInput", "dateRangeInput")) { + } else if (type %in% c("dateInput", "dateRangeInput")) { events_with_display_names[[variable_name]] <- sapply(events_with_code_names[[variable_name]], FUN = function(x) { diff --git a/R/fct_schema.R b/R/fct_schema.R index 02b8c0b..92c96c6 100644 --- a/R/fct_schema.R +++ b/R/fct_schema.R @@ -26,7 +26,7 @@ load_schema <- function() { defs <- raw[["$defs"]] common_props <- raw$properties one_of <- raw$oneOf - top_required <- if (!is.null(raw$required)) raw$required else character(0) + top_required <- raw$required %||% character(0) event_registry <- list() property_registry <- list() @@ -38,8 +38,7 @@ load_schema <- function() { prop_resolved <- resolve_property(prop, defs) desc <- build_property_descriptor(prop_name, prop_resolved, required = prop_name %in% top_required, - event_type = "__common__", - is_array_item = FALSE) + event_type = "__common__") property_registry[[prop_name]] <- desc } @@ -56,11 +55,7 @@ load_schema <- function() { if (is.null(event_const)) next event_titles <- extract_titles(event_def) - event_required <- if (!is.null(event_def$required)) { - event_def$required - } else { - character(0) - } + event_required <- event_def$required %||% character(0) event_type_choices[[event_const]] <- event_titles @@ -77,8 +72,7 @@ load_schema <- function() { for (pn in names(event_props)) { if (pn == "mgmt_operations_event") next p <- event_props[[pn]] - xui <- p[["x-ui"]] - if (!is.null(xui) && identical(xui$discriminator, TRUE)) { + if (isTRUE(p[["x-ui"]]$discriminator)) { subtype_discriminator <- pn break } @@ -95,11 +89,7 @@ load_schema <- function() { if (is.null(sub_const)) next sub_titles <- extract_titles(subtype_def) - sub_required <- if (!is.null(subtype_def$required)) { - subtype_def$required - } else { - character(0) - } + sub_required <- subtype_def$required %||% character(0) # Register subtype-specific properties sub_prop_names <- character(0) @@ -107,12 +97,12 @@ load_schema <- function() { if (spn == subtype_discriminator) next if (spn == "mgmt_operations_event") next sp <- sub_props[[spn]] + if (!is.null(sp[["const"]]) && is.null(sp$type)) next sp_resolved <- resolve_property(sp, defs) is_req <- spn %in% sub_required || spn %in% event_required desc <- build_property_descriptor(spn, sp_resolved, required = is_req, - event_type = event_const, - is_array_item = FALSE) + event_type = event_const) desc$subtype <- sub_const property_registry[[paste0(spn, REGISTRY_KEY_SEP, event_const, REGISTRY_KEY_SEP, sub_const)]] <- desc sub_prop_names <- c(sub_prop_names, spn) @@ -144,8 +134,7 @@ load_schema <- function() { is_req <- pn %in% event_required desc <- build_property_descriptor(pn, p_resolved, required = is_req, - event_type = event_const, - is_array_item = FALSE) + event_type = event_const) if (pn %in% common_prop_names) { common_overrides[[pn]] <- desc next @@ -222,7 +211,7 @@ resolve_property <- function(prop, defs) { merged <- list() for (part in prop$allOf) { resolved <- resolve_ref(part, defs) - merged <- merge_lists(merged, resolved) + merged[names(resolved)] <- resolved } # Carry over any top-level keys not in allOf for (k in names(prop)) { @@ -264,15 +253,7 @@ resolve_ref <- function(obj, defs) { for (p in parts[-1]) { target <- target[[p]] } - if (is.null(target)) return(obj) - target -} - -merge_lists <- function(a, b) { - for (k in names(b)) { - a[[k]] <- b[[k]] - } - a + target %||% obj } # Titles are only used as UI labels, so they are shown in sentence case here @@ -320,8 +301,8 @@ determine_widget_type <- function(prop) { } if (identical(prop_type, "string")) { - if (!is.null(prop$oneOf) && length(prop$oneOf) > 0) return("selectInput") - if (!is.null(xui) && identical(xui$discriminator, TRUE)) return("selectInput") + if (length(prop$oneOf) > 0) return("selectInput") + if (isTRUE(xui$discriminator)) return("selectInput") if (identical(prop$format, "date")) return("dateInput") return("textInput") } @@ -338,10 +319,8 @@ determine_widget_type <- function(prop) { #' @param prop Resolved property definition #' @param required Whether this property is required #' @param event_type The event type this property belongs to -#' @param is_array_item Whether this property is inside an array items #' @return A named list describing the property -build_property_descriptor <- function(name, prop, required, event_type, - is_array_item) { +build_property_descriptor <- function(name, prop, required, event_type) { xui <- prop[["x-ui"]] widget_type <- determine_widget_type(prop) @@ -354,18 +333,13 @@ build_property_descriptor <- function(name, prop, required, event_type, array_items_required <- NULL if (widget_type == "dataTable" && !is.null(prop$items$properties)) { array_columns <- list() - array_items_required <- if (!is.null(prop$items$required)) { - prop$items$required - } else { - character(0) - } + array_items_required <- prop$items$required %||% character(0) for (col_name in names(prop$items$properties)) { col_prop <- prop$items$properties[[col_name]] array_columns[[col_name]] <- build_property_descriptor( col_name, col_prop, required = col_name %in% array_items_required, - event_type = event_type, - is_array_item = TRUE) + event_type = event_type) } } @@ -403,9 +377,8 @@ build_property_descriptor <- function(name, prop, required, event_type, placeholders = placeholders, total_of = total_of, event_type = event_type, - is_array_item = is_array_item, is_integer = identical(prop$type, "integer"), - is_discriminator = !is.null(xui) && identical(xui$discriminator, TRUE), + is_discriminator = isTRUE(xui$discriminator), array_columns = array_columns, array_items_required = array_items_required, xui = xui @@ -435,8 +408,7 @@ extract_oneof_choices <- function(one_of_array) { #' @return The title string schema_get_title <- function(titles, language = "en", fallback = "") { if (is.null(titles)) return(fallback) - lang_key <- language - result <- titles[[lang_key]] + result <- titles[[language]] if (!is.null(result) && nchar(result) > 0) return(result) # fallback to English result <- titles[["en"]] @@ -457,7 +429,7 @@ lang_to_iso <- function(language) { "sv" = "sv" ) result <- mapping[language] - if (is.na(result) || is.null(result)) "en" else unname(result) + if (is.na(result)) "en" else unname(result) } #' Build a named choice vector for selectInput from schema choices @@ -471,9 +443,7 @@ schema_get_choices <- function(choices, language) { labels <- vapply(choices, function(ch) { schema_get_title(ch$titles, iso, ch$value) }, character(1)) - result <- c("", values) - names(result) <- c("", labels) - result + stats::setNames(c("", values), c("", labels)) } #' Look up a property descriptor from the registry diff --git a/R/fct_schema_ui.R b/R/fct_schema_ui.R index 9a0e209..3c3bd6c 100644 --- a/R/fct_schema_ui.R +++ b/R/fct_schema_ui.R @@ -84,63 +84,49 @@ render_schema_form <- function(schema, ns, language) { #' @param event_const The event type const value #' @return A tagList render_event_panel <- function(event_entry, pr, ns, iso, event_const) { - widgets <- list() - - # Render event-level properties (excluding discriminator and const-only) - for (pn in event_entry$property_names) { + widgets <- lapply(event_entry$property_names, function(pn) { desc <- lookup_property(pr, pn, event_const) - if (is.null(desc)) next - if (desc$type == "const") next - - if (desc$type == "dataTable") { - w <- render_array_table(desc, ns, iso) - } else if (desc$is_discriminator && event_entry$has_subtypes) { - w <- render_subtype_section(desc, event_entry, pr, ns, iso, - event_const) + if (desc$is_discriminator && event_entry$has_subtypes) { + render_subtype_section(desc, event_entry, pr, ns, iso, event_const) } else { - w <- render_property_widget(desc$id, desc, ns, iso) + render_field(desc, ns, iso) } - # Wrap in conditionalPanel if x-ui condition is defined - if (!is.null(desc$condition)) { - w <- conditionalPanel( - condition = convert_condition_to_js(desc$condition, ns), w) - } - widgets[[length(widgets) + 1]] <- w - } - + }) tagList(widgets) } +#' Render the widget or table of a field, shown only when its x-ui condition +#' (if any) is met +#' @param desc Property descriptor +#' @param ns Namespace function +#' @param iso ISO language code +#' @return A Shiny tag +render_field <- function(desc, ns, iso) { + w <- if (desc$type == "dataTable") { + render_array_table(desc, ns, iso) + } else if (desc$type == "fileInput") { + mod_fileInput_ui(ns(desc$id), desc, iso) + } else { + render_property_widget(desc$id, desc, ns, iso) + } + if (is.null(desc$condition)) return(w) + conditionalPanel(condition = convert_condition_to_js(desc$condition, ns), w) +} + #' Render a subtype discriminator and its conditional panels render_subtype_section <- function(desc, event_entry, pr, ns, iso, event_const) { # Render the discriminator selectInput with subtype choices subtype_choices <- build_subtype_choices(event_entry, iso) discriminator_widget <- render_property_widget(desc$id, desc, ns, iso, - override_choices = subtype_choices) + choices = subtype_choices) # Build subtype conditional panels subtype_panels <- lapply(names(event_entry$subtypes), function(sub_const) { - sub <- event_entry$subtypes[[sub_const]] - - sub_widgets <- list() - for (spn in sub$property_names) { - sdesc <- lookup_property(pr, spn, event_const, sub_const) - if (is.null(sdesc)) next - if (sdesc$type == "const") next - - if (sdesc$type == "dataTable") { - sw <- render_array_table(sdesc, ns, iso) - } else { - sw <- render_property_widget(sdesc$id, sdesc, ns, iso) - } - if (!is.null(sdesc$condition)) { - sw <- conditionalPanel( - condition = convert_condition_to_js(sdesc$condition, ns), sw) - } - sub_widgets[[length(sub_widgets) + 1]] <- sw - } - + sub_widgets <- lapply(event_entry$subtypes[[sub_const]]$property_names, + function(spn) { + render_field(lookup_property(pr, spn, event_const, sub_const), ns, iso) + }) condition <- paste0("input['", ns(desc$id), "'] == '", sub_const, "'") conditionalPanel(condition = condition, tagList(sub_widgets)) }) @@ -149,121 +135,51 @@ render_subtype_section <- function(desc, event_entry, pr, ns, iso, } #' Render a single Shiny input widget from a property descriptor -#' @param prop_name Input ID of the widget (desc$id for form fields) +#' @param id Input ID of the widget (desc$id for form fields) #' @param desc Property descriptor from the registry #' @param ns Namespace function #' @param iso ISO language code -#' @param override_code_name Optional code name override (for table cells) -#' @param override_label Optional label override -#' @param override_value Optional value override -#' @param override_choices Optional choices override -#' @param override_selected Optional selected value override -#' @param override_placeholder Optional placeholder override +#' @param label Optional label, the property title by default +#' @param value Optional initial value (the selected value of a selectInput) +#' @param choices Optional choices, the property's choices by default #' @param width Optional width #' @return A Shiny widget tag -render_property_widget <- function(prop_name, desc, ns, iso, - override_code_name = NULL, - override_label = NULL, - override_value = NULL, - override_choices = NULL, - override_selected = NULL, - override_placeholder = NULL, - width = NULL) { - input_id <- ns(if (!is.null(override_code_name)) { - override_code_name - } else { - prop_name - }) - - label <- if (!is.null(override_label)) { - override_label - } else { - make_required_label( - schema_get_title(desc$titles, iso, desc$name), - desc$required - ) - } - - value <- if (!is.null(override_value)) override_value else "" - - placeholder <- if (!is.null(override_placeholder)) { - override_placeholder - } else if (!is.null(desc$placeholders)) { +render_property_widget <- function(id, desc, ns, iso, label = NULL, + value = NULL, choices = NULL, + width = NULL) { + input_id <- ns(id) + label <- label %||% make_required_label( + schema_get_title(desc$titles, iso, desc$name), desc$required) + placeholder <- if (!is.null(desc$placeholders)) { schema_get_title(desc$placeholders, iso, "") - } else { - NULL } - - wtype <- desc$type - extra_args <- list() - if (!is.null(width)) extra_args$width <- width - - if (wtype == "selectInput") { - choices <- if (!is.null(override_choices)) { - override_choices - } else { - schema_get_choices(desc$choices, iso) - } - if (is.null(choices)) choices <- stats::setNames("", "") - selected <- override_selected - - do.call(selectInput, c(list( - inputId = input_id, - label = label, - choices = choices, - selected = selected - ), extra_args)) - - } else if (wtype == "numericInput") { - num_val <- if (is.numeric(override_value)) override_value else NA - num_min <- if (!is.null(desc$minimum)) desc$minimum else NA - num_max <- if (!is.null(desc$maximum)) desc$maximum else NA - - do.call(numericInput, c(list( - inputId = input_id, - label = label, - value = num_val, - min = num_min, - max = num_max, - step = if (isTRUE(desc$is_integer)) 1 else "any" - ), extra_args)) - - } else if (wtype == "dateInput") { - date_val <- if (!is.null(override_value) && nchar(override_value) > 0) { - tryCatch(as.Date(override_value), error = function(e) Sys.Date()) + + if (desc$type == "selectInput") { + choices <- choices %||% schema_get_choices(desc$choices, iso) %||% + stats::setNames("", "") + selectInput(input_id, label = label, choices = choices, selected = value, + width = width) + } else if (desc$type == "numericInput") { + numericInput(input_id, label = label, + value = if (is.numeric(value)) value else NA, + min = desc$minimum %||% NA, max = desc$maximum %||% NA, + step = if (isTRUE(desc$is_integer)) 1 else "any", + width = width) + } else if (desc$type == "dateInput") { + date_val <- if (isTruthy(value)) { + tryCatch(as.Date(value), error = function(e) Sys.Date()) } else { Sys.Date() } - - do.call(dateInput, c(list( - inputId = input_id, - label = label, - value = date_val, - format = "dd/mm/yyyy", - max = Sys.Date(), - weekstart = 1 - ), extra_args)) - - } else if (wtype == "textAreaInput") { - do.call(textAreaInput, c(list( - inputId = input_id, - label = label, - value = value, - resize = "vertical", - placeholder = placeholder - ), extra_args)) - - } else if (wtype == "textInput") { - do.call(textInput, c(list( - inputId = input_id, - label = label, - value = value, - placeholder = placeholder - ), extra_args)) - + dateInput(input_id, label = label, value = date_val, format = "dd/mm/yyyy", + max = Sys.Date(), weekstart = 1, width = width) + } else if (desc$type == "textAreaInput") { + textAreaInput(input_id, label = label, value = value %||% "", + resize = "vertical", placeholder = placeholder, + width = width) } else { - # Fallback - textInput(inputId = input_id, label = label, value = value) + textInput(input_id, label = label, value = value %||% "", + placeholder = placeholder, width = width) } } @@ -300,9 +216,8 @@ schema_table_id <- function(desc) { #' @param desc Property descriptor #' @param iso ISO language code #' @param input The input of the session, to keep the current selection -#' @param override_choices Optional choices (e.g. for a subtype discriminator) -update_schema_widget <- function(session, desc, iso, input, - override_choices = NULL) { +#' @param choices Optional choices (e.g. for a subtype discriminator) +update_schema_widget <- function(session, desc, iso, input, choices = NULL) { id <- desc$id label <- make_required_label( schema_get_title(desc$titles, iso, desc$name), @@ -313,7 +228,7 @@ update_schema_widget <- function(session, desc, iso, input, } if (desc$type == "selectInput") { - choices <- override_choices %||% schema_get_choices(desc$choices, iso) + choices <- choices %||% schema_get_choices(desc$choices, iso) updateSelectInput(session, id, label = label, choices = choices, selected = input[[id]]) } else if (desc$type == "numericInput") { @@ -336,9 +251,7 @@ build_event_type_choices <- function(schema, iso) { labels <- vapply(schema$event_type_choices, function(titles) { schema_get_title(titles, iso, "") }, character(1)) - result <- c("", values) - names(result) <- c("", labels) - result + stats::setNames(c("", values), c("", labels)) } #' Build subtype selectInput choices @@ -352,9 +265,7 @@ build_subtype_choices <- function(event_entry, iso) { labels <- vapply(subtypes, function(s) { schema_get_title(s$titles, iso, s$const) }, character(1)) - result <- c("", values) - names(result) <- c("", labels) - result + stats::setNames(c("", values), c("", labels)) } #' Update a schema-driven widget value (for populating forms) @@ -362,7 +273,6 @@ build_subtype_choices <- function(event_entry, iso) { #' @param desc Property descriptor #' @param value The value to set. NULL clears the widget update_schema_value <- function(session, desc, value) { - if (is.null(desc)) return() id <- desc$id if (is.atomic(value) && all(is_missing_value(value))) value <- NULL diff --git a/R/fct_ui.R b/R/fct_ui.R index abce53e..841f91b 100644 --- a/R/fct_ui.R +++ b/R/fct_ui.R @@ -2,7 +2,7 @@ # e.g. builds additional options for the different activity types # Otto Kuusela 2021 -structure_file_path <- function() system.file("extdata", "ui_structure.json", +structure_file_path <- function() system.file("extdata", "ui_structure.json", package = "fieldactivity") structure <- jsonlite::fromJSON(structure_file_path(), simplifyMatrix = FALSE) @@ -25,11 +25,12 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { if (!is.list(element)) { next } - + # x is a list, so let's test it result <- fun(element, ...) - + if (!is.null(result)) { + # if we have a naming function defined, use that # index is either an actual index or name of the element if (is.null(name_fun)) { @@ -40,8 +41,8 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { results[[index]] <- result } - - # more results might lurk on lower levels of the list. + + # more results might lurk on lower levels of the list. # So let's investigate those more_results <- rlapply(element, fun, name_fun, ...) @@ -63,7 +64,7 @@ rlapply <- function(x, fun, name_fun = NULL, ...) { #' Build lookup list for UI elements #' @description Build a list where the names are the code names of UI elements #' and the values are the corresponding element structures (lists) found in -#' ui_structure.json. Now only contains app chrome elements. +#' ui_structure.json (the app chrome, the event form is built from the schema). #' @return The lookup list. build_structure_lookup_list <- function() { element_fetcher <- function(x) { @@ -88,35 +89,31 @@ structure_lookup_list <- build_structure_lookup_list() # help texts (technically textOutputs) have a different method of updating # when the language is changed because they are outputs rather than inputs, # and for that we need a list of the code names of these objects. -# We also need the code names of fileInput delete buttons to set up observers -# for them text_output_code_names <- NULL -fileInput_code_names <- NULL for (element in structure_lookup_list) { if (element$type == "textOutput") { text_output_code_names <- c(text_output_code_names, element$code_name) - } else if (element$type == "fileInput") { - fileInput_code_names <- c(fileInput_code_names, element$code_name) } } #' Find the choices for a selectInput given its code name #' #' @param selectInput_code_name The code name of the selectInput -#' @param language The language to show the options in. +#' @param language The language to show the options in. This will be passed to +#' get_disp_name #' #' @return A vector of choices (code names). If language was supplied, the names #' will be the names of the vector. get_selectInput_choices <- function(selectInput_code_name, language) { # the choices for a selectInput element can be stored in - # three ways: + # three ways: # 1) the code names of the choices are given as a vector # 2) for site and block selectors, there is IGNORE: # this means that the choices should not be updated here (return NULL) # 3) the category name for the choices is given. # in the following if-statement, these are handled # in this same order - + element_structure <- structure_lookup_list[[selectInput_code_name]] if (!identical(element_structure$type, "selectInput") || @@ -131,6 +128,8 @@ get_selectInput_choices <- function(selectInput_code_name, language) { } else if (element_structure$choices == "IGNORE") { choices <- NULL } else { + # get_category_names returns both display names and + # code names choices <- c( "", get_category_names(element_structure$choices, diff --git a/R/mod_download.R b/R/mod_download.R index 6e3b323..9bba278 100644 --- a/R/mod_download.R +++ b/R/mod_download.R @@ -146,13 +146,13 @@ mod_download_server_table <- function(id, user_auth, base_folder = json_file_bas events <- unlist(lapply(blocks, function(block) { read_json_file(site, block, base_folder = base_folder)$events }), recursive = FALSE) - + if (length(events) == 0) { write.csv("Seems that there isn't any data? Try to create a management event.", file, row.names = FALSE) return() - } - + } + events_table <- events_to_table(events) # block first, as in the event list events_table <- events_table[c("block", setdiff(names(events_table), "block"))] @@ -203,13 +203,13 @@ mod_download_server_json <- function(id, user_auth, base_folder = json_file_base for (block_name in blocks) { file.copy(file.path(base_folder, site, block_name, "events.json"), file.path(tmpdrjson, paste0("events_", block_name, ".json"))) - } + } if (length(list.files(tmpdrjson)) == 0) { if(dp()) message("Return a csv with an error") write.csv("Seems that there isn't any data? Try to create a management event.", file.path(tmpdrjson, "Error.csv"), row.names = FALSE) - } + } zip::zip(zipfile = file, files = "json", root = zip_root) }, contentType = "application/zip" diff --git a/R/mod_event_list.R b/R/mod_event_list.R index facc4f9..dc39661 100644 --- a/R/mod_event_list.R +++ b/R/mod_event_list.R @@ -254,23 +254,12 @@ mod_event_list_server <- function(id, events, language, site) { # if we are only looking at a specific event type, show columns # appropriate to it if (input$event_list_activity_filter != "activity_choice_all") { - hidden_widget_types <- c("textOutput", "dataTable", "fileInput", - "actionButton") - # Use schema registry to get event-specific property names - event_type <- input$event_list_activity_filter - event_entry <- mgmt_schema$event_registry[[event_type]] - if (!is.null(event_entry)) { - activity_variables <- character(0) - for (pn in event_entry$property_names) { - desc <- lookup_property(mgmt_schema$property_registry, pn, - event_type) - if (is.null(desc)) next - if (desc$type %in% c("const", "dataTable")) next - activity_variables <- c(activity_variables, pn) - } - } else { - activity_variables <- character(0) - } + # tables and files are not shown in the event list + activity_fields <- Filter( + function(desc) !desc$type %in% c("dataTable", "fileInput"), + get_relevant_fields(mgmt_schema, input$event_list_activity_filter)) + activity_variables <- vapply(activity_fields, function(desc) desc$name, + character(1)) table_variables <- c(table_variables, activity_variables) } @@ -288,9 +277,10 @@ mod_event_list_server <- function(id, events, language, site) { # filter by activity type if (input$event_list_activity_filter != "activity_choice_all") { event_list <- rlapply(event_list, fun = function(x) - if (!is.null(x$mgmt_operations_event) && x$mgmt_operations_event == input$event_list_activity_filter) {x}) + if (identical(x$mgmt_operations_event, + input$event_list_activity_filter)) {x}) } - + # filter by year if (input$event_list_year_filter != "year_choice_all") { event_list <- rlapply(event_list, fun = function(x) { diff --git a/R/mod_fileInput.R b/R/mod_fileInput.R index ec98ac8..6c037b8 100644 --- a/R/mod_fileInput.R +++ b/R/mod_fileInput.R @@ -24,19 +24,21 @@ #' @description A shiny Module. #' #' @param id,input,output,session Internal parameters for {shiny}. +#' @param desc Property descriptor of the file field +#' @param iso ISO language code #' #' @noRd #' #' @importFrom shiny NS tagList -mod_fileInput_ui <- function(id, widget_structure) { +mod_fileInput_ui <- function(id, desc, iso) { ns <- NS(id) tagList( div(style = "display: flex;", div(style = "flex-grow: 1;", fileInput(ns("file"), - label = get_disp_name(widget_structure$label, init_lang), - accept = widget_structure$filetype)), + label = schema_get_title(desc$titles, iso, desc$name), + accept = desc$xui$accept)), div(style = "margin-left: 5px; padding-top: 26px", shinyjs::hidden( @@ -51,7 +53,7 @@ mod_fileInput_ui <- function(id, widget_structure) { #' fileInput Server Functions #' #' @noRd -mod_fileInput_server <- function(id, language, set_path, reset_path) { +mod_fileInput_server <- function(id, desc, language, set_path, reset_path) { stopifnot(is.reactive(language)) stopifnot(is.reactive(set_path)) @@ -137,8 +139,8 @@ mod_fileInput_server <- function(id, language, set_path, reset_path) { # when language changes, update labels observeEvent(language(), { # update label of widget - label <- structure_lookup_list[[id]]$label - update_label(get_disp_name(label, language())) + update_label(schema_get_title(desc$titles, lang_to_iso(language()), + desc$name)) # update label on the browse button update_button_label(get_disp_name("file_input_button_label", language())) # update delete button label diff --git a/R/mod_form.R b/R/mod_form.R index be1a90f..04c2956 100644 --- a/R/mod_form.R +++ b/R/mod_form.R @@ -21,9 +21,10 @@ mod_form_ui <- function(id){ ns <- NS(id) iso <- lang_to_iso(init_lang) - - tagList( + pr <- mgmt_schema$property_registry + tagList( + # the form contains the widgets for entering information # about the event fluidRow( @@ -32,27 +33,25 @@ mod_form_ui <- function(id){ style = "margin-bottom = 0px; margin-top = 0px; margin-block-start = 0px"), - # in general the choices and labels don't have to be - # defined for selectInputs, as they will be - # populated when the language is changed + # in general the choices and labels don't have to be + # defined for selectInputs, as they will be + # populated when the language is changed # (which also happens when the app starts) - - span(textOutput(ns("required_variables_helptext")), + + span(textOutput(ns("required_variables_helptext")), style = "color:gray"), br(), - - selectInput(ns("block"), label = get_disp_name("block_label", + + selectInput(ns("block"), label = get_disp_name("block_label", init_lang), choices = ""), selectInput(ns("mgmt_operations_event"), label = schema_get_title( - lookup_property(mgmt_schema$property_registry, - "mgmt_operations_event")$titles, - iso, "event"), + pr$mgmt_operations_event$titles, iso, "event"), choices = build_event_type_choices(mgmt_schema, iso) - ), - + ), + # setting max disallows inputting future events dateInput( ns("date"), @@ -66,13 +65,9 @@ mod_form_ui <- function(id){ textAreaInput( ns("mgmt_event_short_notes"), label = schema_get_title( - lookup_property(mgmt_schema$property_registry, - "mgmt_event_short_notes")$titles, - iso, "description"), + pr$mgmt_event_short_notes$titles, iso, "description"), placeholder = schema_get_title( - lookup_property(mgmt_schema$property_registry, - "mgmt_event_short_notes")$placeholders, - iso, ""), + pr$mgmt_event_short_notes$placeholders, iso, ""), resize = "vertical", height = "70px" ) @@ -87,11 +82,14 @@ mod_form_ui <- function(id){ fluidRow( column(width = 12, actionButton(ns("save"), label = "Save"), + actionButton(ns("cancel"), label = "Cancel"), + shinyjs::hidden(actionButton(ns("delete"), label = "Delete", class = "btn-warning")) ) ) + ) } @@ -115,37 +113,41 @@ mod_form_ui <- function(id){ #' #' @import shinyvalidate #' @noRd -mod_form_server <- function(id, site, set_values, reset_values, edit_mode, +mod_form_server <- function(id, site, set_values, reset_values, edit_mode, language, init_signal) { - + stopifnot(is.reactive(site)) stopifnot(is.reactive(set_values)) stopifnot(is.reactive(reset_values)) stopifnot(is.reactive(edit_mode)) stopifnot(is.reactive(language)) stopifnot(is.reactive(init_signal)) - + moduleServer(id, function(input, output, session) { if (dp()) message("Initialising form server function") - + schema <- mgmt_schema er <- schema$event_registry pr <- schema$property_registry - # the widgets of event and subtype properties, and the tables among them - event_fields <- Filter(function(desc) { - desc$event_type != "__common__" && desc$type != "const" - }, pr) - input_fields <- Filter(function(desc) desc$type != "dataTable", - event_fields) + # the widgets of event and subtype properties, and the tables and file + # (image) fields among them + event_fields <- Filter(function(desc) desc$event_type != "__common__", pr) + input_fields <- Filter(function(desc) { + !desc$type %in% c("dataTable", "fileInput") + }, event_fields) table_fields <- Filter(function(desc) desc$type == "dataTable", event_fields) + file_fields <- Filter(function(desc) desc$type == "fileInput", + event_fields) # keys the schema knows about. Other keys of an edited event are kept as # they are when it is saved, so that no data is lost known_names <- c(vapply(pr, function(desc) desc$name, character(1)), "block", "$schema") unknown_values <- reactiveVal(list()) + # the totals currently computed from the tables (see auto-sum below) + summed_ids <- character(0) # the selected event type and subtype current_context <- reactive({ @@ -164,9 +166,8 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, fields <- get_relevant_fields(schema, context$event_type, context$subtype) Filter(function(desc) { - desc$type != "const" && (is.null(desc$condition) || - isTRUE(evaluate_condition(desc$condition, - session))) + is.null(desc$condition) || + isTRUE(evaluate_condition(desc$condition, session)) }, fields) }) relevant_ids <- reactive({ @@ -183,46 +184,47 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, # is relevant. These individual validators are added as subvalidators to # main_iv main_iv <- InputValidator$new() - + common_iv <- InputValidator$new() common_iv$add_rule("mgmt_operations_event", sv_required(message = "Required")) common_iv$add_rule("block", sv_required(message = "Required")) main_iv$add_validator(common_iv) - + date_iv <- InputValidator$new() date_iv$add_rule("date", sv_required(message = "Required")) date_iv$condition(date_required) main_iv$add_validator(date_iv) - + for (desc in input_fields) { iv <- field_validator(desc) if (is.null(iv)) next local({ field_id <- desc$id iv$condition(reactive(field_id %in% relevant_ids())) - }) - main_iv$add_validator(iv) - } + }) + main_iv$add_validator(iv) + } # start showing validation messages main_iv$enable() - + # when site setting is changed, update the block choices on the form observeEvent(site(), ignoreNULL = FALSE, { + if (!isTruthy(site())) { shinyjs::disable("block") shinyjs::disable("save") return() - } - + } + shinyjs::enable("block") shinyjs::enable("save") - + # update block choices block_choices <- subset(sites, sites$site == site())$blocks[[1]] updateSelectInput(session, "block", choices = block_choices) }) - + # Fill the form with the values of an event and clear all other fields, so # that nothing is left over from a previously edited event (empty values # are not saved, so a missing value means an empty field). A new event is @@ -250,50 +252,55 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, rows <- if (desc$id %in% event_ids) values[[desc$name]] tables[[desc$id]]$set_values(rows %||% list()) } + for (desc in file_fields) { + path <- if (desc$id %in% event_ids) values[[desc$name]] + if (is.null(path)) { + files[[desc$id]]$reset_path(TRUE) + } else { + files[[desc$id]]$set_path(path) + } + } unknown_values(values[setdiff(names(values), known_names)]) summed_ids <<- character(0) } - + # when set_values is changed, update the values in the form observeEvent(set_values(), { + if (dp()) message("Filling the form with values") fill_form(set_values()) - + # change set_values back to NULL so that we can catch the next time its # value is changed. This doesn't re-trigger this observeEvent as # observeEvent ignores NULL values by default set_values(NULL) }) - + # when reset_values is signaled, reset the values of all widgets observeEvent(reset_values(), { if (identical(reset_values(), FALSE)) return() if (dp()) message("Resetting form values") fill_form(list()) - - # Reset fileInput fields separately - for (fileInput_code_name in fileInput_code_names) { - files[[fileInput_code_name]]$reset_path(TRUE) - } - reset_values(FALSE) }) - + # show Delete button depending on edit mode observeEvent(edit_mode(), ignoreNULL = FALSE, { shinyjs::toggle("delete", condition = edit_mode()) }) - + # update each of the text outputs automatically, including language changes - # and the dynamic updating in editing table title etc. + # and the dynamic updating in editing table title etc. lapply(text_output_code_names, FUN = function(text_output_code_name) { + # render text output[[text_output_code_name]] <- renderText({ + if (dp()) message(glue("Rendering text for {text_output_code_name}")) - + text_to_show <- get_disp_name(text_output_code_name, language()) - + #get element from the UI structure lookup list element <- structure_lookup_list[[text_output_code_name]] #if the text should be updated dynamically, do that @@ -305,12 +312,14 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, element$dynamic[["FALSE"]] } text_to_show <- get_disp_name(text_to_show, language()) + } } text_to_show }) + }) - + # the date label depends on the event type (e.g. the start date of # grazing) and whether the event type requires a date observe({ @@ -321,14 +330,14 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, # Language switching for schema-driven form fields observeEvent(language(), ignoreInit = TRUE, { iso <- lang_to_iso(language()) - + # Update event type selector updateSelectInput(session, "mgmt_operations_event", label = schema_get_title( pr$mgmt_operations_event$titles, iso, "event"), choices = build_event_type_choices(schema, iso), selected = input$mgmt_operations_event) - + # Update short notes short_notes_desc <- pr$mgmt_event_short_notes updateTextAreaInput(session, "mgmt_event_short_notes", @@ -336,76 +345,73 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, short_notes_desc$titles, iso, "description"), placeholder = schema_get_title( short_notes_desc$placeholders, iso, "")) - + # Update all event and subtype fields for (desc in input_fields) { subtype_choices <- if (desc$is_discriminator) { build_subtype_choices(er[[desc$event_type]], iso) } update_schema_widget(session, desc, iso, input, - override_choices = subtype_choices) + choices = subtype_choices) } - + # Update app chrome (block label, save/cancel/delete buttons) for (code_name in names(reactiveValuesToList(input))) { - element <- structure_lookup_list[[code_name]] + element <- structure_lookup_list[[code_name]] if (is.null(element$type)) next + label <- get_disp_name(element$label, language()) - + if (element$type == "selectInput") { choices <- get_selectInput_choices(code_name, language()) current_value <- input[[code_name]] + if (is.null(choices)) { updateSelectInput(session, code_name, - label = ifelse(is.null(label), "", label), - selected = current_value) + label = ifelse(is.null(label),"",label), + selected = current_value) } else { updateSelectInput(session, code_name, - label = ifelse(is.null(label), "", label), + label = ifelse(is.null(label),"",label), choices = choices, selected = current_value) } } else if (element$type == "actionButton") { updateActionButton(session, code_name, label = label) } + } + + }) - + # Table and fileInput module servers are started on first use. The # reactiveVals for setting table values exist from the start. tables <- lapply(table_fields, function(desc) { list(set_values = reactiveVal()) }) - files <- sapply(fileInput_code_names, USE.NAMES = TRUE, simplify = FALSE, - FUN = function(fileInput_code_name) { - set_path <- reactiveVal() - reset_path <- reactiveVal() - list(set_path = set_path, reset_path = reset_path) - }) - + files <- lapply(file_fields, function(desc) { + list(set_path = reactiveVal(), reset_path = reactiveVal()) + }) + observeEvent(init_signal(), once = TRUE, { if (dp()) message("Initialising table and fileInput server functions") - + for (desc in table_fields) { - tables[[desc$id]]$result <<- mod_table_server_schema( + tables[[desc$id]]$result <<- mod_table_server( schema_table_id(desc), desc, language, tables[[desc$id]]$set_values) + } + + for (desc in file_fields) { + files[[desc$id]]$value <<- mod_fileInput_server( + desc$id, desc, language, files[[desc$id]]$set_path, + files[[desc$id]]$reset_path) } - - # start server for all fileInput modules - sapply(fileInput_code_names, FUN = function(fileInput_code_name) { - files[[fileInput_code_name]]$value <<- - mod_fileInput_server(id = fileInput_code_name, - language = language, - set_path = files[[fileInput_code_name]]$set_path, - reset_path = files[[fileInput_code_name]]$reset_path) - }) }) - + # Auto-sum: update total fields from table column values. A total is only # computed when the table has values to sum, so a total entered without - # per-item values (as in many legacy events) is kept. summed_ids holds the - # totals currently computed from the tables. - summed_ids <- character(0) + # per-item values (as in many legacy events) is kept. observe({ context <- current_context() if (is.null(context)) return() @@ -435,28 +441,31 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, summed_ids <<- union(summed_ids, desc$id) } }) - + # when requested, prepare the entered data form_data <- reactive({ + if (dp()) message("Calculating form data") - + fields <- relevant_fields() is_table <- vapply(fields, function(desc) desc$type == "dataTable", logical(1)) + is_file <- vapply(fields, function(desc) desc$type == "fileInput", + logical(1)) relevant_tables <- lapply(fields[is_table], function(desc) { tables[[desc$id]]$result }) names(relevant_tables) <- vapply(fields[is_table], function(desc) desc$name, character(1)) relevant_tables <- Filter(Negate(is.null), relevant_tables) - + # check that the form and table validation rules have been met tables_valid <- vapply(relevant_tables, function(t) isTRUE(t$valid()), logical(1)) if (!main_iv$is_valid() || !all(tables_valid)) { return(NULL) } - + event <- list() # fill information event$mgmt_operations_event <- input$mgmt_operations_event @@ -465,53 +474,52 @@ mod_form_server <- function(id, site, set_values, reset_values, edit_mode, event$mgmt_event_short_notes <- input$mgmt_event_short_notes event$block <- input$block - for (desc in fields[!is_table]) { - is_fileInput <- !is.null(structure_lookup_list[[desc$name]]) && - identical(structure_lookup_list[[desc$name]]$type, "fileInput") - - value <- if (is_fileInput) { - files[[desc$name]]$value() - } else { - input[[desc$id]] - } - + for (desc in fields[!is_table & !is_file]) { + value <- input[[desc$id]] + # format Date value to character string and replace with "" if that # fails for some reason if (inherits(value, "Date")) { value <- tryCatch(format(value, date_format_json), error = function(cnd) "") } - + event[[desc$name]] <- value - } - + } + # each table is saved as an array of row objects under its property for (array_prop_name in names(relevant_tables)) { event[[array_prop_name]] <- relevant_tables[[array_prop_name]]$values() } - + # trim whitespace from text and leave out empty values event <- drop_empty_values( rapply(event, trimws, classes = "character", how = "replace")) + # the state of each file field (list(filepath, new_file)). The main app + # saves an uploaded file and replaces this with the path of the file + for (desc in fields[is_file]) { + event[[desc$name]] <- files[[desc$id]]$value() + } + # keep the values of the edited event that the form doesn't know about # as they are unknown <- unknown_values() event[names(unknown)] <- unknown event }) - + ################## RETURN VALUE - + list( data = form_data, save = reactive(input$save), cancel = reactive(input$cancel), delete = reactive(input$delete) ) - + }) - + } # Helper: label of a common property for the selected event type. An event diff --git a/R/mod_rotation_cycle.R b/R/mod_rotation_cycle.R index 9b9bf9c..b1fb53c 100644 --- a/R/mod_rotation_cycle.R +++ b/R/mod_rotation_cycle.R @@ -19,7 +19,7 @@ mod_rotation_cycle_ui <- function(id){ #' rotation_cycle Server Functions #' -#' @noRd +#' @noRd mod_rotation_cycle_server <- function(id, rotation, site, block){ # site needs to be added at some point stopifnot(is.reactive(rotation)) diff --git a/R/mod_table.R b/R/mod_table.R index 019fe11..693fad1 100644 --- a/R/mod_table.R +++ b/R/mod_table.R @@ -54,40 +54,15 @@ mod_table_ui <- function(id) { br() ) } - -# -- Helpers for mod_table_server_schema ------------------------------------ - + #' Build a single table cell widget as an HTML string #' @noRd -build_schema_cell_widget <- function(variable, col_desc, ns, iso, - current_row, value) { - code_name <- paste(variable, current_row, sep = "_") - - if (!isTruthy(value) || identical(value, missingval)) value <- "" - - choices <- NULL - if (identical(col_desc$type, "selectInput")) { - choices <- schema_get_choices(col_desc$choices, iso) - } - - placeholder <- NULL - if (!is.null(col_desc$placeholders)) { - placeholder <- schema_get_title(col_desc$placeholders, iso, "") - } - +build_cell_widget <- function(code_name, col_desc, ns, iso, value) { + if (!isTruthy(value)) value <- "" width <- if (col_desc$type == "numericInput") 100 else NULL - - widget_html <- as.character( - render_property_widget(variable, col_desc, ns, iso, - override_code_name = code_name, - override_label = "", - override_value = value, - override_choices = choices, - override_selected = value, - override_placeholder = placeholder, - width = width)) - - list(html = widget_html, code_name = code_name) + as.character(render_property_widget(code_name, col_desc, ns, iso, + label = "", value = value, + width = width)) } #' Build a remove-row button as an HTML string @@ -110,7 +85,7 @@ build_remove_row_button <- function(ns, iso, row_idx, can_remove) { ) } -#' Schema-driven table server module +#' Table server module #' #' @param id Module ID (must match the table_id used in render_array_table) #' @param desc The property descriptor for the array @@ -122,52 +97,40 @@ build_remove_row_button <- function(ns, iso, row_idx, can_remove) { #' table contents as a list of rows (named lists keyed by column name) #' @import shinyvalidate #' @noRd -mod_table_server_schema <- function(id, desc, language, override_values) { - +mod_table_server <- function(id, desc, language, override_values) { + stopifnot(is.reactive(language)) stopifnot(is.reactive(override_values)) - + moduleServer(id, function(input, output, session) { ns <- session$ns - + columns <- desc$array_columns if (is.null(columns)) return(list(values = reactiveVal(list()), valid = reactive(TRUE))) column_names <- names(columns) action_column_name <- "..remove_row.." - + iv <- InputValidator$new() iv$enable() rules_added <- NULL - - add_schema_validation_rules <- function(widgets, variables) { - lapply(seq_along(widgets), FUN = function(i) { - widget_name <- widgets[i] - col_desc <- columns[[variables[i]]] - - if (widget_name %in% rules_added) return() - - # Extract the row number from the widget name (e.g. "crop_name_2" -> 2) - row_num <- as.integer(sub(paste0("^", variables[i], "_"), "", widget_name)) - - child_iv <- field_validator(col_desc, widget_name) - if (is.null(child_iv)) return() - - # Only validate when this row is displayed. Widgets are numbered by - # display position, so compare with the number of rows rather than - # with the (stable) row ids - local({ - local_row <- row_num - child_iv$condition(reactive({ - local_row <= length(dynamic_rows()) - })) - }) - iv$add_validator(child_iv) - }) - rules_added <<- c(rules_added, widgets) - } - + + add_validation_rule <- function(widget_name, col_desc, row_number) { + force(row_number) + if (widget_name %in% rules_added) return() + rules_added <<- c(rules_added, widget_name) + + child_iv <- field_validator(col_desc, widget_name) + if (is.null(child_iv)) return() + + # Only validate when this row is displayed. Widgets are numbered by + # display position, so compare with the number of rows rather than + # with the (stable) row ids + child_iv$condition(reactive(row_number <= length(dynamic_rows()))) + iv$add_validator(child_iv) + } + n_cols <- length(column_names) # the latest entered rows and their dynamic row ids, used to keep the # entered values when the table is re-rendered @@ -175,14 +138,11 @@ mod_table_server_schema <- function(id, desc, language, override_values) { table_values <- reactiveVal() rendered <- reactiveVal(FALSE) dynamic_rows <- reactiveVal() - + observeEvent(input$rendered, { rendered(TRUE) }) - visible <- reactive({ - rows <- dynamic_rows() - !is.null(rows) && length(rows) > 0 - }) - + visible <- reactive(length(dynamic_rows()) > 0) + observeEvent(visible(), ignoreNULL = FALSE, ignoreInit = TRUE, priority = 1, { if (!visible()) { @@ -190,10 +150,10 @@ mod_table_server_schema <- function(id, desc, language, override_values) { old_values(list()) } }) - + override_trigger <- reactiveVal(0) row_trigger <- reactiveVal(0) - + observeEvent(override_values(), { values <- override_values() if (is.null(values)) return() @@ -201,7 +161,7 @@ mod_table_server_schema <- function(id, desc, language, override_values) { dynamic_rows(if (length(values) > 0) seq_along(values) else 1L) override_trigger(override_trigger() + 1) }) - + # Initialize with one row when first accessed (no override data) observe({ if (is.null(dynamic_rows())) { @@ -212,24 +172,23 @@ mod_table_server_schema <- function(id, desc, language, override_values) { # Add row handler observeEvent(input$add_row, { current <- dynamic_rows() - if (is.null(current) || length(current) == 0) { + if (length(current) == 0) { dynamic_rows(1L) } else { dynamic_rows(c(current, max(current) + 1L)) } - row_trigger(row_trigger() + 1) + row_trigger(row_trigger() + 1) }) - + # Remove a specific row while keeping stable row ids. observeEvent(input$remove_row_index, { current <- dynamic_rows() row_id <- input$remove_row_index - if (is.null(current) || length(current) <= 1) return() - if (is.null(row_id) || !(row_id %in% current)) return() + if (length(current) <= 1 || !(row_id %in% current)) return() dynamic_rows(current[current != row_id]) row_trigger(row_trigger() + 1) }) - + # Update button labels on language change observeEvent(language(), { iso <- lang_to_iso(language()) @@ -246,32 +205,28 @@ mod_table_server_schema <- function(id, desc, language, override_values) { req(isolate(rendered())) session$sendCustomMessage("unbind-table", ns("table")) }) - - # Sum calculation for schema tables is handled by the parent form module's - # auto-sum observer, not inside the table module itself. - + table_data <- reactive({ override_trigger() row_trigger() - + iso <- lang_to_iso(language()) override_vals <- isolate(override_values()) do_override <- !is.null(override_vals) - + table_to_display <- data.frame( matrix("", nrow = 0, ncol = n_cols + 1L), stringsAsFactors = FALSE ) names(table_to_display) <- c(column_names, action_column_name) - + if (do_override && identical(override_vals, list())) { - override_values(NULL) - do_override <- FALSE - old_values(list()) - } + override_values(NULL) + do_override <- FALSE + old_values(list()) + } rows <- isolate(dynamic_rows()) - if (is.null(rows) || length(rows) == 0) rows <- integer(0) can_remove_rows <- length(rows) > 1L current_row <- 1 @@ -285,52 +240,52 @@ mod_table_server_schema <- function(id, desc, language, override_values) { old <- isolate(old_values()) old_row_number <- match(row_idx, old$row_ids) if (!is.na(old_row_number)) old$rows[[old_row_number]][[variable]] - } - - cell <- build_schema_cell_widget(variable, col_desc, ns, iso, - current_row, value) - add_schema_validation_rules(cell$code_name, variable) - table_to_display[current_row, variable] <- cell$html - } - + } + + code_name <- paste(variable, current_row, sep = "_") + add_validation_rule(code_name, col_desc, current_row) + table_to_display[current_row, variable] <- + build_cell_widget(code_name, col_desc, ns, iso, value) + } + table_to_display[current_row, action_column_name] <- build_remove_row_button(ns, iso, row_idx, can_remove_rows) - + rownames(table_to_display)[current_row] <- as.character(row_idx) - current_row <- current_row + 1 - } - + current_row <- current_row + 1 + } + override_values(NULL) table_to_display }) - + output$table <- DT::renderDataTable({ req(visible()) rendered(FALSE) table_to_display <- table_data() - + if (nrow(table_to_display) == 0) return() - + iso <- lang_to_iso(language()) # full titles, as they include the unit col_labels <- vapply(column_names, function(cn) { schema_get_title(columns[[cn]]$titles, iso, cn) }, character(1)) names(table_to_display) <- c(col_labels, "") - - table_to_display <- + + table_to_display <- DT::datatable( - table_to_display, + table_to_display, escape = FALSE, selection = "none", class = "table table-hover", rownames = FALSE, - options = + options = list(dom = "t", ordering = FALSE, autoWidth = FALSE, drawCallback = htmlwidgets::JS(js_bind_script), - initComplete = + initComplete = htmlwidgets::JS(paste0( "function(settings, json) {", "do_selectize('", ns("table"), "'); ", @@ -345,23 +300,23 @@ mod_table_server_schema <- function(id, desc, language, override_values) { ) ) )) - table_to_display + table_to_display }, server = FALSE) - + observe({ if (!rendered()) { table_values(list()) return() } - + table_data() - + rows <- dynamic_rows() - if (is.null(rows) || length(rows) == 0) { + if (length(rows) == 0) { table_values(list()) return() } - + # widgets are numbered by display position, not by dynamic row id row_values <- lapply(seq_along(rows), function(row_number) { row <- lapply(column_names, function(variable) { @@ -369,15 +324,18 @@ mod_table_server_schema <- function(id, desc, language, override_values) { }) names(row) <- column_names row - }) - + }) + table_values(row_values) old_values(list(rows = row_values, row_ids = rows)) }) - + list( values = table_values, valid = reactive(iv$is_valid()) ) + }) + } + diff --git a/R/utils_global.R b/R/utils_global.R index 10927a4..8e1ea4d 100644 --- a/R/utils_global.R +++ b/R/utils_global.R @@ -6,13 +6,14 @@ missingval <- "-99.0" date_format_json <- "%Y-%m-%d" date_format_display <- "%d/%m/%Y" -# read the csv file containing the sites -# the path is wrapped inside a function because of this: +# read the csv file containing the sites +#sites_file_path <- "data/FOsites.csv" +# the path is wrapped inside a function because of this: # https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html -# see: "Paths hard-coded in R code" -sites_file_path <- function() system.file("extdata", "FOsites.csv", +# see: “Paths hard-coded in R code” +sites_file_path <- function() system.file("extdata", "FOsites.csv", package = "fieldactivity") -sites <- read.csv(sites_file_path()) +sites <- read.csv(sites_file_path(), na.strings = c("", "NaN", "NULL")) # converts block info from csv (e.g. "[0;1]") to vectors of strings ("0" "1") blocks_to_vector <- function(x) strsplit(substr(x, start = 2, stop = nchar(x)-1), ";") sites$blocks <- sapply(sites$blocks, blocks_to_vector) @@ -31,6 +32,13 @@ init_lang <- languages[1] # is built from it, so the app cannot run without it. mgmt_schema <- load_schema() +# the variables holding a file (image). The main app saves the uploaded files +# and stores their paths under these names +fileInput_code_names <- unique(vapply( + Filter(function(desc) desc$type == "fileInput", + mgmt_schema$property_registry), + function(desc) desc$name, character(1))) + # whether to print debug information (short for debug print) # set the boolean value below to FALSE to suppress prints dp <- function() TRUE #&& golem::app_dev() diff --git a/inst/extdata/management-event.schema.json b/inst/extdata/management-event.schema.json index 2bc7f03..e094c16 100644 --- a/inst/extdata/management-event.schema.json +++ b/inst/extdata/management-event.schema.json @@ -3067,6 +3067,15 @@ "title_fi": "lierojen lukumäärä", "type": "integer", "minimum": 0 + }, + "soil_image": { + "title": "photo of soil", + "title_fi": "kuva maaperästä", + "type": "string", + "x-ui": { + "form-type": "fileInput", + "accept": "image/*" + } } } }, @@ -3225,6 +3234,15 @@ "title_fi": "canopeo-lukema", "type": "number", "minimum": 0 + }, + "canopeo_image": { + "title": "canopeo image", + "title_fi": "canopeo-kuva", + "type": "string", + "x-ui": { + "form-type": "fileInput", + "accept": "image/*" + } } } }, diff --git a/man/build_property_descriptor.Rd b/man/build_property_descriptor.Rd index 9990945..552b711 100644 --- a/man/build_property_descriptor.Rd +++ b/man/build_property_descriptor.Rd @@ -4,7 +4,7 @@ \alias{build_property_descriptor} \title{Build a property descriptor for the property registry} \usage{ -build_property_descriptor(name, prop, required, event_type, is_array_item) +build_property_descriptor(name, prop, required, event_type) } \arguments{ \item{name}{Property name (used as input ID)} @@ -14,8 +14,6 @@ build_property_descriptor(name, prop, required, event_type, is_array_item) \item{required}{Whether this property is required} \item{event_type}{The event type this property belongs to} - -\item{is_array_item}{Whether this property is inside an array items} } \value{ A named list describing the property diff --git a/man/build_structure_lookup_list.Rd b/man/build_structure_lookup_list.Rd index 182ed4a..37ad985 100644 --- a/man/build_structure_lookup_list.Rd +++ b/man/build_structure_lookup_list.Rd @@ -12,5 +12,5 @@ The lookup list. \description{ Build a list where the names are the code names of UI elements and the values are the corresponding element structures (lists) found in -ui_structure.json. Now only contains app chrome elements. +ui_structure.json (the app chrome, the event form is built from the schema). } diff --git a/man/copy_file.Rd b/man/copy_file.Rd index 6605a2d..68ba4c3 100644 --- a/man/copy_file.Rd +++ b/man/copy_file.Rd @@ -24,26 +24,31 @@ copy_file( \item{block}{The block where the event took place} -\item{date}{The day of the event as a character string, format yyyy-mm-dd} +\item{date}{The day of the event as a character string, the format must be +yyyy-mm-dd} -\item{filepath_is_relative}{If TRUE, json_file_base_folder will be added} +\item{filepath_is_relative}{If TRUE, json_file_base_folder will be added to +the beginning of filepath} \item{delete_original}{Should the original file be deleted after copying?} -\item{base_folder}{Included for testing reasons} +\item{base_folder}{Included for testing reasons, the default value should +otherwise be used} } \value{ -A path to the new location of the file relative to events.json. +A path to the new location of the file relative to the events.json + file. } \description{ When a file (image) is uploaded through a fileInput widget, it is saved to a temporary folder. This function copies that file to an appropriate directory -and name. The file does not have to be originally in a temporary folder — -any file path is valid. This allows the function to also be used when cloning -an event and its associated images need to be duplicated. +and name. The file does not have to be originally in a temporary +folder, any file path is ok. Therefore this function can also be used e.g. +when cloning and event and the images associated with it need to be +duplicated. } \details{ -The new file name has the format - `yyyy-mm-dd_site_block_variable_name_#.ext` where `#` is an incrementing - number (0, 1, 2, ...) to ensure uniqueness within the target folder. +The name will be of the format +yyyy-mm-dd_site_block_variable_name_# where # is a number (0, 1, 2, ...) to +ensure that files have unique names. } diff --git a/man/delete_file.Rd b/man/delete_file.Rd index 5587b2a..826c962 100644 --- a/man/delete_file.Rd +++ b/man/delete_file.Rd @@ -20,9 +20,11 @@ delete_file( \item{block}{The block where the event took place} \item{filepath_relative}{Set to TRUE and supply site and block if filepath is -relative to the events.json file.} +relative to the events.json file. This allows the function to figure out +the correct path to the file.} -\item{base_folder}{Included for testing reasons} +\item{base_folder}{Included for testing reasons, the default value should +otherwise be used} } \description{ Delete the file with the path filepath. Used to delete files (images) diff --git a/man/get_selectInput_choices.Rd b/man/get_selectInput_choices.Rd index 927b01c..e0e6541 100644 --- a/man/get_selectInput_choices.Rd +++ b/man/get_selectInput_choices.Rd @@ -9,7 +9,8 @@ get_selectInput_choices(selectInput_code_name, language) \arguments{ \item{selectInput_code_name}{The code name of the selectInput} -\item{language}{The language to show the options in.} +\item{language}{The language to show the options in. This will be passed to +get_disp_name} } \value{ A vector of choices (code names). If language was supplied, the names diff --git a/man/render_field.Rd b/man/render_field.Rd new file mode 100644 index 0000000..3a41fdc --- /dev/null +++ b/man/render_field.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_schema_ui.R +\name{render_field} +\alias{render_field} +\title{Render the widget or table of a field, shown only when its x-ui condition +(if any) is met} +\usage{ +render_field(desc, ns, iso) +} +\arguments{ +\item{desc}{Property descriptor} + +\item{ns}{Namespace function} + +\item{iso}{ISO language code} +} +\value{ +A Shiny tag +} +\description{ +Render the widget or table of a field, shown only when its x-ui condition +(if any) is met +} diff --git a/man/render_property_widget.Rd b/man/render_property_widget.Rd index 04f7486..6cc8b96 100644 --- a/man/render_property_widget.Rd +++ b/man/render_property_widget.Rd @@ -5,21 +5,18 @@ \title{Render a single Shiny input widget from a property descriptor} \usage{ render_property_widget( - prop_name, + id, desc, ns, iso, - override_code_name = NULL, - override_label = NULL, - override_value = NULL, - override_choices = NULL, - override_selected = NULL, - override_placeholder = NULL, + label = NULL, + value = NULL, + choices = NULL, width = NULL ) } \arguments{ -\item{prop_name}{Input ID of the widget (desc$id for form fields)} +\item{id}{Input ID of the widget (desc$id for form fields)} \item{desc}{Property descriptor from the registry} @@ -27,17 +24,11 @@ render_property_widget( \item{iso}{ISO language code} -\item{override_code_name}{Optional code name override (for table cells)} +\item{label}{Optional label, the property title by default} -\item{override_label}{Optional label override} +\item{value}{Optional initial value (the selected value of a selectInput)} -\item{override_value}{Optional value override} - -\item{override_choices}{Optional choices override} - -\item{override_selected}{Optional selected value override} - -\item{override_placeholder}{Optional placeholder override} +\item{choices}{Optional choices, the property's choices by default} \item{width}{Optional width} } diff --git a/man/update_schema_widget.Rd b/man/update_schema_widget.Rd index 7cf9015..8a07330 100644 --- a/man/update_schema_widget.Rd +++ b/man/update_schema_widget.Rd @@ -4,7 +4,7 @@ \alias{update_schema_widget} \title{Update a single schema widget's label and choices} \usage{ -update_schema_widget(session, desc, iso, input, override_choices = NULL) +update_schema_widget(session, desc, iso, input, choices = NULL) } \arguments{ \item{session}{Shiny session} @@ -15,7 +15,7 @@ update_schema_widget(session, desc, iso, input, override_choices = NULL) \item{input}{The input of the session, to keep the current selection} -\item{override_choices}{Optional choices (e.g. for a subtype discriminator)} +\item{choices}{Optional choices (e.g. for a subtype discriminator)} } \description{ Update a single schema widget's label and choices diff --git a/tests/testthat/test-fct_schema.R b/tests/testthat/test-fct_schema.R index 0bc2167..153140e 100644 --- a/tests/testthat/test-fct_schema.R +++ b/tests/testthat/test-fct_schema.R @@ -117,8 +117,7 @@ test_that("build_property_descriptor builds array_columns for dataTable", { ) desc <- build_property_descriptor("my_table", prop, required = FALSE, - event_type = "planting", - is_array_item = FALSE) + event_type = "planting") expect_equal(desc$type, "dataTable") expect_length(desc$array_columns, 2) expect_equal(desc$array_columns$col_a$type, "textInput") diff --git a/tests/testthat/test-mod_form.R b/tests/testthat/test-mod_form.R index 2b62d00..00d9d52 100644 --- a/tests/testthat/test-mod_form.R +++ b/tests/testthat/test-mod_form.R @@ -65,17 +65,17 @@ test_that("the date is required only when the event type requires it", { test_that("keys the form doesn't know about are kept when saving", { testServer(mod_form_server, args = form_module_args(), { set_values(list(mgmt_operations_event = "weeding", date = "2022-06-01", - canopeo_image = "canopeo_image/image.jpg")) + weeding_tool = "hoe")) session$flushReact() session$setInputs(mgmt_operations_event = "weeding", block = "0", date = as.Date("2022-06-01")) - expect_equal(form_data()$canopeo_image, "canopeo_image/image.jpg") + expect_equal(form_data()$weeding_tool, "hoe") # a new event doesn't inherit them reset_values(TRUE) session$flushReact() - expect_null(form_data()$canopeo_image) + expect_null(form_data()$weeding_tool) }) }) @@ -115,3 +115,27 @@ test_that("table rows are saved nested under the array property", { expect_null(event$harvest_crop) }) }) + +test_that("the image of the edited event is passed on for saving", { + testServer(mod_form_server, args = form_module_args(), { + init_signal(TRUE) + set_values(list(mgmt_operations_event = "observation", + observation_type = "observation_type_vegetation", + date = "2022-06-01", + canopeo_image = "canopeo_image/image.jpg")) + session$flushReact() + session$setInputs(mgmt_operations_event = "observation", block = "0", + date = as.Date("2022-06-01")) + set_field(session, field_id("observation_type", "observation"), + "observation_type_vegetation") + + # the main app moves the file if needed and saves its path + expect_equal(form_data()$canopeo_image, + list(filepath = "canopeo_image/image.jpg", new_file = FALSE)) + + # a new event has no image + reset_values(TRUE) + session$flushReact() + expect_null(form_data()$canopeo_image$filepath) + }) +}) diff --git a/tests/testthat/test-mod_table.R b/tests/testthat/test-mod_table.R index 9ef266a..69733a4 100644 --- a/tests/testthat/test-mod_table.R +++ b/tests/testthat/test-mod_table.R @@ -11,7 +11,7 @@ table_module_args <- function(override_values) { test_that("table is prefilled with one row per item", { override_values <- reactiveVal() - testServer(mod_table_server_schema, args = table_module_args(override_values), { + testServer(mod_table_server, args = table_module_args(override_values), { override_values(list(list(harvest_crop = "ZZ1", harvest_method = "HM008"), list(harvest_crop = "BAR"))) session$flushReact() @@ -26,7 +26,7 @@ test_that("table is prefilled with one row per item", { test_that("removing a row keeps the other rows and validates them by position", { override_values <- reactiveVal() - testServer(mod_table_server_schema, args = table_module_args(override_values), { + testServer(mod_table_server, args = table_module_args(override_values), { override_values(list(list(), list())) session$flushReact() session$setInputs(rendered = TRUE, harvest_crop_1 = "ZZ1", diff --git a/tests/testthat/test-schema_integration.R b/tests/testthat/test-schema_integration.R index c4d1a59..e57ee06 100644 --- a/tests/testthat/test-schema_integration.R +++ b/tests/testthat/test-schema_integration.R @@ -51,6 +51,21 @@ test_that("a table inside a subtype is registered under the subtype", { expect_equal(schema_table_id(desc), paste0(key, "_table")) }) +test_that("image fields are file uploads of their observation subtype", { + pr <- mgmt_schema$property_registry + soil <- lookup_property(pr, "soil_image", "observation", + "observation_type_soil") + canopeo <- lookup_property(pr, "canopeo_image", "observation", + "observation_type_vegetation") + expect_equal(soil$type, "fileInput") + expect_equal(canopeo$type, "fileInput") + expect_setequal(fileInput_code_names, c("soil_image", "canopeo_image")) + + html <- as.character(render_field(canopeo, NS("form"), "fi")) + expect_match(html, "Canopeo-kuva", fixed = TRUE) + expect_match(html, 'accept="image/*"', fixed = TRUE) +}) + test_that("a date field without a value is cleared", { # updateDateInput ignores a NULL value, so the widget must be sent null sent <- list()