hydro:shiny
Unterschiede
Hier werden die Unterschiede zwischen zwei Versionen angezeigt.
Beide Seiten der vorigen RevisionVorhergehende ÜberarbeitungNächste Überarbeitung | Vorhergehende Überarbeitung | ||
hydro:shiny [2024/04/10 10:02] – Externe Bearbeitung 127.0.0.1 | hydro:shiny [2024/04/15 15:11] (aktuell) – angelegt ckuells | ||
---|---|---|---|
Zeile 1: | Zeile 1: | ||
- | ====== Beispiel für einen Shiny-Code ====== | + | === Mixing Model === |
- | Dieses Beispiel erfordert noch Eingabedateien. | ||
- | |||
- | <code R |Shiny.R> | ||
- | |||
- | library(shiny) | ||
- | library(datasets) | ||
- | library(ggplot2) | ||
- | require(maptools) | ||
- | |||
- | ui <- shinyUI(fluidPage( | ||
- | titlePanel(" | ||
- | tabsetPanel( | ||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | ), | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | |||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | ' | ||
- | ' | ||
- | |||
- | # added interface for uploading data from | ||
- | # http:// | ||
- | | ||
- | | ||
- | | ||
- | c(Comma=',', | ||
- | Semicolon=';', | ||
- | Tab=' | ||
- | ',' | ||
- | | ||
- | c(None='', | ||
- | ' | ||
- | ' | ||
- | '"' | ||
- | |||
- | ), | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | pageWithSidebar( | ||
- | headerPanel(' | ||
- | sidebarPanel( | ||
- | # "Empty inputs" | ||
- | | ||
- | | ||
- | |||
- | ), | ||
- | mainPanel( | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | ' | ||
- | ' | ||
- | |||
- | # added interface for uploading data from | ||
- | # http:// | ||
- | | ||
- | | ||
- | | ||
- | c(Comma=',', | ||
- | Semicolon=';', | ||
- | Tab=' | ||
- | ',' | ||
- | | ||
- | c(None='', | ||
- | ' | ||
- | ' | ||
- | '"' | ||
- | |||
- | ), | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | |||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | # "Empty inputs" | ||
- | # "Empty inputs" | ||
- | | ||
- | | ||
- | | ||
- | label = "Wet area %", | ||
- | min = 0.0, | ||
- | max = 5.0, | ||
- | value = 1.5), | ||
- | | ||
- | label = " | ||
- | min = 0.135, | ||
- | max = 0.25, | ||
- | value = 0.135) | ||
- | ), | ||
- | | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | ' | ||
- | ' | ||
- | |||
- | | ||
- | | ||
- | | ||
- | c(Comma=',', | ||
- | Semicolon=';', | ||
- | Tab=' | ||
- | ',' | ||
- | | ||
- | c(None='', | ||
- | ' | ||
- | ' | ||
- | '"' | ||
- | |||
- | ), | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | pageWithSidebar( | ||
- | | ||
- | | ||
- | # "Empty inputs" | ||
- | sliderInput(inputId = " | ||
- | label = " | ||
- | min = 0.05, | ||
- | max = 0.25, | ||
- | value = 0.2), | ||
- | sliderInput(inputId = " | ||
- | label = " | ||
- | min = 10, | ||
- | max = 250, | ||
- | value = 50), | ||
- | plotOutput(' | ||
- | ), | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | # "Empty inputs" | ||
- | | ||
- | 10, min = 1, | ||
- | max = 10000), | ||
- | # verbatimTextOutput(" | ||
- | | ||
- | 10, min = 1, | ||
- | max = 100), | ||
- | # verbatimTextOutput(" | ||
- | | ||
- | 10, min = 1, | ||
- | max = 100), | ||
- | | ||
- | label = "Slope in m/m", | ||
- | min = 0.001, | ||
- | max = 0.1, | ||
- | value = 0.01), | ||
- | | ||
- | label = " | ||
- | value = 1000, | ||
- | min = 0, | ||
- | max = 1000000), | ||
- | | ||
- | label = " | ||
- | value = 0.0, | ||
- | min = 0.0, | ||
- | max = 10.0), | ||
- | ), | ||
- | | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ), | ||
- | | ||
- | tabPanel(" | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | | ||
- | label = " | ||
- | min = 0.0, | ||
- | max = 5.0, | ||
- | value = 1.0), | ||
- | | ||
- | label = " | ||
- | min = 0.0, | ||
- | max = 5.0, | ||
- | value = 1.0) | ||
- | ), | ||
- | | ||
- | | ||
- | | ||
- | ) | ||
- | ) | ||
- | ) | ||
- | | ||
- | ) | ||
- | ) | ||
- | |||
- | |||
- | server <- shinyServer(function(input, | ||
- | # added " | ||
- | | ||
- | # rainfall file and processing | ||
- | data <- reactive({ | ||
- | req(input$file1) ## ?req # require that the input is available | ||
- | |||
- | inFile <- input$file1 | ||
- | |||
- | # tested with a following dataset: write.csv(mtcars, | ||
- | # and write.csv(iris, | ||
- | df <- read.csv(inFile$datapath, | ||
- | quote = input$quoteR) | ||
- | |||
- | |||
- | # Update inputs (you could create an observer with both updateSel...) | ||
- | # You can also constraint your choices. If you wanted select only numeric | ||
- | # variables you could set " | ||
- | # It depends on what do you want to do later on. | ||
- | |||
- | updateSelectInput(session, | ||
- | choices = " | ||
- | updateSelectInput(session, | ||
- | choices = names(df), selected = names(df)[2]) | ||
- | |||
- | return(df) | ||
- | }) | ||
- | |||
- | output$contentsPrec <- renderTable({ | ||
- | data() | ||
- | }) | ||
- | |||
- | output$Plot <- renderPlot({ | ||
- | # plot the data using ggplot | ||
- | datumR <- as.Date(data()[, | ||
- | precData <- data()[, | ||
- | dx <- data.frame(datumR, | ||
- | ggplot(dx, aes(x = datumR, y = precData)) + | ||
- | geom_bar(stat=" | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | }) | ||
- | | ||
- | output$Hist <- renderPlot({ | ||
- | # histogram | ||
- | dy <- data()[, | ||
- | dy[dy < 1] <- NA | ||
- | hist(dy, breaks = 25, freq = FALSE, col = ' | ||
- | }) | ||
- | | ||
- | # climate file and processing | ||
- | dataC <- reactive({ | ||
- | req(input$file2) ## ?req # require that the input is available | ||
- | | ||
- | inFileC <- input$file2 | ||
- | | ||
- | # tested with a following dataset: write.csv(mtcars, | ||
- | # and write.csv(iris, | ||
- | dfC <- read.csv(inFileC$datapath, | ||
- | quote = input$quoteC) | ||
- | | ||
- | # Update inputs (you could create an observer with both updateSel...) | ||
- | # You can also constraint your choices. If you wanted select only numeric | ||
- | # variables you could set " | ||
- | # It depends on what do you want to do later on. | ||
- | | ||
- | updateSelectInput(session, | ||
- | choices = " | ||
- | updateSelectInput(session, | ||
- | choices = names(dfC), selected = names(dfC)[2]) | ||
- | | ||
- | return(dfC) | ||
- | }) | ||
- | | ||
- | output$contentsClim <- renderTable({ | ||
- | dataC() | ||
- | }) | ||
- | | ||
- | output$PlotC <- renderPlot({ | ||
- | # plot the data using ggplot | ||
- | datumC <- as.Date(dataC()[, | ||
- | climData <- dataC()[, | ||
- | dxC <- data.frame(datumC, | ||
- | ggplot(dxC, aes(x = datumC, y = climData)) + | ||
- | geom_line(size = 1.0) + | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | }) | ||
- | | ||
- | output$HistC <- renderPlot({ | ||
- | # histogram | ||
- | dyC <- dataC()[, | ||
- | dyC[dyC < 1] <- NA | ||
- | hist(dyC, breaks = 25, freq = FALSE, col = ' | ||
- | }) | ||
- | |||
- | # discharge file and processing | ||
- | dataM <- reactive({ | ||
- | req(input$file3) ## ?req # require that the input is available | ||
- | | ||
- | inFileC <- input$file3 | ||
- | | ||
- | dfM <- read.csv(inFileC$datapath, | ||
- | quote = input$quoteM) | ||
- | | ||
- | # Update inputs (you could create an observer with both updateSel...) | ||
- | # You can also constraint your choices. If you wanted select only numeric | ||
- | # variables you could set " | ||
- | # It depends on what do you want to do later on. | ||
- | | ||
- | updateSelectInput(session, | ||
- | choices = " | ||
- | updateSelectInput(session, | ||
- | choices = names(dfM), selected = names(dfM)[2]) | ||
- | | ||
- | return(dfM) | ||
- | }) | ||
- | | ||
- | output$contentsMeasured <- renderTable({ | ||
- | dataM() | ||
- | }) | ||
- | | ||
- | output$PlotM <- renderPlot({ | ||
- | # plot the data using ggplot | ||
- | datumM <- as.Date(dataM()[, | ||
- | measuredData <- dataM()[, | ||
- | dxM <- data.frame(datumM, | ||
- | ggplot(dxM, aes(x = datumM, y = measuredData)) + | ||
- | geom_line(size = 1.0) + | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | }) | ||
- | | ||
- | output$HistM <- renderPlot({ | ||
- | # histogram | ||
- | dyM <- dataM()[, | ||
- | dyM[dyM < 1] <- NA | ||
- | hist(dyM, breaks = 25, freq = FALSE, col = ' | ||
- | }) | ||
- | | ||
- | # read a shape file + | ||
- | uploadShpfile <- reactive({ | ||
- | if (!is.null(input$shpFile)){ | ||
- | shpDF <- input$shpFile | ||
- | prevWD <- getwd() | ||
- | uploadDirectory <- dirname(shpDF$datapath[1]) | ||
- | setwd(uploadDirectory) | ||
- | for (i in 1: | ||
- | file.rename(shpDF$datapath[i], | ||
- | } | ||
- | shpName <- shpDF$name[grep(x=shpDF$name, | ||
- | shpPath <- paste(uploadDirectory, | ||
- | setwd(prevWD) | ||
- | shpFile <- readShapePoly(shpPath) | ||
- | return(shpFile) | ||
- | } else { | ||
- | return() | ||
- | } | ||
- | }) | ||
- | | ||
- | output$map <- renderPlot({ | ||
- | if (!is.null(uploadShpfile())){ | ||
- | plot(uploadShpfile()) | ||
- | } | ||
- | }) | ||
- | | ||
- | output$area <- renderText({ input$area}) | ||
- | output$length <- renderText({ input$length }) | ||
- | | ||
- | # render SCS plot | ||
- | output$scsCurve <- renderPlot({ | ||
- | # SCS | ||
- | lambda <- input$Sia | ||
- | scn <- input$Scn | ||
- | sia <- lambda * scn | ||
- | |||
- | # Rainfall to Runoff | ||
- | prDatum <- as.Date(data()[, | ||
- | prSeries <- data()[, | ||
- | pt <- data.frame(prDatum, | ||
- | | ||
- | qsSeries <- prSeries*0 | ||
- | | ||
- | ip <- length(qsSeries) | ||
- | |||
- | i=1 | ||
- | while (i<=ip) { | ||
- | if (prSeries[i]< | ||
- | qsSeries[i] <- 0 | ||
- | } else { | ||
- | qsSeries[i] <- (prSeries[i]-sia)^2/ | ||
- | } | ||
- | i = i+1 | ||
- | } | ||
- | | ||
- | qt <- data.frame(prDatum, | ||
- | |||
- | ggplot(qt, aes(x = prDatum, y = qsSeries)) + | ||
- | geom_bar(stat=" | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | |||
- | }) | ||
- | |||
- | # render SCS plot | ||
- | output$scsCurveSidebar <- renderPlot({ | ||
- | # SCS | ||
- | lambda <- input$Sia | ||
- | scn <- input$Scn | ||
- | sia <- lambda * scn | ||
- | prs <- seq(0, | ||
- | qss <- prs*0 | ||
- | ln <- length(prs) | ||
- | | ||
- | i=1 | ||
- | while (i<=ln) { | ||
- | if (prs[i]< | ||
- | qss[i] <- 0 | ||
- | } else { | ||
- | qss[i] <- (prs[i]-sia)^2/ | ||
- | } | ||
- | i = i+1 | ||
- | } | ||
- | xy <- data.frame(prs, | ||
- | ggplot(data=xy, | ||
- | geom_line(linetype = " | ||
- | geom_point() + | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | }) | ||
- | | ||
- | # Calculate Discharge | ||
- | output$Discharge <- renderPlot({ | ||
- | | ||
- | lambda <- input$Sia | ||
- | scn <- input$Scn | ||
- | sia <- lambda * scn | ||
- | |||
- | # CIA | ||
- | barea <- input$Area | ||
- | blength | ||
- | bwidth | ||
- | bslope | ||
- | casm <- input$Ca | ||
- | tlr <- input$Tl | ||
- | |||
- | # Rainfall to Runoff | ||
- | dDatum <- as.Date(data()[, | ||
- | pSeries <- data()[, | ||
- | dt <- data.frame(dDatum, | ||
- | |||
- | dSeries <- pSeries*0 | ||
- | dHeight <- pSeries*0 | ||
- | dLosses <- pSeries*0 | ||
- | |||
- | id <- length(dSeries) | ||
- | | ||
- | tcmsi <- 0.0195*(blength*1000)^0.77*bslope^-0.385 # time in minutes | ||
- | tdurs <- tcmsi*60*2.67 # event duration in hours | ||
- | # transmission losses in channel | ||
- | trlos <- blength*1000*bwidth*tlr/ | ||
- | | ||
- | i=1 | ||
- | while (i<=id) { | ||
- | if (pSeries[i]< | ||
- | dSeries[i] <- 0 | ||
- | } else { | ||
- | # Runoff calculation in dSeries: From mm in pSeries to cubic meters per second | ||
- | # p (mm/sm*d) -> r (mm/sm*d) -> q (cubic m/s): p x area*1E+6 * 1/1000 * 1/86400 | ||
- | conversion <- barea*1E+6 * 1/1000 * 1/86400 | ||
- | dSeries[i] <- ((pSeries[i]-sia)^2/ | ||
- | | ||
- | # convolution and routing | ||
- | | ||
- | # Previous calculation of losses: | ||
- | # units x Area x infiltration per hour x Duration in hours | ||
- | if(dSeries[i] >= trlos){ | ||
- | dSeries[i] | ||
- | dLosses[i] | ||
- | } else { | ||
- | dLosses[i] | ||
- | dSeries[i] | ||
- | } | ||
- | } | ||
- | dHeight[i] <- dSeries[i]/ | ||
- | i = i+1 | ||
- | } | ||
- | | ||
- | dt <- data.frame(dDatum, | ||
- | ggplot(data=dt, | ||
- | geom_line(linetype = " | ||
- | labs(x = " | ||
- | y = " | ||
- | title = " | ||
- | | ||
- | }) | ||
- | | ||
- | # Calculate Concentration time | ||
- | output$Tcmsi <- renderText({ | ||
- | # CIA | ||
- | barea <- input$Area | ||
- | blength | ||
- | bwidth | ||
- | bslope | ||
- | mn <- input$Mn | ||
- | | ||
- | # concentration time in min/hours | ||
- | tcmsi <- 0.0195*(blength*1000)^0.77*bslope^-0.385 # time in minutes | ||
- | tcmsi <- format(tcmsi, | ||
- | |||
- | paste(" | ||
- | |||
- | }) | ||
- | | ||
- | # Calculate Peak Discharge | ||
- | output$CIA <- renderText({ | ||
- | # CIA | ||
- | barea <- input$Area | ||
- | blength | ||
- | bwidth | ||
- | bslope | ||
- | mn <- input$Mn | ||
- | | ||
- | # concentration time in min/hours | ||
- | CIA <- 1/ | ||
- | CIA <- format(CIA, digits = 3) | ||
- | | ||
- | paste(" | ||
- | | ||
- | }) | ||
- | | ||
- | }) | ||
- | |||
- | shinyApp(ui, | ||
- | |||
- | </ |
/usr/www/users/uhydro/doku/data/attic/hydro/shiny.1712736173.txt.gz · Zuletzt geändert: 2024/04/10 10:02 von 127.0.0.1