---
title: "HAMR"
output:
flexdashboard::flex_dashboard:
logo: img/logos_trans_white.png
orientation: rows
vertical_layout: fill
css: 'styles.css'
runtime: shiny
---
```{r global, include=FALSE}
rm(list = ls())
library(shiny)
library(flexdashboard)
library(leaflet)
library(dplyr)
library(dygraphs)
library(ggplot2)
library(data.table)
library(plotly)
library(DT)
library(parallel)
#devtools::install_github("KVHEM/CatCa")
#install.packages("home/ownCloud/Shared/BILAN_UPOV/bilan/bilan_2016-10-20.tar.gz",repos=NULL, type="source")
#library(bilan)
#CatCa::give_paths()
.datadir <- getwd()
BM <- readRDS(file.path(.datadir, "webapp_data/mbilan/bilan_month_data_table.rds"))
povodi <- readRDS(file.path(.datadir, "webapp_data/geo_rds/povodi.rds"))
reky <- readRDS(file.path(.datadir, "webapp_data/geo_rds/reky.rds"))
jezera <- readRDS(file.path(.datadir, "webapp_data/geo_rds/jezera.rds"))
nadrze <- readRDS(file.path(.datadir, "webapp_data/geo_rds/nadrze.rds"))
kraje <- readRDS(file.path(.datadir, "webapp_data/geo_rds/kraje.rds"))
okresy <- readRDS(file.path(.datadir, "webapp_data/geo_rds/okresy.rds"))
povodi_III <- readRDS(file.path(.datadir, "webapp_data/geo_rds/povodi_III.rds"))
QD_stanice <- readRDS(file.path(.datadir, "webapp_data/geo_rds/stanice.rds"))
stanice <- readRDS(file.path(.datadir, "webapp_data/geo_rds/E04_Vodomerne_stanice.rds"))
tabB <- readRDS(file.path(.datadir, "webapp_data/TABB.rds"))
cp <- readRDS(file.path(.datadir, "webapp_data/mbilan/cara_prekroceni_dt.rds"))
popis <- readRDS(file.path(.datadir, "webapp_data/popis.rds"))
pars <- readRDS(file.path(.datadir, "webapp_data/pars.rds"))
u <- readRDS(file.path(.datadir, "webapp_data/uzivani/uzivani_na_nahraz_dt.rds"))
u_leaflet <- readRDS(file.path(.datadir, "webapp_data/uzivani/u_leaflet.rds"))
QD <- readRDS(file.path(.datadir, "webapp_data/chmu/QD.rds"))
dta_val <- readRDS(file.path(.datadir, "webapp_data/chmu/data_validace.rds"))
chars <- readRDS(file.path(.datadir, "webapp_data/chmu/chars_mm.rds"))
chars_sim <- readRDS(file.path(.datadir, "webapp_data/chmu/chars_mm_sim.rds"))
# Merging data----------------
povodi <- sp::merge(povodi, popis, by='UPOV_ID')
search.choices <- as.character(povodi$UPOV_ID)
names(search.choices) <- paste(povodi$NAZ_UTVAR, search.choices, sep = ": ")
choices <- c("P" , "R", "RM", "BF", "B", "DS", "PET", "ET","SW", "SS", "GS", "INF", "PERC", "RC", "T", "H", "WEI")
names(choices) <- c(
'P - srážky na povodí [mm]',
'R - odtok (pozorovaný) [mm]',
'RM - celkovy odtok (simulovaný) [mm]',
'BF - základní odtok (simulovaný) [mm]',
'B - základní odtok (odvozený) [mm]',
'DS - zásoba pro přímý odtok [mm]',
'PET - potenciální evapotranspirace [mm]',
'ET - územní výpar [mm]',
'SW - půdní vlhkost (zásoba vody v nenasycené zóně) [mm]',
'SS - zásoba vody ve sněhu [mm]',
'GS - zásoba podzemní vody [mm]',
'INF - infiltrace do půdy [mm]',
'PERC - perkolace z půdní vrstvy [mm]',
'RC - dotace zásoby podzemní vody [mm]',
'T - teplota vzduchu [°C]',
'H - vlhkost vzduchu [%]',
'WEI - váhy pro kalibraci odtoku [-]')
choices2 <- c("P", "RM", "BF", "DS", "PET", "ET","SW")
names(choices2) <- c(
'P - srážky na povodí [mm]',
'RM - celkovy odtok (simulovaný) [mm]',
'BF - základní odtok (simulovaný) [mm]',
'DS - zásoba pro přímý odtok [mm]',
'PET - potenciální evapotranspirace [mm]',
'ET - územní výpar [mm]',
'SW - půdní vlhkost (zásoba vody v nenasycené zóně) [mm]')
choices3 <- c("QMER", "QNEX", "QNEY", "RM")
choices.QD <- c("value", "mean_month", "mean_year")
names(choices.QD) <- c("Denni prutoky", "Mesicni prutoky", "Rocni prutoky")
choices.routed <- c("TRM_mm_d", "RM_month", "RM_year")
names(choices.routed) <- c("Simulovane prutoky", "Simulovane mesicni prutoky", "Simulovane rocni prutoky")
choices.pars <- as.character(unique(pars$name))
choices.mday <- c("Q30d", "Q60d", "Q90d", "Q120d", "Q150d", "Q180d", "Q210d",
"Q240d", "Q270d", "Q300d", "Q330d", "Q355d", "Q364d")
mesice <- c("Leden", "Únor", "Březen", "Duben", "Květen", "Červen",
"Červenec", "Srpen", "Září", "Říjen", "Listopad", "Prosinec")
```
Základní mapa {data-icon="fa-map-o"}
=====================================
Column {.sidebar data-width=400}
-----------------------------------------------------------------------
```{r ZM sidebar}
#Inputs--------------------
#
renderUI({
wellPanel(
HTML('
Vyhledat můžete jak dle názvu, tak dle UPOV_ID.
'),
selectizeInput(inputId = "search.id","Vyhledávání útvaru",
selected=input$map_shape_click$id,
choices = search.choices)
)
})
wellPanel(HTML('
Zvolte proměnnou, kterou chcete zobrazit a nastavte období.
'),
selectInput("entry.variable", label="Prvky hydrologické bilance",
choices = choices, selected = "P"),
radioButtons("kartogram", label=NULL, choices = c("Dlouhodobé průměry" = "A",
"Měsíční průměry" = "B", "Roční průměry" = "C"),
selected = "A"),
conditionalPanel(condition = "input.kartogram == 'A'",
radioButtons("DP", label=NULL, selected = "DP1",
choices = c("Celé období" = "DP1", "Volba období" = "DP2")),
conditionalPanel(condition = "input.DP == 'DP1'"),
conditionalPanel(condition = "input.DP == 'DP2'",
selectInput("entry.period", label = NULL,
choices = list("1961-1990" = "1", "1971-2000" = "2",
"1981 - 2010" = "3"), selected = "1")
)
),
conditionalPanel(condition = "input.kartogram == 'B'",
dateInput("entry.date", label = NULL, "yyyy-mm-dd", language = "cs",
value = as.Date("1961-01-01"), startview = "decade",
min = as.Date("1961-01-01"), max = as.Date("2015-12-01"))
),
conditionalPanel(condition = "input.kartogram == 'C'",
selectInput("entry.yearC", label = "Zvolte rok:",
choices = seq(1961,2015,1))
)
)
renderUI({
wellPanel(
HTML('
Tady nastavte rozsah hodnot.
'),
sliderInput("entry.range", label = "Filtrace dle hodnoty",
min = floor(reac()$def_min),
max = ceiling(reac()$def_max),
value = c(floor(reac()$inputed_min),
ceiling(reac()$inputed_max)))
)
})
hr()
wellPanel(checkboxGroupInput("entry.layer", label = "Vrstvy",
choices = c("Mapový podklad" = "MP", "Povodí" ="P", "Řeky" = "R", "Jezera" = "J",
"Nádrže" = "N", "Kraje" = "K", "Okresy" = "O", "Povodí 3. řádu" = "P3"),
selected = c("MP", "P"),
inline = T))
hr()
div(style="display:inline-block",
actionButton("reset_button", "Reset", icon("arrows"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
actionButton("go1", "Zobrazit", icon("check"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4")
)
```
```{r ZM Reactions}
#Reactions--------------------
reac<- eventReactive(input$go1,{
vrstvy <- input$entry.layer
bilance <- BM[variable == input$entry.variable]
bilance_filtr <- c()
dta <- c()
#Dlouhodobé průměry (celé období/vybrané období)
if(input$kartogram == "A"){
if(input$DP == "DP1"){
bilance_filtr <- bilance[year==2000 & month==1]
colnames(bilance_filtr)[colnames(bilance_filtr)=="value"] <- "monthly.avg"
colnames(bilance_filtr)[colnames(bilance_filtr)=="mean_ep"] <- "value"
dta <- (sp::merge(povodi,bilance_filtr, by="UPOV_ID"))
}else if(input$DP == "DP2"){
if(input$entry.period == "1"){period=seq(1961,1990,1)
}else if(input$entry.period == "2"){period = seq(1971,2000,1)
}else if(input$entry.period == "3"){period = seq(1981,2010,1)}
bilance_filtr <- bilance[year %in% period] %>% group_by(UPOV_ID) %>% summarise(mean.period = mean(value))
colnames(bilance_filtr)[colnames(bilance_filtr)=="value"] <- "monthly.avg"
colnames(bilance_filtr)[colnames(bilance_filtr)=="mean.period"] <- "value"
dta <- (sp::merge(povodi,bilance_filtr, by="UPOV_ID"))
#Měsíční průměry
}}else if(input$kartogram == "B"){
bilance_filtr <- bilance[year == year(input$entry.date) & month==month(input$entry.date)]
dta <- (sp::merge(povodi,bilance_filtr, by="UPOV_ID"))
#Roční průměry
}else if(input$kartogram == "C"){
bilance_filtr <- bilance[year==input$entry.yearC & month==1]
colnames(bilance_filtr)[colnames(bilance_filtr)=="value"] <- "monthly.avg"
colnames(bilance_filtr)[colnames(bilance_filtr)=="annual.avg"] <- "value"
dta <- (sp::merge(povodi,bilance_filtr, by="UPOV_ID"))}
#Minima a maxima pro filtraci dle hodnoty
def_min = min(dta$value, na.rm = T)
def_max = max(dta$value, na.rm = T)
inputed_min = def_min
inputed_max = def_max
if(!is.null(input$entry.range[1])){
if(input$entry.range[1] != def_min){
inputed_min = input$entry.range[1]}
if(input$entry.range[2] != def_max){
inputed_max = input$entry.range[2]}
}
dta <- base::subset(dta, (value >= inputed_min & value <= inputed_max) | is.na(value))
#Vytvaření palet
mojePaleta <- c("#f90012", "#e5734a", "#e8da89", "#b3eab3", "#3a96f2", "#0046a2")
if(input$entry.variable == "T"){
pal <- colorBin(mojePaleta, domain = dta$value, pretty = TRUE, reverse = TRUE, na.color = "#ffffff")
}else{pal <- colorBin(mojePaleta, domain = dta$value, pretty = TRUE, na.color = "#ffffff")}
return(list(bilance=bilance_filtr, dta=dta, pal = pal, inputed_min=inputed_min, inputed_max=inputed_max,
def_min=def_min, def_max=def_max, vrstvy = vrstvy))
}, ignoreNULL = FALSE, ignoreInit = FALSE)
```
```{r loga, include=FALSE}
absolutePanel(id = "logos", fixed = TRUE,
draggable = FALSE, top = "auto", left = "auto", right = "auto", bottom = 10,
width = 400,
style = "opacity: 1;",
HTML(''),
HTML(''),
HTML(''),
HTML(''))
```
Row
-------------------------------------
```{r ZM mapa}
#Functions--------------------
title.f <- reactive({
title<- popis$NAZ_UTVAR[popis$UPOV_ID == default.shape()]
return(title)
})
default.shape <- reactive({
UPOV_ID.sel <- input$search.id
return(UPOV_ID.sel)})
initial_lat = 49.7437572
initial_lng = 15.3386383
initial_zoom = 7
#Outputs
#Leaflet--------------------
output$map<-renderLeaflet({
reac_app <- reac()
dta <- reac_app$dta
pal <- reac_app$pal
vrstvy <- reac_app$vrstvy
# Creating labels--------------------
labels <- sprintf(
"%s
Kategorie: %s
Stav: %s
UPOV_ID: %s
Hodnota: %s",
dta$NAZ_UTVAR, dta$KTG_UPOV, dta$U_PMU, dta$UPOV_ID, round(dta$value,2)
) %>% lapply(htmltools::HTML)
if(length(labels)==0){labels <- c(" ")}
#ZM
map <- leaflet() %>%
setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom)
#Zbarvení povodí dle hodnoty + Legenda
if("P" %in% vrstvy){
map <- map %>% addPolygons(data=dta, layerId = dta$UPOV_ID, color = "burlywood4",
weight = 1.3, opacity = 0.3, smoothFactor = 0,
fillColor = ~pal(value), fillOpacity = 0.8,
group = "Povodí",
highlightOptions = highlightOptions(color = "#a53333",
opacity = 1,
fillOpacity = 0,
weight = 2.3,
bringToFront = TRUE, sendToBack = TRUE),
label = labels,
labelOptions = labelOptions(clickable = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE, noHide = FALSE,
"border-color" = "rgb(255, 255, 255)"),
textsize = "13px", direction = "auto")) %>%
addLegend(pal = pal, values = dta$value, opacity = 0.7, title = "Legenda",
position = "bottomright")}
#Vrstvy mapy
if("MP" %in% vrstvy){
map <- map %>% addTiles(group = "Mapový podklad", options = tileOptions(minZoom=7, maxZoom=13))
}
if("R" %in% vrstvy){
map <- map %>% addPolylines(data=reky, color="#007C8C", weight = 1.5,
opacity = 1, stroke= TRUE, group = "Řeky")
}
if("J" %in% vrstvy){
map <- map %>% addPolygons(data=jezera, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Jezera")}
if("N" %in% vrstvy){
map <- map %>% addPolygons(data=nadrze, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Nádrže")}
if("K" %in% vrstvy){
map <- map %>% addPolylines(data=kraje, color="#000000", weight = 2.5,
stroke= TRUE, group = "Kraje")}
if("O" %in% vrstvy){
map <- map %>% addPolylines(data=okresy, color="#000000", weight = 2,
stroke= TRUE, group = "Okresy")}
if("P3" %in% vrstvy){
map <- map %>% addPolylines(data=povodi_III, color="#cc0000", weight = 2.5, opacity = 1,
stroke= TRUE, group = "Povodí 3. řádu")
}
#Ovládání vrstev mapy v leaflet
map <- map %>% addLayersControl(overlayGroups = c("Horní povodí"),
position = "bottomleft",
options = layersControlOptions(collapsed = FALSE)) %>%
hideGroup(c("Horní povodí"))
print(map)
})
#Zobrazení horního povodí
horni.povodi <- reactive({
povodi[povodi$UPOV_ID %in% tabB$FROM[tabB$TO==input$search.id],] })
observe({
leafletProxy("map") %>%
clearGroup("Horní povodí") %>%
addPolylines(data=horni.povodi(),
color = "#00264d", weight = 2.5, opacity = 0.7, stroke = TRUE,
group = "Horní povodí")
})
#Zvyraznění současného povodí
observe({
leafletProxy("map") %>%
clearGroup("current_shape") %>%
addPolylines(data = subset(povodi, UPOV_ID==(if(is.null(input$search.id)){"DUN_0010"}else{input$search.id})),
group = "current_shape",
color = "#a53333", opacity = 1, weight = 3,
stroke = TRUE)
})
#Reset button
observe({
input$reset_button
leafletProxy("map") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom)})
leafletOutput("map")
```
Row {.tabset}
-------------------------------------
### Denní data
```{r cr denni data}
renderDygraph({
d <- dir(file.path(.datadir, "webapp_data/res"))
bilan_dir <- data.frame(source=d, UPOV_ID=gsub("*.rds","",d))
dta_bd <- readRDS(file.path(.datadir,"webapp_data/res", bilan_dir$source[bilan_dir$UPOV_ID==default.shape()]))
ts.bilance <- dta_bd %>% select(input$entry.variable_d, DTM)
RangeMin <- min(ts.bilance %>% select(c(input$entry.variable_d)))-0.5
RangeMax <- max(ts.bilance %>% select(c(input$entry.variable_d)))+0.5
ts.bilance <- xts::xts(ts.bilance, order.by = ts.bilance$DTM)
dygraph(ts.bilance, main = paste(as.character(title.f())), xlab = "Čas") %>%
dyAxis("y", valueRange = c(RangeMin, RangeMax)) %>%
dyRangeSelector() %>%
dyCrosshair(direction = "vertical")
})
absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = '52.7%', left = "auto", right = '0.5%', bottom = "auto",
width = '15%',
style = "opacity: 0.9; style = z-index: 400",
HTML(''),
tags$div(id = 'box7', class="collapse", style = "max-height: 250px; overflow-y:scroll",
checkboxGroupInput("entry.variable_d", "Zvolte:", choices = choices, selected = c("RM"))))
```
### Měsíční data
```{r cr mesicni data}
renderDygraph({
ts.bilance <- BM[UPOV_ID == default.shape() & variable == input$entry.variable2] %>% select(value, DTM)
RangeMin <- min(ts.bilance$value)-0.5
RangeMax <- max(ts.bilance$value)+0.5
ts.bilance <- xts::xts(ts.bilance, order.by = ts.bilance$DTM)
dygraph(ts.bilance, main = paste(as.character(title.f())), xlab = "Čas") %>%
dyAxis("y", valueRange = c(RangeMin, RangeMax)) %>%
dyRangeSelector() %>%
dyCrosshair(direction = "vertical")
})
absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = '52.7%', left = "auto", right = '0.5%', bottom = "auto",
width = '15%',
style = "opacity: 0.9; style = z-index: 400",
HTML(''),
tags$div(id = 'box4', class="collapse", style = "max-height: 250px; overflow-y:scroll",
checkboxGroupInput("entry.variable2", "Zvolte:", choices = choices, selected = c("RM"))))
```
### Čára překročení
```{r cara prekroceni}
renderPlot({
cp_c <- cp[UPOV_ID == default.shape() & variable == input$variable_cp] %>%
select(value, p_year) %>% arrange(value)
g1<- ggplot(cp_c, aes(p_year, value)) + geom_line()+
xlab("Pravděpodobnosti") + ylab(input$variable_cp)+
theme_minimal() + ggtitle("Celé období")+
theme(plot.title = element_text(hjust = 0.5))
cp_s <- cp[UPOV_ID == default.shape() & variable == input$variable_cp] %>% group_by(seasons) %>%
select(p_season, value, seasons) %>% arrange(value)
g2<-ggplot(cp_s, aes(p_season, value)) + geom_line(aes(group=seasons, colour=seasons)) +
xlab("Pravděpodobnosti")+ylab(input$variable_cp)+
theme_minimal()+ggtitle("Roční období")+theme(plot.title = element_text(hjust = 0.5))
g2$labels$colour <- "Legenda"
cp_m <- cp[UPOV_ID == default.shape() & variable == input$variable_cp] %>% group_by(month2) %>%
select(p_month, value, month2) %>% arrange(value)
g3<- ggplot(cp_m, aes(p_month, value)) + geom_line(aes(group=month2, colour=month2))+
xlab("Pravděpodobnosti")+ylab(input$variable_cp)+theme_minimal()+ggtitle("Měsíce")+
theme(plot.title = element_text(hjust = 0.5))
g3$labels$colour <- "Legenda"
gridExtra::grid.arrange(g1,g2,g3, ncol=3)
})
```
```{r ZM cp: absPanel}
absolutePanel(class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = '52.7%', left = "auto", right = '0.5%', bottom = "auto",
width = '15%',
style = "opacity: 1; style = z-index: 400",
HTML(''),
tags$div(id = 'box5', class="collapse", style = "max-height: 420px",
selectInput("variable_cp", label=NULL , choices = choices, selected = c("RM"))))
```
### Trendy
```{r ZM trendy: reactions}
trend.reac <- reactive({
dta_tr <- BM[UPOV_ID == default.shape() &
(year > input$date_trend[1] & year < input$date_trend[2]) &
variable == input$variable_trend]
if(input$variable_trend == "T"){
ts.year = dta_tr[, .(value = mean(value)), by = .(year)]
}else{ts.year = dta_tr[, .(value = sum(value)), by = .(year)]}
model_y = ts.year[, list(list(lm(value ~ year)))]
ts.year$fit = model_y$V1[[1]]$fitted.values
if(input$variable_trend == "T"){
ts.month =dta_tr[, .(value = mean(value)), by = .(year, month2)]
}else{
ts.month = dta_tr[, .(value = sum(value)), by = .(year, month2)]}
model_m = ts.month[, list(list(lm(value ~ year))), by = month2]
mesice <- unique(ts.month$month2)
ts.month$fit <- c(0)
for(i in c(1:12)){
ts.month[month2==mesice[i], fit := model_m$V1[[i]]$fitted.values]
}
if(input$variable_trend == "T"){
ts.season = dta_tr[, .(value = mean(value)), by = .(year, seasons)]
}else{
ts.season = dta_tr[, .(value = sum(value)), by = .(year, seasons)]}
model_s = ts.season[, list(list(lm(value ~ year))), by = seasons]
seasons = unique(dta_tr$seasons)
ts.season$fit <- c(0)
for(i in c(1:4)){
ts.season[seasons==seasons[i], fit := model_s$V1[[i]]$fitted.values]
}
return(list(ts.year=ts.year, ts.month=ts.month, ts.season=ts.season,
model_y=model_y, model_m=model_m, model_s=model_s))
})
```
```{r ZM trendy: graf}
renderPlot({
trend.reac.app = trend.reac()
ts.year = trend.reac.app$ts.year
ts.month = trend.reac.app$ts.month
ts.season = trend.reac.app$ts.season
ts1 <- ggplot(ts.year) +
geom_line(aes(year,value)) +
labs(x = 'rok', y = paste(input$variable_trend), title = 'Roční průměry') +
geom_line(aes(y=fit, x=year), color = 'darkblue', show.legend = F)+
theme_minimal()
ts2 <- ggplot(ts.month) +
geom_line(aes(year,value, color = month2), show.legend = F) +
facet_wrap(~month2, scales="free_y")+
labs(x = 'rok', y = paste(input$variable_trend), title = 'Měsiční průměry') +
geom_line(aes(year,fit), color = 'darkblue')+
theme_minimal()
trend_seasons <- ggplot(ts.season) +
geom_line(aes(year,value, colour=seasons), show.legend = F)+
facet_wrap(~seasons, scales="free_y", nrow=1) +
labs(x = 'rok', y = paste(input$variable_trend)) +
geom_line(aes(year,fit), color = 'darkblue')+
theme_minimal()
ts <- gridExtra::grid.arrange(ts1, trend_seasons, nrow=2)
gridExtra::grid.arrange(ts, ts2, ncol = 2)
})
```
```{r ZM trendy: absPanel}
absolutePanel(class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = '52.7%', left = "auto", right = '0.5%', bottom = "auto",
width = '15%',
style = "opacity: 0.9; style = z-index: 400",
HTML(''),
tags$div(id = 'box6', class="collapse", style = "max-height: 420px",
wellPanel(
selectInput("variable_trend", label=NULL , choices = choices, selected = c("RM")),
sliderInput("date_trend", label = NULL, min = 1961, max = 2015, value = c(1990,2015))
)
)
)
```
### Trendy: tabulka
```{r ZM trendy: tabulka}
renderDataTable({
trend.reac.app = trend.reac()
model_y = trend.reac.app$model_y
model_m = trend.reac.app$model_m
model_s = trend.reac.app$model_s
sig.stars <- function(x){symnum(x, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
symbols = c("***", "**", "*", ".", " "))}
sum.tab <- function(type,model){
dfr <- c()
if(dim(model)[2]==1){rname <- "(celé období)"}else{
rname <- unlist(model[,1])
rname <- as.character(rname)
}
for(i in 1:length(model$V1)){
smr <- summary(model$V1[[i]])
p <- model$V1[[i]]$rank
d <- smr$coefficients[,c(1,3)]
pval <- sig.stars(smr$coefficients[,4])
dfr <- rbind(dfr, data.frame(model=c(paste0(type, " ", rname[i]), rep(" ", (p-1))),
variables = gsub("seasons","",gsub("month2","",rownames(d))),
round(d,3), "Vyznamnost" = pval,
"R-squared" = round(as.numeric(c(smr$r.squared, rep("", (p-1)))),3)
))
}
return(dfr)}
rbind(sum.tab("rok", model_y),
sum.tab("sezona", model_s),
sum.tab("měsíc", model_m))
},class = 'compact cell-border', rownames = FALSE, options = list(scrollY = "300px", pageLength = 25, lengthMenu = c(25)))
```
Indikátory sucha {data-icon="fa-tint"}
=====================================
Column {.sidebar data-width=400}
-----------------------------------------------------------------------
```{r indikatory: sidebar}
renderUI({
wellPanel(
HTML('
Vyhledat můžete jak dle názvu, tak dle UPOV_ID.
'),
selectizeInput(inputId = "search.id.ind","Vyhledávání útvaru",
selected=input$indikatory_shape_click$id,
choices = search.choices)
)
})
wellPanel(HTML('
Volba indikátoru, kroku a datumu.
'),
radioButtons("indikatory", label=NULL, choices = c("SPEI" = "spei", "SPI" = "spi"),
selected = "spei"),
selectInput("krok", label = NULL, choices = c("1 měsíc" = 1, "3 měsíce" = 3,
"6 měsíců" = 6, "12 měsíců" = 12), selected = 3),
dateInput("entry.date.ind", label = NULL, "yyyy-mm-dd", language = "cs",
value = as.Date("1985-01-01"), startview = "decade",
min = as.Date("1961-01-01"), max = as.Date("2015-12-01")),
conditionalPanel(condition = "input.indikatory == 'A'",
selectInput("entry.variable.ind", label=NULL, selected = "P",
choices = c('P', 'R', 'RM', 'BF'))
)
)
wellPanel(checkboxGroupInput("entry.layer.ind", label = "Vrstvy",
choices = c("Mapový podklad" = "MP", "Povodí" ="P", "Řeky" = "R", "Jezera" = "J",
"Nádrže" = "N", "Kraje" = "K", "Okresy" = "O", "Povodí 3. řádu" = "P3"),
selected = c("MP", "P"),
inline = T))
hr()
div(style="display:inline-block",
actionButton("reset_button2", "Reset", icon("arrows"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
actionButton("go2", "Zobrazit", icon("check"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4")
)
```
```{r indikatory: Reactions}
#Reactions--------------------
reac.ind <- eventReactive(input$go2,{
vrstvy <- input$entry.layer.ind
ind_dta <- readRDS(file.path(.datadir,"webapp_data/indikatory", paste0(input$indikatory, "_", input$krok, ".rds")))
ind_dta_f <- c()
#Dlouhodobé průměry (celé období/vybrané období)
if(input$indikatory == "spi"){
ind_dta_f <- ind_dta[variable == input$entry.variable.ind]
dta <- (sp::merge(povodi,ind_dta_f[year == year(input$entry.date.ind) & month==month(input$entry.date.ind)], by="UPOV_ID"))}
else{
ind_dta_f <- ind_dta
dta <- (sp::merge(povodi,ind_dta_f[year == year(input$entry.date.ind) & month==month(input$entry.date.ind)], by="UPOV_ID"))}
#Vytvaření palet
# (2,0 až inf) - tmave modra
# (1,4 až 2,0) - modra
# (0,5 až 1,4) - svetle zelena
# (-0,5 až 0,5) - neutralni
# (-0,5 až -1,4) - zluto oranzova (+-)
# (-1,4 až -2,0) - cervena
# (- 2,0 až -inf) - tmave červena
mojePaleta <- c("#800000", "#ff0000", "#feb316", "#eafe9a", "#99ff66", "#0066ff", "#000066")
pal <- colorBin(mojePaleta, domain = dta$value, bins = c(Inf, 2, 1.4, 0.5, -0.5, -1.4, -2, -Inf),
na.color = "#999999")
return(list(vrstvy = vrstvy, dta=dta, ind_dta_f = ind_dta_f, pal = pal))
}, ignoreNULL = FALSE, ignoreInit = FALSE)
```
Row
-------------------------------------
```{r indikatory: mapa}
#Functions--------------------
default.shape.ind <- reactive({
UPOV_ID.sel <- input$search.id.ind
return(UPOV_ID.sel)})
initial_lat = 49.7437572
initial_lng = 15.3386383
initial_zoom = 7
#Outputs
#Leaflet--------------------
output$indikatory<-renderLeaflet({
reac.ind_app <- reac.ind()
dta <- reac.ind_app$dta
pal <- reac.ind_app$pal
vrstvy <- reac.ind_app$vrstvy
# Creating labels--------------------
labels <- sprintf(
"%s
Kategorie: %s
Stav: %s
UPOV_ID: %s
Hodnota: %s",
dta$NAZ_UTVAR, dta$KTG_UPOV, dta$U_PMU, dta$UPOV_ID, round(dta$value,2)
) %>% lapply(htmltools::HTML)
if(length(labels)==0){labels <- c(" ")}
indikatory <- leaflet() %>%
setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom)
#Zbarvení povodí dle hodnoty
if("P" %in% vrstvy){
indikatory <- indikatory %>%
addPolygons(data=dta, layerId = dta$UPOV_ID, color = "black",
weight = 1.5, opacity = 0.45, smoothFactor = 0,
fillColor = ~pal(value), fillOpacity = 0.5,
group = "Povodí",
highlightOptions = highlightOptions(color = "#a53333",
opacity = 1,
fillOpacity = 0,
weight = 2.3,
bringToFront = TRUE, sendToBack = TRUE),
label = labels,
labelOptions = labelOptions(clickable = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE, noHide = FALSE,
"border-color" = "rgb(255, 255, 255)"),
textsize = "13px", direction = "auto")) %>%
addLegend(pal = pal, values = dta$value, opacity = 0.7, title = "Legenda",
position = "bottomright")
}
if("MP" %in% vrstvy){
indikatory <- indikatory %>% addTiles(group = "Mapový podklad", options = tileOptions(minZoom=7, maxZoom=13))
}
if("R" %in% vrstvy){
indikatory <- indikatory %>% addPolylines(data=reky, color="#007C8C", weight = 1.5,
opacity = 1, stroke= TRUE, group = "Řeky")
}
if("J" %in% vrstvy){
indikatory <- indikatory %>% addPolygons(data=jezera, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Jezera")}
if("N" %in% vrstvy){
indikatory <- indikatory %>% addPolygons(data=nadrze, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Nádrže")}
if("K" %in% vrstvy){
indikatory <- indikatory %>% addPolylines(data=kraje, color="#000000", weight = 2.5,
stroke= TRUE, group = "Kraje")}
if("O" %in% vrstvy){
indikatory <- indikatory %>% addPolylines(data=okresy, color="#000000", weight = 2,
stroke= TRUE, group = "Okresy")}
if("P3" %in% vrstvy){
indikatory <- indikatory %>% addPolylines(data=povodi_III, color="#cc0000", weight = 2.5, opacity = 1,
stroke= TRUE, group = "Povodí 3. řádu")
}
print(indikatory)
})
#Zvyraznění současného povodí
observe({
leafletProxy("indikatory") %>%
clearGroup("current_shape") %>%
addPolylines(data = subset(povodi,
UPOV_ID==(if(is.null(input$search.id.ind)){"HSL_1190"}else{input$search.id.ind})),
group = "current_shape",
color = "#a53333", opacity = 1, weight = 3,
stroke = TRUE)
})
#Reset button
observe({
input$reset_button2
leafletProxy("indikatory") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom)})
leafletOutput("indikatory")
```
Row
-------------------------------------
```{r indikatory: TS}
renderDygraph({
ts.indikatory <- reac.ind()$ind_dta_f[UPOV_ID == default.shape.ind()] %>% select(value, DTM)
RangeMin <- min(ts.indikatory$value, na.rm = T)-0.5
RangeMax <- max(ts.indikatory$value, na.rm = T)+0.5
ts.indikatory$value[is.na(ts.indikatory$value)]<-0
ts.indikatory <- xts::xts(ts.indikatory, order.by = ts.indikatory$DTM)
dygraph(ts.indikatory,
main = paste(as.character(popis$NAZ_UTVAR[popis$UPOV_ID==default.shape.ind()])),
xlab = "Čas") %>%
dyAxis("y", valueRange = c(RangeMin, RangeMax)) %>%
dyLimit(0, strokePattern = "solid", color = "black") %>%
dyOptions(colors = "gray", fillGraph = TRUE, fillAlpha = 0.4) %>%
dyLegend(show = "always", hideOnMouseOut = FALSE)
})
```
Užívání {data-icon="fa-circle-o"}
=====================================
```{r uzivani: reactions}
#Reactions--------------------
povodi.ds <- reactive({
povodi[povodi$UPOV_ID==input$search.id.u, ]
})
pal_2 <- colorFactor("Paired", domain = u_leaflet$JEV, na.color = "#ffffff")
#Functions--------------------
default.shape2 <- reactive({
UPOV_ID.sel <- input$search.id.u
return(UPOV_ID.sel)})
title.f2 <- reactive({
title<- popis$NAZ_UTVAR[popis$UPOV_ID == default.shape2()]
return(title)
})
default.circle <- reactive({
if(is.null(input$uzivani_marker_click$id)){
NAZICO.sel <- u_leaflet$NAZICO[1]}
else{NAZICO.sel<-input$uzivani_marker_click$id}
return(NAZICO.sel)})
```
Row {data-height=600}
-------------------------------------
### Boční panel {data-width=100}
```{r uzivani: panel}
wellPanel(
renderUI({selectizeInput(inputId = "search.id.u", label = "Vyhledávání útvaru",
selected=input$uzivani_shape_click$id, choices = search.choices)
}),
hr(),
checkboxGroupInput("entry.layer_u", label = "Vrstvy",
choices = c("Mapový podklad" = "MP", "Polygony" = "P",
"Odběratele" = "O", "Řeky" = "R",
"Jezera" = "J", "Nádrže" = "N"),
selected = c("MP", "P", "O")))
```
### Mapa {data-width=450}
```{r uzivani: mapa}
output$uzivani <- renderLeaflet({
labels.points <- sprintf(
"%s
Povodí: %s
Jev: %s
ICOC: %s",
u_leaflet$NAZICO, u_leaflet$POVODI, u_leaflet$JEV, u_leaflet$ICOC) %>%
lapply(htmltools::HTML)
povodif <- base::subset(povodi,UPOV_ID != input$search.id.u)
labels <- sprintf(
"%s
Kategorie: %s
Stav: %s
ID: %s",
povodif$NAZ_UTVAR, povodif$KTG_UPOV, povodif$U_PMU, povodif$UPOV_ID) %>% lapply(htmltools::HTML)
if(length(labels)==0){labels <- c(" ")}
vrstvy <- input$entry.layer_u
centr <- rgeos::gCentroid(povodi.ds(), byid = TRUE)
uzivani <- leaflet() %>% setView(lng=centr@coords[1], lat = centr@coords[2], zoom=12)
if("MP" %in% vrstvy){
uzivani <- uzivani %>% addTiles(group = "Mapový podklad",
options = tileOptions(minZoom=7, maxZoom=20))}
if("R" %in% vrstvy){
uzivani <- uzivani %>% addPolylines(data=reky, color="#007C8C", weight = 1.5,
opacity = 1, stroke= TRUE, group = "Řeky") }
if("J" %in% vrstvy){
uzivani <- uzivani %>% addPolygons(data=jezera, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Jezera") }
if("N" %in% vrstvy){
uzivani <- uzivani %>% addPolygons(data=nadrze, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Nádrže") }
if("O" %in% vrstvy){
uzivani <- uzivani %>% addCircleMarkers(data=u_leaflet, radius = 6.5, color = "black",
fillColor = pal_2(u_leaflet$JEV),
weight = 0.5, opacity = 0.7, fillOpacity = 1, layerId = u_leaflet$NAZICO,
popup = labels.points, clusterOptions = markerClusterOptions()) %>%
addLegend(pal = pal_2, values = u_leaflet$JEV, opacity = 0.7, title = "Legenda",
position = "topright") }
if("P" %in% vrstvy){
uzivani <- uzivani %>% addPolygons(data=povodif, color = "#000000", fillColor = "#708090", weight = 2, opacity = 0.4, smoothFactor = 0,
layerId = povodi$UPOV_ID,
label = labels,
labelOptions = labelOptions(clickable = TRUE, noHide = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE,
"border-color" = "#F5F5F5"),
textsize = "13px", direction = "auto")) }
print(uzivani)
})
leafletOutput("uzivani")
```
### Časová řada {data-width=450}
```{r uzivani: casova rada}
renderDygraph({
ts.uzivani <- u[UPOV_ID == default.shape2()] %>% group_by(JEV, DTM) %>%
summarise(sum = sum(value)) %>% ungroup %>% dcast(DTM~JEV)
ts.uzivani <- xts::xts(ts.uzivani, order.by = ts.uzivani$DTM)
dygraph(ts.uzivani, main = paste(as.character(title.f2())))
})
```
Row {data-heigth=400}
-------------------------------------
### Suma dle odběratele {data-width=552}
```{r uzivani: tab:odberatel}
renderDataTable({
subtotal <- u[UPOV_ID == default.shape2()] %>% replace(is.na(.), 0) %>% group_by(NAZICO, JEV) %>% summarise(suma = sum(value)) %>% select(NAZICO, JEV, suma)}, class = 'compact cell-border', colnames = c("Odběratel", "Jev", "Suma"), options = list(scrollY = "300px", lengthMenu = c(100,200)))
```
### Časová řada - odběratel {data-width=448}
```{r uzivani: TS odberatel}
renderDygraph({
ts.uzivani <- u[NAZICO == default.circle()] %>% dcast(DTM~JEV)
ts.uzivani <- xts::xts(ts.uzivani, order.by = ts.uzivani$DTM)
dygraph(ts.uzivani, main = paste(as.character(default.circle())))
})
```
Validace {data-icon="fa-clone"}
=====================================
```{r validace: reactions}
#Functions--------------------
default.shape3 <- reactive({
UPOV_ID.sel <- input$search.id.val
return(UPOV_ID.sel)})
default.line <- reactive({
if(is.null(input$validace_shape_click$id)){
DBCN.sel <- QD$DBCN[1]}
else{DBCN.sel <- input$validace_shape_click$id}
return(DBCN.sel)})
selected.shape.A <- reactive({
UPOV_ID.sel <- stanice$UPOV_ID[stanice$DBCN == default.line()]
return(UPOV_ID.sel)})
title.f3.1 <- reactive({
title<- popis$NAZ_UTVAR[popis$UPOV_ID == default.shape3()]
return(title)
})
default.circle_val <- reactive({
if(is.null(input$validace_marker_click$id)){
DBCN.sel <- stanice$DBCN[1]}
else{DBCN.sel <- input$validace_marker_click$id}
return(DBCN.sel)})
title.f4 <- reactive({
if(is.null(input$validace_marker_click$id)){
title <- dta_val$NAZ[dta_val$DBCN == "171000"]}else{
title <- dta_val$NAZ[dta_val$DBCN == input$validace_marker_click$id]}
return(title)
})
title.f5 <- reactive({
if(is.null(input$validace_shape_click$id)){
title <- QD_stanice$NAZEV_TOK[QD_stanice$DBCN == "003000"]}else{
title <- QD_stanice$NAZEV_TOK[QD_stanice$DBCN==input$validace_shape_click$id]}
return(title)
})
```
Column {.sidebar data-width=300}
-------------------------------------
```{r validace: sidebar}
wellPanel(
HTML('
Vyhledat můžete jak dle názvu, tak dle UPOV_ID.
'),
radioButtons("validace", label = NULL, choices = c("Denní průtoky" = "A",
"Měsíční průtoky" = "AA",
"Přepínání parametrů" = "B",
"m-denní průtoky" = "C")),
conditionalPanel(condition = "input.validace == 'A'",
absolutePanel(class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = "auto", left = '1%',
right = "auto", bottom = '40%',
width = '13%', height = "2%",
style = "opacity: 1; style = z-index: 400",
HTML(''),
tags$div(id = 'box8', class="collapse", style = "max-height: 200px;
overflow-y:scroll"),
conditionalPanel(condition = "input.validace == 'A'",
checkboxGroupInput("entry.variable4", "Zvolte pozorovana data:",
choices = choices.QD,
selected = c("value")),
checkboxGroupInput("entry.variable5", "Zvolte simulovana data:",
choices = choices.routed,
selected = c("TRM_mm_d"))))),
conditionalPanel(condition = "input.validace == 'AA'",
absolutePanel(class = "panel panel-default", fixed = TRUE,
draggable = FALSE, top = "auto", left = '1%', right = "auto", bottom = '40%',
width = '13%', height = "2%",
style = "opacity: 1; style = z-index: 400",
HTML(''),
tags$div(id = 'box8', class="collapse", style = "max-height: 200px;
overflow-y:scroll"),
conditionalPanel(condition = "input.validace == 'AA'",
checkboxGroupInput("entry.variable6", "Zvolte:",
choices = choices3,
selected = c("QMER", "RM"))))),
conditionalPanel(condition = "input.validace == 'B'",
selectInput("entry.pars", label=NULL,
choices = choices.pars, selected = "Dgm")
),
conditionalPanel(condition = "input.validace == 'C'",
selectInput("entry.mday", label = NULL, choices = choices.mday),
renderUI({
selectizeInput(inputId = "search.id.val","Vyhledávání útvaru",
selected=input$validace_shape_click$id,
choices = search.choices)})
))
hr()
wellPanel(checkboxGroupInput("entry.layer.val", label = "Vrstvy",
choices = c("Mapový podklad" = "MP", "Data" = "P",
"Řeky" = "R", "Jezera" = "J",
"Nádrže" = "N", "Kraje" = "K",
"Okresy" = "O", "Povodí 3. řádu" = "P3"),
selected = c("MP", "P"), inline = T))
```
Row {data-height = 600}
-------------------------------------
### Mapa
```{r validace: mapa}
leafletOutput("validace")
output$validace <- renderLeaflet({
vrstvy <- input$entry.layer.val
vrstvyQD <- input$entry.layer.valA
validace <- leaflet()
if(input$validace == "A"){
labels.lines <- sprintf(
"%s
DBCN:%s
Plocha [km2]: %s",
QD_stanice$NAZEV_TOK, QD_stanice$DBCN, round(QD_stanice$AREA,2)) %>%
lapply(htmltools::HTML)
if("P" %in% vrstvy){
validace <- validace %>%
addPolylines(data=QD_stanice, color="#CA5557", weight = 2.3, dashArray = "3", fill = TRUE,
opacity = 1, stroke= TRUE, group = "QD", layerId = QD_stanice$DBCN,
highlightOptions = highlightOptions(color = "red", opacity = 1, fillOpacity = 1,
weight = 2.3, bringToFront = TRUE,
sendToBack = TRUE),
label = labels.lines,
labelOptions = labelOptions(clickable = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE,
"border-color" = "rgb(255, 255, 255)"),
textsize = "13px", direction = "auto"))}
}else if(input$validace == "AA"){
label.points <- sprintf(
"%s
DBCN:%s
UPOV_ID:%s",
stanice$NAZ, stanice$DBCN, stanice$UPOV_ID) %>%
lapply(htmltools::HTML)
if("P" %in% vrstvy){
validace <- validace %>% addCircleMarkers(data = stanice, lng = stanice@coords[,1], lat = stanice@coords[,2],
radius = 3.5, color = "black", fillColor = "#006600", weight = 0.5, opacity = 1,
fillOpacity = 1, layerId = stanice$DBCN) %>%
addPolylines(data = subset(povodi, UPOV_ID %in% tabB$FROM[tabB$TO==stanice$UPOV_ID[stanice$DBCN==default.circle_val()]]),
group = "current_upov",
color = "#00264d", opacity = 0.5, weight = 2) %>%
addPolylines(data = subset(povodi, UPOV_ID==stanice$UPOV_ID[stanice$DBCN==default.circle_val()]),
group = "current_upov",
color = "#a53333", opacity = 1, weight = 3) %>%
addPopups(lng=stanice@coords[stanice$DBCN==default.circle_val(),1],
lat=stanice@coords[stanice$DBCN==default.circle_val(),2],
label.points[stanice$DBCN == default.circle_val()])
}
}else if(input$validace == "B"){
pars_filtr <- pars %>% filter(name == input$entry.pars)
colnames(pars_filtr)[colnames(pars_filtr) == "current"] <- "value"
dta <- (sp::merge(povodi,pars_filtr, by="UPOV_ID"))
labels <- sprintf(
"%s
UPOV_ID: %s
current: %s
lower: %s
upper: %s
initial: %s",
dta$NAZ_UTVAR , dta$UPOV_ID, round(dta$value,3), dta$lower, dta$upper, dta$initial
) %>% lapply(htmltools::HTML)
pal <- colorBin("YlGnBu", domain = dta$value, pretty = TRUE)
if("P" %in% vrstvy){
validace <- validace %>% addPolygons(data=dta,
color = "burlywood4", weight = 1.3, smoothFactor = 0,
opacity = 0.3, fillColor = ~pal(value),
fillOpacity = 0.8, group = "Povodí",
highlightOptions = highlightOptions(color = "#800000", opacity = 0.8,
weight = 2.3,
bringToFront = TRUE, sendToBack=TRUE),
label = labels,
labelOptions = labelOptions(clickable = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE, noHide = TRUE,
"border-color" = "rgb(255, 255, 255)"),
textsize = "15px", direction = "auto")) %>%
addLegend(pal = pal, values = dta$value, opacity = 0.7, title = "Legenda",
position = "bottomright")}
}else{
chars_filtr <- chars %>% select(UPOV_ID, input$entry.mday)
colnames(chars_filtr)[colnames(chars_filtr) == input$entry.mday] <- "value"
dta <- (sp::merge(povodi,chars_filtr, by="UPOV_ID"))
labels <- sprintf(
"%s
UPOV_ID: %s
Hodnota: %s",
dta$NAZ_UTVAR, dta$UPOV_ID, round(dta$value,3)) %>% lapply(htmltools::HTML)
pal <- colorBin("YlGnBu", domain = round(dta$value,3), pretty = TRUE)
if("P" %in% vrstvy){
validace <- validace %>% addPolygons(data=dta, layerId = dta$UPOV_ID,
color = "burlywood4", weight = 1.3, smoothFactor = 0,
opacity = 0.3, fillColor = ~pal(value),
fillOpacity = 0.8, group = "Povodí",
highlightOptions = highlightOptions(color = "#800000", opacity = 0.8,
weight = 2.3,
bringToFront = TRUE, sendToBack=TRUE),
label = labels,
labelOptions = labelOptions(clickable = TRUE,
style = list("font-weight" = "normal",
"font-family" = "sans-serif", padding = "3px 8px",
keepInView = TRUE, noHide = TRUE,
"border-color" = "rgb(255, 255, 255)"),
textsize = "15px", direction = "auto")) %>%
addLegend(pal = pal, values = round(dta$value,2), opacity = 0.7, title = "Legenda",
position = "bottomright")
}
}
#Vrstvy mapy
if("MP" %in% vrstvy){
validace <- validace %>% addTiles(group = "Mapový podklad", options = tileOptions(minZoom=7, maxZoom=13))}
if("R" %in% vrstvy){
validace <- validace %>% addPolylines(data=reky, color="#007C8C", weight = 1.5,
opacity = 1, stroke= TRUE, group = "Řeky")}
if("J" %in% vrstvy){
validace <- validace %>% addPolygons(data=jezera, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Jezera")}
if("N" %in% vrstvy){
validace <- validace %>% addPolygons(data=nadrze, color="#007C8C", fillColor = "#0099ff",
weight = 1, opacity = 1, stroke= TRUE, group = "Nádrže")}
if("K" %in% vrstvy){
validace <- validace %>% addPolylines(data=kraje, color="#000000", weight = 2.5,
stroke= TRUE, group = "Kraje")}
if("O" %in% vrstvy){
validace <- validace %>% addPolylines(data=okresy, color="#000000", weight = 2,
stroke= TRUE, group = "Okresy")}
if("P3" %in% vrstvy){
validace <- validace %>% addPolylines(data=povodi_III, color="#cc0000", weight = 2.5, opacity = 1,
stroke= TRUE, group = "Povodí 3. řádu")}
print(validace)
})
```
Row {.tabset data-height=400}
-------------------------------------
### Grafy
```{r}
renderPlotly({
if(input$validace == "A"){
d <- dir(file.path(.datadir, "webapp_data/routed-0_bilan_bez_VN"))
routed0_dir <- data.frame(source=d, UPOV_ID=gsub("*.rds","",d))
routed <- readRDS(file.path(.datadir,"webapp_data/routed-0_bilan_bez_VN",
routed0_dir$source[routed0_dir$UPOV_ID==selected.shape.A()]))
routed <- routed[,c("DTM", "TRM_mm_d")]
ts.routed <- routed %>%
mutate(month = format(DTM, "%m"), year = format(DTM, "%Y")) %>%
group_by(year) %>% mutate(RM_year = mean(TRM_mm_d, na.rm = TRUE)) %>% ungroup %>%
group_by(month, year) %>% mutate(RM_month = mean(TRM_mm_d, na.rm=TRUE)) %>% ungroup %>%
select(input$entry.variable5, DTM)
ts.QD <- QD %>% filter(DBCN == default.line()) %>%
mutate(month = format(DTM, "%m"), year = format(DTM, "%Y")) %>%
group_by(year) %>% mutate(mean_year = mean(value, na.rm = TRUE)) %>% ungroup %>%
group_by(month, year) %>% mutate(mean_month = mean(value, na.rm=TRUE)) %>% ungroup %>%
select(input$entry.variable4, DTM)
p1 <- plot_ly(mode="lines", type="scatter", line = list(width = 1)) %>%
layout(title=paste(as.character(title.f5())))
if( "value" %in% input$entry.variable4){
p1 <- p1 %>% add_trace(data=ts.QD, text=paste(ts.QD$DTM), x = ~DTM, y = ~value,
name = 'Denni prutoky')}
if( "mean_month" %in% input$entry.variable4){
p1 <- p1 %>% add_trace(data=ts.QD, text=paste(ts.QD$DTM), x = ~DTM, y = ~mean_month,
name = 'Mesicni prumery prutoku')}
if("mean_year" %in% input$entry.variable4){
p1 <- p1 %>% add_trace(data=ts.QD, text=paste(ts.QD$DTM), x = ~DTM, y = ~mean_year,
name = 'Rocni prumery prutoku')}
if("TRM_mm_d" %in% input$entry.variable5){
p1 <- p1 %>% add_trace(data=ts.routed, text=paste(routed$DTM), x = ~DTM, y = ~TRM_mm_d,
name = 'Simulovane prutoky')}
if("RM_month" %in% input$entry.variable5){
p1 <- p1 %>% add_trace(data=ts.routed, text=paste(routed$DTM), x = ~DTM, y = ~RM_month,
name = 'Simulovane mesicni prutoky')}
if("RM_year" %in% input$entry.variable5){
p1 <- p1 %>% add_trace(data=ts.routed, text=paste(routed$DTM), x = ~DTM, y = ~RM_year,
name = 'Simulovane rocni prutoky')}
p1
}else if(input$validace == "AA"){
ts.dta.val <- dta_val %>% filter(DBCN == default.circle_val()) %>% select(input$entry.variable6, DTM)
p <- plot_ly(data=ts.dta.val, text=paste(ts.dta.val$DTM),
mode="lines", type="scatter", line = list(width = 1)) %>%
layout(title=paste(as.character(title.f4())))
if( "QMER" %in% input$entry.variable6){
p <- p %>% add_trace(x = ~DTM, y = ~QMER, name = 'QMER')}
if( "QNEX" %in% input$entry.variable6){
p <- p %>% add_trace(x = ~DTM, y = ~QNEX, name = 'QNEX')}
if("QNEY" %in% input$entry.variable6){
p <- p %>% add_trace(x = ~DTM, y = ~QNEY, name = 'QNEY')}
if("RM" %in% input$entry.variable6){
p <- p %>% add_trace(x = ~DTM, y = ~RM, name = 'RM')}
p %>% layout(yaxis = list(title = "value"))
}else if(input$validace == "C"){
chars_filter <- chars %>% filter(UPOV_ID == default.shape3()) %>% select(choices.mday)
chars_filter <- data.frame(value = t(chars_filter), m = c(seq(30,330,30),355,364))
chars_sim_filter <- chars_sim %>% filter(UPOV_ID == default.shape3()) %>% select(choices.mday)
chars_sim_filter <- data.frame(value = t(chars_sim_filter), m = c(seq(30,330,30),355,364))
p2 <- plot_ly(type="scatter", mode="lines") %>%
layout(title=paste(as.character(title.f3.1())))
p2 <- p2 %>% add_trace(data=chars_filter, x=~m, y=~value, name = 'Pozorovana data')
p2 <- p2 %>% add_trace(data=chars_sim_filter, x=~m, y=~value, name = 'Simulovana data')
p2
}
})
```
### Tabulky
```{r}
renderTable({
if(input$validace == "A"){
QD_filter <- QD %>% filter(DBCN == default.line()) %>% select(value) %>% unlist
QD_filter <- psych::describe(QD_filter, skew = F, IQR = T, quant = c(0.5, 0.75))
QD_filter <-cbind(name="value",QD_filter[,-1])
}else if(input$validace == "AA"){
t1 <- dta_val %>% filter(DBCN == default.circle_val()) %>% select(QMER, QNEX, QNEY, RM)
t1 <- psych::describe(t1, skew = F, IQR = T, quant = c(0.5, 0.75))
t1 <- as.data.frame(t1)
t1$vars <- rownames(t1)
rownames(t1) <- NULL
t2a <- hydroGOF::gof(dta_val$RM, dta_val$QNEX)
colnames(t2a) <- "QNEX"
t2b <- hydroGOF::gof(dta_val$RM, dta_val$QNEY)
colnames(t2b) <- "QNEY"
t2c <- hydroGOF::gof(dta_val$RM, dta_val$QMER)
colnames(t2c) <- "QMER"
t2 <- as.data.frame(t(cbind(t2a, t2b, t2c)))
print(t2)
} else if(input$validace == "C"){
chars_filter <- chars %>% filter(UPOV_ID == default.shape3()) %>% select(choices.mday)
chars_sim_filter <- chars_sim %>% filter(UPOV_ID == default.shape3()) %>% select(choices.mday)
table <- rbind(chars_filter, chars_sim_filter)
rownames(table) <- c("Pozorovana data", "Simulovana data")
print(table)
}
}, digits = 3, spacing = 'xs', rownames = TRUE)
```
O projektu {data-icon="fa-user-circle"}
=====================================
#### O projektu
Systém je založen na propojení modelu půdního (SoilClim), modelu hydrologické (Bilan) a vodohospodářské bilance. Tyto modely spolu se vstupními klimatologickými daty reprezentují sucho meteorologické, zemědělské a hydrologické.
Na vzniku systému se podílí:
##### **Výzkumný ústav vodohospodářský T. G. Masaryka, v.v.i.**
Podbabská 30, 160 00 Praha 6
**Ing. Adam Vizina, Ph.D.**
##### **Česká zemědělská univerzita v Praze, Fakulta životního prostředí**
Kamýcká 129, 165 21 Praha 6
**doc. Ing. Martin Hanel, Ph.D.**
##### **Ústav výzkumu globální změny AV ČR, v.v.i.**
Bělidla 986/4a, 603 00 Brno
**prof. Ing. Mgr. Miroslav Trnka, Ph.D.**
##### **Český hydrometeorologický ústav**
Na Šabatce 2050/17, 143 06 Praha 412
**RNDr. Jan Daňhelka, Ph.D.**
Systém pro předpověď sucha vznikl v rámci projektu financovaném Ministerstvem životního prostředí v roce 2017.