diff --git a/R/10_mod_board_simulation_server.R b/R/10_mod_board_simulation_server.R
index 01e985b..0781423 100644
--- a/R/10_mod_board_simulation_server.R
+++ b/R/10_mod_board_simulation_server.R
@@ -11,9 +11,11 @@ board_simulation_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = list.files(
path = file.path(session$userData$user_folder, "study_objects"),
@@ -23,9 +25,11 @@ board_simulation_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "scenario_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "scenarios"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "scenarios"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -53,9 +57,11 @@ board_simulation_server <- function(
shinyWidgets::updatePickerInput(
session,
"json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = input$json_file_name
)
@@ -64,9 +70,11 @@ board_simulation_server <- function(
shinyWidgets::updatePickerInput(
session,
"scenario_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "scenarios"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "scenarios"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -78,9 +86,11 @@ board_simulation_server <- function(
cat(file = stderr(), "10 - Update json_file_name choices\n")
shinyWidgets::updatePickerInput(
inputId = "json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = list.files(
path = file.path(session$userData$user_folder, "study_objects"),
@@ -129,20 +139,19 @@ board_simulation_server <- function(
observeEvent(list(input$run_scenario, input$scenario_name), {
cat(file = stderr(), "10 - Display warning text\n")
shinyjs::hide(selector = jns("warning_scenario_text"))
+ req(input$scenario_name)
# according to the scenario data
- if (!is.null(input$scenario_name)) {
- warning_msg <- readRDS(
+ warning_msg <- readRDS(
file.path(
session$userData$user_folder, "scenarios",
input$scenario_name, "scenario_data.rds"
)
)$warning_msg
- if (!is.null(warning_msg$warning_text)) {
- shinyjs::show(id = "warning_scenario_text")
- shinyjs::html(
- id = "warning_scenario_text", html = warning_msg$warning_text
- )
- }
+ if (!is.null(warning_msg$warning_text)) {
+ shinyjs::show(id = "warning_scenario_text")
+ shinyjs::html(
+ id = "warning_scenario_text", html = warning_msg$warning_text
+ )
}
}, ignoreInit = FALSE)
@@ -237,7 +246,7 @@ board_simulation_server <- function(
land_required = land_required,
nitrogen_balance = nitrogen_balance
)
-
+
# Add dry matter intake checks -----------------------------------------
# Convert to daily intake
dmi_per_day <- energy_required$annual_results$dmi_tot / 365
@@ -329,8 +338,10 @@ board_simulation_server <- function(
# update choices for scenario_name and scenario_results_comp input
shinyWidgets::updatePickerInput(
inputId = "scenario_name",
- choices = list.files(
- file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ )
),
selected = sub("\\.json$", "", input$json_file_name[1])
)
@@ -441,15 +452,19 @@ board_simulation_server <- function(
shinyWidgets::updatePickerInput(
session = session,
"scenario_name",
- choices = list.files(
- file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ )
),
selected = character(0)
)
shinyWidgets::updatePickerInput(
inputId = "scenario_results_comp",
- choices = list.files(
- file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ )
),
selected = list.files(
file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
@@ -461,67 +476,46 @@ board_simulation_server <- function(
)
})
- # ------ PLOT GHG emission ---------------------------------------------------
- output$plot_ghg_emission <- renderGirafe({
-
+ # ------ Cached scenario data (read RDS once, shared by all 4 plots) ----------
+ scenario_plot_data <- reactive({
req(input$scenario_name)
req(session$userData$run_scenario_counter())
- cat(file = stderr(), "10 - Plot GHG emission\n")
-
- # Read the data
- on_farm_table <- readRDS(
+ readRDS(
file.path(
session$userData$user_folder, "scenarios",
- input$scenario_name,
- "scenario_data.rds"
+ input$scenario_name, "scenario_data.rds"
)
- )[["on_farm_table"]]
-
+ )
+ })
+
+ # ------ PLOT GHG emission ---------------------------------------------------
+ output$plot_ghg_emission <- renderGirafe({
+ cat(file = stderr(), "10 - Plot GHG emission\n")
+ scenario_data <- scenario_plot_data()
+ on_farm_table <- scenario_data[["on_farm_table"]]
unit <- graphs_desc[graphs_desc$indicator == "ghg_emission", ]$unit
plot_ghg_emissions(on_farm_table, unit)
})
# ------ PLOT N BALANCE ------------------------------------------------------
output$plot_n_balance <- renderGirafe({
-
- req(input$scenario_name)
- req(session$userData$run_scenario_counter())
cat(file = stderr(), "10 - Plot N Balance\n")
-
- # Read the data
- nitrogen_balance <- readRDS(
- file.path(
- session$userData$user_folder,
- "scenarios",
- input$scenario_name,
- "scenario_data.rds"
- )
- )[["nitrogen_balance"]]
-
+ scenario_data <- scenario_plot_data()
+ nitrogen_balance <- scenario_data[["nitrogen_balance"]]
unit <- graphs_desc[graphs_desc$indicator == "n_balance", ]$unit
plot_n_balance(nitrogen_balance, unit)
})
# ------ PLOT LAND REQUIRED --------------------------------------------------
output$plot_land_req <- renderGirafe({
-
- req(session$userData$run_scenario_counter())
- req(input$scenario_name)
cat(file = stderr(), "10 - Plot Land Required\n")
-
# hide all the seasons legend items
lapply(1:max_seasons, function(i) {
shinyjs::hide(id = paste0("Seasons_LegendItemtxt_", i))
})
- # Read the data
- land_required <- readRDS(
- file.path(
- session$userData$user_folder,
- "scenarios", input$scenario_name,
- "scenario_data.rds"
- )
- )[["land_required"]]
+ scenario_data <- scenario_plot_data()
+ land_required <- scenario_data[["land_required"]]
# unique seasons
seasons <- unique(land_required$season_name)
@@ -539,23 +533,14 @@ board_simulation_server <- function(
# ----- PLOT WATER USE PER FEED ----------------------------------------------
output$plot_water_feed <- renderGirafe({
-
- req(session$userData$run_scenario_counter())
- req(input$scenario_name)
cat(file = stderr(), "10 - Plot Water Use per Feed\n")
-
# hide all the feeds legend items
lapply(1:max_feed_items, function(i) {
shinyjs::hide(id = paste0("Feeds_LegendItemtxt_", i))
})
- # Read the data
- water_use_per_feed_item <- readRDS(
- file.path(
- session$userData$user_folder, "scenarios",
- input$scenario_name, "scenario_data.rds"
- )
- )[["water_use_per_feed_item"]]
+ scenario_data <- scenario_plot_data()
+ water_use_per_feed_item <- scenario_data[["water_use_per_feed_item"]]
# unique feeds
feeds <- unique(water_use_per_feed_item$feed)
diff --git a/R/10_mod_board_simulation_ui.R b/R/10_mod_board_simulation_ui.R
index bcb7d96..1b0c31c 100644
--- a/R/10_mod_board_simulation_ui.R
+++ b/R/10_mod_board_simulation_ui.R
@@ -41,6 +41,7 @@ board_simulation_ui <- function(id) {
choices = NULL,
multiple = TRUE,
options = list(
+ `live-search` = TRUE,
`selected-text-format` = "count",
`count-selected-text` = "{0}/{1} Scenarios"
)
@@ -98,7 +99,8 @@ board_simulation_ui <- function(id) {
inputId = ns("scenario_name"),
label = NULL,
choices = NULL,
- multiple = FALSE
+ multiple = FALSE,
+ options = list(`live-search` = TRUE)
)
)
),
diff --git a/R/20_mod_board_comparison_server.R b/R/20_mod_board_comparison_server.R
index f66e501..be4fad6 100644
--- a/R/20_mod_board_comparison_server.R
+++ b/R/20_mod_board_comparison_server.R
@@ -10,8 +10,10 @@ board_comparison_server <- function(
cat(file = stderr(), "20 - Update scenarios lists on new scenario Runs\n")
shinyWidgets::updatePickerInput(
inputId = "scenario_results_comp",
- choices = list.files(
- file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
+ )
),
selected = list.files(
file.path(session$userData$user_folder, "scenarios"), full.names = FALSE
@@ -26,10 +28,12 @@ board_comparison_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "scenario_results_comp",
- choices = list.files(
- file.path(
- session$userData$user_folder, "scenarios"
- ), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(
+ session$userData$user_folder, "scenarios"
+ ), full.names = FALSE
+ )
),
selected = head(
list.files(
@@ -44,10 +48,12 @@ board_comparison_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "comp_name",
- choices = list.files(
- file.path(
- session$userData$user_folder, "comparisons"
- ), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(
+ session$userData$user_folder, "comparisons"
+ ), full.names = FALSE
+ )
),
selected = character(0)
)
@@ -59,9 +65,11 @@ board_comparison_server <- function(
shinyWidgets::updatePickerInput(
session,
"scenario_results_comp",
- choices = list.files(
- path = file.path(session$userData$user_folder, "scenarios"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "scenarios"),
+ full.names = FALSE
+ )
),
selected = input$scenario_results_comp
)
@@ -73,9 +81,11 @@ board_comparison_server <- function(
shinyWidgets::updatePickerInput(
session,
"comp_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "comparisons"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "comparisons"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -181,10 +191,12 @@ board_comparison_server <- function(
# update choices for comp_name input
shinyWidgets::updatePickerInput(
inputId = "comp_name",
- choices = list.files(
- file.path(
- session$userData$user_folder, "comparisons"
- ), full.names = FALSE
+ choices = sort(
+ list.files(
+ file.path(
+ session$userData$user_folder, "comparisons"
+ ), full.names = FALSE
+ )
),
selected = paste(input$scenario_results_comp, collapse = " - ")
)
@@ -268,16 +280,18 @@ board_comparison_server <- function(
source_file_path <- file.path(
session$userData$user_folder, "comparisons", input$comp_name
)
-
+
# Delete the selected comparison folder
unlink(source_file_path, recursive = TRUE)
# Update the selectInput choices after deletion
shinyWidgets::updatePickerInput(
session, "comp_name",
- choices = list.files(file.path(
- session$userData$user_folder, "comparisons"
- ), full.names = FALSE),
+ choices = sort(
+ list.files(file.path(
+ session$userData$user_folder, "comparisons"
+ ), full.names = FALSE)
+ ),
selected = character(0)
)
showNotification(
@@ -372,6 +386,17 @@ board_comparison_server <- function(
)
+ # ------ Cached comparison results (read RDS once, shared by all 44 plots) ----
+ comparison_results <- reactive({
+ req(input$comp_name, input$comp_category, input$base_scenario)
+ readRDS(
+ file.path(
+ session$userData$user_folder, "comparisons",
+ input$comp_name, "results_list.rds"
+ )
+ )[[input$base_scenario]]
+ })
+
# ------ PLOT comparisons graphs ---------------------------------------------
lapply(
graphs_desc$indicator[5:48], #1st 4 plots removed, belong to the 1st section
@@ -380,18 +405,8 @@ board_comparison_server <- function(
cat(file = stderr(), "20 - Plot comparison - ", indicator, "\n")
- # Check if the inputs are available
- req(input$comp_name)
- req(input$comp_category)
- req(input$base_scenario)
-
- # Read comparison results
- results_list <- readRDS(
- file.path(
- session$userData$user_folder, "comparisons",
- input$comp_name, "results_list.rds"
- )
- )[[input$base_scenario]]
+ # Use cached comparison results (single readRDS for all 44 plots)
+ results_list <- comparison_results()
# Get the data for each indicator
datos <- results_list[[indicator]]$datos
diff --git a/R/20_mod_board_comparison_ui.R b/R/20_mod_board_comparison_ui.R
index 4b1bb1a..b863080 100644
--- a/R/20_mod_board_comparison_ui.R
+++ b/R/20_mod_board_comparison_ui.R
@@ -43,7 +43,8 @@ board_comparison_ui <- function(id) {
label = NULL,
choices = NULL,
selected = NULL,
- multiple = TRUE
+ multiple = TRUE,
+ options = list(`live-search` = TRUE)
)
),
column(
@@ -81,7 +82,8 @@ board_comparison_ui <- function(id) {
inputId = ns("comp_name"),
label = NULL,
choices = NULL,
- multiple = FALSE
+ multiple = FALSE,
+ options = list(`live-search` = TRUE)
)
)
),
@@ -120,9 +122,12 @@ board_comparison_ui <- function(id) {
shinyWidgets::pickerInput(
inputId = ns("comp_category"),
label = NULL,
- choices = unique(graphs_desc$category)[-1], # remove scenario graphs
+ choices = sort(
+ unique(graphs_desc$category)[-1]
+ ), # remove scenario graphs
selected = unique(graphs_desc$category)[1],
- multiple = FALSE
+ multiple = FALSE,
+ options = list(`live-search` = TRUE)
)
)
)
diff --git a/R/30_mod_scenario_init.R b/R/30_mod_scenario_init.R
index 9e3e60b..263b436 100644
--- a/R/30_mod_scenario_init.R
+++ b/R/30_mod_scenario_init.R
@@ -27,7 +27,6 @@ feedtype_colnames <- c(
"Slope P Factor",
"Main product dry yield (t DM/ha)",
"Residue dry yield (t DM/ha)",
- "Main product N content (kg N/kg DM)",
"Reside N content (kg N/kg DM)",
"Kc: Initial",
"Kc: MidSeason",
@@ -82,11 +81,8 @@ livestock_table_colnames <- c(
"Lactation length (small ruminants/pigs, days)",
"Proportion growth piglets covered by milk (%)",
"LW gain piglets (kg/day)",
- "Grazing displacement (km/day)",
"Crude Protein/Lysine requirement maintenance (kg/day)",
- "Crude Protein requirement grazing (kg/km)",
"Crude Protein/ Lysine requirement pregnancy (kg)",
- "Crude Protein/ Lysine requirement lactation (kg/ lactation)",
"Crude Protein requirement (kg/kg milk)",
"Crude Protein/ Lysine requirement growth (kg/kg LWG)",
"Parturition interval (years)",
@@ -96,7 +92,6 @@ livestock_table_colnames <- c(
"Energy content meat",
"Protein content meat (%)",
"Carcass fraction",
- "Energy content eggs",
"Average N content manure",
"Meat product",
"Milk product",
@@ -164,24 +159,20 @@ livestock_data_initialization <- data.frame(
litter_size = numeric(),
piglets_relying_on_milk = numeric(),
lactation_length = numeric(),
- proportion_growth = numeric(),
- lw_gain = numeric(),
- grazing_displacement = numeric(),
+ proportion_growth_piglets_milk = numeric(),
+ lw_gain_piglets = numeric(),
cp_maintenance = numeric(),
- cp_grazing = numeric(),
- cp_pregnancy = numeric(),
- cp_lactation = numeric(),
+ cp_lys_pregnancy = numeric(),
cp_lactmilk = numeric(),
- cp_growth = numeric(),
+ cp_lys_growth = numeric(),
birth_interval = numeric(),
protein_milkcontent = numeric(),
- fat_content = numeric(),
+ fat_milkcontent = numeric(),
energy_milkcontent = numeric(),
energy_meatcontent = numeric(),
protein_meatcontent = numeric(),
carcass_fraction = numeric(),
- energy_eggcontent = numeric(),
- n_content = numeric(),
+ n_manure_content = numeric(),
meat_product = character(),
milk_product = character(),
ipcc_ef_category_t1 = character(),
@@ -192,10 +183,10 @@ livestock_data_initialization <- data.frame(
)
feedtype_initialization <- data.frame(
- feed_type_code = numeric(),
+ crop_code = numeric(),
feed_item_code = numeric(),
feed_item_name = character(),
- feed_type_name = character(),
+ crop_name = character(),
source_type = character(),
intercrop = numeric(),
intercrop_fraction = numeric(),
@@ -219,7 +210,6 @@ feedtype_initialization <- data.frame(
slope_p_factor = numeric(),
dry_yield = numeric(),
residue_dry_yield = numeric(),
- n_content = numeric(),
residue_n = numeric(),
kc_initial = numeric(),
kc_midseason = numeric(),
@@ -302,6 +292,20 @@ fertilizer_percentages <- c(
"Ammonia" = 82
)
+# Fertilizer name to column mapping --------------------------------------------
+# Maps fertilizer names from the 'Farm > Fertilizer' tab to their corresponding
+# column names in the 'Crop Inputs' dataframe. Used to dynamically identify
+# and control column editability.
+fertilizer_column_mapping <- c(
+ "Urea" = "urea",
+ "NPK" = "npk",
+ "DAP" = "dap",
+ "Ammonium nitrate" = "ammonium_nitrate",
+ "Ammonium sulfate" = "ammonium_sulfate",
+ "N solutions" = "n_solutions",
+ "Ammonia" = "ammonia"
+)
+
# Water regime SelectInput options ---------------------------------------------
water_regime_options <- c(
"Non-flooded pre-season <180 days( often in double cropping of rice)",
diff --git a/R/30_mod_scenario_server.R b/R/30_mod_scenario_server.R
index 756aad3..3c2b5b2 100644
--- a/R/30_mod_scenario_server.R
+++ b/R/30_mod_scenario_server.R
@@ -19,9 +19,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session,
"json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -30,9 +32,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_shared_folder",
- choices = list.files(
- path = file.path("data", "shared_folder", "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path("data", "shared_folder", "study_objects"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -41,9 +45,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session,
"database_code",
- choices = list.files(
- path = file.path(session$userData$user_folder, "parameters_database"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "parameters_database"),
+ full.names = FALSE
+ )
),
selected = character(0)
)
@@ -63,6 +69,9 @@ scenario_server <- function(
shinyjs::html(id = "last_update_date", html = last_modification_date)
})
+ # ----- Validation Module ----------------------------------------------------
+ farm_validation_server("validation", input = input, parent_session = session)
+
# ----- * Show Scenario Editor Section after selection ----------------------
observeEvent(input$json_file_name, {
shinyjs::show(id = "scenario_editor_section")
@@ -85,7 +94,7 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session,
"database_code",
- choices = session$userData$databases(),
+ choices = sort(session$userData$databases()),
selected = input$database_code
)
})
@@ -117,9 +126,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session,
"json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = input$json_file_name
)
@@ -131,9 +142,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session,
"database_code",
- choices = list.files(
- path = file.path(session$userData$user_folder, "parameters_database"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "parameters_database"),
+ full.names = FALSE
+ )
),
selected = input$database_code
)
@@ -144,26 +157,9 @@ scenario_server <- function(
})
# ----- UX Interaction logic --------------------------------------------
- # Observe the selection from the radio buttons
+ # Show/hide folder UIs based on radio selection (uses shared helper)
observeEvent(input$scenario_folder, {
- if (input$scenario_folder == "user") {
- # Show User Folder UI and hide the others
- shinyjs::show(id = "user_folder_ui")
- shinyjs::hide(id = "shared_examples_ui")
- shinyjs::hide(id = "shared_pool_ui")
-
- } else if (input$scenario_folder == "shared") {
- # Show Shared Examples UI and hide the others
- shinyjs::show(id = "shared_examples_ui")
- shinyjs::hide(id = "user_folder_ui")
- shinyjs::hide(id = "shared_pool_ui")
-
- } else if (input$scenario_folder == "pool") {
- # Show Shared Pool UI and hide the others
- shinyjs::show(id = "shared_pool_ui")
- shinyjs::hide(id = "user_folder_ui")
- shinyjs::hide(id = "shared_examples_ui")
- }
+ show_hide_folder_ui(input$scenario_folder, ns)
})
# on renaming a scenario
observeEvent(input$rename_json, {
@@ -206,9 +202,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
)
)
@@ -247,8 +245,8 @@ scenario_server <- function(
if (file.exists(source_file_path)) {
file.copy(source_file_path, share_file_path, overwrite = TRUE)
- # Share the related database if it's not the default database
- if (input$database_code != "Params DB - Default") {
+ # Share the related database if it's not a default (read-only) database
+ if (!(input$database_code %in% primary_database_names())) {
# Define the source and destination paths for the database directory
db_path <- file.path(
session$userData$user_folder, "parameters_database", input$database_code
@@ -297,7 +295,9 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(destination_dir, full.names = FALSE),
+ choices = sort(
+ list.files(destination_dir, full.names = FALSE)
+ ),
selected = basename(new_file_path)
)
@@ -335,9 +335,11 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(
- path = file.path(session$userData$user_folder, "study_objects"),
- full.names = FALSE
+ choices = sort(
+ list.files(
+ path = file.path(session$userData$user_folder, "study_objects"),
+ full.names = FALSE
+ )
),
selected = paste0(input$json_new_name, ".json")
)
@@ -381,7 +383,9 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(destination_dir, full.names = FALSE),
+ choices = sort(
+ list.files(destination_dir, full.names = FALSE)
+ ),
selected = basename(clone_file_path)
)
@@ -469,7 +473,9 @@ scenario_server <- function(
shinyWidgets::updatePickerInput(
session = session,
inputId = "json_file_name",
- choices = list.files(destination_dir, full.names = FALSE),
+ choices = sort(
+ list.files(destination_dir, full.names = FALSE)
+ ),
selected = basename(clone_file_path)
)
@@ -513,668 +519,106 @@ scenario_server <- function(
)
}
})
- # Observe Cloning the shared JSON from the pool
- observeEvent(input$confirm_clone_shared_pool, {
+ # Observe Cloning the shared JSON from the pool
+ observeEvent(input$confirm_clone_shared_pool, {
+
+ # Check if the user confirmed the cloning
+ if (isTRUE(input$confirm_clone_shared_pool)) {
- # Check if the user confirmed the cloning
- if (isTRUE(input$confirm_clone_shared_pool)) {
-
- # Path for the original file in the shared pool
- source_file_path <- file.path(
- Sys.getenv("DATA_DIR"), "shared_pool", "study_objects", input$pool_file_search
+ # Path for the original file in the shared pool
+ source_file_path <- file.path(
+ Sys.getenv("DATA_DIR"), "shared_pool", "study_objects", input$pool_file_search
+ )
+
+ # Set the base name for the cloned JSON file
+ base_clone_file_name <- tools::file_path_sans_ext(input$pool_file_search)
+
+ # Define the destination directory for the cloned JSON file
+ destination_dir <- file.path(session$userData$user_folder, "study_objects")
+
+ # Use versioned_copy to create a versioned clone of the JSON file
+ clone_file_path <- versioned_copy(
+ source_path = source_file_path,
+ destination_dir = destination_dir,
+ base_name = base_clone_file_name,
+ extension = "json",
+ versioning = TRUE
+ )
+
+ # Read the json file and get the related database's name
+ json_data <- fromJSON(source_file_path)
+ db_name <- json_data$database_code
+
+ # If the database is not a default (read-only) database and is available on
+ # the shared_pool folder, clone the database as well
+ if (!(db_name %in% primary_database_names()) &&
+ db_name %in% list.files(
+ file.path(Sys.getenv("DATA_DIR"), "shared_pool", "parameters_database")
+ )) {
+ # Define the source and destination paths for the database directory
+ db_path <- file.path(
+ Sys.getenv("DATA_DIR"), "shared_pool", "parameters_database", db_name
)
+ destination_dir <- file.path(session$userData$user_folder, "parameters_database")
- # Set the base name for the cloned JSON file
- base_clone_file_name <- tools::file_path_sans_ext(input$pool_file_search)
-
- # Define the destination directory for the cloned JSON file
- destination_dir <- file.path(session$userData$user_folder, "study_objects")
-
- # Use versioned_copy to create a versioned clone of the JSON file
- clone_file_path <- versioned_copy(
- source_path = source_file_path,
+ # Use versioned_copy to clone the database directory with versioning
+ versioned_copy(
+ source_path = db_path,
destination_dir = destination_dir,
- base_name = base_clone_file_name,
- extension = "json",
+ base_name = db_name,
versioning = TRUE
)
- # Read the json file and get the related database's name
- json_data <- fromJSON(source_file_path)
- db_name <- json_data$database_code
-
- # If the database is not the default database and is available on
- # the shared_pool folder, clone the database as well
- if (db_name != "Params DB - Default" &&
- db_name %in% list.files(
- file.path(Sys.getenv("DATA_DIR"), "shared_pool", "parameters_database")
- )) {
- # Define the source and destination paths for the database directory
- db_path <- file.path(
- Sys.getenv("DATA_DIR"), "shared_pool", "parameters_database", db_name
- )
- destination_dir <- file.path(session$userData$user_folder, "parameters_database")
-
- # Use versioned_copy to clone the database directory with versioning
- versioned_copy(
- source_path = db_path,
- destination_dir = destination_dir,
- base_name = db_name,
- versioning = TRUE
- )
-
- #Update the database picker input with the cloned database
- shinyWidgets::updatePickerInput(
- session = session,
- inputId = "database_code",
- choices = list.files(destination_dir, full.names = FALSE),
- selected = db_name
- )
- }
-
- # Reset the Text Input
- updateTextInput(session, "pool_file_search", value = "")
-
- # Update the radio button value to 'user'
- updateRadioButtons(session, inputId = "scenario_folder", selected = "user")
-
- # Update the Json PickerInput to the cloned file
+ #Update the database picker input with the cloned database
shinyWidgets::updatePickerInput(
session = session,
- inputId = "json_file_name",
- choices = list.files(
- file.path(session$userData$user_folder, "study_objects"), full.names = FALSE
+ inputId = "database_code",
+ choices = sort(
+ list.files(destination_dir, full.names = FALSE)
),
- selected = basename(clone_file_path)
- )
-
- # Show a success notification
- showNotification(
- "The JSON and the related Parameters Database have been cloned successfully!",
- duration = 3,
- type = "message"
+ selected = db_name
)
}
- })
-
- # ----------- Seasons Tab ----------------------------------------------------
- # Reactive value to store the seasons data
- seasons <- reactiveVal(seasons_initialization)
-
- # Add season button click
- observeEvent(input$add_season, {
- req(input$json_file_name)
- if (modal_open()) return()
- modal_open(TRUE)
- showModal(modalDialog(
- title = "Add season",
- h2("Season name:", class = "mb-3"),
- textInput(ns("season_name"), label = NULL),
- easyClose = TRUE,
- footer = tagList(
- actionButton(ns("ok_add_season"), "OK"),
- modalButton("Cancel")
- )
- ))
- })
-
- # OK button in modal dialog for adding season
- observeEvent(input$ok_add_season, {
- req(input$season_name)
- current_seasons <- seasons()
- if (!input$season_name %in% current_seasons$Season) {
- days_left <- max(365 - sum(current_seasons$Days), 0)
- new_row <- data.frame(Season = input$season_name, Days = days_left)
- updated_seasons <- rbind(current_seasons, new_row)
- seasons(updated_seasons)
- }
- updateTextInput(session, "season_name", value = "")
- removeModal()
- })
-
- # Render the table
- output$season_table <- renderDT({
-
- # Re-initialize the season data if the columns are missing (show empty table on start)
- if (ncol(seasons()) == 0) {
- seasons(seasons_initialization)
- }
-
- season_dt <- seasons()
-
- # Checkboxes for selecting rows (to be deleted)
- season_dt$selected_season <- generate_shiny_inputs(
- FUN = checkboxInput,
- len = nrow(season_dt),
- id = ns("selected_season"),
- value = rep(FALSE, nrow(season_dt)),
- width = "2px"
- )
- # Move the 'selected_season' column to the first position
- season_dt <- season_dt[, c("selected_season", setdiff(names(season_dt), "selected_season"))]
-
- datatable(
- season_dt,
- editable = list(
- target = "cell",
- # Prevent editing of the first column (check boxes for delete rows)
- disable = list(columns = 0)
- ),
- escape = FALSE,
- selection = "none",
- rownames = FALSE,
- # Set the first column (selected) name to an empty string
- colnames = c("", colnames(season_dt)[-1]),
- options = list(
- dom = "t",
- paging = FALSE,
- columnDefs = list(
- # 2 px width for the first column (checkboxes)
- list(width = "50px", targets = 0)
- ),
- # Link renderDT's checkbox to the shiny input (not automatic)
- drawCallback = JS(checkbox_link(id = "selected_season", ns = ns))
- )
- )
- }, server = FALSE)
-
- # Delete season button click
- observeEvent(input$delete_season, {
- req(nrow(seasons()) > 0) # Ensure there are rows to process
- selected <- which(
- sapply(
- seq_len(nrow(seasons())),
- function(i) input[[paste0("selected_season", i)]]
- )
- )
- if (length(selected)) {
- current_seasons <- seasons()
- updated_seasons <- current_seasons[-selected, ]
- seasons(updated_seasons)
- }
- })
-
- # Update season table data with edited values
- observeEvent(input$season_table_cell_edit, {
- info <- input$season_table_cell_edit
- new_data <- seasons()
-
- # Update the specific cell while preserving the column's data type
- new_data <- update_cell(new_data, info, offset = 0)
-
- seasons(new_data)
- })
-
- # Observe the season data and show/hide the error message
- observeEvent(seasons(), {
- # if the sum of days is 365, hide the error message
- if (nrow(seasons()) == 0 || sum(seasons()$Days) == 365) {
- shinyjs::hide(id = "alert_message_season")
- } else {
- shinyjs::show(id = "alert_message_season")
- }
- })
-
- # ----------- Manure/Fertilizer Tab ------------------------------------------
- # Reactive value to store the fertilizer data
- fertilizers <- reactiveVal(fertilizers_initialization)
-
- # Add fertilizer button click
- observeEvent(input$add_fertilizer, {
- req(input$json_file_name)
- if (modal_open()) return()
- modal_open(TRUE)
- showModal(modalDialog(
- title = "Add new fertilizer",
- h2("Choose a Fertilizer", class = "mb-3"),
- shinyWidgets::pickerInput(
- ns("fertilizer_code"),
- choices = setNames(
- lkp_orgfertilizer()$fertilizer_code,
- lkp_orgfertilizer()$fertilizer_desc
- )
- ),
- easyClose = TRUE,
- footer = tagList(
- actionButton(ns("ok_add_fertilizer"), "OK"),
- modalButton("Cancel")
- )
- ))
- })
-
- # OK button in modal dialog for adding fertilizer
- observeEvent(input$ok_add_fertilizer, {
- req(input$fertilizer_code)
- current_fertilizers <- fertilizers()
- if (!input$fertilizer_code %in% current_fertilizers$fertilizer_code) {
- fertilizer_name <- lkp_orgfertilizer()$fertilizer_desc[
- lkp_orgfertilizer()$fertilizer_code == input$fertilizer_code
- ]
- new_row <- data.frame(
- fertilizer_code = input$fertilizer_code,
- fertilizer_desc = fertilizer_name,
- fraction = 0,
- percentage_n = ifelse(fertilizer_name %in% names(fertilizer_percentages),
- fertilizer_percentages[fertilizer_name], 0)
- )
- updated_fertilizers <- rbind(current_fertilizers, new_row)
- fertilizers(updated_fertilizers)
- }
- # Reset the select input
- shinyWidgets::updatePickerInput(
- session,
- "fertilizer_code",
- selected = setNames(lkp_orgfertilizer()$fertilizer_code, lkp_orgfertilizer()$fertilizer_desc)[1]
- )
- removeModal()
- })
-
- # Render the fertilizer table
- output$fertilizer_table <- renderDT({
-
- # Re-initialize the fertilizer data if the columns are missing (show empty table on start)
- if (ncol(fertilizers()) == 0) {
- fertilizers(fertilizers_initialization)
- }
-
- # Identify rows to disable based on fertilizer names
- fertilizers_data <- fertilizers() %>% select(-fertilizer_code, -fraction)
- rows_to_disable <- which(
- fertilizers_data$fertilizer_desc %in% names(fertilizer_percentages)
- ) - 1
-
- # Checkboxes for selecting rows (to be deleted)
- fertilizers_data$selected_fertilizer <- generate_shiny_inputs(
- FUN = checkboxInput,
- len = nrow(fertilizers_data),
- id = ns("selected_fertilizer"),
- value = rep(FALSE, nrow(fertilizers_data)),
- width = "2px"
- )
-
- # Move the 'selected_fertilizer' column to the first position
- fertilizers_data <- fertilizers_data[
- , c("selected_fertilizer", setdiff(names(fertilizers_data), "selected_fertilizer"))
- ]
-
- datatable(
- fertilizers_data,
- colnames = c("", "Fertilizer", "% N"), # Set the first column (selected) name to an empty string
- editable = list(
- target = "cell",
- # Prevent editing of the first column (check boxes for delete rows)
- disable = list(columns = 0)
- ),
- selection = "none",
- rownames = FALSE,
- escape = FALSE,
- options = list(
- dom = "t",
- paging = FALSE,
- columnDefs = list(
- list(
- width = "2px", # Define the width of the checkbox column
- targets = 0
- ),
- # Disable editing fertilizer's column
- list(
- targets = get_column_indices(fertilizers_data, "fertilizer_desc") - 1,
- createdCell = JS(disable_all_rows_edit_js()),
- searchable = FALSE
- ),
- # Disable editing for specific rows in the % N column
- list(
- targets = get_column_indices(fertilizers_data, "percentage_n") - 1,
- createdCell = JS(disable_specific_rows_edit_js(rows_to_disable)),
- searchable = FALSE
- )
+
+ # Reset the Text Input
+ updateTextInput(session, "pool_file_search", value = "")
+
+ # Update the radio button value to 'user'
+ updateRadioButtons(session, inputId = "scenario_folder", selected = "user")
+
+ # Update the Json PickerInput to the cloned file
+ shinyWidgets::updatePickerInput(
+ session = session,
+ inputId = "json_file_name",
+ choices = list.files(
+ file.path(session$userData$user_folder, "study_objects"), full.names = FALSE
),
- # Link renderDT's checkbox to the shiny input (not automatic)
- drawCallback = JS(checkbox_link(id = "selected_fertilizer", ns = ns))
- )
- )
- }, server = FALSE)
-
- # Delete fertilizer button click
- observeEvent(input$delete_fertilizer, {
- req(nrow(fertilizers()) > 0) # Ensure there are rows to process
- selected <- which(
- sapply(
- seq_len(nrow(fertilizers())),
- function(i) input[[paste0("selected_fertilizer", i)]]
- )
- )
- if (length(selected)) {
- current_fertilizers <- fertilizers()
- updated_fertilizers <- current_fertilizers[-selected, ]
- fertilizers(updated_fertilizers)
- }
- })
-
- # Update fertilizer table data with edited values
- observeEvent(input$fertilizer_table_cell_edit, {
- info <- input$fertilizer_table_cell_edit
- new_data <- fertilizers()
-
- # Update the specific cell while preserving the column's data type
- new_data <- update_cell(new_data, info, offset = 2)
-
- fertilizers(new_data)
- })
-
- # ----------- Area tab -------------------------------------------------------
- observeEvent(input$soil_description, {
- selected_soil <- input$soil_description
- k_value <- lkp_soil()$k_value[lkp_soil()$soil_desc == selected_soil]
- updateNumericInput(session, "soil_k_value", value = k_value)
- })
-
- observeEvent(input$cropland_system, {
- selected_system <- input$cropland_system
- change_factor <- lkp_croplandsystem()$change_factor[lkp_croplandsystem()$sys_desc == selected_system]
- updateNumericInput(session, "cropland_system_ipcc", value = change_factor)
- })
-
- observeEvent(input$cropland_tillage, {
- selected_tillage <- input$cropland_tillage
- change_factor <- lkp_tillageregime()$change_factor[lkp_tillageregime()$tillage_desc == selected_tillage]
- updateNumericInput(session, "cropland_tillage_ipcc", value = change_factor)
- })
-
- observeEvent(input$cropland_orgmatter, {
- selected_input <- input$cropland_orgmatter
- change_factor <- lkp_organicmatter()$change_factor[lkp_organicmatter()$orgmatter_desc == selected_input]
- updateNumericInput(session, "cropland_orgmatter_ipcc", value = change_factor)
- })
-
- observeEvent(input$grassland_management, {
- selected_management <- input$grassland_management
- change_factor <- lkp_grasslandman()$change_factor[
- lkp_grasslandman()$management_desc == selected_management
- ]
- updateNumericInput(session, "grassland_management_ipcc", value = change_factor)
- })
-
- observeEvent(input$grassland_implevel, {
- selected_input_level <- input$grassland_implevel
- change_factor <- lkp_grassinputlevel()$change_factor[
- lkp_grassinputlevel()$grassinputlevel_desc == selected_input_level
- ]
- updateNumericInput(session, "grassland_implevel_ipcc", value = change_factor)
- })
-
- # ----------- Livestock tab --------------------------------------------------
- # Initial data frame
- livestock_data <- reactiveVal(livestock_data_initialization)
-
- # Add reactive for the selected cell
- selected_cell <- reactiveVal()
-
- # Add livestock button click
- observeEvent(input$add_livestock, {
- req(input$json_file_name)
- if (modal_open()) return()
- modal_open(TRUE)
- showModal(modalDialog(
- title = "Add livestock",
- h2("Choose a livestock category", class = "mb-3"),
- shinyWidgets::pickerInput(
- ns("livestock"),
- label = NULL,
- choices = setNames(lkp_livetype()$livetype_code, lkp_livetype()$livetype_desc)
- ),
- easyClose = TRUE,
- footer = tagList(
- actionButton(ns("ok_add_livestock"), "OK"),
- modalButton("Cancel")
+ selected = basename(clone_file_path)
)
- ))
- })
-
- # Add new livestock row from modal
- observeEvent(input$ok_add_livestock, {
- req(input$livestock)
- if (!(input$livestock %in% livestock_data()[, "livetype_code"])) {
- selected_livestock <- lkp_livetype()[lkp_livetype()$livetype_code == input$livestock, ]
- manureman_selection <- lkp_manureman()$manureman_desc[1]
- new_row <- data.frame(
- livetype_code = as.character(selected_livestock$livetype_code),
- livetype_desc = selected_livestock$livetype_desc,
- herd_composition = 0,
- annual_milk = 0,
- annual_wool = 0,
- annual_growth = 0,
- time_in_stable = 0,
- manure_in_stable = 0,
- manureman_stable = manureman_selection,
- time_in_non_roofed_enclosure = 0,
- manure_in_non_roofed_enclosure = 0,
- manureman_non_roofed_enclosure = manureman_selection,
- time_in_onfarm_grazing = 0,
- manure_in_field = 0,
- manureman_onfarm_grazing = manureman_selection,
- time_in_offfarm_grazing = 0,
- manureman_offfarm_grazing = manureman_selection,
- distance_to_pasture = 0,
- manure_onfarm_fraction = 0,
- manure_sales_fraction = 0,
- body_weight = selected_livestock$body_weight,
- body_weight_weaning = 0,
- body_weight_year_one = 0,
- adult_weight = 0,
- work_hour = 0,
- litter_size = selected_livestock$litter_size,
- piglets_relying_on_milk = 0,
- lactation_length = selected_livestock$lactation_length,
- proportion_growth = selected_livestock$proportion_growth,
- lw_gain = selected_livestock$lw_gain,
- grazing_displacement = selected_livestock$grazing_displacement,
- cp_maintenance = selected_livestock$cp_maintenance,
- cp_grazing = selected_livestock$cp_grazing,
- cp_pregnancy = selected_livestock$cp_pregnancy,
- cp_lactation = selected_livestock$cp_lactation,
- cp_lactmilk = selected_livestock$cp_lactmilk,
- cp_growth = selected_livestock$cp_growth,
- birth_interval = selected_livestock$birth_interval,
- protein_milkcontent = selected_livestock$protein_milkcontent,
- fat_content = selected_livestock$fat_content,
- energy_milkcontent = selected_livestock$energy_milkcontent,
- energy_meatcontent = selected_livestock$energy_meatcontent,
- protein_meatcontent = selected_livestock$protein_meatcontent,
- carcass_fraction = selected_livestock$carcass_fraction,
- energy_eggcontent = selected_livestock$energy_eggcontent,
- n_content = selected_livestock$n_content,
- meat_product = selected_livestock$meat_product,
- milk_product = selected_livestock$milk_product,
- ipcc_ef_category_t1 = selected_livestock$ipcc_meth_ef_t1,
- ipcc_ef_category_t2 = selected_livestock$ipcc_meth_ef_t2,
- ipcc_meth_man_category = selected_livestock$ipcc_meth_man,
- ipcc_n_exc_category = selected_livestock$ipcc_meth_exc,
- stringsAsFactors = FALSE
+
+ # Show a success notification
+ showNotification(
+ "The JSON and the related Parameters Database have been cloned successfully!",
+ duration = 3,
+ type = "message"
)
- livestock_data(rbind(livestock_data(), new_row))
}
-
- # Freeze and restore scroll position for livestock table
- freeze_and_unfreeze_scroll(session, ns("livestock_table"))
-
- shinyWidgets::updatePickerInput(
- session,
- "livestock",
- selected = setNames(lkp_livetype()$livetype_code, lkp_livetype()$livetype_desc)[1]
- )
- removeModal()
})
- # Render the table
- output$livestock_table <- renderDT({
- livestock_dt <- livestock_data()
-
- # Apply bold and underline formatting to selectInputs text
- livestock_dt[manure_cols] <- lapply(livestock_dt[manure_cols], format_text_displayed)
-
- # Remove the 'livetype_code' column
- livestock_dt <- livestock_dt %>%
- select(-livetype_code)
-
- # Checkboxes for selecting rows (to be deleted)
- livestock_dt$selected_livestock <- generate_shiny_inputs(
- FUN = checkboxInput,
- len = nrow(livestock_dt),
- id = ns("selected_livestock"),
- value = rep(FALSE, nrow(livestock_dt)),
- width = "2px"
- )
- # Move the 'selected_livestock' column to the first position
- livestock_dt <- livestock_dt[, c("selected_livestock", setdiff(names(livestock_dt), "selected_livestock"))]
-
- datatable(
- livestock_dt,
- colnames = livestock_table_colnames,
- editable = list(
- target = "cell",
- # Prevent editing of the first column (check boxes for delete rows)
- disable = list(columns = 0)
- ),
- selection = "none",
- rownames = FALSE,
- escape = FALSE,
- extensions = "FixedColumns",
- options = list(
- scrollX = TRUE,
- dom = "t",
- paging = FALSE,
- fixedColumns = list(leftColumns = 2),
- columnDefs = list(
- list(
- targets = get_column_indices(
- livestock_dt,
- c("livetype_desc", # Disable editing for livestock type
- "manureman_stable",
- "manureman_non_roofed_enclosure",
- "manureman_onfarm_grazing",
- "manureman_offfarm_grazing",
- "ipcc_ef_category_t1",
- "ipcc_ef_category_t2",
- "ipcc_meth_man_category",
- "ipcc_n_exc_category"
- )
- ) - 1,
- createdCell = JS(disable_all_rows_edit_js()),
- searchable = FALSE
- )
- ),
- # Link renderDT's checkbox to the shiny input (not automatic)
- drawCallback = JS(checkbox_link(id = "selected_livestock", ns = ns))
- )
- ) %>%
- formatStyle(
- columns = c(
- "herd_composition", "annual_milk", "annual_wool", "annual_growth",
- "time_in_stable", "manure_in_stable", "manureman_stable",
- "time_in_non_roofed_enclosure", "manure_in_non_roofed_enclosure",
- "manureman_non_roofed_enclosure", "time_in_onfarm_grazing",
- "manure_in_field", "manureman_onfarm_grazing", "time_in_offfarm_grazing",
- "manureman_offfarm_grazing", "distance_to_pasture",
- "manure_onfarm_fraction", "manure_sales_fraction"
- ),
- backgroundColor = "#a9d18e"
- ) %>%
- formatStyle(
- columns = c(
- "body_weight", "body_weight_weaning", "body_weight_year_one",
- "adult_weight", "work_hour", "litter_size", "piglets_relying_on_milk",
- "lactation_length", "proportion_growth", "lw_gain", "grazing_displacement",
- "cp_maintenance", "cp_grazing", "cp_pregnancy", "cp_lactation",
- "cp_lactmilk", "cp_growth", "birth_interval", "protein_milkcontent",
- "fat_content", "energy_milkcontent", "energy_meatcontent",
- "protein_meatcontent", "carcass_fraction", "energy_eggcontent",
- "n_content", "meat_product", "milk_product", "ipcc_ef_category_t1",
- "ipcc_ef_category_t2", "ipcc_meth_man_category", "ipcc_n_exc_category"
- ),
- backgroundColor = "#f4b183"
- )
- }, server = FALSE)
+ # ----------- Seasons Tab (sourced sub-module) --------------------------------
+ source("R/scenario/32_scenario_seasons.R", local = TRUE)
- # Update the table data when edited
- observeEvent(input$livestock_table_cell_edit, {
- info <- input$livestock_table_cell_edit
- new_data <- livestock_data()
-
- # Update the specific cell while preserving the column's data type
- new_data <- update_cell(new_data, info, offset = 1)
-
- # Freeze and restore scroll position for livestock table
- freeze_and_unfreeze_scroll(session, ns("livestock_table"))
-
- livestock_data(new_data)
- })
+ # ----------- Manure/Fertilizer Tab (sourced sub-module) ---------------------
+ source("R/scenario/33_scenario_fertilizer.R", local = TRUE)
- # Delete selected row
- observeEvent(input$delete_livestock, {
- req(nrow(livestock_data()) > 0) # Ensure there are rows to process
- selected_row <- which(
- sapply(
- seq_len(nrow(livestock_data())),
- function(i) input[[paste0("selected_livestock", i)]]
- )
- )
- if (length(selected_row) > 0) {
- new_data <- livestock_data()
- new_data <- new_data[-selected_row, ]
- livestock_data(new_data)
- }
-
- # Freeze and restore scroll position for livestock table
- freeze_and_unfreeze_scroll(session, ns("livestock_table"))
- })
+ # ----------- Area tab (sourced sub-module) ----------------------------------
+ source("R/scenario/34_scenario_area.R", local = TRUE)
- # Show modal dialog to update manure management
- observeEvent(input$livestock_table_cell_clicked, {
- info <- input$livestock_table_cell_clicked
- req(length(info) > 0)
-
- if (!is.null(info) && !is.null(info$col) && (names(livestock_data())[info$col + 1] %in% manure_cols)) {
- column_name <- names(livestock_data())[info$col]
- if (modal_open()) return()
- modal_open(TRUE)
- showModal(modalDialog(
- title = paste("Select a manure management type"),
- shinyWidgets::pickerInput(
- inputId = ns("manure_management"),
- label = NULL,
- choices = unique(lkp_manureman()$manureman_desc)
- ),
- footer = tagList(
- actionButton(ns("ok_update_manure_management"), "OK"),
- modalButton("Cancel")
- )
- ))
-
- selected_cell(info)
- }
- })
+ # ----------- Livestock tab (sourced sub-module) -----------------------------
+ source("R/scenario/35_scenario_livestock.R", local = TRUE)
- # Update manure management in the table
- observeEvent(input$ok_update_manure_management, {
- req(input$manure_management)
- selected_cell <- selected_cell()
- if (!is.null(selected_cell)) {
- new_data <- livestock_data()
- column_name <- names(new_data)[selected_cell$col + 1]
- new_data[selected_cell$row, column_name] <- input$manure_management
- livestock_data(new_data)
- }
- shinyWidgets::updatePickerInput(
- session,
- "manure_management",
- selected = lkp_manureman()$manureman_desc[1]
- )
- removeModal()
-
- # Freeze and restore scroll position for livestock table
- freeze_and_unfreeze_scroll(session, ns("livestock_table"))
- })
+ # ----------- Feed production tab --------------------------------------------
+ # (Kept inline; seasons/fertilizer/area/livestock are sourced from R/scenario/32-35)
# ----------- Feed production tab --------------------------------------------
# Initial data frame for crops
@@ -1196,14 +640,19 @@ scenario_server <- function(
shinyWidgets::pickerInput(
inputId = ns("feed"),
label = NULL,
- choices = setNames(lkp_feeditem()$feed_item_code, lkp_feeditem()$feed_item_name)
+ choices = setNames(
+ lkp_feeditem()$feed_item_code,
+ lkp_feeditem()$feed_item_name
+ )[sort(lkp_feeditem()$feed_item_name)],
+ options = list(`live-search` = TRUE)
),
br(),
h2("Selected a Crop", class = "mb-3"),
shinyWidgets::pickerInput(
inputId = ns("crop"),
label = NULL,
- choices = NULL
+ choices = NULL,
+ options = list(`live-search` = TRUE)
),
easyClose = TRUE,
footer = tagList(
@@ -1215,29 +664,29 @@ scenario_server <- function(
# Update second select input "crop" depending on the first input "feed"
observeEvent(input$feed, {
- feed_type_code <- lkp_feeditem()$feed_type_code[lkp_feeditem()$feed_item_code == input$feed]
+ crop_code <- lkp_feeditem()$crop_code[lkp_feeditem()$feed_item_code == input$feed]
choices <- setNames(
- lkp_feedtype()$feed_type_code[lkp_feedtype()$feed_type_code == feed_type_code],
- lkp_feedtype()$feed_type_name[lkp_feedtype()$feed_type_code == feed_type_code]
+ lkp_crops()$crop_code[lkp_crops()$crop_code == crop_code],
+ lkp_crops()$crop_name[lkp_crops()$crop_code == crop_code]
)
# remove NA values
choices <- choices[!is.na(choices)]
shinyWidgets::updatePickerInput(
session,
"crop",
- choices = choices
+ choices = choices[sort(names(choices))]
)
})
# Add new crop row from modal
observeEvent(input$ok_add_crop, {
req(input$crop, input$feed)
- if (!((input$crop %in% feedtype()[, "feed_type_code"]) && (input$feed %in% feedtype()[, "feed_item_code"]))) {
+ if (!((input$crop %in% feedtype()[, "crop_code"]) && (input$feed %in% feedtype()[, "feed_item_code"]))) {
new_row <- data.frame(
- feed_type_code = input$crop,
+ crop_code = input$crop,
feed_item_code = input$feed,
feed_item_name = lkp_feeditem()$feed_item_name[lkp_feeditem()$feed_item_code == input$feed],
- feed_type_name = lkp_feedtype()$feed_type_name[lkp_feedtype()$feed_type_code == input$crop],
+ crop_name = lkp_crops()$crop_name[lkp_crops()$crop_code == input$crop],
source_type = "Main", # Only column that is hard coded like the qt app
intercrop = 0,
intercrop_fraction = 0,
@@ -1259,33 +708,32 @@ scenario_server <- function(
grassman_change_factor = lkp_grasslandman()$change_factor[1],
landcover_c_factor = lkp_landcover()$c_factor[1],
slope_p_factor = lkp_slope()$p_factor[1],
- dry_yield = lkp_feedtype()$dry_yield[lkp_feedtype()$feed_type_code == input$crop],
- residue_dry_yield = lkp_feedtype()$residue_dry_yield[lkp_feedtype()$feed_type_code == input$crop],
- n_content = 0,
- residue_n = lkp_feedtype()$residue_n[lkp_feedtype()$feed_type_code == input$crop],
- kc_initial = lkp_feedtype()$kc_initial[lkp_feedtype()$feed_type_code == input$crop],
- kc_midseason = lkp_feedtype()$kc_midseason[lkp_feedtype()$feed_type_code == input$crop],
- kc_late = lkp_feedtype()$kc_late[lkp_feedtype()$feed_type_code == input$crop],
- category = lkp_feedtype()$category[lkp_feedtype()$feed_type_code == input$crop],
- trees_ha = lkp_feedtype()$trees_ha[lkp_feedtype()$feed_type_code == input$crop],
- trees_dhb = lkp_feedtype()$trees_dhb[lkp_feedtype()$feed_type_code == input$crop],
- trees_growth = lkp_feedtype()$trees_growth[lkp_feedtype()$feed_type_code == input$crop],
- trees_removal = lkp_feedtype()$trees_removal[lkp_feedtype()$feed_type_code == input$crop],
- trees_ha_dbh25 = lkp_feedtype()$trees_ha_dbh25[lkp_feedtype()$feed_type_code == input$crop],
- average_dbh25 = lkp_feedtype()$average_dbh25[lkp_feedtype()$feed_type_code == input$crop],
- increase_dbh25 = lkp_feedtype()$increase_dbh25[lkp_feedtype()$feed_type_code == input$crop],
- trees_ha_dbh2550 = lkp_feedtype()$trees_ha_dbh2550[lkp_feedtype()$feed_type_code == input$crop],
- average_dbh2550 = lkp_feedtype()$average_dbh2550[lkp_feedtype()$feed_type_code == input$crop],
- increase_dbh2550 = lkp_feedtype()$increase_dbh2550[lkp_feedtype()$feed_type_code == input$crop],
- trees_ha_dbh50 = lkp_feedtype()$trees_ha_dbh50[lkp_feedtype()$feed_type_code == input$crop],
- average_dbh50 = lkp_feedtype()$average_dbh50[lkp_feedtype()$feed_type_code == input$crop],
- increase_dbh50 = lkp_feedtype()$increase_dbh50[lkp_feedtype()$feed_type_code == input$crop],
- time_horizon = lkp_feedtype()$time_horizon[lkp_feedtype()$feed_type_code == input$crop],
- diameter_breast = lkp_feedtype()$diameter_breast[lkp_feedtype()$feed_type_code == input$crop],
+ dry_yield = lkp_crops()$dry_yield[lkp_crops()$crop_code == input$crop],
+ residue_dry_yield = lkp_crops()$residue_dry_yield[lkp_crops()$crop_code == input$crop],
+ residue_n = lkp_crops()$residue_n[lkp_crops()$crop_code == input$crop],
+ kc_initial = lkp_crops()$kc_initial[lkp_crops()$crop_code == input$crop],
+ kc_midseason = lkp_crops()$kc_midseason[lkp_crops()$crop_code == input$crop],
+ kc_late = lkp_crops()$kc_late[lkp_crops()$crop_code == input$crop],
+ category = lkp_crops()$category[lkp_crops()$crop_code == input$crop],
+ trees_ha = lkp_crops()$trees_ha[lkp_crops()$crop_code == input$crop],
+ trees_dhb = lkp_crops()$trees_dhb[lkp_crops()$crop_code == input$crop],
+ trees_growth = lkp_crops()$trees_growth[lkp_crops()$crop_code == input$crop],
+ trees_removal = lkp_crops()$trees_removal[lkp_crops()$crop_code == input$crop],
+ trees_ha_dbh25 = lkp_crops()$trees_ha_dbh25[lkp_crops()$crop_code == input$crop],
+ average_dbh25 = lkp_crops()$average_dbh25[lkp_crops()$crop_code == input$crop],
+ increase_dbh25 = lkp_crops()$increase_dbh25[lkp_crops()$crop_code == input$crop],
+ trees_ha_dbh2550 = lkp_crops()$trees_ha_dbh2550[lkp_crops()$crop_code == input$crop],
+ average_dbh2550 = lkp_crops()$average_dbh2550[lkp_crops()$crop_code == input$crop],
+ increase_dbh2550 = lkp_crops()$increase_dbh2550[lkp_crops()$crop_code == input$crop],
+ trees_ha_dbh50 = lkp_crops()$trees_ha_dbh50[lkp_crops()$crop_code == input$crop],
+ average_dbh50 = lkp_crops()$average_dbh50[lkp_crops()$crop_code == input$crop],
+ increase_dbh50 = lkp_crops()$increase_dbh50[lkp_crops()$crop_code == input$crop],
+ time_horizon = lkp_crops()$time_horizon[lkp_crops()$crop_code == input$crop],
+ diameter_breast = lkp_crops()$diameter_breast[lkp_crops()$crop_code == input$crop],
# These ones are available in the json but not in the DT
fraction_as_manure = "NULL", # We should get null in the json
n_fertilizer = "NULL", # We should get null in the json
- main_n = lkp_feedtype()$main_n[lkp_feedtype()$feed_type_code == input$crop],
+ main_n = lkp_crops()$main_n[lkp_crops()$crop_code == input$crop],
land_cover = lkp_landcover()$landcover_code[1],
slope = lkp_slope()$slope_code[1],
grassman = lkp_grasslandman()$management_code[1],
@@ -1294,7 +742,7 @@ scenario_server <- function(
new_input_row <- data.frame(
Feed = lkp_feeditem()$feed_item_name[lkp_feeditem()$feed_item_code == input$feed],
- Crop = lkp_feedtype()$feed_type_name[lkp_feedtype()$feed_type_code == input$crop],
+ Crop = lkp_crops()$crop_name[lkp_crops()$crop_code == input$crop],
fraction_as_fertilizer = 0,
urea = 0,
npk = 0,
@@ -1333,7 +781,7 @@ scenario_server <- function(
rows_not_contains_grass <- which(feedtype_dt$category != "grass") - 1 # index for js
# Identify indices of non-rice crops
- rows_not_contains_rice <- which(feedtype_dt$feed_type_name != "Rice") - 1 # index for js
+ rows_not_contains_rice <- which(feedtype_dt$crop_name != "Rice") - 1 # index for js
# Identify indices of rows to disable depending on the source type
rows_not_residue <- which(feedtype_dt$source_type != "Residue") - 1 # index for js
@@ -1351,12 +799,11 @@ scenario_server <- function(
# Update feedtype with the modified feedtype_dt
feedtype(feedtype_dt)
-
# Checkboxes for enabling/disabling intercrop
feedtype_dt$intercrop <- generate_shiny_inputs(
FUN = checkboxInput,
len = nrow(feedtype_dt),
- id = ("intercrop_check"),
+ id = ("intercrop_check"),
value = checked_boxes$intercrop_checked
)
@@ -1388,7 +835,7 @@ scenario_server <- function(
feedtype_dt <- feedtype_dt %>%
select(
- -feed_type_code, -feed_item_code, -fraction_as_manure, -n_fertilizer,
+ -crop_code, -feed_item_code, -fraction_as_manure, -n_fertilizer,
-main_n, -slope, -grassman, -land_cover
)
@@ -1447,7 +894,7 @@ scenario_server <- function(
targets = get_column_indices(
feedtype_dt,
c("feed_item_name",
- "feed_type_name",
+ "crop_name",
"source_type",
"intercrop",
"land_cover_desc",
@@ -1490,7 +937,7 @@ scenario_server <- function(
) %>%
formatStyle(
columns = c(
- "dry_yield", "residue_dry_yield", "n_content", "residue_n", "kc_initial",
+ "dry_yield", "residue_dry_yield", "residue_n", "kc_initial",
"kc_midseason", "kc_late", "category", "trees_ha", "trees_dhb",
"trees_growth", "trees_removal", "trees_ha_dbh25", "average_dbh25",
"increase_dbh25", "trees_ha_dbh2550", "average_dbh2550",
@@ -1501,31 +948,196 @@ scenario_server <- function(
)
}, server = FALSE)
- # Update the crop table data when check box is checked
- observeEvent(
- input$checkbox_info, {
- info <- input$checkbox_info
- checked_boxes$intercrop_checked[info$row] <- info$value
- feedtype_dt <- feedtype()
- feedtype_dt$intercrop <- as.numeric(checked_boxes$intercrop_checked) # we need integer for json
- # Reset the disabled cell to the value 0
- feedtype_dt$intercrop_fraction[feedtype_dt$intercrop == 0] <- 0
- feedtype(feedtype_dt)
+ # ------ CROP INTERCROPPING FRACTION AUTO-UPDATE -----------------------------
+ observeEvent(input$checkbox_info, {
+ info <- input$checkbox_info
+ req(length(info) > 0)
+ # Update stored checkbox states
+ checked_boxes$intercrop_checked[info$row] <- info$value
+ # Retrieve the current crop table data
+ feedtype_dt <- feedtype()
+ # Ensure required columns exist
+ required_columns <- c("intercrop", "intercrop_fraction")
+ if (!all(required_columns %in% names(feedtype_dt))) return()
+ # Update intercropping flag (numeric for JSON export)
+ feedtype_dt$intercrop <- as.numeric(checked_boxes$intercrop_checked)
+ # Apply logic for automatic fraction updates when checked
+ if (isTRUE(info$value)) {
+ if (is.na(feedtype_dt$intercrop_fraction[info$row]) ||
+ feedtype_dt$intercrop_fraction[info$row] == 0) {
+ feedtype_dt$intercrop_fraction[info$row] <- 0.01
+ }
+ } else {
+ feedtype_dt$intercrop_fraction[info$row] <- 0
+ }
+ # Push updated table back into reactive
+ feedtype(feedtype_dt)
+ # Keep scroll position stable after re-render
+ freeze_and_unfreeze_scroll(session, ns("crop_table"))
+ })
+
+ # ------ FEEDTYPE VALIDATION -------------------------------------------------
+ observeEvent(feedtype(), {
+ # Hide previous warnings before running new validation
+ shinyjs::hide("alert_message_Intercropping_fraction_inputs")
+ shinyjs::hide("alert_message_residue_fractions_inputs")
+ # Stop if no feed table data is available
+ feed_table <- feedtype()
+ if (is.null(feed_table) || nrow(feed_table) == 0) return()
+
+ # --- Validate intercropping fractions -------------------------------------
+ intercropping_fields <- c("feed_item_name", "intercrop", "intercrop_fraction")
+ if (all(intercropping_fields %in% names(feed_table))) {
+
+ invalid_intercrop_msgs <- character(0)
- # Freeze and restore scroll position for crop table
- freeze_and_unfreeze_scroll(session, ns("crop_table"))
+ for (row_index in seq_len(nrow(feed_table))) {
+ # Proceed only when intercropping checkbox is checked
+ intercropping_selected <- !is.na(feed_table$intercrop[row_index]) &&
+ feed_table$intercrop[row_index] == 1
+ feed_label <- feed_table$feed_item_name[row_index]
+
+ if (intercropping_selected) {
+ intercropping_value <- feed_table$intercrop_fraction[row_index]
+ # Auto-assign 0.01 when selected but value left blank
+ if (is.na(intercropping_value)) {
+ intercropping_value <- 0.01
+ feed_table$intercrop_fraction[row_index] <- intercropping_value
+ }
+ # Validate that fraction is strictly between 0 and 1
+ if (intercropping_value <= 0 || intercropping_value >= 1) {
+ invalid_intercrop_msgs[feed_label] <- sprintf(
+ "• For %s , the value in
+ 'IF intercropping, fraction of field occupied by this crop'
+ column must be > 0 and < 1!",
+ feed_label
+ )
+ }
+ } else {
+ # Reset fraction to 0 when intercropping is unchecked
+ feed_table$intercrop_fraction[row_index] <- 0
+ }
+ }
+ # Display intercropping validation messages
+ if (length(invalid_intercrop_msgs) > 0) {
+ invalid_intercrop_msgs <- invalid_intercrop_msgs[
+ order(names(invalid_intercrop_msgs))
+ ]
+ shinyjs::html(
+ id = "alert_message_Intercropping_fraction_inputs",
+ html = paste(invalid_intercrop_msgs, collapse = "• For %s , the value in
+ '%s' column must be ≥ 0 and ≤ 1!",
+ feed_labels, residue_label
+ )
+
+ names(msg_list) <- feed_labels
+ msg_list
+ }))
+ # Display residue validation messages
+ if (length(invalid_residue_msgs) > 0) {
+ invalid_residue_msgs <- invalid_residue_msgs[
+ order(names(invalid_residue_msgs))
+ ]
+ shinyjs::html(
+ id = "alert_message_residue_fractions_inputs",
+ html = paste(invalid_residue_msgs, collapse = " 'Fraction collected manure used
+ as fertilizer' across all rows should not exceed 1!"
+ )
+ )
+ ),
+ # Displays a warning if no fertilizers are selected
+ # controlled via shinyjs in the server
+ shinyjs::hidden(
+ div(
+ id = ns("alert_no_fertilizers"),
+ class = "alert alert-danger",
+ HTML(
+ "No fertilizers have been selected in the 'Farm > Fertilizer' tab.
+ Please add at least one fertilizer to enable editing."
+ )
)
),
div(DTOutput(ns("crop_inputs_table")), class = "without_checkbox"),
@@ -1040,9 +1100,16 @@ scenario_ui <- function(id) {
tabPanel(
"Livestock Feeding",
div(class = "p-5 bg-light",
- uiOutput(ns("livestock_feeding_ui")),
- h2("Allocation in percentage of a feed to livestock by season", class = "mb-5"),
- uiOutput(ns("livestock_feeding_table"))
+ uiOutput(ns("livestock_feeding_ui")),
+ h2("Allocation in percentage of a feed to livestock by season", class = "mb-5"),
+ shinyjs::hidden(
+ div(
+ id = ns("alert_livestock_feeding_global"),
+ class = "alert alert-danger",
+ style = "margin-bottom: 20px;"
+ )
+ ),
+ uiOutput(ns("livestock_feeding_table"))
)
)
)
diff --git a/R/30_mod_scenario_validation.R b/R/30_mod_scenario_validation.R
new file mode 100644
index 0000000..a27d65f
--- /dev/null
+++ b/R/30_mod_scenario_validation.R
@@ -0,0 +1,534 @@
+# ------ VALIDATION MODULE ---------------------------------------------------
+#'
+#' Real-time data validation engine providing immediate feedback on user inputs
+#' across multiple application tabs. Implements rule-based validation logic with
+#' dynamic error messaging to ensure data integrity and guide users toward
+#' correct input values.
+#'
+#' VALIDATION SYSTEMS:
+#'
+#' 1. FARM TAB: farm_validation_server()
+#' Field-level validation for Area, Waste, and Manure inputs
+#' Rules: non-negative, positive, percentage, between 0-1
+#'
+#' 2. LIVESTOCK FEEDING TAB: livestock_feeding_validation_server()
+#' Table-level validation for allocation percentages
+#' Rule: Each livestock column must sum to exactly 100% per season
+
+# ------ SECTION 1: FARM TAB VALIDATION --------------------------------------
+
+# VALIDATION RULES & ERROR MESSAGES ------------------------------------------
+
+# Lookup table for validation rule functions
+# Each function takes a numeric value and returns TRUE if valid, FALSE otherwise
+validation_conditions <- list(
+ # Validates value is zero or greater
+ non_negative = function(x) x >= 0,
+ # Validates value is strictly greater than zero
+ positive = function(x) x > 0,
+ # Validates value is a percentage (0-100 inclusive)
+ percentage = function(x) x >= 0 && x <= 100,
+ # Validates value is a proportion (0-1 inclusive)
+ between_0_1 = function(x) x >= 0 && x <= 1
+)
+
+# Error message templates corresponding to each validation rule
+# These are displayed to users when validation fails
+error_message_templates <- list(
+ non_negative = "It must be ≥ 0!",
+ positive = "It must be > 0!",
+ percentage = "It must be ≥ 0 and ≤ 100!",
+ between_0_1 = "It must be ≥ 0 and ≤ 1!"
+)
+
+# Configuration for area input fields
+# Each field specifies its input ID, display label, and validation rule
+area_fields_config <- list(
+ list(
+ id = "soil_n",
+ label = "Soil N (g/kg)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "soil_c",
+ label = "Soil C (g/kg)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "soil_clay",
+ label = "Soil clay (%)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "soil_bulk",
+ label = "Bulk density (g/cm³)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "soil_depth",
+ label = "Soil depth (m)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "et",
+ label = "ET₀ (mm/year)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "grassland_toarable",
+ label = "Conversion Grassland to arable land (ha)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "arable_tograssland",
+ label = "Conversion Arable land to grassland (ha)",
+ validator = "non_negative"
+ )
+)
+
+# Configuration for waste input fields (percentages)
+# Each field specifies its input ID, display label, and validation rule
+waste_fields_config <- list(
+ list(
+ id = "waste_production_milk",
+ label = "Production (milk)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_distribution_milk",
+ label = "Distribution (milk)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_processing_milk",
+ label = "Processing (milk)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_consume_milk",
+ label = "Consumption (milk)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_production_meat",
+ label = "Production (meat)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_distribution_meat",
+ label = "Distribution (meat)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_processing_meat",
+ label = "Processing (meat)",
+ validator = "percentage"
+ ),
+ list(
+ id = "waste_consume_meat",
+ label = "Consumption (meat)",
+ validator = "percentage"
+ )
+)
+
+# Configuration for manure/fertilizer input fields
+# Each field specifies its input ID, display label, and validation rule
+manure_fields_config <- list(
+ list(
+ id = "purchased_manure",
+ label = "Annual purchase of manure (kg N)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "purchased_compost",
+ label = "Annual purchase of compost (kg N)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "purchased_organic_n",
+ label = "Annual purchase of other organic N additions (kg N)",
+ validator = "non_negative"
+ ),
+ list(
+ id = "purchased_bedding",
+ label = "Annual purchase of bedding materials (kg N)",
+ validator = "non_negative"
+ )
+)
+
+# ------ VALIDATION REGISTRY -------------------------------------------------
+
+# Central registry organizing validation configurations by input group
+# Each entry contains field configurations and the associated alert element ID
+validation_registry <- list(
+ area_inputs = list(
+ fields = area_fields_config,
+ alert_id = "alert_message_area_inputs"
+ ),
+ waste_inputs = list(
+ fields = waste_fields_config,
+ alert_id = "alert_message_waste_inputs"
+ ),
+ manure_inputs = list(
+ fields = manure_fields_config,
+ alert_id = "alert_message_manure_inputs"
+ )
+)
+
+# ------ CORE VALIDATION LOGIC -----------------------------------------------
+
+#' Execute validation logic and synchronize UI state
+#'
+#' Validates all provided fields against their validation rules and displays
+#' error messages in the UI alert element when validation fails.
+#'
+#' @param fields List of field objects, each containing:
+#' - id: Input field identifier
+#' - label: Human-readable field name
+#' - value: Current field value
+#' - validate_fn: Validation function
+#' - error_msg: Error message template
+#' @param alert_id Character string specifying the UI element ID for displaying
+#' validation messages
+#'
+#' @return Invisible logical: TRUE if validation errors found, FALSE otherwise
+
+execute_validation <- function(fields, alert_id) {
+ # Initially hide the alert message element
+ shinyjs::hide(id = alert_id, asis = TRUE)
+
+ # Initialize empty list to collect validation errors with field information
+ validation_errors <- list()
+
+ # Iterate through each field configuration with index
+ for (i in seq_along(fields)) {
+ field <- fields[[i]]
+
+ # Only validate fields with non-null and non-NA values
+ # Empty or NA values are considered acceptable and skip validation
+ if (!is.null(field$value) && !is.na(field$value)) {
+ # Apply the validation function to the field's current value
+ is_valid <- field$validate_fn(field$value)
+
+ # If validation fails, construct and collect error with field index
+ if (!is_valid) {
+ formatted_error_message <- sprintf(
+ "• The value in '%s' is %s . %s",
+ field$label,
+ field$value,
+ field$error_msg
+ )
+
+ # Store error with field index for sorting
+ validation_errors[[length(validation_errors) + 1]] <- list(
+ index = i,
+ message = formatted_error_message
+ )
+ }
+ }
+ }
+
+ # If any validation errors were found, sort and display them
+ if (length(validation_errors) > 0) {
+ # Sort errors by field index to maintain config order
+ sorted_errors <- validation_errors[order(sapply(validation_errors, function(e) e$index))]
+
+ # Extract just the messages
+ validation_error_messages <- sapply(sorted_errors, function(e) e$message)
+
+ # Combine all error messages with line breaks for display
+ combined_error_html <- paste(validation_error_messages, collapse = "• For season '%s' , ",
+ "the total of feed allocations in '%s' ",
+ "is %s%% . It must equal 100%% ."
+ ),
+ season_name,
+ livestock_name,
+ actual_sum
+ )
+ })
+ }
+
+ return(validation_result)
+}
+
+#' Livestock Feeding Tab Validation Server Module
+#'
+#' TARGET TAB: Livestock Feeding
+#'
+#' Validates allocation tables: each livestock column must sum to 100% per season.
+#' Uses single observer pattern to prevent observer accumulation.
+#'
+#' @param id Module namespace ID
+#' @param basket_data ReactiveValues containing allocation data per season
+#' @param seasons Reactive data frame with season information
+#' @param parent_session Shiny session object from parent scope
+#'
+#' @return Shiny module server function
+
+
+livestock_feeding_validation_server <- function(
+ id,
+ basket_data,
+ seasons,
+ parent_session
+) {
+ moduleServer(id, function(input, output, session) {
+ # Reactive values to track validation errors for each season
+ # Using reactiveValues() allows direct assignment
+ season_errors <- reactiveValues()
+
+ # Single observer that validates all seasons when any data changes
+ observeEvent(c(seasons(), reactiveValuesToList(basket_data)), {
+ # Get current seasons
+ current_seasons <- if (!is.null(seasons()) && nrow(seasons()) > 0) {
+ seasons()$Season
+ } else {
+ character(0)
+ }
+
+ # Clean up errors for deleted seasons
+ all_error_keys <- names(reactiveValuesToList(season_errors))
+ deleted_keys <- setdiff(all_error_keys, current_seasons)
+ for (key in deleted_keys) {
+ season_errors[[key]] <- NULL
+ }
+
+ # Validate each existing season
+ for (season in current_seasons) {
+ season_data <- basket_data[[season]]
+
+ # Skip if no valid data
+ if (is.null(season_data) || !is.data.frame(season_data) || nrow(season_data) == 0) {
+ next
+ }
+
+ # Validate and store errors
+ validation_result <- validate_season_allocations(
+ season_data = season_data,
+ season_name = season
+ )
+ season_errors[[season]] <- if (validation_result$has_errors) {
+ validation_result$error_messages
+ } else {
+ NULL
+ }
+ }
+ }, ignoreNULL = FALSE, ignoreInit = FALSE)
+
+ # Observer to update the global alert based on all validation errors
+ observe({
+ global_alert_id <- parent_session$ns("alert_livestock_feeding_global")
+
+ # Get all error messages
+ all_errors <- reactiveValuesToList(season_errors)
+ non_null_errors <- all_errors[!sapply(all_errors, is.null)]
+ messages <- unlist(non_null_errors)
+
+ if (length(messages) > 0) {
+ # Show alert with combined errors
+ combined_html <- paste(messages, collapse = " %s ", code)
+ )
+
+ # Build grammatically correct list of codes
+ if (length(bold_codes) == 1) {
+ codes_text <- bold_codes[1]
+ } else if (length(bold_codes) == 2) {
+ codes_text <- paste(bold_codes, collapse = " and ")
+ } else {
+ codes_text <- paste(
+ paste(bold_codes[-length(bold_codes)], collapse = ", "),
+ "and",
+ bold_codes[length(bold_codes)]
+ )
+ }
+
+ # Construct error message with column name and duplicate codes
+ error_message <- sprintf(
+ paste0(
+ "In '%s' column, the following codes are duplicated : %s. ",
+ "Please fix these duplications to have a unique code for each row."
+ ),
+ code_column,
+ codes_text
+ )
+
+ # Display the alert message to the user
+ shinyjs::html(
+ id = paste0("alert_duplicate_code_", name),
+ html = error_message
+ )
+ shinyjs::show(id = paste0("alert_duplicate_code_", name))
+
+ } else {
+ # No duplicates found - hide the alert message
+ shinyjs::hide(id = paste0("alert_duplicate_code_", name))
+ }
+ })
+ })
# ------ * Observe edits on rendered DT -------------------------------------
lapply(parameters_db_names, function(name) {
observeEvent(input[[paste0("table_", name, "_cell_edit")]], {
req(input$database_name)
+ req(!(input$database_name %in% primary_database_names()))
# Get the info of the edited cell
info <- input[[paste0("table_", name, "_cell_edit")]]
new_data <- session$userData$parameters_db[[name]]
@@ -644,49 +817,269 @@ params_db_server <- function(
})
})
- # ------ * Observe delete and add empty rows buttons ------------------------
- lapply(parameters_db_names, function(name) {
- observeEvent(input[[paste0("delete_rows_", name)]], {
- req(input$database_name)
- rows_to_delete <- which(
- sapply(
- seq_len(nrow(session$userData$parameters_db[[name]])),
- function(i) input[[paste0("selected_row_", name, "_", i)]]
+ # ------ * Handle crop_name click for feeditem table ------------------------
+ # Show modal dialog to select a crop when clicking crop_name cell
+ observeEvent(input$table_lkp_feeditem_cell_clicked, {
+ info <- input$table_lkp_feeditem_cell_clicked
+ req(length(info) > 0)
+ # Don't allow editing default (read-only) DBs
+ req(!(input$database_name %in% primary_database_names()))
+
+ # Get data tables
+ feeditem_data <- session$userData$parameters_db[["lkp_feeditem"]]
+ crops_table <- session$userData$parameters_db[["lkp_crops"]]
+
+ if (is.null(crops_table) || is.null(feeditem_data)) {
+ return()
+ }
+
+ # Reconstruct the display table structure to get correct column names
+ temp_data <- as.data.frame(feeditem_data)
+ temp_data$crop_name <- crops_table$crop_name[
+ match(temp_data$crop_code, crops_table$crop_code)
+ ]
+
+ # Reorder same as display
+ temp_data <- reorder_feeditem_columns(temp_data)
+
+ # Add checkbox column (first column in display)
+ temp_data <- data.frame(
+ selected_row = rep(FALSE, nrow(temp_data)),
+ temp_data,
+ stringsAsFactors = FALSE
+ )
+
+ # Check if clicked column is crop_name
+ clicked_col_name <- names(temp_data)[info$col + 1]
+
+ if (!is.null(info$col) && clicked_col_name == "crop_name") {
+ if (modal_open()) {
+ return()
+ }
+ modal_open(TRUE)
+
+ # Use row index directly as the unique identifier
+ # DataTables sends 1-based indices for this table config
+ clicked_row_idx <- info$row
+
+ # Verify row index is valid
+ if (clicked_row_idx < 1 || clicked_row_idx > nrow(feeditem_data)) {
+ return()
+ }
+
+ current_crop_code <- feeditem_data$crop_code[clicked_row_idx]
+
+ # Get valid choices using helper function
+ crop_data <- get_valid_crop_choices(crops_table, current_crop_code)
+
+ showModal(modalDialog(
+ title = "Select a Crop Name",
+ shinyWidgets::pickerInput(
+ inputId = ns("crop_selector"),
+ label = NULL,
+ choices = crop_data$choices,
+ selected = crop_data$selected,
+ options = list(`live-search` = TRUE)
+ ),
+ easyClose = FALSE,
+ footer = tagList(
+ actionButton(ns("ok_update_crop"), "OK"),
+ actionButton(ns("cancel_crop_selector"), "Cancel")
+ )
+ ))
+
+ # Store the row index (unique identifier) instead of code
+ session$userData$feeditem_clicked_row_idx <- clicked_row_idx
+ }
+ })
+
+ # ------ * Update crop_code when crop selection confirmed --------------------
+ observeEvent(input$ok_update_crop, {
+ req(input$crop_selector)
+ req(!(input$database_name %in% primary_database_names()))
+ clicked_row_idx <- session$userData$feeditem_clicked_row_idx
+
+ if (!is.null(clicked_row_idx)) {
+ new_data <- session$userData$parameters_db[["lkp_feeditem"]]
+
+ if (clicked_row_idx < 1 || clicked_row_idx > nrow(new_data)) {
+ modal_open(FALSE)
+ removeModal()
+ return()
+ }
+
+ # Update crop_code for the specific row index
+ new_data$crop_code[clicked_row_idx] <- as.integer(input$crop_selector)
+
+ # Update in session - reassign entire parameters_db to trigger reactivity
+ temp_params_db <- session$userData$parameters_db
+ temp_params_db[["lkp_feeditem"]] <- new_data
+ session$userData$parameters_db <- temp_params_db
+
+ # Write updated table back to CSV
+ fwrite(
+ new_data,
+ file.path(
+ session$userData$user_folder, "parameters_database",
+ input$database_name, "lkp_feeditem.csv"
)
)
- # Proceed only if there are rows selected to delete
- if (length(rows_to_delete) > 0) {
- session$userData$parameters_db[[name]] <- session$userData$parameters_db[[name]][-rows_to_delete]
- # Write updated table back to CSV
- fwrite(
- session$userData$parameters_db[[name]],
- file.path(session$userData$user_folder, "parameters_database",
- input$database_name, paste0(name, ".csv"))
+
+ # Freeze and restore scroll position after the table re-renders
+ freeze_and_unfreeze_scroll(session, ns("table_lkp_feeditem"))
+ }
+
+ # Clear stored identifier
+ session$userData$feeditem_clicked_code <- NULL
+ modal_open(FALSE)
+ removeModal()
+ })
+
+ # Handle cancel button click
+ observeEvent(input$cancel_crop_selector, {
+ modal_open(FALSE)
+ session$userData$feeditem_clicked_code <- NULL
+ removeModal()
+ })
+
+ # ------ DELETE ROW BUTTON ---------------------------------------------------
+ # Delete selected parameter records and update memory + disk immediately.
+ lapply(parameters_db_names, function(table_name) {
+ observeEvent(input[[paste0("delete_rows_", table_name)]], {
+ req(input$database_name)
+ req(!(input$database_name %in% primary_database_names()))
+
+ parameter_table <- session$userData$parameters_db[[table_name]]
+ if (nrow(parameter_table) == 0) return()
+
+ # Detect which checkboxes are selected
+ selected_indices <- which(vapply(
+ seq_len(nrow(parameter_table)),
+ function(i) isTRUE(input[[paste0("selected_row_", table_name, "_", i)]]),
+ logical(1)
+ ))
+ if (length(selected_indices) == 0) return()
+
+ # Remove selected rows
+ parameter_table <- parameter_table[-selected_indices, , drop = FALSE]
+
+ # Update memory
+ session$userData$parameters_db[[table_name]] <- parameter_table
+
+ # Persist to disk
+ fwrite(
+ parameter_table,
+ file.path(
+ session$userData$user_folder,
+ "parameters_database",
+ input$database_name,
+ paste0(table_name, ".csv")
)
- }
+ )
- # Freeze and restore scroll position after deletion
- freeze_and_unfreeze_scroll(session, ns(paste0("table_", name)))
+ # Maintain visual continuity after deletion
+ freeze_and_unfreeze_scroll(session, ns(paste0("table_", table_name)))
})
})
- lapply(parameters_db_names, function(name) {
- observeEvent(input[[paste0("add_rows_", name)]], {
+ # ------ ADD ROW BUTTON ------------------------------------------------------
+ # Add a single empty record to the table.
+ lapply(parameters_db_names, function(table_name) {
+ observeEvent(input[[paste0("add_rows_", table_name)]], {
req(input$database_name)
- session$userData$parameters_db[[name]] <- rbind(
- session$userData$parameters_db[[name]],
- as.list(rep(NA, ncol(session$userData$parameters_db[[name]])))
- )
+ req(!(input$database_name %in% primary_database_names()))
+
+ # Retrieve current table from memory
+ parameter_table <- session$userData$parameters_db[[table_name]]
+
+ # Append one empty record with NA placeholders
+ new_record <- as.list(rep(NA, ncol(parameter_table)))
+ names(new_record) <- names(parameter_table)
+
+ # Auto-generate unique code for first column
+ code_column <- names(parameter_table)[1]
+ new_record[[code_column]] <- generate_next_code(parameter_table, code_column)
+
+ # Append to table
+ parameter_table <- rbind(parameter_table, new_record)
+
+ # Update in-memory data and persist to disk
+ session$userData$parameters_db[[table_name]] <- parameter_table
fwrite(
- session$userData$parameters_db[[name]],
- file.path(session$userData$user_folder, "parameters_database",
- input$database_name, paste0(name, ".csv"))
+ parameter_table,
+ file.path(
+ session$userData$user_folder,
+ "parameters_database",
+ input$database_name,
+ paste0(table_name, ".csv")
+ )
)
- # Freeze and restore scroll position after adding rows
- freeze_and_unfreeze_scroll(session, ns(paste0("table_", name)))
+ # Keep table scroll position to prevent UI jump
+ freeze_and_unfreeze_scroll(session, ns(paste0("table_", table_name)))
+ # Auto-jump to the bottom to show newly added row
+ session$onFlushed(function() {
+ scroll_to_bottom(session, ns(paste0("table_", table_name)))
+ }, once = TRUE)
})
})
-})}
+ # ------ CLONE ROW BUTTON ----------------------------------------------------
+ # Duplicates a selected parameter record and inserts it immediately after.
+ # Only one record can be cloned at a time.
+ lapply(parameters_db_names, function(table_name) {
+ observeEvent(input[[paste0("clone_rows_", table_name)]], {
+ req(input$database_name)
+ req(!(input$database_name %in% primary_database_names()))
+
+ parameter_table <- session$userData$parameters_db[[table_name]]
+ if (nrow(parameter_table) == 0) return()
+
+ # Find which record is selected
+ selected_row <- which(vapply(
+ seq_len(nrow(parameter_table)),
+ function(i) isTRUE(input[[paste0("selected_row_", table_name, "_", i)]]),
+ logical(1)
+ ))
+ req(length(selected_row) == 1)
+
+ # Clone the selected record and ensure unique ID
+ cloned_record <- parameter_table[selected_row, , drop = FALSE]
+ id_column <- names(parameter_table)[1]
+
+ if (!is.na(cloned_record[[id_column]]) && cloned_record[[id_column]] != "") {
+ cloned_record[[id_column]] <- paste0(cloned_record[[id_column]], "_clone")
+ } else {
+ cloned_record[[id_column]] <- "new_clone"
+ }
+
+ # Insert cloned record immediately after original
+ if (selected_row < nrow(parameter_table)) {
+ parameter_table <- rbind(
+ parameter_table[1:selected_row, ],
+ cloned_record,
+ parameter_table[(selected_row + 1):nrow(parameter_table), ]
+ )
+ } else {
+ parameter_table <- rbind(parameter_table, cloned_record)
+ }
+
+ # Update memory and persist to disk
+ session$userData$parameters_db[[table_name]] <- parameter_table
+ fwrite(
+ parameter_table,
+ file.path(
+ session$userData$user_folder,
+ "parameters_database",
+ input$database_name,
+ paste0(table_name, ".csv")
+ )
+ )
+
+ # Keep scroll position for a seamless editing experience
+ freeze_and_unfreeze_scroll(session, ns(paste0("table_", table_name)))
+ })
+ })
+})
+}
diff --git a/R/40_mod_params_db_ui.R b/R/40_mod_params_db_ui.R
index 76dadaf..d9d1034 100644
--- a/R/40_mod_params_db_ui.R
+++ b/R/40_mod_params_db_ui.R
@@ -7,13 +7,23 @@ params_db_ui <- function(id) {
class = "container",
# ------ Last Update -----------------------------------------------------
p(
- class = "pt-3 pb-5 text-end text-primary text-small",
+ class = "pt-3 pb-4 text-end text-primary text-small",
span("Last update: "),
span(strong(id = ns("last_update_date")))
),
),
+ div(
+ class = "container mt-2 mb-2",
+ style = "text-align: left",
+ a(
+ class = "editInformationBtn",
+ icon("chevron-left", class = "editInfoIcon"),
+ "Scenario - Enterprise Description",
+ onclick = go_to(target = "scenario")
+ )
+ ),
fixedPage(
- class = "bg-light px-4 pt-5 pb-5 mt-5 mb-5",
+ class = "bg-light px-4 pt-5 pb-5 mt-4 mb-4",
style = "margin-top: 20px;",
h2("Choose a parameters database option:", class = "mb-3"),
fluidRow(
@@ -89,7 +99,8 @@ params_db_ui <- function(id) {
shinyWidgets::pickerInput(
inputId = ns("database_name"),
label = NULL,
- choices = NULL
+ choices = NULL,
+ options = list(`live-search` = TRUE)
)
)
),
@@ -155,7 +166,8 @@ params_db_ui <- function(id) {
shinyWidgets::pickerInput(
inputId = ns("database_shared_folder"),
label = NULL,
- choices = NULL
+ choices = NULL,
+ options = list(`live-search` = TRUE)
)
)
)
@@ -233,21 +245,10 @@ params_db_ui <- function(id) {
)
)
),
- div(
- class = "container mt-2 mb-2",
- style = "text-align: left",
- a(
- class = "editInformationBtn",
- icon("chevron-left", class = "editInfoIcon"),
- "Scenario - Enterprise Description",
- onclick = go_to(target = "scenario")
- )
- ),
fixedPage(
- style = "margin-top: 50px;",
fluidRow(
class = "bg-light",
- style = "margin-top: 50px;",
+ style = "margin-top: 40px;",
div(
class = "custom-tab-width",
# Use lapply to loop over each tab name and generate the tabPanels
@@ -256,10 +257,16 @@ params_db_ui <- function(id) {
c(
id = "tabs",
lapply(
- c("lkp_feeditem", "lkp_feedtype", "lkp_livetype"),
+ c("lkp_feeditem", "lkp_crops", "lkp_livetype"),
function(tab_name) {
+ # Custom tab titles mapping
+ tab_titles <- c(
+ "lkp_feeditem" = "Feeditems",
+ "lkp_crops" = "Crops",
+ "lkp_livetype" = "Livetype"
+ )
tabPanel(
- str_to_title(sub("^lkp_", "", tab_name)),
+ tab_titles[tab_name],
div(
class = "p-5 bg-light",
fluidRow(
@@ -273,6 +280,19 @@ params_db_ui <- function(id) {
icon = icon("plus")
)
),
+ column(
+ width = 3,
+ div(
+ br(),
+ class = "d-flex align-items-center px-1",
+ actionButton(
+ inputId = ns(paste0("clone_rows_", tab_name)),
+ label = "Clone Row",
+ class = "btn btn-primary filters-btn",
+ icon = icon("copy")
+ )
+ )
+ ),
column(
width = 3,
div(
@@ -287,7 +307,16 @@ params_db_ui <- function(id) {
)
)
),
+ # Alert for duplicate code warnings
+ shinyjs::hidden(
+ div(
+ id = ns(paste0("alert_duplicate_code_", tab_name)),
+ class = "alert alert-danger",
+ style = "display:none;"
+ )
+ ),
div(DTOutput(ns(paste0("table_", tab_name))), class = "with_checkbox"),
+ # Informational message: edits are auto-saved to CSV
tags$div(
"The data is immediately saved to the corresponding CSV
file, no confirmation is required!",
@@ -296,8 +325,10 @@ params_db_ui <- function(id) {
font-weight: 500; text-align: left; color: #005275;
font-family: 'serif , Merriweather';"
)
+
)
)
+
}
)
)
@@ -306,4 +337,4 @@ params_db_ui <- function(id) {
)
)
)
-}
+}
\ No newline at end of file
diff --git a/R/helpers_ui.R b/R/helpers_ui.R
new file mode 100644
index 0000000..54dd972
--- /dev/null
+++ b/R/helpers_ui.R
@@ -0,0 +1,27 @@
+# UI helpers - shared patterns across modules -------------------------------
+
+#' Show/hide folder choice UIs based on radio button selection.
+#' Used when user selects "User Folder", "Shared Examples", or "Shared Pool".
+#' Keeps the same pattern in scenario and params_db modules for consistency.
+#'
+#' @param folder_value Character: "user", "shared", or "pool" from the radio input
+#' @param ns Namespace function (e.g. session$ns from a Shiny module)
+#' @noRd
+show_hide_folder_ui <- function(folder_value, ns) {
+ if (folder_value == "user") {
+ # Show User Folder UI and hide the others
+ shinyjs::show(id = ns("user_folder_ui"))
+ shinyjs::hide(id = ns("shared_examples_ui"))
+ shinyjs::hide(id = ns("shared_pool_ui"))
+ } else if (folder_value == "shared") {
+ # Show Shared Examples UI and hide the others
+ shinyjs::show(id = ns("shared_examples_ui"))
+ shinyjs::hide(id = ns("user_folder_ui"))
+ shinyjs::hide(id = ns("shared_pool_ui"))
+ } else if (folder_value == "pool") {
+ # Show Shared Pool UI and hide the others
+ shinyjs::show(id = ns("shared_pool_ui"))
+ shinyjs::hide(id = ns("user_folder_ui"))
+ shinyjs::hide(id = ns("shared_examples_ui"))
+ }
+}
diff --git a/R/scenario/32_scenario_seasons.R b/R/scenario/32_scenario_seasons.R
new file mode 100644
index 0000000..4b73ea0
--- /dev/null
+++ b/R/scenario/32_scenario_seasons.R
@@ -0,0 +1,119 @@
+# ----------- Seasons Tab --------------------------------------------------------
+# Sub-module: seasons management (reactive, observers, table render)
+# Sourced from 30_mod_scenario_server.R with local = TRUE
+# Reactive value to store the seasons data
+seasons <- reactiveVal(seasons_initialization)
+
+# Add season button click
+observeEvent(input$add_season, {
+ req(input$json_file_name)
+ if (modal_open()) return()
+ modal_open(TRUE)
+ showModal(modalDialog(
+ title = "Add season",
+ h2("Season name:", class = "mb-3"),
+ textInput(ns("season_name"), label = NULL),
+ easyClose = TRUE,
+ footer = tagList(
+ actionButton(ns("ok_add_season"), "OK"),
+ modalButton("Cancel")
+ )
+ ))
+})
+
+# OK button in modal dialog for adding season
+observeEvent(input$ok_add_season, {
+ req(input$season_name)
+ current_seasons <- seasons()
+ if (!input$season_name %in% current_seasons$Season) {
+ days_left <- max(365 - sum(current_seasons$Days), 0)
+ new_row <- data.frame(Season = input$season_name, Days = days_left)
+ updated_seasons <- rbind(current_seasons, new_row)
+ seasons(updated_seasons)
+ }
+ updateTextInput(session, "season_name", value = "")
+ removeModal()
+})
+
+# Render the table
+output$season_table <- renderDT({
+
+ # Re-initialize the season data if the columns are missing (show empty table on start)
+ if (ncol(seasons()) == 0) {
+ seasons(seasons_initialization)
+ }
+
+ season_dt <- seasons()
+
+ # Checkboxes for selecting rows (to be deleted)
+ season_dt$selected_season <- generate_shiny_inputs(
+ FUN = checkboxInput,
+ len = nrow(season_dt),
+ id = ns("selected_season"),
+ value = rep(FALSE, nrow(season_dt)),
+ width = "2px"
+ )
+ # Move the 'selected_season' column to the first position
+ season_dt <- season_dt[, c("selected_season", setdiff(names(season_dt), "selected_season"))]
+
+ datatable(
+ season_dt,
+ editable = list(
+ target = "cell",
+ # Prevent editing of the first column (check boxes for delete rows)
+ disable = list(columns = 0)
+ ),
+ escape = FALSE,
+ selection = "none",
+ rownames = FALSE,
+ # Set the first column (selected) name to an empty string
+ colnames = c("", colnames(season_dt)[-1]),
+ options = list(
+ dom = "t",
+ paging = FALSE,
+ columnDefs = list(
+ # 2 px width for the first column (checkboxes)
+ list(width = "50px", targets = 0)
+ ),
+ # Link renderDT's checkbox to the shiny input (not automatic)
+ drawCallback = JS(checkbox_link(id = "selected_season", ns = ns))
+ )
+ )
+}, server = FALSE)
+
+# Delete season button click
+observeEvent(input$delete_season, {
+ req(nrow(seasons()) > 0) # Ensure there are rows to process
+ selected <- which(
+ sapply(
+ seq_len(nrow(seasons())),
+ function(i) input[[paste0("selected_season", i)]]
+ )
+ )
+ if (length(selected)) {
+ current_seasons <- seasons()
+ updated_seasons <- current_seasons[-selected, ]
+ seasons(updated_seasons)
+ }
+})
+
+# Update season table data with edited values
+observeEvent(input$season_table_cell_edit, {
+ info <- input$season_table_cell_edit
+ new_data <- seasons()
+
+ # Update the specific cell while preserving the column's data type
+ new_data <- update_cell(new_data, info, offset = 0)
+
+ seasons(new_data)
+})
+
+# Observe the season data and show/hide the error message
+observeEvent(seasons(), {
+ # if the sum of days is 365, hide the error message
+ if (nrow(seasons()) == 0 || sum(seasons()$Days) == 365) {
+ shinyjs::hide(id = "alert_message_season")
+ } else {
+ shinyjs::show(id = "alert_message_season")
+ }
+})
diff --git a/R/scenario/33_scenario_fertilizer.R b/R/scenario/33_scenario_fertilizer.R
new file mode 100644
index 0000000..3fa6a80
--- /dev/null
+++ b/R/scenario/33_scenario_fertilizer.R
@@ -0,0 +1,149 @@
+# ----------- Manure/Fertilizer Tab ----------------------------------------------
+# Sub-module: fertilizer management
+# Sourced from 30_mod_scenario_server.R with local = TRUE
+# Reactive value to store the fertilizer data
+fertilizers <- reactiveVal(fertilizers_initialization)
+
+# Add fertilizer button click
+observeEvent(input$add_fertilizer, {
+ req(input$json_file_name)
+ if (modal_open()) return()
+ modal_open(TRUE)
+ showModal(modalDialog(
+ title = "Add new fertilizer",
+ h2("Choose a Fertilizer", class = "mb-3"),
+ shinyWidgets::pickerInput(
+ ns("fertilizer_code"),
+ choices = setNames(
+ lkp_orgfertilizer()$fertilizer_code,
+ lkp_orgfertilizer()$fertilizer_desc
+ )[sort(lkp_orgfertilizer()$fertilizer_desc)],
+ options = list(`live-search` = TRUE)
+ ),
+ easyClose = TRUE,
+ footer = tagList(
+ actionButton(ns("ok_add_fertilizer"), "OK"),
+ modalButton("Cancel")
+ )
+ ))
+})
+
+# OK button in modal dialog for adding fertilizer
+observeEvent(input$ok_add_fertilizer, {
+ req(input$fertilizer_code)
+ current_fertilizers <- fertilizers()
+ if (!input$fertilizer_code %in% current_fertilizers$fertilizer_code) {
+ fertilizer_name <- lkp_orgfertilizer()$fertilizer_desc[
+ lkp_orgfertilizer()$fertilizer_code == input$fertilizer_code
+ ]
+ new_row <- data.frame(
+ fertilizer_code = input$fertilizer_code,
+ fertilizer_desc = fertilizer_name,
+ fraction = 0,
+ percentage_n = ifelse(fertilizer_name %in% names(fertilizer_percentages),
+ fertilizer_percentages[fertilizer_name], 0)
+ )
+ updated_fertilizers <- rbind(current_fertilizers, new_row)
+ fertilizers(updated_fertilizers)
+ }
+ # Reset the select input
+ shinyWidgets::updatePickerInput(
+ session,
+ "fertilizer_code",
+ selected = setNames(lkp_orgfertilizer()$fertilizer_code, lkp_orgfertilizer()$fertilizer_desc)[1]
+ )
+ removeModal()
+})
+
+# Render the fertilizer table
+output$fertilizer_table <- renderDT({
+
+ # Re-initialize the fertilizer data if the columns are missing (show empty table on start)
+ if (ncol(fertilizers()) == 0) {
+ fertilizers(fertilizers_initialization)
+ }
+
+ # Identify rows to disable based on fertilizer names
+ fertilizers_data <- fertilizers() %>% select(-fertilizer_code, -fraction)
+ rows_to_disable <- which(
+ fertilizers_data$fertilizer_desc %in% names(fertilizer_percentages)
+ ) - 1
+
+ # Checkboxes for selecting rows (to be deleted)
+ fertilizers_data$selected_fertilizer <- generate_shiny_inputs(
+ FUN = checkboxInput,
+ len = nrow(fertilizers_data),
+ id = ns("selected_fertilizer"),
+ value = rep(FALSE, nrow(fertilizers_data)),
+ width = "2px"
+ )
+
+ # Move the 'selected_fertilizer' column to the first position
+ fertilizers_data <- fertilizers_data[
+ , c("selected_fertilizer", setdiff(names(fertilizers_data), "selected_fertilizer"))
+ ]
+
+ datatable(
+ fertilizers_data,
+ colnames = c("", "Fertilizer", "% N"), # Set the first column (selected) name to an empty string
+ editable = list(
+ target = "cell",
+ # Prevent editing of the first column (check boxes for delete rows)
+ disable = list(columns = 0)
+ ),
+ selection = "none",
+ rownames = FALSE,
+ escape = FALSE,
+ options = list(
+ dom = "t",
+ paging = FALSE,
+ columnDefs = list(
+ list(
+ width = "2px", # Define the width of the checkbox column
+ targets = 0
+ ),
+ # Disable editing fertilizer's column
+ list(
+ targets = get_column_indices(fertilizers_data, "fertilizer_desc") - 1,
+ createdCell = JS(disable_all_rows_edit_js()),
+ searchable = FALSE
+ ),
+ # Disable editing for specific rows in the % N column
+ list(
+ targets = get_column_indices(fertilizers_data, "percentage_n") - 1,
+ createdCell = JS(disable_specific_rows_edit_js(rows_to_disable)),
+ searchable = FALSE
+ )
+ ),
+ # Link renderDT's checkbox to the shiny input (not automatic)
+ drawCallback = JS(checkbox_link(id = "selected_fertilizer", ns = ns))
+ )
+ )
+}, server = FALSE)
+
+# Delete fertilizer button click
+observeEvent(input$delete_fertilizer, {
+ req(nrow(fertilizers()) > 0) # Ensure there are rows to process
+ selected <- which(
+ sapply(
+ seq_len(nrow(fertilizers())),
+ function(i) input[[paste0("selected_fertilizer", i)]]
+ )
+ )
+ if (length(selected)) {
+ current_fertilizers <- fertilizers()
+ updated_fertilizers <- current_fertilizers[-selected, ]
+ fertilizers(updated_fertilizers)
+ }
+})
+
+# Update fertilizer table data with edited values
+observeEvent(input$fertilizer_table_cell_edit, {
+ info <- input$fertilizer_table_cell_edit
+ new_data <- fertilizers()
+
+ # Update the specific cell while preserving the column's data type
+ new_data <- update_cell(new_data, info, offset = 2)
+
+ fertilizers(new_data)
+})
diff --git a/R/scenario/34_scenario_area.R b/R/scenario/34_scenario_area.R
new file mode 100644
index 0000000..c23d28b
--- /dev/null
+++ b/R/scenario/34_scenario_area.R
@@ -0,0 +1,42 @@
+# ----------- Area tab ---------------------------------------------------------
+# Sub-module: area/soil/cropland/grassland observers
+# Sourced from 30_mod_scenario_server.R with local = TRUE
+observeEvent(input$soil_description, {
+ selected_soil <- input$soil_description
+ k_value <- lkp_soil()$k_value[lkp_soil()$soil_desc == selected_soil]
+ updateNumericInput(session, "soil_k_value", value = k_value)
+})
+
+observeEvent(input$cropland_system, {
+ selected_system <- input$cropland_system
+ change_factor <- lkp_croplandsystem()$change_factor[lkp_croplandsystem()$sys_desc == selected_system]
+ updateNumericInput(session, "cropland_system_ipcc", value = change_factor)
+})
+
+observeEvent(input$cropland_tillage, {
+ selected_tillage <- input$cropland_tillage
+ change_factor <- lkp_tillageregime()$change_factor[lkp_tillageregime()$tillage_desc == selected_tillage]
+ updateNumericInput(session, "cropland_tillage_ipcc", value = change_factor)
+})
+
+observeEvent(input$cropland_orgmatter, {
+ selected_input <- input$cropland_orgmatter
+ change_factor <- lkp_organicmatter()$change_factor[lkp_organicmatter()$orgmatter_desc == selected_input]
+ updateNumericInput(session, "cropland_orgmatter_ipcc", value = change_factor)
+})
+
+observeEvent(input$grassland_management, {
+ selected_management <- input$grassland_management
+ change_factor <- lkp_grasslandman()$change_factor[
+ lkp_grasslandman()$management_desc == selected_management
+ ]
+ updateNumericInput(session, "grassland_management_ipcc", value = change_factor)
+})
+
+observeEvent(input$grassland_implevel, {
+ selected_input_level <- input$grassland_implevel
+ change_factor <- lkp_grassinputlevel()$change_factor[
+ lkp_grassinputlevel()$grassinputlevel_desc == selected_input_level
+ ]
+ updateNumericInput(session, "grassland_implevel_ipcc", value = change_factor)
+})
diff --git a/R/scenario/35_scenario_livestock.R b/R/scenario/35_scenario_livestock.R
new file mode 100644
index 0000000..9f590e8
--- /dev/null
+++ b/R/scenario/35_scenario_livestock.R
@@ -0,0 +1,393 @@
+# ----------- Livestock tab ------------------------------------------------------
+# Sub-module: livestock management
+# Sourced from 30_mod_scenario_server.R with local = TRUE
+# Initial data frame
+livestock_data <- reactiveVal(livestock_data_initialization)
+
+# Add reactive for the selected cell
+selected_cell <- reactiveVal()
+
+# Add livestock button click
+observeEvent(input$add_livestock, {
+ req(input$json_file_name)
+ if (modal_open()) return()
+ modal_open(TRUE)
+ showModal(modalDialog(
+ title = "Add livestock",
+ h2("Choose a livestock category", class = "mb-3"),
+ shinyWidgets::pickerInput(
+ ns("livestock"),
+ label = NULL,
+ choices = setNames(
+ lkp_livetype()$livetype_code,
+ lkp_livetype()$livetype_desc
+ )[sort(lkp_livetype()$livetype_desc)],
+ options = list(`live-search` = TRUE)
+ ),
+ easyClose = TRUE,
+ footer = tagList(
+ actionButton(ns("ok_add_livestock"), "OK"),
+ modalButton("Cancel")
+ )
+ ))
+})
+
+# Add new livestock row from modal
+observeEvent(input$ok_add_livestock, {
+ req(input$livestock)
+ if (!(input$livestock %in% livestock_data()[, "livetype_code"])) {
+ selected_livestock <- lkp_livetype()[lkp_livetype()$livetype_code == input$livestock, ]
+ manureman_selection <- lkp_manureman()$manureman_desc[1]
+ new_row <- data.frame(
+ livetype_code = as.character(selected_livestock$livetype_code),
+ livetype_desc = selected_livestock$livetype_desc,
+ herd_composition = 0,
+ annual_milk = 0,
+ annual_wool = 0,
+ annual_growth = 0,
+ time_in_stable = 0,
+ manure_in_stable = 0,
+ manureman_stable = manureman_selection,
+ time_in_non_roofed_enclosure = 0,
+ manure_in_non_roofed_enclosure = 0,
+ manureman_non_roofed_enclosure = manureman_selection,
+ time_in_onfarm_grazing = 0,
+ manure_in_field = 0,
+ manureman_onfarm_grazing = manureman_selection,
+ time_in_offfarm_grazing = 0,
+ manureman_offfarm_grazing = manureman_selection,
+ distance_to_pasture = 0,
+ manure_onfarm_fraction = 0,
+ manure_sales_fraction = 0,
+ body_weight = selected_livestock$body_weight,
+ body_weight_weaning = 0,
+ body_weight_year_one = 0,
+ adult_weight = 0,
+ work_hour = 0,
+ litter_size = selected_livestock$litter_size,
+ piglets_relying_on_milk = 0,
+ lactation_length = selected_livestock$lactation_length,
+ proportion_growth_piglets_milk = selected_livestock$proportion_growth_piglets_milk,
+ lw_gain_piglets = selected_livestock$lw_gain_piglets,
+ cp_maintenance = selected_livestock$cp_maintenance,
+ cp_lys_pregnancy = selected_livestock$cp_lys_pregnancy,
+ cp_lactmilk = selected_livestock$cp_lactmilk,
+ cp_lys_growth = selected_livestock$cp_lys_growth,
+ birth_interval = selected_livestock$birth_interval,
+ protein_milkcontent = selected_livestock$protein_milkcontent,
+ fat_milkcontent = selected_livestock$fat_milkcontent,
+ energy_milkcontent = selected_livestock$energy_milkcontent,
+ energy_meatcontent = selected_livestock$energy_meatcontent,
+ protein_meatcontent = selected_livestock$protein_meatcontent,
+ carcass_fraction = selected_livestock$carcass_fraction,
+ n_manure_content = selected_livestock$n_manure_content,
+ meat_product = selected_livestock$meat_product,
+ milk_product = selected_livestock$milk_product,
+ ipcc_ef_category_t1 = selected_livestock$ipcc_meth_ef_t1,
+ ipcc_ef_category_t2 = selected_livestock$ipcc_meth_ef_t2,
+ ipcc_meth_man_category = selected_livestock$ipcc_meth_man,
+ ipcc_n_exc_category = selected_livestock$ipcc_meth_exc,
+ stringsAsFactors = FALSE
+ )
+ livestock_data(rbind(livestock_data(), new_row))
+ }
+
+ # Freeze and restore scroll position for livestock table
+ freeze_and_unfreeze_scroll(session, ns("livestock_table"))
+
+ shinyWidgets::updatePickerInput(
+ session,
+ "livestock",
+ selected = setNames(lkp_livetype()$livetype_code, lkp_livetype()$livetype_desc)[1]
+ )
+ removeModal()
+})
+
+# Render the table
+output$livestock_table <- renderDT({
+ livestock_dt <- livestock_data()
+
+ # Apply bold and underline formatting to selectInputs text
+ livestock_dt[manure_cols] <- lapply(livestock_dt[manure_cols], format_text_displayed)
+
+ # Remove the 'livetype_code' column
+ livestock_dt <- livestock_dt %>%
+ select(-livetype_code)
+
+ # Checkboxes for selecting rows (to be deleted)
+ livestock_dt$selected_livestock <- generate_shiny_inputs(
+ FUN = checkboxInput,
+ len = nrow(livestock_dt),
+ id = ns("selected_livestock"),
+ value = rep(FALSE, nrow(livestock_dt)),
+ width = "2px"
+ )
+ # Move the 'selected_livestock' column to the first position
+ livestock_dt <- livestock_dt[, c("selected_livestock", setdiff(names(livestock_dt), "selected_livestock"))]
+
+ datatable(
+ livestock_dt,
+ colnames = livestock_table_colnames,
+ editable = list(
+ target = "cell",
+ # Prevent editing of the first column (check boxes for delete rows)
+ disable = list(columns = 0)
+ ),
+ selection = "none",
+ rownames = FALSE,
+ escape = FALSE,
+ extensions = "FixedColumns",
+ options = list(
+ scrollX = TRUE,
+ dom = "t",
+ paging = FALSE,
+ fixedColumns = list(leftColumns = 2),
+ columnDefs = list(
+ list(
+ targets = get_column_indices(
+ livestock_dt,
+ c("livetype_desc", # Disable editing for livestock type
+ "manureman_stable",
+ "manureman_non_roofed_enclosure",
+ "manureman_onfarm_grazing",
+ "manureman_offfarm_grazing",
+ "ipcc_ef_category_t1",
+ "ipcc_ef_category_t2",
+ "ipcc_meth_man_category",
+ "ipcc_n_exc_category"
+ )
+ ) - 1,
+ createdCell = JS(disable_all_rows_edit_js()),
+ searchable = FALSE
+ )
+ ),
+ # Link renderDT's checkbox to the shiny input (not automatic)
+ drawCallback = JS(checkbox_link(id = "selected_livestock", ns = ns))
+ )
+ ) %>%
+ formatStyle(
+ columns = c(
+ "herd_composition", "annual_milk", "annual_wool", "annual_growth",
+ "time_in_stable", "manure_in_stable", "manureman_stable",
+ "time_in_non_roofed_enclosure", "manure_in_non_roofed_enclosure",
+ "manureman_non_roofed_enclosure", "time_in_onfarm_grazing",
+ "manure_in_field", "manureman_onfarm_grazing", "time_in_offfarm_grazing",
+ "manureman_offfarm_grazing", "distance_to_pasture",
+ "manure_onfarm_fraction", "manure_sales_fraction"
+ ),
+ backgroundColor = "#a9d18e"
+ ) %>%
+ formatStyle(
+ columns = c(
+ "body_weight", "body_weight_weaning", "body_weight_year_one",
+ "adult_weight", "work_hour", "litter_size", "piglets_relying_on_milk",
+ "lactation_length", "proportion_growth_piglets_milk", "lw_gain_piglets",
+ "cp_maintenance", "cp_lys_pregnancy", "cp_lactmilk",
+ "cp_lys_growth", "birth_interval", "protein_milkcontent",
+ "fat_milkcontent", "energy_milkcontent", "energy_meatcontent",
+ "protein_meatcontent", "carcass_fraction", "n_manure_content",
+ "meat_product", "milk_product", "ipcc_ef_category_t1",
+ "ipcc_ef_category_t2", "ipcc_meth_man_category", "ipcc_n_exc_category"
+ ),
+ backgroundColor = "#f4b183"
+ )
+}, server = FALSE)
+
+# Update the table data when edited
+observeEvent(input$livestock_table_cell_edit, {
+ info <- input$livestock_table_cell_edit
+ new_data <- livestock_data()
+
+ # Update the specific cell while preserving the column's data type
+ new_data <- update_cell(new_data, info, offset = 1)
+
+ # Freeze and restore scroll position for livestock table
+ freeze_and_unfreeze_scroll(session, ns("livestock_table"))
+
+ livestock_data(new_data)
+})
+
+# Delete selected row
+observeEvent(input$delete_livestock, {
+ req(nrow(livestock_data()) > 0) # Ensure there are rows to process
+ selected_row <- which(
+ sapply(
+ seq_len(nrow(livestock_data())),
+ function(i) input[[paste0("selected_livestock", i)]]
+ )
+ )
+ if (length(selected_row) > 0) {
+ new_data <- livestock_data()
+ new_data <- new_data[-selected_row, ]
+ livestock_data(new_data)
+ }
+
+ # Freeze and restore scroll position for livestock table
+ freeze_and_unfreeze_scroll(session, ns("livestock_table"))
+})
+
+# ------ LIVESTOCK TIME FRACTIONS VALIDATION ---------------------------------
+observeEvent(livestock_data(), {
+ # Always hide previous warnings at the start to avoid stale messages
+ shinyjs::hide("alert_message_livestock_invalid_values_inputs")
+ shinyjs::hide("alert_message_livestock_invalid_sum_inputs")
+
+ # Validate input data: ensure data exists and contains at least one row
+ time_input <- livestock_data()
+ if (is.null(time_input) || nrow(time_input) == 0) return()
+
+ # Identify the expected time-fraction columns
+ expected_columns <- c(
+ "time_in_stable",
+ "time_in_non_roofed_enclosure",
+ "time_in_onfarm_grazing",
+ "time_in_offfarm_grazing"
+ )
+
+ # Keep only columns that exist in the current dataset
+ valid_columns <- intersect(expected_columns, names(time_input))
+ if (length(valid_columns) == 0) return()
+
+ # Extract subset of time allocation data
+ time_data <- time_input[valid_columns]
+
+ # Map backend variable names to display labels
+ display_labels <- livestock_table_colnames[
+ match(valid_columns, names(livestock_data_initialization))
+ ]
+
+ # Initialize result containers
+ invalid_value_messages <- character(0)
+ livestock_invalid_values <- character(0)
+ invalid_sum_messages <- character(0)
+ livestock_invalid_sums <- character(0)
+
+ # Check for invalid fraction values (<0 or >1)
+ for (i in seq_along(valid_columns)) {
+ column_name <- valid_columns[i]
+ column_label <- display_labels[i]
+ fraction_values <- time_data[[column_name]]
+
+ invalid_rows <- which(fraction_values < 0 | fraction_values > 1)
+ if (length(invalid_rows) == 0) next
+
+ livestock_names <- time_input$livetype_desc[invalid_rows]
+ invalid_values <- fraction_values[invalid_rows]
+
+ messages <- sprintf(
+ "• For %s , the value in
+ '%s' is %s . It must be ≥ 0 and ≤ 1!",
+ livestock_names, column_label, invalid_values
+ )
+
+ invalid_value_messages <- c(invalid_value_messages, messages)
+ livestock_invalid_values <- c(livestock_invalid_values, livestock_names)
+ }
+
+ # Check for invalid totals (sum of all four fractions ≠ 1)
+ row_sums <- rowSums(time_data, na.rm = TRUE)
+
+ # Use a small tolerance when checking equality to 1
+ # This avoids false warnings from floating-point rounding errors
+ tolerance <- 1e-6
+ invalid_sum_rows <- which(abs(row_sums - 1) > tolerance)
+
+ if (length(invalid_sum_rows) > 0) {
+ livestock_names <- time_input$livetype_desc[invalid_sum_rows]
+ total_values <- row_sums[invalid_sum_rows]
+
+ # Display decimals only when needed (e.g., 0.9998 vs 1)
+ formatted_totals <- ifelse(
+ abs(total_values %% 1) < 1e-6,
+ as.character(round(total_values, 0)),
+ formatC(total_values, format = "f", digits = 4)
+ )
+
+ messages <- sprintf(
+ "• For %s , the total across
+ the four time-fraction columns is %s . It must equal 1!",
+ livestock_names, formatted_totals
+ )
+
+ invalid_sum_messages <- c(invalid_sum_messages, messages)
+ livestock_invalid_sums <- c(livestock_invalid_sums, livestock_names)
+ }
+
+ # Sort messages alphabetically by livestock name
+ if (length(invalid_value_messages) > 0) {
+ order_index <- order(tolower(livestock_invalid_values))
+ invalid_value_messages <- invalid_value_messages[order_index]
+ }
+
+ if (length(invalid_sum_messages) > 0) {
+ order_index <- order(tolower(livestock_invalid_sums))
+ invalid_sum_messages <- invalid_sum_messages[order_index]
+ }
+
+ # Display messages if there are issues
+ if (length(invalid_value_messages) > 0) {
+ shinyjs::html(
+ "alert_message_livestock_invalid_values_inputs",
+ html = paste(invalid_value_messages, collapse = " inside alerts */
+ strong {
+ font-weight: 600;
+ color: inherit;
+ }
+ }
+}
+
+
/* Add x-axis only for pie chart (plot_water_feed) */
.plot_water_feed {
@@ -1369,3 +1448,149 @@ table.dataTable tbody tr>.dtfc-fixed-left{
}
}
}
+
+:root {
+ // Default sizing constraints used by all Bootstrap-select menus
+ --picker-min-height: 96px; // ensure a usable scroll pane
+ --picker-max-height: 210px; // baseline cap for standard pages
+ --picker-viewport-cap: calc(100vh - 220px); // guard against viewport overflow
+}
+
+// ------ Adaptive Bootstrap-select Dropdown Height ---------------------------
+.bootstrap-select {
+ // Effective max height; modals can override this via --modal-picker-max-height
+ --picker-effective-max-height: var(--picker-max-height);
+
+ .inner.open {
+ // Keep the menu scrollable while respecting both modal and viewport limits
+ max-height: clamp(
+ var(--picker-min-height, 96px),
+ var(--picker-effective-max-height),
+ var(--picker-viewport-cap, 70vh)
+ ) !important;
+ min-height: var(--picker-min-height, 96px);
+ overflow-y: auto !important;
+ }
+}
+
+.modal {
+ .bootstrap-select {
+ --picker-effective-max-height: var(--modal-picker-max-height, var(--picker-max-height));
+
+ // Allow long option labels to wrap naturally inside modal dropdowns
+ .dropdown-menu {
+ .dropdown-item {
+ align-items: flex-start;
+
+ .text {
+ display: block;
+ max-width: none;
+ white-space: normal; // wrap only on word boundaries
+ overflow: visible;
+ text-overflow: clip;
+ }
+ }
+ }
+ }
+}
+
+/* ========================================================= */
+/* === RESPONSIVE MODAL WIDTH (WIDER BELOW 1300PX) ========= */
+/* ========================================================= */
+
+.modal-dialog.modal-lg {
+ width: 72vw; /* default width for large screens */
+ max-width: 1160px; /* baseline for desktops */
+ margin: auto;
+ display: flex;
+ align-items: center;
+ justify-content: center;
+}
+
+/* ========================================================= */
+/* === RESPONSIVE MODAL WIDTH (+30% BELOW 1300PX) ========== */
+/* ========================================================= */
+
+.modal-dialog.modal-lg {
+ width: 72vw; /* default width for large screens */
+ max-width: 1160px; /* baseline for desktops */
+ margin: auto;
+ display: flex;
+ align-items: center;
+ justify-content: center;
+}
+
+/* Widen modal by ~30% on smaller screens */
+@media (max-width: 1299.98px) {
+ .modal-dialog.modal-lg {
+ width: 94vw !important; /* becomes ~30% wider than 72vw */
+ max-width: 1508px !important; /* 1160 × 1.3 = 1508px cap */
+ margin: auto;
+ --bs-modal-margin: 0.75rem; /* smaller outer margin for tight viewports */
+ }
+
+ .modal .modal-body {
+ padding: calc(2rem + 1vw) calc(2.5rem + 1vw); /* proportional padding */
+ }
+}
+
+/* ======================================== */
+/* ======= DATATABLE COLUMN SEARCH ======= */
+/* ======================================== */
+
+/* Styles for the second header row containing column search inputs */
+table.dataTable thead tr:nth-child(2) th {
+ vertical-align: bottom !important;
+ padding: 2px !important;
+ line-height: 1 !important;
+ box-sizing: border-box !important;
+ background-color: #f5f5f5 !important;
+ overflow: hidden !important;
+ max-width: 100% !important;
+ min-width: 0 !important;
+
+ /* Search input field styling */
+ input[type="text"] {
+ width: 100% !important;
+ padding: 4px 8px !important;
+ margin: 0 !important;
+ border: 1px solid #005275 !important;
+ border-radius: 4px !important;
+ font-size: 12px !important;
+ line-height: 1.4 !important;
+ box-sizing: border-box !important;
+ color: #005275 !important;
+
+ /* Focus state styling */
+ &:focus {
+ border: 2px solid #005275 !important;
+ outline: none !important;
+ padding: 3px 7px !important;
+ }
+ }
+}
+
+/* Fix first column search cell to stay with fixed column */
+table.dataTable thead tr.search-row th:first-child {
+ position: sticky !important;
+ left: 0 !important;
+ z-index: 3 !important;
+ background-color: #f5f5f5 !important;
+}
+
+/* Hide the global DataTables search filter */
+.dataTables_filter {
+ display: none !important;
+}
+
+/* ===================== */
+/* ==== CROP NAME ===== */
+/* ===================== */
+.crop-name-cell {
+ cursor: pointer;
+ color: #005275;
+ text-align: left !important;
+ &:hover {
+ text-decoration: underline;
+ }
+}
\ No newline at end of file
diff --git a/www/sass/hack.scss b/www/sass/hack.scss
index a23a1e7..995b735 100644
--- a/www/sass/hack.scss
+++ b/www/sass/hack.scss
@@ -28,3 +28,25 @@
display: block !important;
}
}
+
+// Force climate picker to show all available options
+.climate-picker {
+ // Allow dropdown to overflow parent containers
+ overflow: visible !important;
+
+ .bootstrap-select {
+ .inner.open {
+ max-height: 90px !important;
+ overflow-y: auto !important;
+ }
+ .dropdown-menu {
+ max-height: 90px !important;
+ }
+ }
+}
+
+// Ensure carousel containers don't clip the dropdown
+.carousel-item:has(.climate-picker),
+.carousel-inner:has(.climate-picker) {
+ overflow: visible !important;
+}
\ No newline at end of file