#### SERVER ####
server <- function(input, output, session) {
# for local use : stop the server when the session ends
is_local <- Sys.getenv('SHINY_PORT') == ""
if(is_local) session$onSessionEnded(function() stopApp())
# Observe -----------------------------------------------------------------
observe_helpers()
## Get language in the url ####
lang <- dyn <- NULL
observe(priority = 1000, {
lang <<- isolate(getQueryString()$lang)
if (is.null(lang) || !(lang %in% c("fr", "en", "sp"))) {
lang <<- "fr"
}
})
## Plot themes ####
theme_update(text = element_text(family = "sans-serif"))
## Orchards map ####
output$pruning_orchard_map <- renderLeaflet({
leaflet(options = leafletOptions(maxZoom = 16)) %>%
setView(55.4884, -21.32264, zoom = 16) %>%
addProviderTiles("Esri.WorldImagery") %>%
addMarkers(55.4884, -21.32264)
})
#-21.322763, 55.490350
output$cultivar_orchard_map <- renderLeaflet({
leaflet(options = leafletOptions(maxZoom = 16)) %>%
setView(55.49035, -21.32276, zoom = 16) %>%
addProviderTiles("Esri.WorldImagery") %>%
addMarkers(55.49035, -21.32276)
})
# Essai taille ------------------------------------------------------------
# couleur des différents types de taille
coul_taille <- c(`taille_ete` = "#5acc56", `taille_hiver` = "#009eff", `taille_sans` = "#fb7017", bordure = "#0300000C")
## Plan de la parcelle ####
output$taille_parcelle <- renderGirafe({
taille %>%
distinct(X, Y, arbre, bloc, Taille) %>%
bind_rows(
tibble(
arbre = textesUI[textesUI$id == "bordure", lang],
bloc = "bordure",
Taille = "bordure",
X = rep(LETTERS[9:1], each = 2) %>% factor(),
Y = rep(c(1,17), times = 9) %>% factor()
)
) %>%
{ggplot(.) +
aes(x = X, y = Y, fill = Taille, data_id = Taille, tooltip = arbre) +
geom_tile_interactive(color = "black") +
scale_fill_manual(
values = coul_taille, labels = textesUI[textesUI$id %in% c(levels(taille$Taille), "bordure"), lang] %>% setNames(c(levels(taille$Taille), "bordure")),
guide = guide_legend(byrow = TRUE)
) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, fill = textesUI[textesUI$id == "taille_legend", lang])} %>%
girafe(
ggobj = ., height_svg = 4, width_svg = 4,
options = list(
opts_hover_inv(css = "opacity:0.2;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "fill:black;opacity:0.8;"),
opts_selection(type = "none")
)
)
})
## Description du cycle des tailles ####
output$cycles_taille <- renderPlot(res = 90, {
#' Data for pruning cycle graph: Pruning dates
#'
#' @format A data frame of 4 x 6
#'
#' \describe{
#' \item{Taille}{Type of pruning}
#' \item{Date_taille}{Pruning date}
#' \item{Depart}{Beginning of the arrow}
#' \item{Pointe}{End of the arrow}
#' \item{pos_img}{Position of the shears image}
#' \item{img}{Path to the shears image}
#' }
date_taille <- tibble(
Taille = rep(c("taille_hiver", "taille_ete"), times = 2),
Date_taille = c("2016-08-01", "2016-02-01", "2018-08-01", "2018-02-01") %>% as.Date(),
Depart = c(4, 4, 2, 2), # sens et position de la flèche
Pointe = Depart - 0.6,
pos_img = Depart + 0.5,
img = "www/shears_ratio.png"
) %>%
rowwise() %>%
mutate(
Taille = textesUI[textesUI$id == Taille, lang]
)
#' Data for pruning cycle graph: Date labels for the x axis
#'
#' @format A data frame of 47 x 3
#'
#' \describe{
#' \item{pas}{date break}
#' \item{pas_label}{first letter of the month}
#' \item{annee}{turn the year into a general identifier}
#' \item{etiquette}{date label, with a month format + the year id once per year}
#' }
date_labels <- tibble(
pas = seq(as.Date("2015-06-01"), as.Date("2019-04-01"), "month"),
pas_label = ifelse(
lang == "sp" & month(pas) == 1,
"E", # "enero" in spanish
month(pas, label = TRUE, locale = "C") %>% as.character() %>% str_sub(end = 1) %>% str_to_upper()
),
annee = paste(textesUI[textesUI$id == "annee", lang], year(pas) - 2015),
# etiquette = ifelse(month(pas) == 7, paste(format(pas, "%m"), annee, sep = "\n"), format(pas, "%m"))
etiquette = case_when(
month(pas) == 7 ~ paste(pas_label, annee, sep = "\n"),
month(pas) == 1 ~ paste(pas_label, "|", sep = "\n"),
TRUE ~ pas_label
)
)
ggplot(cycle) +
aes(x = Debut, y = Cycle) +
geom_vline(xintercept = seq(as.Date("2016-01-01"), as.Date("2019-01-01"), "year"), linewidth = 2, color = "white") +
geom_segment(
aes(xend = Fin, yend = Cycle, colour = Etape),
linewidth = 8
) +
geom_segment(
data = date_taille,
mapping = aes(x = Date_taille, xend = Date_taille, y = Depart, yend = Pointe),
arrow = arrow(length = unit(0.1, "inches")),
linewidth = 1, colour = "black"
) +
geom_point_img(
data = date_taille,
mapping = aes(x = Date_taille, y = pos_img),
img = list(png::readPNG("www/shears_ratio.png")), # image is the same for all points
size = 0.75,
alpha = -1 # to avoid override of native image transparency (cf comment of function ggimg:::fix_img_dims)
) +
geom_text(
data = date_taille,
mapping = aes(x = Date_taille, y = pos_img + 0.8, label = Taille)
) +
scale_color_manual(
labels = textesUI[textesUI$id %in% levels(cycle$Etape), lang] %>% setNames(levels(cycle$Etape)),
values = c("#007510", "#47CBFF", "#FFC038", "#FF8800", "#DE3800") %>% setNames(levels(cycle$Etape))
) +
scale_y_discrete(breaks = NULL) +
scale_x_date(
breaks = date_labels$pas,
minor_breaks = NULL,
labels = date_labels$etiquette
) +
coord_fixed(70, ylim = c(0.8, 5.2)) +
labs(title = textesUI[textesUI$id == "taille_plan_title", lang], x = NULL, y = "", colour = "") +
theme(legend.position = "bottom", axis.text.x = element_text(face = "bold"))
})
## comparaison des tailles ####
# action du bouton "tout désélectionner"
observeEvent(input$taille_year_none, {
updateCheckboxGroupButtons(
session,
"taille_checkbox_year",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$taille_year_all, {
updateCheckboxGroupButtons(
session,
"taille_checkbox_year",
selected = unique(taille$Annee)
)
})
output$taille_taille <- renderGirafe({
if(!is.null(input$taille_checkbox_year)) { # if no selected date, no plot
{taille %>%
filter(Mesure == input$taille_mesure, Annee %in% input$taille_checkbox_year, !is.na(Valeur)) %>%
ggplot() +
aes(x = Taille, y = Valeur, fill = Taille, label = arbre) +
geom_violin(alpha = 0.3, color = "transparent", scale = "count") +
geom_jitter_interactive(alpha = 0.3, width = 0.2, height = 0, aes(tooltip = paste(after_stat(label), round(after_stat(y), 1), sep = "<br>"), data_id = arbre)) +
geom_point(stat = "summary", fun = mean, size = 4, color = "white") +
geom_point_interactive(
stat = "summary",
fun = mean, size = 3,
aes(color = Taille, tooltip = round(after_stat(y), 1), data_id = Taille)
) +
scale_fill_manual(values = coul_taille, aesthetics = c("colour", "fill")) +
scale_x_discrete(labels = textesUI[textesUI$id %in% levels(taille$Taille), lang] %>% setNames(levels(taille$Taille))) +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$taille_mesure, lang]) +
theme(legend.position = "none")
} %>%
girafe(
ggobj = ., height_svg = 4, width_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0.4;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "fill:black;"),
opts_selection(type = "none")
)
) %>%
suppressWarnings()
}
})
## comparaison des années (suivi temporel) ####
# action du bouton "tout désélectionner"
observeEvent(input$taille_temp_none, {
updateCheckboxGroupButtons(
session,
"taille_temps_multi",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$taille_temp_all, {
updateCheckboxGroupButtons(
session,
"taille_temps_multi",
selected = levels(taille$Taille)
)
})
output$taille_temporel <- renderGirafe({
if(!is.null(input$taille_temps_multi)) { # if no selected taille, no plot
{if(length(input$taille_temps_multi) == 1) { # if one selected taille
taille %>%
filter(Mesure == input$taille_mesure, Taille == input$taille_temps_multi, !is.na(Valeur)) %>%
rowwise() %>%
mutate(Taille_trad = textesUI[textesUI$id == Taille, lang]) %>%
ggplot() +
aes(x = Annee, y = Valeur) +
geom_vline_interactive(xintercept = 2011.5, color = "white", linewidth = 2, aes(tooltip = textesUI[textesUI$id == "pruning_start", lang])) +
geom_line_interactive(aes(group = arbre, data_id = arbre, tooltip = arbre, hover_css = "fill:none"), alpha = 0.1) +
geom_point_interactive(alpha = 0.3, aes(data_id = arbre, tooltip = arbre)) +
geom_line(stat = "summary", fun = mean, aes(colour = Taille_trad)) +
geom_point_interactive(stat = "summary", fun = mean, size = 3, aes(colour = Taille_trad, tooltip = paste(after_stat(colour), round(after_stat(y), 1), sep = "<br>"))) +
geom_smooth_interactive(method = "lm", formula = "y~1", se = FALSE, color = "black", linetype = 2, aes(tooltip = paste(textesUI[textesUI$id == "global_mean", lang], round(after_stat(y), 1), sep = "<br>"))) +
scale_color_manual(
values = coul_taille[input$taille_temps_multi] %>% unname() # car aes color : Taille_trad
) +
scale_x_continuous(breaks = seq(2008, 2022, by = 2)) +
labs(
x = NULL, y = NULL,
title = textesUI[textesUI$id == input$taille_mesure, lang],
colour = textesUI[textesUI$id == "taille_legend", lang]
)
} else { # if several/all selected taille
taille %>%
filter(Mesure == input$taille_mesure, Taille %in% input$taille_temps_multi) %>%
group_by(Annee, Taille) %>%
summarise(
Moyenne = mean(Valeur, na.rm = TRUE),
n = length(na.omit(Valeur))
) %>%
suppressMessages() %>% # group message
rowwise() %>%
mutate(Taille_trad = textesUI[textesUI$id == Taille, lang]) %>%
ggplot() +
aes(x = Annee, y = Moyenne, colour = Taille, tooltip = paste(Taille_trad, "<br>", round(Moyenne, 1), "(n=", n, ")"), data_id = Taille) +
geom_vline_interactive(xintercept = 2011.5, color = "white", linewidth = 2, aes(tooltip = textesUI[textesUI$id == "pruning_start", lang])) +
geom_line(aes(group = Taille)) +
geom_point_interactive() +
scale_color_manual(values = coul_taille[input$taille_temps_multi], labels = textesUI[textesUI$id %in% levels(taille$Taille), lang] %>% setNames(levels(taille$Taille))) +
scale_x_continuous(breaks = seq(2008, 2022, by = 2)) +
labs(
x = NULL, y = NULL,
title = textesUI[textesUI$id == input$taille_mesure, lang],
colour = textesUI[textesUI$id == "taille_legend", lang]
)
} } %>%
suppressWarnings() %>% # geom_vline(): Ignoring `mapping` because `xintercept` was provided.
girafe(
ggobj = ., height_svg = 4, width_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "stroke-width:3px;"),
opts_selection(type = "none")
)
)
}
})
## mesures à l'échelle de la parcelle ####
# action du bouton "tout désélectionner"
observeEvent(input$taille_spatial_none, {
updateCheckboxGroupButtons(
session,
"taille_spatial_multi",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$taille_spatial_all, {
updateCheckboxGroupButtons(
session,
"taille_spatial_multi",
selected = levels(taille$Taille)
)
})
output$taille_spatial <- renderGirafe({
if(!is.null(input$taille_spatial_multi)) { # if no selected taille, no plot
{if(input$taille_all_year) {
taille %>%
filter(
Mesure == input$taille_mesure,
Taille %in% input$taille_spatial_multi
) %>%
group_by(X, Y, Taille) %>%
summarise(Moyenne = mean(Valeur, na.rm = TRUE), n = n()) %>%
suppressMessages() %>% # group message
rowwise() %>%
mutate(Taille_trad = textesUI[textesUI$id == Taille, lang]) %>%
ggplot() +
aes(x = X, y = Y, fill = Moyenne, tooltip = paste(Taille_trad, "<br>", round(Moyenne, 1), "(n=", n, ")"), data_id = Taille) +
geom_tile_interactive(colour = "black") +
scale_fill_distiller(palette = "YlOrRd", na.value = "transparent", direction = 1) +
scale_x_discrete(drop = FALSE) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$taille_mesure, lang], fill = NULL)
} else {
taille %>%
filter(
Mesure == input$taille_mesure,
Taille%in% input$taille_spatial_multi
) %>%
rowwise() %>%
mutate(Taille_trad = textesUI[textesUI$id == Taille, lang]) %>%
ggplot() +
aes(x = X, y = Y, fill = Valeur, tooltip = paste(Taille_trad, round(Valeur, 1), sep = "<br>"), data_id = Taille) +
geom_tile_interactive(colour = "black") +
scale_fill_distiller(palette = "YlOrRd", na.value = "transparent", direction = 1) +
scale_x_discrete(drop = FALSE) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$taille_mesure, lang], fill = NULL) +
facet_wrap(~ Annee, nrow = 2)
}}%>%
girafe(
ggobj = ., width_svg = 10, height_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0.2;"),
opts_tooltip(use_stroke = TRUE),
opts_hover(css = ""),
opts_selection(type = "none")
)
)
}
})
# Evaluation variétale ----------------------------------------------------
## Présentation ####
# Présentation des 10 variétés
output$variete_ui_desc <- renderUI({
textesUI[textesUI$id == input$variete_radio_desc, lang] %>%
markdown()
})
output$variete_img_desc <- renderImage({
list(src = paste0("./www/varietes/", input$variete_radio_desc, ".jpg"))
}, deleteFile = FALSE)
# Bilan : fiches variétales
output$variete_img_bilan <- renderImage({
list(src = paste0("./www/fiches-varietales/", input$variete_radio_bilan, ".jpg"))
}, deleteFile = FALSE)
# Couleur des variétés
coul_var <- c("#b94137", "#0080b4", "#008355", "#7f4ecc", "#ce7e26", "#8aa543", "#56423e", "#be4b7f", "#a5af98", "#00c1ff", "#0300000C") %>%
setNames(c(levels(variete$cultivar), "bordure"))
## Plan de la parcelle ####
output$variete_parcelle <- renderGirafe({
variete %>%
distinct(X, Y, cultivar) %>%
bind_rows(
tibble(
cultivar = "bordure",
X = c(rep("K",17), rep(LETTERS[10:2], each = 2), rep("A",17)) %>% factor(),
Y = c(1:17, rep(c(1,17), times = 9), 1:17) %>% factor()
)
) %>%
mutate(cultivar_trad = ifelse(cultivar == "bordure", textesUI[textesUI$id == "bordure", lang], cultivar)) %>%
{ggplot(.) +
aes(x = X, y = Y, fill = cultivar, tooltip = cultivar_trad, data_id = cultivar) +
geom_tile_interactive(color = "black") +
annotate(geom = "point", x = "F", y = "12", shape = 4, size = 5) +
scale_fill_manual(
values = coul_var, labels = c(bordure = textesUI[textesUI$id == "bordure", lang]),
guide = guide_legend(byrow = TRUE)) +
scale_x_discrete(drop = FALSE) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, fill = textesUI[textesUI$id == "cultivar", lang])} %>%
girafe(
ggobj = ., height_svg = 4, width_svg = 4,
options = list(
opts_hover_inv(css = "opacity:0.2;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "fill:black;opacity:0.8;"),
opts_selection(type = "none")
)
)
})
## comparaison des variétés ####
# action du bouton "tout désélectionner"
observeEvent(input$variete_year_none, {
updateCheckboxGroupButtons(
session,
"variete_checkbox_year",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$variete_year_all, {
updateCheckboxGroupButtons(
session,
"variete_checkbox_year",
selected = unique(variete$Annee)
)
})
output$variete_var <- renderGirafe({
if(!is.null(input$variete_checkbox_year)) { # if no selected date, no plot
{variete %>%
filter(Mesure == input$variete_mesure, Annee %in% input$variete_checkbox_year, !is.na(Valeur)) %>%
ggplot() +
aes(x = cultivar, y = Valeur, fill = cultivar, label = arbre) +
geom_violin(alpha = 0.3, color = "transparent", scale = "count") +
geom_jitter_interactive(alpha = 0.3, width = 0.2, height = 0, aes(tooltip = paste(after_stat(label), round(after_stat(y), 1), sep = "<br>"), data_id = arbre)) +
geom_point(stat = "summary", fun = mean, size = 4, color = "white") +
geom_point_interactive(
stat = "summary",
fun = mean, size = 3,
aes(color = cultivar, tooltip = paste(after_stat(colour), round(after_stat(y), 1), sep = "<br>"), data_id = cultivar)
) +
scale_fill_manual(values = coul_var, aesthetics = c("colour", "fill")) +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$variete_mesure, lang]) +
theme(legend.position = "none", axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))
} %>%
girafe(
ggobj = ., height_svg = 4, width_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0.4;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "fill:black;"),
opts_selection(type = "none")
)
) %>%
suppressWarnings()
}
})
## comparaison des années (suivi temporel) ####
# action du bouton "tout désélectionner"
observeEvent(input$variete_temp_none, {
updateCheckboxGroupButtons(
session,
"variete_temp_var",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$variete_temp_all, {
updateCheckboxGroupButtons(
session,
"variete_temp_var",
selected = levels(variete$cultivar)
)
})
output$variete_temp_graph <- renderGirafe({
if(!is.null(input$variete_temp_var)) # if no selected cultivar, no plot
{
{if(length(input$variete_temp_var) == 1) { # if one selected cultivar
variete %>%
filter(Mesure == input$variete_mesure, cultivar == input$variete_temp_var, !is.na(Valeur)) %>%
ggplot() +
aes(x = Annee, y = Valeur) +
geom_line_interactive(aes(group = arbre, data_id = arbre, tooltip = arbre, hover_css = "fill:none"), alpha = 0.1) +
geom_point_interactive(alpha = 0.3, aes(data_id = arbre, tooltip = arbre)) +
geom_smooth_interactive(method = "lm", formula = "y~1", se = FALSE, color = "black", linetype = 2, aes(tooltip = paste(textesUI[textesUI$id == "global_mean", lang], round(after_stat(y), 1), sep = "<br>"))) +
geom_line(stat = "summary", fun = mean, aes(colour = cultivar)) +
geom_point_interactive(stat = "summary", fun = mean, size = 3, aes(colour = cultivar, tooltip = paste(after_stat(color), round(after_stat(y), 1), sep = "<br>"))) +
scale_color_manual(values = coul_var[input$variete_temp_var]) +
labs(
x = NULL, y = NULL,
title = textesUI[textesUI$id == input$variete_mesure, lang],
colour = textesUI[textesUI$id == "cultivar", lang]
)
} else { # if several selected cultivars
variete %>%
filter(Mesure == input$variete_mesure, cultivar %in% input$variete_temp_var) %>%
group_by(Annee, cultivar) %>%
summarise(
Moyenne = mean(Valeur, na.rm = TRUE),
# n = n()
n = length(na.omit(Valeur))
) %>%
suppressMessages() %>% # group message
ggplot() +
aes(x = Annee, y = Moyenne, colour = cultivar, tooltip = paste(cultivar, "<br>", round(Moyenne, 1), "(n=", n, ")"), data_id = cultivar) +
geom_line(aes(group = cultivar)) +
geom_point_interactive() +
scale_color_manual(values = coul_var[input$variete_temp_var]) +
labs(
x = NULL, y = NULL,
title = textesUI[textesUI$id == input$variete_mesure, lang],
colour = textesUI[textesUI$id == "cultivar", lang]
)
} } %>%
girafe(
ggobj = ., height_svg = 4, width_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0;"),
opts_tooltip(use_fill = TRUE),
opts_hover(css = "stroke-width:3px;"),
opts_selection(type = "none")
)
)
}
})
## mesures à l'échelle de la parcelle ####
# action du bouton "tout désélectionner"
observeEvent(input$variete_spatial_none, {
updateCheckboxGroupButtons(
session,
"variete_spatial_var",
selected = NA
)
})
# action du bouton "tout sélectionner"
observeEvent(input$variete_spatial_all, {
updateCheckboxGroupButtons(
session,
"variete_spatial_var",
selected = levels(variete$cultivar)
)
})
output$variete_spatial_graph <- renderGirafe({
if(!is.null(input$variete_spatial_var)) { # if no selected cultivar, no plot
{if(input$variete_all_year) {
variete %>%
filter(
Mesure == input$variete_mesure,
cultivar %in% input$variete_spatial_var
) %>%
group_by(X, Y, cultivar) %>%
summarise(Moyenne = mean(Valeur, na.rm = TRUE), n = n()) %>%
suppressMessages() %>% # group message
ggplot() +
aes(x = X, y = Y, fill = Moyenne, tooltip = paste(cultivar, "<br>", round(Moyenne, 1), "(n=", n, ")"), data_id = cultivar) +
geom_tile_interactive(colour = "black") +
scale_fill_distiller(palette = "YlOrRd", na.value = "transparent", direction = 1) +
scale_x_discrete(drop = FALSE) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$variete_mesure, lang], fill = NULL)
} else {
variete %>%
filter(
Mesure == input$variete_mesure,
cultivar %in% input$variete_spatial_var
) %>%
ggplot() +
aes(x = X, y = Y, fill = Valeur, tooltip = paste(cultivar, round(Valeur, 1), sep = "<br>"), data_id = cultivar) +
geom_tile_interactive(colour = "black") +
scale_fill_distiller(palette = "YlOrRd", na.value = "transparent", direction = 1) +
scale_x_discrete(drop = FALSE) +
scale_y_discrete(drop = FALSE) +
coord_fixed() +
labs(x = NULL, y = NULL, title = textesUI[textesUI$id == input$variete_mesure, lang], fill = NULL) +
facet_wrap(~ Annee, nrow = 2)
}}%>%
girafe(
ggobj = ., width_svg = 10, height_svg = 5,
options = list(
opts_hover_inv(css = "opacity:0.2;"),
opts_tooltip(use_stroke = TRUE),
opts_hover(css = ""),
opts_selection(type = "none")
)
)
}
})
} # end of server
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.