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