├── md ├── todo.md ├── rightclick.md ├── images │ ├── topmodel_m.png │ └── Reed1_small.png ├── dtrng.md ├── mamnotes.md ├── recess_dur.md ├── boxplot-info.md ├── recess_durTime.md ├── recession_coef.md ├── bfannnotes.md ├── cumu.md ├── saas_mmbf.md ├── bfmntnotes.md ├── parsenotes.md ├── saas.md ├── references.md ├── bfnotes.md ├── knotes.md ├── ihanotes.md └── about.md ├── pkg ├── sources.R ├── styles.css ├── js.R ├── packages.R ├── html.R └── app_members.R ├── images ├── eq_k.png └── screenshot.png ├── www ├── favicon.png ├── loading_bar.gif ├── loading_bar_rev.gif ├── ORMGP_logo_no_text_short.png └── ORMGP_logo_no_text_bw_small.png ├── doc └── sHydrologyUM.pdf ├── dat └── Hydat.sqlite3.txt ├── ui ├── settings.R ├── hydrograph │ ├── disaggregation.R │ ├── data │ │ ├── data_qual.R │ │ ├── data_table.R │ │ └── data_summary.R │ ├── separation.R │ └── discharge.R ├── references.R ├── trend │ ├── annual.R │ ├── daily.R │ ├── seasonal.R │ ├── monthly.R │ ├── cumu.R │ └── monthly_bf.R ├── about.R ├── statistics │ ├── recess_dur.R │ ├── recession.R │ ├── peak.R │ ├── mam.R │ └── eflows.R ├── trends.R ├── stats.R └── hydrograph.R ├── functions ├── integer-breaks.R ├── piecewiseReg.R ├── return-period-q.R ├── separateHydrograph.R ├── globals.R ├── monthly35.R ├── hydrograph_fdc.R ├── hydrograph_monthly_bar.R ├── daterange.R ├── baseflow_range.R ├── hydrograph_parsing_plot.R ├── collect_hydrograph.R ├── hydrograph_recession_coef.R ├── hydrograph_parsing.R ├── iha.R ├── hydrograph_frequency_analysis.R ├── HYDAT_query.R └── hydrograph_separation.R ├── server ├── hydrograph │ ├── data │ │ ├── data_qual.R │ │ ├── data_summary.R │ │ └── data_table.R │ ├── discharge_leaflet.R │ ├── disaggregation.R │ ├── discharge_gghydgrph.R │ ├── discharge.R │ ├── separation.R │ └── discharge_dyhygrph.R ├── statistics │ ├── recession.R │ ├── saas_cff.R │ ├── saas_roc.R │ ├── saas_hfp.R │ ├── recess_dur.R │ ├── peak.R │ ├── saas_rf.R │ ├── mam.R │ ├── saas.R │ └── iha.R ├── server_sources.R └── trend │ ├── monthly.R │ ├── seasonal.R │ ├── annual.R │ ├── cumu.R │ ├── daily.R │ └── monthly_bf.R ├── .gitignore ├── LICENSE ├── app.R └── README.md /md/todo.md: -------------------------------------------------------------------------------- 1 | This functionality is under construction 2 | -------------------------------------------------------------------------------- /pkg/sources.R: -------------------------------------------------------------------------------- 1 | 2 | source("functions/HYDAT_query.R", local = TRUE) -------------------------------------------------------------------------------- /md/rightclick.md: -------------------------------------------------------------------------------- 1 | **Note:** save plot by *right-clicking* to `Save Image As...` 2 | -------------------------------------------------------------------------------- /pkg/styles.css: -------------------------------------------------------------------------------- 1 | 2 | /* Define empty space */ 3 | .space300 { margin-top: 300px; } -------------------------------------------------------------------------------- /images/eq_k.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/images/eq_k.png -------------------------------------------------------------------------------- /www/favicon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/www/favicon.png -------------------------------------------------------------------------------- /www/loading_bar.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/www/loading_bar.gif -------------------------------------------------------------------------------- /doc/sHydrologyUM.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/doc/sHydrologyUM.pdf -------------------------------------------------------------------------------- /images/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/images/screenshot.png -------------------------------------------------------------------------------- /md/images/topmodel_m.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/md/images/topmodel_m.png -------------------------------------------------------------------------------- /www/loading_bar_rev.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/www/loading_bar_rev.gif -------------------------------------------------------------------------------- /md/images/Reed1_small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/md/images/Reed1_small.png -------------------------------------------------------------------------------- /md/dtrng.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | *Adjusting the above time-series will affect plots on this page. Use to compare differing time-periods.* -------------------------------------------------------------------------------- /www/ORMGP_logo_no_text_short.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/www/ORMGP_logo_no_text_short.png -------------------------------------------------------------------------------- /dat/Hydat.sqlite3.txt: -------------------------------------------------------------------------------- 1 | placeholder for Hydat.sqlite3 that can be downloaded here: http://collaboration.cmc.ec.gc.ca/cmc/hydrometrics/www/ -------------------------------------------------------------------------------- /www/ORMGP_logo_no_text_bw_small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maseology/sHydrology_analysis/HEAD/www/ORMGP_logo_no_text_bw_small.png -------------------------------------------------------------------------------- /ui/settings.R: -------------------------------------------------------------------------------- 1 | navbarMenu("Settings", 2 | tabPanel("baseflow parameters", 3 | shiny::includeMarkdown("md/todo.md") 4 | ) 5 | ) -------------------------------------------------------------------------------- /md/mamnotes.md: -------------------------------------------------------------------------------- 1 | #### Mean Annual Minimum (MAM): 2 | 3 | An *n*-day MAM is the minimum average discharge over *n* consecutive days, for a given calendar year. 4 | -------------------------------------------------------------------------------- /md/recess_dur.md: -------------------------------------------------------------------------------- 1 | from Gustard, A. & Demuth, S. (2009) (Eds) Manual on Low-flow Estimation and Prediction. Operational Hydrology Report No. 50, WMO-No. 1029, 136p. -------------------------------------------------------------------------------- /ui/hydrograph/disaggregation.R: -------------------------------------------------------------------------------- 1 | 2 | fluidRow( 3 | shiny::includeMarkdown("md/parsenotes.md"), 4 | hr(), 5 | htmlOutput("hdr1"), 6 | dygraphOutput("hydgrph.prse"), 7 | br(), 8 | plotOutput("hydgrph.prse.scatter") 9 | ) -------------------------------------------------------------------------------- /ui/references.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | tabPanel("References", 4 | fluidPage( 5 | column(2), 6 | column(8, 7 | shiny::includeMarkdown("md/references.md") 8 | ) 9 | ) 10 | ) -------------------------------------------------------------------------------- /ui/trend/annual.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel('Annual series'), 4 | column(6, plotOutput('yr.q')), 5 | column(6, plotOutput('yr.q.rel')), br(), 6 | shiny::includeMarkdown("md/rightclick.md"), br(), 7 | shiny::includeMarkdown("md/bfannnotes.md") 8 | ) -------------------------------------------------------------------------------- /ui/hydrograph/data/data_qual.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | headerPanel('Data summary'), 3 | htmlOutput("hdr.qual"), br(), 4 | column(6, h4('count'), 5 | tableOutput('qaqc.cnt')), 6 | column(6, h4('average discharge'), 7 | tableOutput('qaqc.avg')) 8 | ) 9 | -------------------------------------------------------------------------------- /md/boxplot-info.md: -------------------------------------------------------------------------------- 1 | 2 | Boxpots follow the method of McGill et.al. (1978): box represents the 25% to 75% quantile, while the centre line represents median (50% quantile). Whiskers represent the observation less than or equal to the box extents ±1.5 * IQR (inter-quartile range). -------------------------------------------------------------------------------- /md/recess_durTime.md: -------------------------------------------------------------------------------- 1 | The above plot is a simple means of determining how long high flows would return to base levels. This could be informative in cases when discharge high, and a water resource manager wishes to know the period with which there is a higher flood risk due to wet anticedent conditions. -------------------------------------------------------------------------------- /functions/integer-breaks.R: -------------------------------------------------------------------------------- 1 | # https://stackoverflow.com/questions/15622001/how-to-display-only-integer-values-on-an-axis-using-ggplot2 2 | integer_breaks <- function(n = 5, ...) { 3 | fxn <- function(x) { 4 | breaks <- floor(pretty(x, n, ...)) 5 | names(breaks) <- attr(breaks, "labels") 6 | breaks 7 | } 8 | return(fxn) 9 | } -------------------------------------------------------------------------------- /ui/about.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # tabPanel("About", shiny::includeMarkdown("md/about.md")) 4 | 5 | 6 | tabPanel("About", 7 | withMathJax(), 8 | fluidPage( 9 | column(2), 10 | column(8, 11 | shiny::includeMarkdown("md/about.md"), 12 | shiny::includeMarkdown("md/references.md") 13 | ) 14 | ) 15 | ) -------------------------------------------------------------------------------- /server/hydrograph/data/data_qual.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | output$qaqc.cnt <- renderTable({ 4 | if (!is.null(sta$hyd)) group1(read.zoo(sta$hyd[,1:2]),length,TRUE) 5 | }, 6 | rownames = TRUE 7 | ) 8 | 9 | output$qaqc.avg <- renderTable({ 10 | if (!is.null(sta$hyd)) group1(read.zoo(sta$hyd[,1:2]),mean,TRUE) 11 | }, 12 | rownames = TRUE 13 | ) 14 | -------------------------------------------------------------------------------- /ui/statistics/recess_dur.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | headerPanel('Recession duration analysis'), 4 | column(6, plotOutput('rsdr.hist'), 5 | shiny::includeMarkdown("md/recess_dur.md")), 6 | column(6, plotOutput('rsdr.time'), 7 | shiny::includeMarkdown("md/recess_durTime.md")), br(), 8 | shiny::includeMarkdown("md/rightclick.md") 9 | ) -------------------------------------------------------------------------------- /md/recession_coef.md: -------------------------------------------------------------------------------- 1 | #### Recession coefficient 2 | 3 | The recession coefficient is computed automatically based on the analysis of available data. The user may `Update` the value to meet their needs. (CAUTION: updating the recession coefficient will impact hydrograph separation and event yield calculations.) 4 | 5 | Pressing `Reset` will re-compute the recession coefficient. -------------------------------------------------------------------------------- /ui/hydrograph/separation.R: -------------------------------------------------------------------------------- 1 | 2 | fluidRow( 3 | withMathJax(), 4 | htmlOutput("hdr0"), br(), 5 | dygraphOutput("hydgrph.bf"), br(), 6 | column(2), 7 | column(10, 8 | checkboxInput("bf.shwall", "show each individual baseflow hydrographs (**This process will take time to render large datasets.)", width='100%') 9 | ), br(), 10 | shiny::includeMarkdown("md/bfnotes.md") 11 | ) -------------------------------------------------------------------------------- /ui/hydrograph/data/data_table.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | sidebarPanel( 3 | dateRangeInput("tabRng", label = "Date range"), 4 | br(), actionButton("tabCmplt", "Include all computations"), 5 | br(), br(), downloadButton("tabCsv", "Download csv.."), 6 | width=2 7 | ), 8 | mainPanel( 9 | DT::dataTableOutput('tabSta'), br(), 10 | DT::dataTableOutput('tabhyd'), 11 | width=10 12 | ) 13 | ) -------------------------------------------------------------------------------- /ui/trend/daily.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel('Distributions of mean-daily discharge'), 4 | fluidRow( 5 | sidebarPanel( 6 | h4("select date range:"), 7 | dygraphOutput("rng.mdd"), br(), 8 | shiny::includeMarkdown("md/dtrng.md") 9 | ), 10 | mainPanel( 11 | plotOutput('dy.q'), 12 | plotOutput('dy.qmmm') 13 | # plotOutput('dy.qbox') 14 | ) 15 | ) 16 | ) 17 | 18 | -------------------------------------------------------------------------------- /md/bfannnotes.md: -------------------------------------------------------------------------------- 1 | 2 | Notes: 3 | 4 | 1. Annual baseflow calculated as the annual sum of daily median baseflow, calculated from 14 hydrograph separation methods found in the `Hydrographs`->`(baseflow) separation` page. 5 | 2. Bars outlined in red do not qualify as a **"complete record"** based on the World Meteorological Organization (WMO) "3-5 rule": years must not have 3 (or more) consecutive missing days and months with 5 (or more) missing days (total). -------------------------------------------------------------------------------- /server/hydrograph/discharge_leaflet.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | points <- eventReactive(input$recalc, { 4 | if (!is.null(sta)) cbind(sta$LONG, sta$LAT) 5 | }, ignoreNULL = FALSE) 6 | 7 | 8 | output$leaflet <- renderLeaflet({ 9 | if (!is.null(sta)) { 10 | leaflet() %>% 11 | addProviderTiles(providers$Stamen.TonerLite, 12 | options = providerTileOptions(noWrap = TRUE) 13 | ) %>% 14 | addMarkers(data = points()) 15 | } 16 | }) 17 | -------------------------------------------------------------------------------- /ui/trend/seasonal.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel('Seasonal summary'), 4 | # title = 'Seasonal summary', 5 | # headerPanel('Seasonal summary'), 6 | column(6, 7 | plotOutput('se.q', height='600px'), br(), 8 | shiny::includeMarkdown("md/rightclick.md") 9 | ), 10 | column(6, 11 | h4("Annual time-series overlay"), hr(), 12 | fluidRow(dygraphOutput('rng.se', height='450px')), br(), 13 | fluidRow(formattableOutput('tab.se')) 14 | ) 15 | ) -------------------------------------------------------------------------------- /ui/trend/monthly.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel('Monthly distributions'), 4 | fluidRow( 5 | sidebarPanel( 6 | h4("select date range:"), 7 | dygraphOutput("rng.mnt"), br(), 8 | shiny::includeMarkdown("md/dtrng.md") 9 | ), 10 | mainPanel( 11 | fluidRow(plotOutput('mnt.qbox')), 12 | shiny::includeMarkdown("md/rightclick.md"), 13 | shiny::includeMarkdown("md/boxplot-info.md"), br(), 14 | htmlOutput('info.mnt'), 15 | fluidRow(formattableOutput('tab.mnt')) 16 | ) 17 | ) 18 | ) 19 | 20 | -------------------------------------------------------------------------------- /md/cumu.md: -------------------------------------------------------------------------------- 1 | #### Cumulative discharge: 2 | 3 | Notes: 4 | 5 | 1. Black dotted line: Average watershed yield over the entire period of record. 6 | 1. Blue line: Piecewise regression (helpful in detecting breakpoints). 7 | 8 | 9 | #### BFI plot: 10 | 11 | A 365-day rolling average of the baseflow index determined using the median of [hydrograph separation estimates](https://owrc.github.io/info/hydrographseparation/). 12 | 13 | The baseflow index (BFI) is the proportion of total flow (\\(q_t\\)) composed of "baseflow" (\\(q_b\\)): 14 | 15 | $$ \text{BFI}=\frac{\sum q_b}{\sum q_t} $$ 16 | -------------------------------------------------------------------------------- /functions/piecewiseReg.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # modified from https://stackoverflow.com/questions/8758646/piecewise-regression-with-r-plotting-the-segments 4 | 5 | 6 | piecewise.regression.line <- function(dati) { 7 | out.lm <- lm(y ~ x, data = dati) 8 | o <- segmented(out.lm, seg.Z = ~x, control = seg.control(display = FALSE)) 9 | dato = data.frame(x = out.lm$model$x, y = broken.line(o)$fit) 10 | 11 | dfo <- data.frame(d=as.Date(dato$x),v=dato$y) 12 | brkrow <- dfo[dfo$d == as.character(as.Date(o$psi[[2]])),] 13 | brko <- list(x=brkrow$d,y=brkrow$v) 14 | return( list( df=dfo, brk=brko) ) 15 | } -------------------------------------------------------------------------------- /md/saas_mmbf.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | The degree of alteration in individual indicators can be evaluated as follows: 4 | 5 | - **Low alteration**: A monthly median baseflow indicator that lies between the 38th and the 62nd percent exceedance baseflow for the reference condition. 6 | 7 | - **Medium alteration**: A monthly median baseflow indicator that lies between the 13th and 38th or 62nd and 87th percent exceedance baseflow for the reference condition. 8 | 9 | - **High alteration**: A monthly median baseflow indicator less than the 13th or greater than the 87th percent exceedance baseflow for the reference condition. -------------------------------------------------------------------------------- /md/bfmntnotes.md: -------------------------------------------------------------------------------- 1 | #### Hydrograph separation summary: 2 | 3 | Boxplots and Baseflow index (BFI: the ratio of baseflow to total flow) are computed using the 14 hydrograph separation methods found in the `Hydrographs`->`(baseflow) separation` page. Boxpots follow the method of McGill et.al. (1978): box represents the 25% to 75% quantile, while the centre line represents median (50% quantile). Whiskers represent the observation less than or equal to the box extents ±1.5 * IQR (inter-quartile range). 4 | 5 | Monthly BFIs given by the monthly medians of calculated baseflow (from 14 hydrograph separation methods). 6 | -------------------------------------------------------------------------------- /pkg/js.R: -------------------------------------------------------------------------------- 1 | 2 | ####################### 3 | ### JavaScript code ### 4 | ####################### 5 | 6 | 7 | ### capture mouse-up events in shiny 8 | jscode.mup <- ' 9 | $(function() { 10 | $(document).mouseup(function(e) { 11 | Shiny.onInputChange("mouseup", ["up", Math.random()]); 12 | }); 13 | });' 14 | 15 | 16 | ### open page loading message 17 | appLoad <- " 18 | #loading-content { 19 | position: absolute; 20 | background: #000000; 21 | opacity: 0.9; 22 | z-index: 100; 23 | left: 0; 24 | right: 0; 25 | height: 100%; 26 | text-align: center; 27 | color: #FFFFFF; 28 | }" -------------------------------------------------------------------------------- /server/hydrograph/data/data_summary.R: -------------------------------------------------------------------------------- 1 | 2 | output$selected_var <- renderText({ 3 | if (!is.null(sta$hyd)) { 4 | if (!sta$BFbuilt) separateHydrograph() 5 | # df <- sta$hyd[sta$hyd$Date >= input$tabRng[1] & sta$hyd$Date <= input$tabRng[2],] 6 | df <- sta$hyd 7 | if (ncol(df) > 4) { 8 | nl <- df %>% summarise_each(funs(mean(., na.rm = TRUE))) 9 | # print(nl) 10 | # paste(summarise_each(df, funs(mean)), collapse='\n' ) 11 | paste(sta$name,paste(names(nl),nl,sep="\t",collapse="\n"),sep="\n") 12 | } else { 13 | "best to have all computed.." 14 | } 15 | } 16 | #paste("You have selected", input$var) 17 | }) -------------------------------------------------------------------------------- /ui/trend/cumu.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | withMathJax(), 4 | titlePanel('Cumulative discharge'), 5 | # title = 'Cumulative discharge', 6 | # headerPanel('Cumulative discharge'), 7 | sidebarLayout( 8 | sidebarPanel( 9 | h4("select date range:"), 10 | dygraphOutput("rng.cd") 11 | ), 12 | mainPanel( 13 | fluidRow( 14 | column(6, 15 | plotOutput('cum.q') 16 | ), 17 | column(6, 18 | plotOutput('cum.bf') 19 | ), br(), 20 | shiny::includeMarkdown("md/rightclick.md"), br(), 21 | shiny::includeMarkdown("md/cumu.md") 22 | ) 23 | ) 24 | ) 25 | ) -------------------------------------------------------------------------------- /ui/trend/monthly_bf.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel('Monthly distributions of baseflow'), 4 | # headerPanel('Monthly baseflow summary'), 5 | fluidRow( 6 | sidebarPanel( 7 | h4("select date range:"), 8 | dygraphOutput("rng.bf"), br(), 9 | shiny::includeMarkdown("md/dtrng.md") 10 | ), 11 | mainPanel( 12 | shiny::includeMarkdown("md/bfmntnotes.md"), 13 | column(6, plotOutput('BF.mnt')), 14 | column(6, plotOutput('BFI.mnt')), br(), 15 | shiny::includeMarkdown("md/rightclick.md"),br(), 16 | htmlOutput('info.mntbf'), 17 | fluidRow(formattableOutput('tab.mntbf')) 18 | ) 19 | ) 20 | ) 21 | -------------------------------------------------------------------------------- /server/statistics/recession.R: -------------------------------------------------------------------------------- 1 | 2 | ###################### 3 | ### plots 4 | ###################### 5 | observe({ 6 | updateNumericInput(session,'k.val',value=sta$k) 7 | }) 8 | 9 | observeEvent(input$k.reset,isolate({ 10 | sta$k <- recession_coef(sta$hyd$Flow) 11 | updateNumericInput(session,'k.val',value=sta$k) 12 | })) 13 | 14 | output$k.coef <- renderPlot({ 15 | input$k.update 16 | isolate({ 17 | if(!is.na(input$k.val)) sta$k <- input$k.val 18 | recession_coef_plot(sta$hyd$Flow, sta$k, sta$label) 19 | }) 20 | }) 21 | 22 | output$m.coef <- renderPlot({ 23 | isolate({ 24 | recession_coef_plot_m(sta$hyd, sta$k, sta$label) 25 | }) 26 | }) -------------------------------------------------------------------------------- /ui/hydrograph/data/data_summary.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | titlePanel("Aggregated summary"), 4 | 5 | sidebarLayout( 6 | sidebarPanel( 7 | helpText("Create and copy summaries of queried data."), 8 | 9 | selectInput("var", 10 | label = "Choose statistic", 11 | choices = c("mean", 12 | "median"), 13 | selected = "mean"), 14 | 15 | sliderInput("range", 16 | label = "Range of interest:", 17 | min = 0, max = 100, value = c(0, 100)) 18 | ), 19 | 20 | mainPanel( 21 | verbatimTextOutput("selected_var") 22 | ) 23 | ) 24 | ) -------------------------------------------------------------------------------- /ui/statistics/recession.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | withMathJax(), 4 | headerPanel('Automated streamflow recession computation'), 5 | sidebarPanel( 6 | numericInput('k.val','Recession coefficient',NULL,min=0.001,max=0.9999,step=0.0001), 7 | fluidRow( 8 | column(3, actionButton("k.reset", "Recompute k")), 9 | column(9, align="right", actionButton("k.update","Update plot")) 10 | ), 11 | width = 2 12 | ), 13 | mainPanel( 14 | fluidRow( 15 | column(6, plotOutput('k.coef', height = "600px")), 16 | column(6, plotOutput('m.coef', height = "600px")) 17 | ), 18 | fluidRow(column(8, shiny::includeMarkdown("md/knotes.md"))), 19 | width = 10 20 | ) 21 | ) 22 | -------------------------------------------------------------------------------- /ui/hydrograph/discharge.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | sidebarPanel( 3 | htmlOutput('info.main'), 4 | dateRangeInput("dt.rng",label='select date range:'), 5 | checkboxInput('chk.flg','show observation flags'), 6 | # shiny::includeMarkdown("md/todo.md"), 7 | htmlOutput("link.shydrograph"), 8 | width = 2 9 | ), 10 | mainPanel( 11 | tabsetPanel(type = "tabs", 12 | tabPanel("Dynamic", dygraphOutput("dyhydgrph")), 13 | tabPanel("Printable", plotOutput("gghydgrph")), 14 | tabPanel("Map", leafletOutput("leaflet", height = "600px")) 15 | ), br(), 16 | column(6, plotOutput('fdc')), 17 | column(6, plotOutput('mnt.q')), 18 | width = 10 19 | ) 20 | ) 21 | 22 | -------------------------------------------------------------------------------- /functions/return-period-q.R: -------------------------------------------------------------------------------- 1 | 2 | getQ <- function(fa,rp) { 3 | o <- fa[round(fa$rp,5)==rp, 'estimate'] 4 | if (length(o)==0) { 5 | r1 <- fa[round(fa$rp,5)% slice(which.max(estimate)) 6 | r2 <- fa[round(fa$rp,5)>rp, ] %>% slice(which.min(estimate)) 7 | o <- (r2$rp-rp)/(r2$rp-r1$rp)*(r2$estimate-r1$estimate)+r1$estimate 8 | } 9 | return(o) 10 | } 11 | 12 | returnQ <- function(hyd, rp) { 13 | extrms <- hyd %>% 14 | mutate(yr=year(Date)) %>% 15 | dplyr::select(yr,Flow) %>% 16 | group_by(yr) %>% 17 | dplyr::summarise(max = max(Flow, na.rm=TRUE)) %>% 18 | ungroup() %>% 19 | slice(-which.min(yr)) %>% 20 | slice(-which.max(yr)) 21 | 22 | fa <- FrequencyAnalysis(extrms$max, 'lp3') 23 | getQ(fa$output, rp) 24 | } 25 | -------------------------------------------------------------------------------- /ui/trends.R: -------------------------------------------------------------------------------- 1 | navbarMenu("Trends", 2 | tabPanel("annual series", 3 | source(file.path("ui/trend", "annual.R"), local = TRUE)$value 4 | ), 5 | tabPanel("seasonal summary", 6 | source(file.path("ui/trend", "seasonal.R"), local = TRUE)$value 7 | ), 8 | tabPanel("monthly distributions", 9 | source(file.path("ui/trend", "monthly.R"), local = TRUE)$value 10 | ), 11 | tabPanel("monthly, baseflow", 12 | source(file.path("ui/trend", "monthly_bf.R"), local = TRUE)$value 13 | ), 14 | tabPanel("day-of-year", 15 | source(file.path("ui/trend", "daily.R"), local = TRUE)$value 16 | ), 17 | tabPanel("cumulative", 18 | source(file.path("ui/trend", "cumu.R"), local = TRUE)$value 19 | ) 20 | ) -------------------------------------------------------------------------------- /functions/separateHydrograph.R: -------------------------------------------------------------------------------- 1 | 2 | separateHydrograph <- function(){ 3 | # progress bar 4 | progress <- shiny::Progress$new() 5 | progress$set(message = "separating hydrograph..", detail = 'initializing..', value = 0.1) 6 | on.exit(progress$close()) 7 | updateProgress <- function(value = NULL, detail = NULL) { 8 | if (is.null(value)) { 9 | value <- progress$getValue() 10 | value <- value + (progress$getMax() - value) / 5 11 | } 12 | progress$set(value = value, detail = detail) 13 | } 14 | if (!is.null(sta$hyd) & !sta$BFbuilt){ 15 | qBF <- baseflow_range(sta$hyd,sta$carea,sta$k,BFp,updateProgress) %>% subset(select=-c(Flow,Flag)) 16 | sta$hyd <- merge(sta$hyd, qBF, 'Date') 17 | sta$BFbuilt <- TRUE 18 | progress$set(value = 1) 19 | } 20 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | \bak 2 | \old 3 | \test 4 | *.sqlite3 5 | *.Rproj 6 | YCDB_API_query.R 7 | YCDB_query.R 8 | test.R 9 | 10 | # History files 11 | .Rhistory 12 | .Rapp.history 13 | 14 | # Session Data files 15 | .RData 16 | 17 | # Example code in package build process 18 | *-Ex.R 19 | 20 | # Output files from R CMD build 21 | /*.tar.gz 22 | 23 | # Output files from R CMD check 24 | /*.Rcheck/ 25 | 26 | # RStudio files 27 | .Rproj.user/ 28 | 29 | # produced vignettes 30 | vignettes/*.html 31 | vignettes/*.pdf 32 | 33 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 34 | .httr-oauth 35 | 36 | # knitr and R markdown default cache directories 37 | /*_cache/ 38 | /cache/ 39 | 40 | # Temporary files created by R markdown 41 | *.utf8.md 42 | *.knit.md 43 | .Rproj.user 44 | *-CONFLICT-* 45 | rsconnect/ 46 | old/ 47 | *.Rds -------------------------------------------------------------------------------- /functions/globals.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # general functions and globals 4 | ######################################################## 5 | # cms <- "m³/s" # "m3/s" 6 | # km2 <- "km²" 7 | # m3 <- "m³" 8 | gglabcms <- expression('Mean Daily Discharge ' ~ (m^3/s)) 9 | dylabcms <- "Discharge (m3/s)" 10 | 11 | month <- function (x) as.numeric(format(x, "%m")) 12 | montho <- function (x) (month(x)+2) %% 12 13 | montha <- c("Oct","Nov","Dec", "Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep") 14 | 15 | wtr_yr <- function(dates, start_month=10) { 16 | # Convert dates into POSIXlt 17 | dates.posix = as.POSIXlt(dates) 18 | # Year offset 19 | offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0) 20 | # Water year 21 | adj.year = dates.posix$year + 1900 + offset 22 | # Return the water year 23 | adj.year 24 | } -------------------------------------------------------------------------------- /ui/stats.R: -------------------------------------------------------------------------------- 1 | navbarMenu("Statistics", 2 | tabPanel("peak flow frequency", 3 | source(file.path("ui/statistics", "peak.R"), local = TRUE)$value 4 | ), 5 | tabPanel("low flow frequency", 6 | source(file.path("ui/statistics", "mam.R"), local = TRUE)$value 7 | ), 8 | tabPanel("recession duration", 9 | source(file.path("ui/statistics", "recess_dur.R"), local = TRUE)$value 10 | ), 11 | # tabPanel("flow regime: IHA", 12 | # source(file.path("ui/statistics", "iha.R"), local = TRUE)$value 13 | # ), 14 | # tabPanel("flow regime: SAAS", 15 | # shiny::includeMarkdown("md/todo.md") 16 | # ), br(), 17 | tabPanel("environmental flows", 18 | source(file.path("ui/statistics", "eflows.R"), local = TRUE)$value 19 | ), br(), 20 | tabPanel("recession coefficient", 21 | source(file.path("ui/statistics", "recession.R"), local = TRUE)$value 22 | ) 23 | ) -------------------------------------------------------------------------------- /ui/hydrograph.R: -------------------------------------------------------------------------------- 1 | navbarMenu("Hydrograph", 2 | # tabPanel("raw queried data", 3 | # # tags$head(tags$script(HTML(jscode.mup))), 4 | tabPanel("daily-mean data", 5 | source(file.path("ui/hydrograph", "discharge.R"), local = TRUE)$value 6 | ), 7 | tabPanel("(baseflow) separation", 8 | source(file.path("ui/hydrograph", "separation.R"), local = TRUE)$value 9 | ), 10 | tabPanel("disaggregation", 11 | source(file.path("ui/hydrograph", "disaggregation.R"), local = TRUE)$value 12 | ), 13 | tabPanel("data quality (counts)", 14 | source(file.path("ui/hydrograph/data", "data_qual.R"), local = TRUE)$value 15 | ), 16 | tabPanel("aggregated data summary", 17 | source(file.path("ui/hydrograph/data", "data_summary.R"), local = TRUE)$value 18 | ), 19 | tabPanel("Download data", 20 | source(file.path("ui/hydrograph/data", "data_table.R"), local = TRUE)$value 21 | ) 22 | ) 23 | -------------------------------------------------------------------------------- /md/parsenotes.md: -------------------------------------------------------------------------------- 1 | ## Hydrograph Disaggregation 2 | 3 | This algorithm is used to parse the hydrograph into three main constituents: 4 | 5 | 1. The rising limb – the rapid increase in discharge following a storm/melt event; 6 | 2. The falling limb – the rapid decrease in discharge following the rising limb; and, 7 | 3. Streamflow recession – the gradual decline in discharge as the watershed drains. 8 | 9 | ### Event yields 10 | 11 | Event yields are calculated using an algorithm that locates the onset of a rising limb and projects streamflow recession as if the event had never occurred. This projected streamflow, termed "underlying flow" by Reed et.al. (1975), is subtracted from the total observed flow to approximate the runoff volume associated with the event as indicated by the hydrograph. The calculation of event yields, in effect, "discretizes" the continuous hydrograph such that it can be better compared with measured (i.e., rainfall/smowmelt) event volumes. 12 | 13 | ![from Reed etal (1975)](images/Reed1_small.png) 14 | -------------------------------------------------------------------------------- /md/saas.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | # Hydrologic regime components and associated indicators selected to assess hydrologic alteration. 7 | 8 | 9 | 10 | | Characteristics | Indicator(s) | 11 | |---|---| 12 | | Baseflow | Monthly median baseflow magnitude $(\text{m}^3\text{s}^{-1})$. | 13 | | Subsistence flow | Monthly 95% exceedance flow magnitude of total streamflow $(\text{m}^3\text{s}^{-1})$ (preliminary assessment). % wetted perimeter (field-based assessment) | 14 | | High flow pulses (less than bankfull) | Monthly median frequency and duration $(\text{days})$ of flow events less than the bankfull flow magnitude | 15 | | Channel forming flow | Magnitude $(\text{m}^3\text{s}^{-1})$, duration $(\text{days})$ and timing (month) of flows with a recurrence interval of 1.5 years | 16 | | Riparian flow | Magnitude $(\text{m}^3\text{s}^{-1})$, duration $(\text{days})$ and timing (month) of flows with recurrence intervals of 2, 10, and 20 years | 17 | | Rate of change of flow | Monthly median rate-of-change of flow $(\text{m}^3\text{s}^{-1}\text{hr}^{-1})$ for rising and falling limbs of flow events. | -------------------------------------------------------------------------------- /functions/monthly35.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | df.monthly <- function(df) { 4 | 5 | # detect consecutive NAs 6 | df$consNA <- sequence(rle(is.na(df$Flow))$lengths) 7 | df[!is.na(df$Flow),'consNA'] = 0 8 | 9 | df <- df %>% 10 | mutate(year = year(Date)) %>% 11 | mutate(month = month(Date)) %>% 12 | group_by(year, month) 13 | 14 | df <- df %>% dplyr::summarise(stat = mean(Flow, na.rm = TRUE), 15 | n = sum(!is.na(Flow)), 16 | xcon = max(consNA)) 17 | 18 | df$Date <- zoo::as.Date(paste(df$year, df$month, '1'), "%Y %m %d") 19 | df$ntot <- days_in_month(df$Date) 20 | df$wmo <- ifelse((df$ntot-df$n>4) | (df$xcon>2),0,1) # WMO 3/5 rule: 5+ total days missing OR 3+ consecutive days missing 21 | df[df$n==0,'stat'] = NA 22 | 23 | return(df) 24 | } 25 | 26 | 27 | df.monthly.simple <- function(df) { 28 | return(df.monthly(df)[-c(3:7)]) 29 | } 30 | 31 | df.annual.simple <- function(df) { 32 | df <- df.monthly(df) %>% 33 | ungroup() %>% 34 | group_by(year) %>% 35 | dplyr::summarise(wmo = sum(wmo, na.rm = TRUE)/12) 36 | return(df) 37 | } -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Mason Marchildon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /server/hydrograph/disaggregation.R: -------------------------------------------------------------------------------- 1 | 2 | output$hydgrph.prse <- renderDygraph({isolate( 3 | if (!is.null(sta$hyd)){ 4 | inclEV <- TRUE 5 | withProgress(message = 'parsing hydrograph..', value = 0.1, { 6 | if(is.null(sta$hyd$qtyp)) sta$hyd <- parse_hydrograph(sta$hyd,sta$k) 7 | if(!is.null(sta$carea) && is.null(sta$hyd$evnt)){sta$hyd <- discretize_hydrograph(sta$hyd, sta$carea, sta$k)}else{inclEV <- FALSE} 8 | }) 9 | withProgress(message = 'rendering plot..', value = 0.1, { 10 | flow_hydrograph_parsed(sta$hyd,inclEV) 11 | }) 12 | } 13 | )}) 14 | 15 | 16 | 17 | output$hydgrph.prse.scatter <- renderPlot({ 18 | if (!is.null(sta$hyd$qtyp)){ 19 | sta$hyd %>% 20 | mutate(new = ifelse(evnt > 0, 1, 0)) %>% 21 | mutate(new2 = cumsum(new)) %>% 22 | group_by(new2) %>% 23 | mutate(pevnt=sum(Rf+Sm, na.rm = TRUE)) %>% 24 | ungroup() %>% 25 | filter(new==1) %>% 26 | ggplot(aes(pevnt,evnt)) + 27 | theme_bw() + 28 | geom_abline(slope=1,intercept=0, alpha=.5, linetype='dashed') + 29 | geom_point() + 30 | labs(x="Atmospheric yield", y="Event (discharge) yield") 31 | coord_fixed() 32 | } 33 | }) 34 | -------------------------------------------------------------------------------- /server/hydrograph/discharge_gghydgrph.R: -------------------------------------------------------------------------------- 1 | 2 | output$gghydgrph <- renderPlot({ 3 | wflg <- input$chk.flg 4 | if (!is.null(sta$hyd)){ 5 | df <- dRange() 6 | if(!wflg){ 7 | ggplot(df,aes(x=Date)) + 8 | theme_bw() + theme(panel.grid.major = element_line(colour = "#808080"), panel.grid.minor = element_line(colour = "#808080")) + 9 | geom_line(aes(y=Flow), color="blue") + 10 | xlab(gglabcms) 11 | } else { 12 | ggplot(df,aes(x=Date,y=Flow,color=factor(Flag))) + 13 | theme_bw() + theme(panel.grid.major = element_line(colour = "#808080"), panel.grid.minor = element_line(colour = "#808080"), 14 | axis.title.x = element_blank()) + 15 | theme(legend.position=c(0.97,0.97), legend.justification=c(1,1), legend.title=element_blank()) + 16 | geom_line(aes(group=1),size=1) + 17 | scale_color_manual(name="", 18 | values = c("blue", "ice_conditions"="#ffa552", "estimate"="#008000", "partial"="lightblue", "realtime_uncorrected"="#6635b5"), 19 | labels = c("Flow","Ice conditions","Estimate","Partial","Uncorrected")) + 20 | ylab(gglabcms) + ggtitle(sta$label) 21 | } 22 | } 23 | }) 24 | -------------------------------------------------------------------------------- /ui/statistics/peak.R: -------------------------------------------------------------------------------- 1 | fluidPage( 2 | title = 'sHydrology peak flow analysis', 3 | fluidRow( 4 | headerPanel('Peak flow analysis'), 5 | htmlOutput("hdr2"), 6 | column(3, 7 | selectInput('pk.freq', 'flow frequency model', c('Log Pearson III'='lp3', 8 | 'Generalized Extreme Value'='gev', 9 | 'Weibull'='wei', 10 | 'Gumbel'='gum', 11 | 'three-parameter lognormal'='ln3')) 12 | ), 13 | column(3, 14 | numericInput('pk.rsmpl','number of boostrap resamples',10000,min=1000,max=100000) 15 | ), 16 | column(3, 17 | numericInput('pk.ci','confidence interval',0.9,min=0.05,max=0.999,step=0.01) 18 | ), 19 | column(2, br(), 20 | actionButton('pk.regen',"Regenerate"), 21 | offset = 1 22 | ) 23 | ), hr(), 24 | fluidRow( 25 | column(4, plotOutput('pk.q')), 26 | column(4, plotOutput('pk.dist')), 27 | column(4, plotOutput('pk.hist')) 28 | ), br(), 29 | shiny::includeMarkdown("md/rightclick.md") 30 | ) 31 | -------------------------------------------------------------------------------- /server/statistics/saas_cff.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | output$saas.cff <- renderPlot({ 4 | req(rng <- input$rng.saas_date_window) 5 | if (!is.null(sta$hyd)){ 6 | 7 | qn <- returnQ(sta$hyd, 1.5) 8 | # qx <- returnQ(sta$hyd, 1.7) 9 | 10 | evnts <- sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 11 | dplyr::select(c('Date','Flow','evnt')) %>% 12 | mutate(new = ifelse(evnt > 0, 1, 0)) %>% 13 | mutate(new2 = cumsum(new)) %>% 14 | group_by(new2) %>% 15 | mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 16 | ungroup() %>% 17 | # filter(new==1, (pkflw>=qn & pkflw=qn) ) 19 | 20 | p1 <- evnts %>% ggplot(aes(pkflw)) + theme_bw() + geom_density() + xlab("peak flow (m3/s)") 21 | p2 <- evnts %>% ggplot(aes(dur)) + theme_bw() + geom_density() + xlab("duration (days)") 22 | p3 <- evnts %>% 23 | mutate(mnt=month(Date)) %>% 24 | group_by(mnt) %>% 25 | summarise(nevnt=n()) %>% 26 | mutate(mnt=month.abb[mnt]) %>% 27 | mutate(mnt=factor(mnt,levels=month.abb)) %>% 28 | ggplot(aes(mnt,nevnt)) + theme_bw() + geom_bar(stat='identity') + scale_x_discrete(drop=FALSE) + labs(x="timing (month)",y="count") 29 | 30 | grid.arrange(p1, p2, p3, nrow = 1, top=sta$label) 31 | } 32 | }) -------------------------------------------------------------------------------- /ui/statistics/mam.R: -------------------------------------------------------------------------------- 1 | fluidPage( 2 | title = 'sHydrology MAM analysis', 3 | fluidRow( 4 | headerPanel('n-day annual minima recurrence'), 5 | htmlOutput("hdr3"), 6 | column(3, 7 | selectInput('mam.freq', 'frequency model', c('Log Pearson III'='lp3', 8 | 'Generalized Extreme Value'='gev', 9 | 'Weibull'='wei', 10 | 'Gumbel'='gum', 11 | 'three-parameter lognormal'='ln3')) 12 | ), 13 | column(3, 14 | numericInput('mam.rsmpl','number of boostrap resamples',10000,min=1000,max=100000) 15 | ), 16 | column(3, 17 | numericInput('mam.ci','confidence interval',0.9,min=0.05,max=0.999,step=0.01) 18 | ), 19 | column(2, br(), 20 | actionButton('mam.regen',"Regenerate"), 21 | offset = 1 22 | ) 23 | ), hr(), 24 | fluidRow( 25 | column(4, plotOutput('mam.q1')), 26 | column(4, plotOutput('mam.q7')), 27 | column(4, plotOutput('mam.q30')) 28 | ), 29 | fluidRow( 30 | column(4, plotOutput('hist.q1')), 31 | column(4, plotOutput('hist.q7')), 32 | column(4, plotOutput('hist.q30')) 33 | ),br(), 34 | shiny::includeMarkdown("md/rightclick.md"), 35 | shiny::includeMarkdown("md/mamnotes.md") 36 | ) -------------------------------------------------------------------------------- /pkg/packages.R: -------------------------------------------------------------------------------- 1 | ### sHydrology packages 2 | 3 | library(shiny) 4 | library(shinyjs) 5 | library(markdown) 6 | library(jsonlite) 7 | library(lubridate) 8 | library(date) 9 | library(zoo) 10 | library(xts) 11 | library(broom) 12 | library(plyr) 13 | library(dplyr) 14 | library(tidyr) 15 | library(purrr) 16 | library(formattable) 17 | library(lmomco) 18 | library(cvequality) 19 | library(dygraphs) 20 | library(ggplot2) 21 | library(gridExtra) 22 | library(leaflet) 23 | library(scales) 24 | library(segmented) 25 | library(DT) 26 | library(bitops) 27 | library(segmented) 28 | library(caTools) 29 | library(forcats) 30 | 31 | 32 | 33 | source("pkg/js.R", local = TRUE) 34 | source("pkg/html.R", local = TRUE) 35 | 36 | source("functions/globals.R", local = TRUE) 37 | source("functions/monthly35.R", local = TRUE) 38 | source("functions/baseflow_range.R", local = TRUE) 39 | source("functions/hydrograph_recession_coef.R", local = TRUE) 40 | source("functions/hydrograph_separation.R", local = TRUE) 41 | source("functions/hydrograph_parsing.R", local = TRUE) 42 | source("functions/hydrograph_parsing_plot.R", local = TRUE) 43 | source("functions/hydrograph_frequency_analysis.R", local = TRUE) 44 | source("functions/hydrograph_fdc.R", local = TRUE) 45 | source("functions/hydrograph_monthly_bar.R", local = TRUE) 46 | source("functions/iha.R", local = TRUE) 47 | source("functions/piecewiseReg.R", local = TRUE) 48 | source("functions/return-period-q.R", local = TRUE) 49 | source("functions/integer-breaks.R", local = TRUE) -------------------------------------------------------------------------------- /server/statistics/saas_roc.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | output$saas.roc <- renderPlot({ 4 | req(rng <- input$rng.saas_date_window) 5 | if (!is.null(sta$hyd)){ 6 | 7 | sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 8 | dplyr::select(c('Date','Flow','evnt')) %>% 9 | mutate(new = ifelse(evnt > 0, 1, 0)) %>% 10 | mutate(evntid = cumsum(new)) %>% 11 | group_by(evntid) %>% 12 | mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 13 | mutate(new3 = case_when(Flow == pkflw ~ Date)) %>% 14 | mutate(peakDate = max(new3, na.rm = TRUE)) %>% 15 | mutate(daysToPeak = as.integer(peakDate-Date)) %>% 16 | mutate(new6 = min(daysToPeak)) %>% 17 | mutate(new7 = case_when(new6 == daysToPeak ~ Flow)) %>% 18 | mutate(lastFlow = max(new7, na.rm = TRUE)) %>% 19 | ungroup() %>% 20 | filter(new==1) %>% 21 | dplyr::select(-c('new','new3','new6','new7')) %>% 22 | mutate(rise=(pkflw-Flow)/daysToPeak/24, fall=(pkflw-lastFlow)/(dur-daysToPeak)/24) %>% 23 | mutate(mnt=month(Date)) %>% 24 | group_by(mnt) %>% 25 | summarise(rising=median(rise, na.rm=TRUE),falling=median(fall, na.rm=TRUE)) %>% 26 | mutate(mnt=month.abb[mnt]) %>% 27 | mutate(mnt=factor(mnt,levels=month.abb)) %>% 28 | gather(key = "Limb", value = "val", -mnt) %>% 29 | ggplot(aes(mnt,val)) + 30 | theme_bw() + 31 | geom_bar(aes(fill=Limb), stat='identity', position = "dodge") + 32 | scale_x_discrete(drop=FALSE) + 33 | labs(title=sta$label,x=NULL,y="median rate-of-change of flow (m3 sec-1 hr-1)") 34 | 35 | } 36 | }) -------------------------------------------------------------------------------- /functions/hydrograph_fdc.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # Flow Duration Curve 4 | ######################################################## 5 | 6 | flow_duration_curve <- function(pg1,pg2=NULL) { 7 | breaks <- 10^(-10:10) 8 | minor_breaks <- rep(1:9, 21)*(10^rep(-10:10, each=9)) 9 | 10 | p <- ggplot() + 11 | theme_bw() + theme(panel.grid.major = element_line(colour = "#808080"), panel.grid.minor = element_line(colour = "#808080")) + 12 | theme(legend.position=c(0.97,0.97), legend.justification=c(1,1), legend.title=element_blank()) + 13 | geom_step(data=pg1, aes(x = x, y = (1-y)*100, color="complete data range"), size=2.5) + 14 | coord_flip() + scale_x_log10(breaks = breaks, minor_breaks = minor_breaks) + 15 | labs(x = gglabcms, y = "Exceedance frequency (%)",title='Flow Duration Curve') 16 | 17 | if(!is.null(pg2)){ 18 | p <- p + geom_step(data=pg2, aes(x = x, y = (1-y)*100, color="selected data range"), size=2) + 19 | scale_colour_manual(values=c("selected data range"="#ffa552", "complete data range"="#001a7f")) 20 | } 21 | 22 | return(p) 23 | } 24 | 25 | flow_duration_curve2 <- function(hyd,DTrng=NULL) { 26 | if(is.null(DTrng)){ 27 | stat <- quantile(pg1$x,probs=c(0.5,0.95,0.05),na.rm=T) 28 | flow_duration_curve(flow_duration_curve_build(hyd), stat) 29 | }else{ 30 | flow_duration_curve(flow_duration_curve_build(hyd,DTrng)) 31 | } 32 | } 33 | 34 | flow_duration_curve_build <- function(hyd,DTrng=NULL){ 35 | if(is.null(DTrng)){ 36 | p <- ggplot(hyd, aes(Flow)) + stat_ecdf() 37 | }else{ 38 | p <- ggplot(subset(hyd, Date>=min(DTrng) & Date<=max(DTrng)), aes(Flow)) + stat_ecdf() 39 | } 40 | return(ggplot_build(p)$data[[1]]) 41 | } -------------------------------------------------------------------------------- /pkg/html.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # hydrograph info 4 | ######################################################## 5 | html.hyd.info <- function(title,ndat,DTb,DTe,carea,stat){ 6 | por <- as.integer(difftime(DTe, DTb, units = "days"))+1 7 | stat <- round(stat,2) 8 | if(is.null(carea)){ 9 | st.carea <- '
Contributing area: unknown
' 10 | }else{ 11 | st.carea <- paste0('
Contributing area: ',round(carea,1),' km2
') 12 | } 13 | 14 | paste0( 15 | "

",title,"

", br(), 16 | st.carea, br(), 17 | '
Period of Record: ',strftime(DTb, "%b %Y"),' to ',strftime(DTe, "%b %Y"),' (',por,' days)
', 18 | '
total missing: ',por-ndat-1,' days (',round((1-ndat/por)*100,0),'%)
', br(), 19 | 20 | '
Average discharge: ',stat[1],' m3/s
', 21 | '
Median discharge: ',stat[2],' m3/s
', 22 | '
95th percentile discharge: ',stat[3],' m3/s
', 23 | '
5th percentile discharge: ',stat[4],' m3/s
' 24 | ) 25 | } 26 | 27 | hyd.info.rng <- function(ndat,DTb,DTe,stat){ 28 | por <- as.integer(difftime(DTe, DTb, units = "days"))+1 29 | stat <- round(stat,2) 30 | return(paste0( 31 | 32 | '

selected data range:

', br(), 33 | 34 | '
Period of Record: ',strftime(DTb, "%b %Y"),' to ',strftime(DTe, "%b %Y"),' (',por,' days)
', 35 | '
total missing: ',por-ndat-1,' days (',round((1-ndat/por)*100,0),'%)
', br(), 36 | 37 | '
Average discharge: ',stat[1],' m3/s
', 38 | '
Median discharge: ',stat[2],' m3/s
', 39 | '
95th percentile discharge: ',stat[3],' m3/s
', 40 | '
5th percentile discharge: ',stat[4],' m3/s
', br() 41 | )) 42 | } -------------------------------------------------------------------------------- /server/server_sources.R: -------------------------------------------------------------------------------- 1 | source(file.path("server/hydrograph", "discharge.R"), local = TRUE)$value 2 | source(file.path("server/hydrograph", "discharge_gghydgrph.R"), local = TRUE)$value 3 | source(file.path("server/hydrograph", "discharge_leaflet.R"), local = TRUE)$value 4 | source(file.path("server/hydrograph", "discharge_dyhygrph.R"), local = TRUE)$value 5 | source(file.path("server/hydrograph", "separation.R"), local = TRUE)$value 6 | source(file.path("server/hydrograph", "disaggregation.R"), local = TRUE)$value 7 | source(file.path("server/trend", "annual.R"), local = TRUE)$value 8 | source(file.path("server/trend", "seasonal.R"), local = TRUE)$value 9 | source(file.path("server/trend", "daily.R"), local = TRUE)$value 10 | source(file.path("server/trend", "monthly.R"), local = TRUE)$value 11 | source(file.path("server/trend", "monthly_bf.R"), local = TRUE)$value 12 | source(file.path("server/trend", "cumu.R"), local = TRUE)$value 13 | source(file.path("server/statistics", "peak.R"), local = TRUE)$value 14 | source(file.path("server/statistics", "mam.R"), local = TRUE)$value 15 | source(file.path("server/statistics", "iha.R"), local = TRUE)$value 16 | source(file.path("server/statistics", "saas.R"), local = TRUE)$value 17 | source(file.path("server/statistics", "saas_hfp.R"), local = TRUE)$value 18 | source(file.path("server/statistics", "saas_cff.R"), local = TRUE)$value 19 | source(file.path("server/statistics", "saas_rf.R"), local = TRUE)$value 20 | source(file.path("server/statistics", "saas_roc.R"), local = TRUE)$value 21 | source(file.path("server/statistics", "recess_dur.R"), local = TRUE)$value 22 | source(file.path("server/statistics", "recession.R"), local = TRUE)$value 23 | source(file.path("server/hydrograph/data", "data_table.R"), local = TRUE)$value 24 | source(file.path("server/hydrograph/data", "data_qual.R"), local = TRUE)$value 25 | source(file.path("server/hydrograph/data", "data_summary.R"), local = TRUE)$value -------------------------------------------------------------------------------- /functions/hydrograph_monthly_bar.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # monthly bar chart 4 | ######################################################## 5 | 6 | flow_monthly_bar_build <- function(hyd,carea=NULL,DTrng=NULL){ 7 | hyd$mnt <- format(hyd$Date, "%b") 8 | hyd$mnt <- as.factor(hyd$mnt) 9 | if(!is.null(carea)) hyd$Flow <- hyd$Flow * 2592/carea # mm/30 days 10 | 11 | if(is.null(DTrng)){ 12 | p <- ggplot(hyd, aes(x = reorder(mnt, montho(Date)), y = Flow)) + 13 | stat_summary(fun="mean", geom="bar") 14 | }else{ 15 | hyd2 <- subset(hyd, Date>=min(DTrng) & Date<=max(DTrng)) 16 | p <- ggplot(hyd2, aes(x = reorder(mnt, montho(Date)), y = Flow)) + 17 | stat_summary(fun="mean", geom="bar") 18 | } 19 | 20 | return(ggplot_build(p)$data[[1]]) 21 | } 22 | 23 | flow_monthly_bar <- function(pg1,pg2=NULL){ 24 | if(is.null(pg2)){ 25 | p <- ggplot() + 26 | theme_bw() + 27 | geom_bar(data=pg1, aes(x,y), stat='identity') 28 | }else{ 29 | pg1$name <- "complete data range" 30 | pg2$name <- "selected data range" 31 | d <- rbind(pg1, pg2) 32 | p <- ggplot(d, aes(x, y, fill = name)) + 33 | theme_bw() + theme(legend.position=c(0.97,0.97), legend.justification=c(1,1), legend.title=element_blank()) + 34 | geom_bar(position = "dodge", stat='identity') + 35 | scale_fill_manual(values=c("selected data range"="#ffa552", "complete data range"="#001a7f")) 36 | } 37 | 38 | return( 39 | p + scale_x_discrete(limits=c('Oct','Nov','Dec','Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep'), expand=c(0.01,0.01)) + 40 | labs(y = "Discharge (mm/month)", x=NULL, title='Monthly Discharge') 41 | ) 42 | } 43 | 44 | flow_monthly_bar2 <- function(hyd,carea,DTrng=NULL){ 45 | if(is.null(DTrng)){ 46 | flow_monthly_bar(flow_monthly_bar_build(hyd,carea)) 47 | }else{ 48 | flow_monthly_bar(flow_monthly_bar_build(hyd,carea),flow_monthly_bar_build(hyd,carea,DTrng)) 49 | } 50 | } -------------------------------------------------------------------------------- /pkg/app_members.R: -------------------------------------------------------------------------------- 1 | 2 | ############################################################## 3 | ### headers 4 | ############################################################## 5 | 6 | output$hdr0 <- renderUI({shiny::HTML(paste0("

 ",sta$label,"

"))}) 7 | output$hdr1 <- renderUI({shiny::HTML(paste0("

 ",sta$label,"

"))}) 8 | output$hdr2 <- renderUI({shiny::HTML(paste0("

 ",sta$label,"

"))}) 9 | output$hdr3 <- renderUI({shiny::HTML(paste0("

 ",sta$label,"

"))}) 10 | 11 | output$hdr.iha <- renderUI({shiny::HTML(paste0("

",sta$label," ",iha.dates(),"

"))}) 12 | 13 | output$hdr.qual <- renderUI({shiny::HTML(paste0("

 ",sta$label,"

"))}) 14 | 15 | output$link.shydrograph <- renderUI({ shiny::HTML(paste0('open in general timeseries analysis tool'))}) 16 | 17 | 18 | ############################################################## 19 | ### members 20 | ############################################################## 21 | 22 | sta <- reactiveValues(lid=NULL, iid=NULL, name=NULL, name2=NULL, 23 | carea=NULL, k=NULL, hyd=NULL, 24 | DTb=NULL, DTe=NULL, label=NULL, info.html=NULL, 25 | LONG=NULL, LAT=NULL, 26 | info=NULL, BFbuilt=FALSE, HPbuilt=FALSE) 27 | 28 | sta.fdc <- reactiveValues(cmplt=NULL,prtl=NULL) 29 | sta.mnt <- reactiveValues(cmplt=NULL,prtl=NULL) 30 | BFp <- list(LHa=0.925, LHp=3, BFIx=0.8, JHC=0.3) # default baseflow parameters 31 | 32 | 33 | 34 | ############################################################## 35 | ### other sources 36 | ############################################################## 37 | source(file.path("functions", "collect_hydrograph.R"), local = TRUE)$value 38 | source(file.path("functions", "separateHydrograph.R"), local = TRUE)$value 39 | source(file.path("functions", "daterange.R"), local = TRUE)$value 40 | 41 | -------------------------------------------------------------------------------- /server/hydrograph/discharge.R: -------------------------------------------------------------------------------- 1 | 2 | observe({ 3 | input$mouseup 4 | isolate({ 5 | if (!is.null(sta$hyd)){ 6 | rng <- input$dyhydgrph_date_window 7 | sta.fdc$prtl <- flow_duration_curve_build(sta$hyd,rng) 8 | sta.mnt$prtl <- flow_monthly_bar_build(sta$hyd,sta$carea,rng) 9 | } 10 | }) 11 | }) 12 | 13 | observe({ 14 | if (!is.null(sta$hyd)) 15 | updateDateRangeInput(session, "dt.rng", start = sta$DTb, end = sta$DTe, min = sta$DTb, max = sta$DTe) 16 | }) 17 | 18 | observeEvent(input$dyhydgrph_date_window, { 19 | updated_date_window(input$dyhydgrph_date_window,"dt.rng") 20 | }) 21 | 22 | observeEvent(input$dt.rng, { 23 | rng <- input$dt.rng 24 | updated_date_selector(rng) 25 | # isolate({ 26 | # sta.fdc$prtl <- flow_duration_curve_build(sta$hyd,rng) 27 | # sta.mnt$prtl <- flow_monthly_bar_build(sta$hyd,sta$carea,rng) 28 | # }) 29 | }) 30 | 31 | output$info.main <- renderUI({ 32 | DTb <- as.Date(strftime(req(input$dyhydgrph_date_window[[1]]), "%Y-%m-%d")) 33 | DTe <- as.Date(strftime(req(input$dyhydgrph_date_window[[2]]), "%Y-%m-%d")) 34 | isolate({ 35 | if (!is.null(sta$hyd)){ 36 | hyd2 <- subset(sta$hyd, Date>=DTb & Date<=DTe) 37 | stat <- c(mean(hyd2$Flow),quantile(hyd2$Flow,probs=c(0.5,0.95,0.05),na.rm=T)) 38 | 39 | shiny::HTML(paste0( 40 | '', 41 | sta$info.html, br(), 42 | 43 | hyd.info.rng(nrow(hyd2)-1,DTb,DTe,stat), 44 | '' 45 | )) 46 | } 47 | }) 48 | }) 49 | 50 | 51 | ###################### 52 | ### plots 53 | ###################### 54 | dRange <- reactive({ 55 | req(rng <- input$dt.rng) 56 | sta$hyd[sta$hyd$Date >= as.character(rng[1]) & sta$hyd$Date <= as.character(rng[2]),] 57 | }) 58 | 59 | 60 | output$fdc <- renderPlot({ 61 | if (!is.null(sta.fdc$prtl)){ 62 | flow_duration_curve(sta.fdc$cmplt,sta.fdc$prtl) 63 | } 64 | }) 65 | 66 | output$mnt.q <- renderPlot({ 67 | if (!is.null(sta.mnt$prtl)){ 68 | flow_monthly_bar(sta.mnt$cmplt,sta.mnt$prtl) 69 | } 70 | }) -------------------------------------------------------------------------------- /server/statistics/saas_hfp.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | output$saas.hfp <- renderPlot({ 4 | req(rng <- input$rng.saas_date_window) 5 | if (!is.null(sta$hyd)){ 6 | if(is.null(sta$hyd$qtyp)) { 7 | showNotification("parsing hydrograph..") 8 | sta$hyd <- parse_hydrograph(sta$hyd,sta$k) 9 | if(!is.null(sta$carea) && is.null(sta$hyd$evnt)) sta$hyd <- discretize_hydrograph(sta$hyd, sta$carea, sta$k) 10 | } 11 | 12 | qbf <- returnQ(sta$hyd, 1.5) 13 | 14 | evnts <- sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 15 | dplyr::select(c('Date','Flow','evnt')) %>% 16 | mutate(new = ifelse(evnt > 0, 1, 0)) %>% 17 | mutate(new2 = cumsum(new)) %>% 18 | group_by(new2) %>% 19 | mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 20 | ungroup() %>% 21 | filter(new==1, pkflw% 24 | mutate(yr=year(Date), mnt=month(Date)) %>% 25 | group_by(yr,mnt) %>% 26 | summarise(freq=n()) %>% 27 | ungroup() %>% 28 | dplyr::select(-yr) %>% 29 | mutate(mnt=month.abb[mnt]) %>% 30 | mutate(mnt=factor(mnt,levels=month.abb)) %>% 31 | group_by(mnt) %>% 32 | summarise(med.f=median(freq, na.rm=TRUE)) %>% 33 | ggplot(aes(mnt,med.f)) + 34 | theme_bw() + 35 | geom_bar(stat = 'identity') + 36 | labs(x=NULL, y="median frequency of flow events less than bankfull flow") + 37 | scale_y_continuous(breaks = integer_breaks()) 38 | 39 | p2 <- evnts %>% 40 | mutate(mnt=month(Date)) %>% 41 | group_by(mnt) %>% 42 | summarise(med.d=median(dur, na.rm=TRUE)) %>% 43 | mutate(mnt=month.abb[mnt]) %>% 44 | mutate(mnt=factor(mnt,levels=month.abb)) %>% 45 | ggplot(aes(mnt,med.d)) + 46 | theme_bw() + 47 | geom_bar(stat = 'identity') + 48 | labs(x=NULL, y="median duration (days) of flow events less than bankfull flow") + 49 | scale_y_continuous(breaks = integer_breaks()) 50 | 51 | grid.arrange(p1, p2, nrow = 1, top=sta$label) 52 | } 53 | }) -------------------------------------------------------------------------------- /server/hydrograph/data/data_table.R: -------------------------------------------------------------------------------- 1 | 2 | #### data tables 3 | output$tabSta <- DT::renderDataTable({ 4 | if (!is.null(sta$info)){ 5 | drop <- c("LOC_ID","INT_ID") 6 | print(sta$info) 7 | df <- sta$info[,!(names(sta$info) %in% drop)] %>% 8 | dplyr::rename(StationName=LOC_NAME, LongName=LOC_NAME_ALT1, latitude=LAT, longitude=LONG, DrainageArea=SW_DRAINAGE_AREA_KM2, nData=CNT, PeriodBegin=YRb, PeriodEnd=YRe, Quality=QUAL) 9 | DT::datatable(df) %>% 10 | formatPercentage('Quality', 0) %>% 11 | formatRound(c('latitude', 'longitude'), 3) %>% 12 | formatRound('DrainageArea',1) 13 | } 14 | }) 15 | 16 | output$tabhyd <- DT::renderDataTable({ 17 | if (!is.null(sta$hyd)){ 18 | df <- sta$hyd[sta$hyd$Date >= input$tabRng[1] & sta$hyd$Date <= input$tabRng[2],] 19 | if (!is.null(df$qtyp)){ 20 | df$qtyp <- as.character(df$qtyp) 21 | df$qtyp[df$qtyp=="1"] <- "Rising Limb" 22 | df$qtyp[df$qtyp=="2"] <- "Falling Limb" 23 | df$qtyp[df$qtyp=="3"] <- "Flow Recession" 24 | } 25 | # if (ncol(df) > 3 + 6) { 26 | # df %>% select(-c('BF.min','BF.max')) 27 | # } else { 28 | # df 29 | # } 30 | return(df) 31 | } 32 | }, 33 | options = list(scrollY='100%', scrollX=TRUE, 34 | lengthMenu = c(5, 30, 100, 365, 3652), 35 | pageLength = 100, 36 | searching=FALSE) 37 | ) 38 | 39 | observe(updateDateRangeInput(session, "tabRng", start = sta$DTb, end = sta$DTe, min = sta$DTb, max = sta$DTe)) 40 | 41 | observeEvent(input$tabCmplt, { 42 | if (!sta$BFbuilt) separateHydrograph() 43 | if (is.null(sta$hyd$qtyp)) { 44 | sta$hyd <- parse_hydrograph(sta$hyd,sta$k) 45 | if(!is.null(sta$carea) && is.null(sta$hyd$evnt)) sta$hyd <- discretize_hydrograph(sta$hyd,sta$carea,sta$k) 46 | } 47 | }) 48 | 49 | output$tabCsv <- downloadHandler( 50 | filename <- function() { paste0(sta$name, '.csv') }, 51 | content <- function(file) { 52 | if (!is.null(sta$hyd)){ 53 | dat.out <- sta$hyd[sta$hyd$Date >= input$tabRng[1] & sta$hyd$Date <= input$tabRng[2],] 54 | write.csv(dat.out[!is.na(dat.out$Flow),], file, row.names = FALSE) 55 | } 56 | } 57 | ) 58 | -------------------------------------------------------------------------------- /server/statistics/recess_dur.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # recession duration analysis 4 | ######################################################## 5 | 6 | 7 | ###################### 8 | ### plots 9 | ###################### 10 | output$rsdr.hist <- renderPlot({ 11 | isolate({ 12 | if (!is.null(sta$hyd)){ 13 | if (is.null(sta$hyd$qtyp)) { 14 | withProgress(message = 'parsing hydrograph..', value = 0.1, { 15 | sta$hyd <- parse_hydrograph(sta$hyd,sta$k) 16 | }) 17 | } 18 | 19 | sta$hyd$grp <- cumsum(c(0,as.numeric(diff(sta$hyd$qtyp))!=0)) 20 | sta$hyd$cnt <- sequence(rle(as.numeric(sta$hyd$qtyp))$lengths) 21 | 22 | df <- sta$hyd[sta$hyd$qtyp==3,] %>% 23 | group_by(grp) %>% 24 | summarize(dur = max(cnt, na.rm = TRUE)) 25 | 26 | ggplot(df,aes(dur)) + 27 | theme_bw() + 28 | geom_histogram() + 29 | labs(x='duration of streamflow recession (days)', title=sta$label) 30 | # facet_wrap(~(dur > 21), scale = 'free') 31 | } 32 | }) 33 | }) 34 | 35 | output$rsdr.time <- renderPlot({ 36 | isolate({ 37 | if (!is.null(sta$hyd)) { 38 | Q50 <- median(sta$hyd$Flow) 39 | brks <- quantile(sta$hyd$Flow, c(0.01,0.05,0.25,0.5,0.75,0.95,0.99)) 40 | minor_breaks <- rep(1:9, 21)*(10^rep(-10:10, each=9)) 41 | names(brks) <- rev(names(brks)) 42 | fun.1 <- function(t) Q50/exp(-sta$k*t) 43 | fun.inv <- function(q) -log(Q50/q)/sta$k 44 | 45 | ggplot(data.frame(t = 0),aes(x=t)) + # dummy dataframe 46 | theme_bw() + 47 | stat_function(fun = fun.1, size=1) + 48 | geom_hline(yintercept=Q50, linetype = "dashed") + 49 | # geom_vline(xintercept=0, linetype = "dashed") + 50 | scale_x_reverse(limits = c(fun.inv(max(sta$hyd$Flow)),fun.inv(min(sta$hyd$Flow))), breaks = pretty_breaks(10)) + 51 | scale_y_continuous(trans='log10', minor_breaks = minor_breaks, 52 | sec.axis = sec_axis(~.*1, breaks = brks, name = 'discharge percent exceedance')) + 53 | labs(x="days to median discharge",y=gglabcms, title=sta$label) 54 | } 55 | }) 56 | }) -------------------------------------------------------------------------------- /server/hydrograph/separation.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ######################################################## 4 | # baseflow hydrograph 5 | ######################################################## 6 | output$hydgrph.bf <- renderDygraph({ 7 | if (input$bf.shwall) { 8 | isolate( 9 | if (!is.null(sta$hyd)){ 10 | if (!sta$BFbuilt) separateHydrograph() 11 | build_hydrograph(c('Flow','BF.min','BF.max', 12 | 'BF.LH','BF.CM','BF.BE','BF.JH','BF.Cl', 13 | 'BF.UKn','BF.UKm','BF.UKx', 14 | 'BF.HYSEP.FI','BF.HYSEP.SI','BF.HYSEP.LM', 15 | 'BF.PART1','BF.PART2','BF.PART3')) 16 | } 17 | ) 18 | } else { 19 | isolate( 20 | if (!is.null(sta$hyd)){ 21 | if (!sta$BFbuilt) separateHydrograph() 22 | build_hydrograph(c('Flow','BF.min','BF.max','BF.med')) 23 | } 24 | ) 25 | } 26 | 27 | }) 28 | 29 | build_hydrograph <- function(sset){ 30 | qxts <- xts(sta$hyd[,sset], order.by = sta$hyd$Date) 31 | showNotification('plot rendering, please be patient..', duration = 10) 32 | if ('BF.med' %in% sset) { 33 | p <- dygraph(qxts) %>% 34 | dySeries(c('BF.min','Flow','BF.max'),label='Discharge',strokeWidth=3) %>% 35 | dySeries('BF.med',label='Median baseflow',strokeWidth=2) %>% 36 | dyOptions(axisLineWidth = 1.5) %>% 37 | dyAxis(name='y', label=dylabcms) %>% 38 | dyLegend(width = 500) %>% 39 | dyRangeSelector(fillColor='', height=80) %>% 40 | dyOptions(retainDateWindow = TRUE) 41 | } else { 42 | p <- dygraph(qxts) %>% 43 | dyHighlight(highlightSeriesOpts = list(strokeWidth = 3)) %>% 44 | dySeries(c('BF.min','Flow','BF.max'),label='Discharge',strokeWidth=3) %>% 45 | dyOptions(axisLineWidth = 1.5) %>% 46 | dyAxis(name='y', label=dylabcms) %>% 47 | dyLegend(width = 500) %>% 48 | dyRangeSelector(fillColor='', height=80) %>% 49 | dyOptions(retainDateWindow = TRUE) 50 | } 51 | 52 | return(p) 53 | } 54 | 55 | select_hydrographs <- function(){ 56 | showNotification('asdfasdf') 57 | s <- c('Flow','BF.min','BF.max') 58 | if (input$BF.LH) s <- append(s, 'BF.LH') 59 | return(s) 60 | } 61 | -------------------------------------------------------------------------------- /functions/daterange.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # from https://stackoverflow.com/questions/49215000/synchronise-dygraph-and-daterangeinput-in-shiny 4 | ntrig <- 10 # Note that I added a reset of the counters when above 10. This is too avoid the trigger value to be to high for R. When the counter resets, you may notice a small outburst, depending on the speed your users change the slider. You can increase this value to make it appear less often. 5 | 6 | r <- reactiveValues( 7 | change_datewindow = 0, 8 | change_rngselect = 0, 9 | change_datewindow_auto = 0, 10 | change_rngselect_auto = 0, 11 | rngselect = NULL #c(loc$DTb, loc$DTe) 12 | ) 13 | 14 | updated_date_window <- function(date_window,inputId) { 15 | r$change_datewindow <- r$change_datewindow + 1 16 | if (r$change_datewindow > r$change_datewindow_auto) { 17 | r$change_rngselect_auto <- r$change_rngselect_auto + 1 18 | r$change_datewindow_auto <- r$change_datewindow 19 | 20 | start <- as.Date(ymd_hms(date_window[[1]])) 21 | stop <- as.Date(ymd_hms(date_window[[2]])) 22 | updateDateRangeInput(session = session, 23 | inputId = inputId, 24 | start = start,end = stop 25 | ) 26 | } else { 27 | if (r$change_datewindow >= ntrig) { 28 | r$change_datewindow_auto <- r$change_datewindow <- 0 29 | } 30 | } 31 | } 32 | 33 | updated_date_selector <- function(rng) { 34 | r$change_rngselect <- r$change_rngselect + 1 35 | if (r$change_rngselect > r$change_rngselect_auto) { 36 | r$change_datewindow_auto <- r$change_datewindow_auto + 1 37 | r$change_rngselect_auto <- r$change_rngselect 38 | r$rngselect <- rng 39 | } else { 40 | if (r$change_rngselect >= ntrig) { 41 | r$change_rngselect_auto <- r$change_rngselect <- 0 42 | } 43 | } 44 | } 45 | 46 | 47 | ################################### 48 | 49 | # # Sample 50 | # observe(updateDateRangeInput(session, "DATERANGE", start = loc$DTb, end = loc$DTe, min = loc$DTb, max = loc$DTe)) 51 | # 52 | # observeEvent(input$DYGRAPH_date_window, { 53 | # updated_date_window(input$DYGRAPH_date_window,"DATERANGE") 54 | # }) 55 | # 56 | # observeEvent(input$DATERANGE, { 57 | # updated_date_selector(input$DATERANGE) 58 | # }) 59 | 60 | -------------------------------------------------------------------------------- /functions/baseflow_range.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ############################################################## 4 | ### Compute baseflow from 14 hydrograph separation methods 5 | ############################################################## 6 | baseflow_range <- function(hyd, cArea_km2=NULL, k=NULL, p=NULL, updateProgress=NULL){ 7 | Q <- hyd[,2] 8 | 9 | Qcoll <- data.frame(Date=hyd[,1],Flow=Q,Flag=hyd[,3],BF.min=rep(NA,nrow(hyd)),BF.med=rep(NA,nrow(hyd)),BF.max=rep(NA,nrow(hyd))) 10 | if (is.null(p)){p <- list(LHa=0.925, LHp=3, BFIx=0.8, JHC=0.3)} # defaults 11 | 12 | if (is.function(updateProgress)){updateProgress(detail = 'computing Lyne-Hollick..')} 13 | Qcoll$BF.LH <- digital_filter(Q,p$LHa,'lyne-hollick',nPasses=p$LHp) 14 | if (is.function(updateProgress)){updateProgress(detail = 'computing Chapman-Maxwell..')} 15 | Qcoll$BF.CM <- digital_filter(Q,k,'chapman-maxwell') 16 | if (is.function(updateProgress)){updateProgress(detail = 'computing Boughton-Eckhardt..')} 17 | Qcoll$BF.BE <- digital_filter(Q,k,'boughton-eckhardt',param=p$BFIx) 18 | if (is.function(updateProgress)){updateProgress(detail = 'computing Jakeman-Hornberger..')} 19 | Qcoll$BF.JH <- digital_filter(Q,k,'jakeman-hornberger',param=p$JHC) 20 | if (is.function(updateProgress)){updateProgress(detail = 'computing Clarifica..')} 21 | Qcoll$BF.Cl <- Clarifica(Q) 22 | if (is.function(updateProgress)){updateProgress(detail = 'computing UKIH..')} 23 | Qcoll$BF.UKn <- UKIH(Q,'sweepingmin') 24 | Qcoll$BF.UKm <- UKIH(Q,'sweepingmedian') 25 | Qcoll$BF.UKx <- UKIH(Q,'sweepingmax') 26 | if (is.function(updateProgress)){updateProgress(detail = 'computing HYSEP..')} 27 | Qcoll$BF.HYSEP.FI <- HYSEP(Q,'FixedInterval',cArea_km2) 28 | Qcoll$BF.HYSEP.SI <- HYSEP(Q,'SlidingInterval',cArea_km2) 29 | Qcoll$BF.HYSEP.LM <- HYSEP(Q,'LocalMinimum',cArea_km2) 30 | if (is.function(updateProgress)){updateProgress(detail = 'computing PART..')} 31 | Qcoll$BF.PART1 <- PART(Q,cArea_km2,1) 32 | Qcoll$BF.PART2 <- PART(Q,cArea_km2,2) 33 | Qcoll$BF.PART3 <- PART(Q,cArea_km2,3) 34 | 35 | if (is.function(updateProgress)){updateProgress(detail = 'computing statistics..')} 36 | Qcoll[,7:20] <- apply(Qcoll[,7:20], 2, function(x) round(x,3)) 37 | 38 | # summarize 39 | Qcoll$BF.min <- apply(Qcoll[,7:20], 1, function(x) if(all(is.na(x))){NA}else{min(x, na.rm = TRUE)}) 40 | Qcoll$BF.med <- apply(Qcoll[,7:20], 1, function(x) if(all(is.na(x))){NA}else{median(x, na.rm = TRUE)}) 41 | Qcoll$BF.max <- apply(Qcoll[,7:20], 1, function(x) if(all(is.na(x))){NA}else{max(x, na.rm = TRUE)}) 42 | 43 | return(Qcoll) 44 | } -------------------------------------------------------------------------------- /md/references.md: -------------------------------------------------------------------------------- 1 | 2 | ## References 3 | 4 | Boughton, W.C., 1993. A hydrograph-based model for estimating the water yield of ungauged catchments. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Newcastle: 317-324. 5 | 6 | Chapman, T.G. and A.I. Maxwell, 1996. Baseflow separation - comparison of numerical methods with tracer experiments.Institute Engineers Australia National Conference. Publ. 96/05, 539-545. 7 | 8 | Chapman T.G., 1999. A comparison of algorithms for stream flow recession and baseflow separation. Hydrological Processes 13: 710-714. 9 | 10 | Clarifica Inc., 2002. Water Budget in Urbanizing Watersheds: Duffins Creek Watershed. Report prepared for the Toronto and Region Conservation Authority. 11 | 12 | Eckhardt, K., 2005. How to construct recursive digital filters for baseflow separation. Hydrological Processes 19, 507-515. 13 | 14 | Institute of Hydrology, 1980. Low Flow Studies report. Wallingford, UK. 15 | 16 | Jakeman, A.J. and Hornberger G.M., 1993. How much complexity is warranted in a rainfall-runoff model? Water Resources Research 29: 2637-2649. 17 | 18 | Linsley, R.K., M.A. Kohler, J.L.H. Paulhus, 1975. Hydrology for Engineers 2nd ed. McGraw-Hill. 482pp. 19 | 20 | Lyne, V. and M. Hollick, 1979. Stochastic time-variable rainfall-runoff modelling. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Perth: 89-92. 21 | 22 | McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of box plots. The American Statistician 32, 12-16. 23 | 24 | Metcalfe, R.A., Mackereth, R.W., Grantham, B., Jones, N., Pyrce, R.S., Haxton, T., Luce, J.J., Stainton, R., 2013. Aquatic Ecosystem Assessments for Rivers. Science and Research Branch, Ministry of Natural Resources, Peterborough, Ontario. 210 pp. 25 | 26 | Piggott, A.R., S. Moin, C. Southam, 2005. A revised approach to the UKIH method for the calculation of baseflow. Hydrological Sciences Journal 50(5): 911-920. 27 | 28 | Reed, D.W., P. Johnson, J.M. Firth, 1975. A Non-Linear Rainfall-Runoff Model, Providing for Variable Lag Time. Journal of Hydrology 25: 295–305. 29 | 30 | Richter, B.D., J.V. Baumgertner, J. Powell, D.P. Braun, 1996. A Method for Assessing Hydrologic Alteration within Ecosystems. Conservation Biology 10(4): 1163-1174. 31 | 32 | Rutledge, A.T., 1998. Computer Programs for Describing the Recession of Ground-Water Discharge and for Estimating Mean Ground-Water Recharge and Discharge from Streamflow Records-Update, Water-Resources Investigation Report 98-4148. 33 | 34 | Sloto, R.A. and M.Y. Crouse, 1996. HYSEP: A Computer Program for Streamflow Hydrograph Separation and Analysis U.S. Geological Survey Water-Resources Investigations Report 96-4040. 35 | -------------------------------------------------------------------------------- /app.R: -------------------------------------------------------------------------------- 1 | ########################################################## 2 | ##################### sHydrology ######################### 3 | #### A Shiny-Leaflet interface to the HYDAT database. #### 4 | ########################################################## 5 | # Hydrological analysis tools 6 | # 7 | # By M.Marchildon 8 | # v.1.7 9 | # Aug, 2023 10 | ########################################################## 11 | 12 | 13 | source("pkg/packages.R", local = TRUE) 14 | source("pkg/sources.R", local = TRUE) 15 | 16 | 17 | sta.id <- '02EC009' # User must set the HYDAT station name here 18 | 19 | 20 | shinyApp( 21 | ui <- fluidPage( 22 | useShinyjs(), 23 | tags$head(includeCSS("pkg/styles.css")), 24 | tags$head(tags$script(HTML(jscode.mup))), 25 | inlineCSS(appLoad), 26 | 27 | # Loading message 28 | div( 29 | id = "loading-content", 30 | div(class='space300'), 31 | h2("Loading..."), 32 | div(img(src='ORMGP_logo_no_text_bw_small.png')), br(), 33 | shiny::img(src='loading_bar_rev.gif') 34 | ), 35 | 36 | # The main app 37 | hidden( 38 | div( 39 | id = "app-content", 40 | list(tags$head(HTML(''))), 41 | div(style="padding: 1px 0px; height: 0px", titlePanel(title="", windowTitle="sHydrology")), # height: 0px 42 | navbarPage( 43 | title=div(img(src="ORMGP_logo_no_text_short.png", height=11), "sHydrology v1.7"), 44 | source(file.path("ui", "hydrograph.R"), local = TRUE)$value, 45 | source(file.path("ui", "trends.R"), local = TRUE)$value, 46 | source(file.path("ui", "stats.R"), local = TRUE)$value, 47 | # source(file.path("ui", "settings.R"), local = TRUE)$value, 48 | # source(file.path("ui", "data.R"), local = TRUE)$value, 49 | source(file.path("ui", "about.R"), local = TRUE)$value, 50 | source(file.path("ui", "references.R"), local = TRUE)$value 51 | ) 52 | ) 53 | ) 54 | ), 55 | 56 | server <- function(input, output, session){ 57 | ################### 58 | ### Parameters & methods: 59 | source("pkg/app_members.R", local = TRUE)$value 60 | 61 | 62 | ################### 63 | ### (hard-coded) Load station ID: 64 | if(!is.null(sta.id)) collect_hydrograph(sta.id) # for testing 65 | hide('chk.yld') 66 | # ### Load from URL: 67 | # observe({ 68 | # query <- parseQueryString(session$clientData$url_search) 69 | # if (!is.null(query[['sID']])) { 70 | # collect_hydrograph(query[['sID']]) 71 | # } else { 72 | # showNotification(paste0("Error: URL invalid.")) 73 | # } 74 | # }) 75 | 76 | 77 | ### load external code: 78 | source("server/server_sources.R", local = TRUE)$value 79 | 80 | session$onSessionEnded(stopApp) 81 | } 82 | ) 83 | -------------------------------------------------------------------------------- /server/statistics/peak.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # Peakflow frequency 4 | ######################################################## 5 | peak_flow_frequency <- function(hyd, dist='lp3', n = 2.5E4, ci = 0.90, title=NULL) { 6 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 7 | agg <- aggregate(Flow ~ yr, hyd, max) 8 | input_data <- agg[,2] 9 | 10 | ci <- BootstrapCI(series=input_data, # flow data 11 | distribution=dist, # distribution 12 | n.resamples = n, # number of re-samples to conduct 13 | ci = ci) # confidence interval level 14 | 15 | # generate frequency plot 16 | return(frequencyPlot(input_data, agg[,1], ci$ci, title)) 17 | } 18 | 19 | peak_flow_density <- function(hyd, title=NULL){ 20 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 21 | df <- data.frame(peak=aggregate(Flow ~ yr, hyd, max)[,2]) 22 | 23 | p <- ggplot(df,aes(peak)) + 24 | theme_bw() + 25 | geom_density(colour='blue', size=1, fill='blue', alpha=0.2) + 26 | geom_rug() + 27 | labs(x=expression('Annual maximum daily mean discharge' ~ (m^3/s)), title=NULL) 28 | 29 | if(!is.null(title)) p <- p + ggtitle(title) 30 | 31 | return(p) 32 | } 33 | 34 | peak_flow_histogram <- function(hyd, title=NULL){ 35 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 36 | df <- hyd %>% 37 | group_by(yr) %>% 38 | summarise( 39 | Value = max(Flow,na.rm=TRUE), 40 | Date = Date[which.max(Flow)]) %>% 41 | ungroup() 42 | 43 | df$mo <- as.numeric(format(df$Date, "%m")) 44 | df$mnt <- format(df$Date, "%b") 45 | df$mnt <- ordered(df$mnt, levels = c('Oct','Nov','Dec','Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep')) 46 | 47 | p <- ggplot(df,aes(mnt)) + 48 | theme_bw() + 49 | geom_histogram(stat='count') + 50 | scale_x_discrete(drop = FALSE) + 51 | labs(x=NULL, title=NULL) 52 | 53 | if(!is.null(title)) p <- p + ggtitle(title) 54 | 55 | return(p) 56 | } 57 | 58 | 59 | ###################### 60 | ### plots 61 | ###################### 62 | output$pk.q <- renderPlot({ 63 | input$pk.regen 64 | isolate({ 65 | mdl <- input$pk.freq 66 | nrsm <- input$pk.rsmpl 67 | ci <- input$pk.ci 68 | if (!is.null(sta$hyd)){ 69 | withProgress(message = 'rendering plots..', value = 0.1, {peak_flow_frequency(sta$hyd, mdl, nrsm, ci, paste0(sta$label,'\npeak flow frequency'))}) 70 | } 71 | }) 72 | }) 73 | 74 | output$pk.dist <- renderPlot({ 75 | isolate( 76 | if (!is.null(sta$hyd)){ 77 | withProgress(message = 'rendering extreme distribution..', value = 0.5, {peak_flow_density(sta$hyd, paste0(sta$label,'\ndistribution of annual extreme values'))}) 78 | } 79 | ) 80 | }) 81 | 82 | output$pk.hist <- renderPlot({ 83 | isolate( 84 | if (!is.null(sta$hyd)){ 85 | withProgress(message = 'rendering seasonal distribution..', value = 0.8, {peak_flow_histogram(sta$hyd, paste0(sta$label,'\nseasonal distribution of annual extremes'))}) 86 | } 87 | ) 88 | }) -------------------------------------------------------------------------------- /server/trend/monthly.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | monthly_summary_box <- function(hyd, carea, title, DTrng=NULL) { 5 | hyd <- hyd %>% mutate(Date=as.Date(Date), mnt=factor(strftime(Date, format="%b"),levels=c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'))) 6 | 7 | if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 8 | 9 | 10 | # collect all boxplot stats for selected range 11 | m1 <- matrix(nrow=12,ncol=5) 12 | t1 <- by(hyd$Flow,hyd$mnt,boxplot.stats) 13 | for (i in 1:12){ 14 | m1[i,] <- t1[[i]][[1]] 15 | } 16 | 17 | p <- ggplot(hyd) + 18 | theme_bw() + 19 | geom_boxplot(aes(x = mnt, y = Flow), size = 1) + #, outlier.shape = NA) + 20 | # coord_cartesian(ylim = c(0,max(m1[,5]))*1.05) + 21 | ggtitle(title) + xlab('Month') 22 | 23 | if (!is.null(carea)) { 24 | p + scale_y_log10(name = gglabcms, sec.axis = sec_axis( trans=~.*31557.6/carea, name=paste0("Discharge (mm/yr)"))) 25 | } else { 26 | p + scale_y_log10(name = gglabcms) 27 | } 28 | } 29 | 30 | 31 | 32 | output$mnt.qbox <- renderPlot({ 33 | input$mouseup 34 | isolate( 35 | if (!is.null(sta$hyd)){ 36 | rng <- input$rng.mnt_date_window 37 | monthly_summary_box(sta$hyd,sta$carea,sta$label,rng) 38 | } 39 | ) 40 | }) 41 | 42 | 43 | 44 | output$rng.mnt <- renderDygraph({ 45 | if (!is.null(sta$hyd)){ 46 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 47 | colnames(qxts) <- 'Discharge' 48 | dygraph(qxts) %>% 49 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 50 | dyAxis(name='y', label=dylabcms) %>% 51 | dyRangeSelector(strokeColor = '', height=80) 52 | } 53 | }) 54 | 55 | 56 | 57 | output$tab.mnt <- renderFormattable({ 58 | req(rng <- input$rng.mnt_date_window) 59 | if (!is.null(sta$hyd)){ 60 | sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 61 | mutate(Month=month(Date)) %>% 62 | group_by(Month) %>% 63 | dplyr::summarise(mean = mean(Flow,na.rm=TRUE), 64 | st.Dev = sd(Flow,na.rm=TRUE), 65 | p5 = quantile(Flow,.05,na.rm=TRUE), 66 | median = median(Flow,na.rm=TRUE), 67 | p95 = quantile(Flow,.95,na.rm=TRUE), 68 | n = sum(!is.na(Flow)), 69 | .groups = "keep") %>% 70 | ungroup()%>% 71 | mutate(Month=month.abb[Month]) %>% 72 | formattable() 73 | } 74 | }) 75 | 76 | output$info.mnt <- renderUI({ 77 | req(rng <- input$rng.mnt_date_window) 78 | DTb <- as.Date(strftime(rng[[1]], "%Y-%m-%d")) 79 | DTe <- as.Date(strftime(rng[[2]], "%Y-%m-%d")) 80 | isolate({ 81 | por <- as.integer(difftime(DTe, DTb, units = "days")) 82 | shiny::HTML(paste0( 83 | '', 84 | paste0( 85 | '

Distribution summary:

', 86 | sta$label,'; ',strftime(DTb, "%b %Y"),' to ',strftime(DTe, "%b %Y"),' (',por+1,' days)' 87 | ), 88 | '' 89 | )) 90 | }) 91 | }) -------------------------------------------------------------------------------- /functions/hydrograph_parsing_plot.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ######################################################## 4 | # Flow disaggregation 5 | ######################################################## 6 | flow_hydrograph_parsed <- function(hyd,InclEV=TRUE){ 7 | 8 | # Timeseries prep 9 | h1 <- data.frame(Date = hyd$Date,q = hyd$Flow,qtyp = hyd$qtyp) 10 | h1$qtyp <- rollapply(h1$qtyp, width=list(-1:1), function(x) if(x[1]==1 || x[2]==1){1}, fill=NA) 11 | h1$q[is.na(h1$qtyp)] <- NA 12 | h2 <- data.frame(Date = hyd$Date,q = hyd$Flow,qtyp = hyd$qtyp) 13 | h2$qtyp <- rollapply(h2$qtyp, width=list(-1:1), function(x) if(x[1]==2 || x[2]==2){2}, fill=NA) 14 | h2$q[is.na(h2$qtyp)] <- NA 15 | h3 <- data.frame(Date = hyd$Date,q = hyd$Flow,qtyp = hyd$qtyp) 16 | h3$qtyp <- rollapply(h3$qtyp, width=list(-1:1), function(x) if(x[1]==3 || x[2]==3){3}, fill=NA) 17 | h3$q[is.na(h3$qtyp)] <- NA 18 | x1 <- xts(h1$q, order.by = hyd$Date) 19 | x2 <- xts(h2$q, order.by = hyd$Date) 20 | x3 <- xts(h3$q, order.by = hyd$Date) 21 | 22 | if(InclEV){ 23 | xe <- xts(hyd$evnt, order.by = hyd$Date) 24 | qx <- cbind(x2,x3,x1,xe) 25 | colnames(qx) <- c('falling limb','recession','rising limb','event yield') 26 | p <- dygraph(qx) %>% 27 | dySeries("recession", color = "green", strokeWidth=2) %>% #, fillGraph = TRUE) %>% 28 | dySeries("falling limb", color = "blue", strokeWidth=2) %>% #, fillGraph = TRUE) %>% 29 | dySeries("rising limb", color = "red", strokeWidth=2) %>% #, fillGraph = TRUE) %>% 30 | dyBarSeries("event yield", color = "#0153c5", axis = 'y2') %>% ### BUG: these don't seem to appear as of 191126 (see https://github.com/rstudio/dygraphs/issues/237) 31 | # dySeries("event yield", color = "brown", axis = 'y2', stepPlot = TRUE) %>% #, fillGraph = TRUE) %>% 32 | dyAxis('y', label=dylabcms) %>% 33 | dyAxis('y2', label='Event yield (mm)', valueRange = c(max(hyd$evnt,na.rm=T), 0)) %>% 34 | dyLegend(show = 'always') %>% 35 | dyOptions(axisLineWidth = 1.5, fillAlpha = 0.5, stepPlot = FALSE) %>% 36 | dyLegend(width = 500) %>% 37 | dyRangeSelector(fillColor='', height=80) %>% 38 | dyOptions(retainDateWindow = TRUE) 39 | }else{ 40 | qx <- cbind(x2,x3,x1) 41 | colnames(qx) <- c('falling limb','recession','rising limb') 42 | p <- dygraph(qx) %>% 43 | dySeries("recession", color = "green",strokeWidth=2, fillGraph = TRUE) %>% 44 | dySeries("falling limb", color = "blue",strokeWidth=2, fillGraph = TRUE) %>% 45 | dySeries("rising limb", color = "red",strokeWidth=2, fillGraph = TRUE) %>% 46 | dyAxis('y', label=dylabcms) %>% 47 | dyLegend(show = 'always') %>% 48 | dyOptions(axisLineWidth = 1.5, fillAlpha = 0.5, stepPlot = FALSE) %>% 49 | dyLegend(width = 500) %>% 50 | dyRangeSelector(fillColor='', height=80) %>% 51 | dyOptions(retainDateWindow = TRUE) 52 | } 53 | 54 | return(p) 55 | } 56 | 57 | # flow_hydrograph_parsed2 <- function(hyd,carea,k,InclEV=TRUE){ 58 | # if(is.null(carea)) InclEV=FALSE 59 | # hyd <- parse_hydrograph(hyd,k) 60 | # if(InclEV) hyd <- discretize_hydrograph(hyd,carea,k) 61 | # return(flow_hydrograph_parsed(hyd,InclEV)) 62 | # } -------------------------------------------------------------------------------- /functions/collect_hydrograph.R: -------------------------------------------------------------------------------- 1 | 2 | ############################################################## 3 | ### collect data from API 4 | ############################################################## 5 | collect_hydrograph <- function(LOC_ID) { 6 | isolate(withProgress(message = 'collecting station info..', value = 0.1, { 7 | sta$lid <- LOC_ID 8 | info <- qStaInfo(ldbc, sta$lid) 9 | 10 | if (is.null(info)) showNotification(paste0("Error LOC_ID: ",sta$lid," not found.")) 11 | info.main <- info[info$LOC_ID==LOC_ID,] 12 | # info <- info.main # for testing 13 | sta$info <- info 14 | sta$carea <- info.main$SW_DRAINAGE_AREA_KM2 15 | if (length(sta$carea)==0 || sta$carea<=0) sta$carea=NULL 16 | sta$iid <- info.main$INT_ID 17 | sta$name <- info.main$LOC_NAME 18 | sta$name2 <- info.main$LOC_NAME_ALT1 19 | sta$LONG <- info.main$LONG 20 | sta$LAT <- info.main$LAT 21 | sta$label <- paste0(sta$name,': ',sta$name2) 22 | if (nrow(info)>1) { 23 | showNotification("aggregating co-located stations") 24 | sta$nam2 <- paste0(sta$nam2,' (AGGREGATED)') 25 | sta$label <- paste0(sta$label,' (AGGREGATED)') 26 | } 27 | setProgress(message = 'querying databases..',value=0.45) 28 | sta$hyd <- qTemporal(idbc,info$INT_ID) %>% filter(Flow>=0) 29 | setProgress(message = 'rendering plot..',value=0.65) 30 | 31 | if (nrow(sta$hyd)<=0) showNotification(paste0("Error no data found for ",sta$name2)) 32 | sta$DTb <- min(sta$hyd$Date, na.rm=T) 33 | sta$DTe <- max(sta$hyd$Date, na.rm=T) 34 | sta$k <- recession_coef(sta$hyd$Flow) 35 | stat <- c(mean(sta$hyd$Flow),quantile(sta$hyd$Flow,probs=c(0.5,0.95,0.05),na.rm=T)) 36 | sta$info.html <- html.hyd.info(sta$label,nrow(sta$hyd)-1,min(sta$hyd$Date,na.rm=T),max(sta$hyd$Date,na.rm=T),sta$carea,stat) 37 | # updateNumericInput(session,'k.val',value=sta$k) 38 | setProgress(message = 'computing flow duration and monthly statistics..',value=0.65) 39 | sta.fdc$cmplt <- flow_duration_curve_build(sta$hyd) 40 | sta.mnt$cmplt <- flow_monthly_bar_build(sta$hyd,sta$carea) 41 | setProgress(message = 'gathering climate interpolated to catchment..',value=0.85) 42 | df <- get.supplimental(info) 43 | if ( !is.null(df) ) sta$hyd <- sta$hyd %>% inner_join(df, by="Date") 44 | # sta$hyd <- sta$hyd %>% inner_join(df %>% dplyr::select(-c("Tx","Tn","Sf","Pa")), by="Date") 45 | })) 46 | shinyjs::hide(id = "loading-content", anim = TRUE, animType = "fade") 47 | shinyjs::show("app-content") 48 | } 49 | 50 | collect_hydrograph_csv <- function(fp) { 51 | isolate({ 52 | sta$lid <- -1 53 | sta$carea <- 100 54 | sta$iid <- -1 55 | sta$name <- 'test' 56 | sta$name2 <- paste0('from csv: ',fp) 57 | sta$label <- paste0(sta$name,': ',sta$name2) 58 | sta$hyd <- qTemporal_csv(fp) 59 | sta$DTb <- min(sta$hyd$Date, na.rm=T) 60 | sta$DTe <- max(sta$hyd$Date, na.rm=T) 61 | sta$k <- recession_coef(sta$hyd$Flow) 62 | stat <- c(mean(sta$hyd$Flow),quantile(sta$hyd$Flow,probs=c(0.5,0.95,0.05),na.rm=T)) 63 | sta$info.html <- hyd.info(sta$label,nrow(sta$hyd)-1,min(sta$hyd$Date,na.rm=T),max(sta$hyd$Date,na.rm=T),sta$carea,stat) 64 | sta.fdc$cmplt <- flow_duration_curve_build(sta$hyd) 65 | sta.mnt$cmplt <- flow_monthly_bar_build(sta$hyd,sta$carea) 66 | }) 67 | } 68 | -------------------------------------------------------------------------------- /server/hydrograph/discharge_dyhygrph.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | output$dyhydgrph <- renderDygraph({ 4 | wflg <- input$chk.flg 5 | req(rng <- r$rngselect+1) 6 | print(rng) 7 | if (!is.null(sta$hyd) && rng[[1]]!=rng[[2]]){ 8 | if(!wflg){ 9 | if ("Tx" %in% colnames(sta$hyd)){ 10 | print(colnames(sta$hyd)) 11 | qFlw <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 12 | qRf <- xts(sta$hyd$Rf, order.by = sta$hyd$Date) 13 | qSm <- xts(sta$hyd$Sm, order.by = sta$hyd$Date) 14 | 15 | qx <- cbind(qFlw,qRf,qSm) 16 | colnames(qx) <- c('Observed','Rainfall','Snowmelt') 17 | dygraph(qx) %>% 18 | dySeries("Observed", color = "blue") %>% 19 | dyBarSeries("Rainfall", axis = 'y2', color="#1f78b4") %>% 20 | dyBarSeries("Snowmelt", axis = 'y2', color="#a6cee3") %>% 21 | dyAxis('y', label=dylabcms) %>% 22 | dyAxis('y2', label='Atmospheric yield (mm)', valueRange = c(100, 0)) %>% 23 | dyRangeSelector(fillColor='', height=80, dateWindow = rng) %>% 24 | dyOptions(retainDateWindow = TRUE) 25 | } else { 26 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 27 | colnames(qxts) <- 'Discharge' 28 | if (rng[1]==rng[2]) { # occurs upon opening (bug fix) 29 | dygraph(qxts) %>% 30 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 31 | dyAxis(name='y', label=dylabcms) %>% 32 | dyRangeSelector(fillColor='', height=80) %>% 33 | dyOptions(retainDateWindow = TRUE) 34 | } else { 35 | dygraph(qxts) %>% 36 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 37 | dyAxis(name='y', label=dylabcms) %>% 38 | dyRangeSelector(fillColor='', height=80, dateWindow = rng) %>% 39 | dyOptions(retainDateWindow = TRUE) 40 | } 41 | } 42 | }else{ 43 | hIce <- data.frame(Date = sta$hyd$Date,q = sta$hyd$Flow,flg = sta$hyd$Flag) 44 | hIce[hIce$flg!='ice_conditions',]$q <- NA 45 | hEst <- data.frame(Date = sta$hyd$Date,q = sta$hyd$Flow,flg = sta$hyd$Flag) 46 | hEst[hEst$flg!='estimate',]$q <- NA 47 | hRaw <- data.frame(Date = sta$hyd$Date,q = sta$hyd$Flow,flg = sta$hyd$Flag) 48 | hRaw[hRaw$flg!='realtime_uncorrected',]$q <- NA 49 | 50 | x1 <- xts(hIce$q, order.by = hIce$Date) 51 | x2 <- xts(hEst$q, order.by = hEst$Date) 52 | x3 <- xts(hRaw$q, order.by = hRaw$Date) 53 | xm <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 54 | 55 | qxts <- cbind(xm, x1, x2, x3) 56 | colnames(qxts) <- c('Discharge','Ice conditions','Estimate','Uncorrected') 57 | dygraph(qxts) %>% 58 | dySeries("Discharge", stepPlot = TRUE, fillGraph = TRUE, color = "blue") %>% 59 | dySeries("Ice conditions", stepPlot = TRUE, fillGraph = TRUE, color = "#ffa552", drawPoints=TRUE, strokeWidth=3) %>% 60 | dySeries("Estimate", stepPlot = TRUE, fillGraph = TRUE, color = "#008000", drawPoints=TRUE, strokeWidth=3) %>% 61 | dySeries("Uncorrected", stepPlot = TRUE, fillGraph = TRUE, color = "#6635b5", drawPoints=TRUE, strokeWidth=3) %>% 62 | dyOptions() %>% 63 | dyAxis(name='y', label=dylabcms) %>% 64 | dyRangeSelector(fillColor='', height=80, dateWindow = rng) %>% 65 | dyOptions(retainDateWindow = TRUE) 66 | } 67 | } 68 | }) 69 | -------------------------------------------------------------------------------- /server/trend/seasonal.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ######################################################## 4 | # seasonal flow summary 5 | ######################################################## 6 | 7 | output$se.q <- renderPlot({ 8 | if (!is.null(sta$hyd)){ 9 | 10 | # summarize by month 11 | df <- sta$hyd 12 | df$month <- as.numeric(format(df$Date, "%m")) 13 | 14 | df$wy = wtr_yr(df$Date) 15 | df$se <- NA 16 | df[df$month<3 | df$month>11,]$se = 'DJF' 17 | df[df$month<6 & df$month>2,]$se = 'MAM' 18 | df[df$month<9 & df$month>5,]$se = 'JJA' 19 | df[df$month<12 & df$month>8,]$se = 'SON' 20 | df$se_f <- factor(df$se,levels=c('DJF','MAM','JJA','SON')) 21 | 22 | df <- df %>% group_by(wy,se_f) 23 | if(is.null(sta$carea)){ 24 | df <- df %>% dplyr::summarise(stat = mean(Flow, na.rm = TRUE), n = sum(!is.na(Flow))) 25 | ylab <- expression('Mean seasonal discharge ' ~ (m^3/s)) 26 | } else { 27 | df <- df %>% dplyr::summarise(stat = sum(Flow, na.rm = TRUE)*86.4/sta$carea, n = sum(!is.na(Flow))) 28 | ylab <- 'Total discharge (mm)' 29 | } 30 | 31 | if (nrow(df[df$n==0,])>0) df[df$n==0,]$stat <- NA 32 | 33 | ggplot(df, aes(wy,stat)) + 34 | theme_bw() + 35 | geom_step(na.rm = TRUE) + 36 | geom_smooth(na.rm=TRUE) + 37 | facet_grid(rows = vars(se_f)) + #, scales = "free") + 38 | ggtitle(paste0(sta$label,'\nmean annual discharge by season')) + 39 | ylab(ylab) + xlab('water year (oct-sept)') 40 | } 41 | }) 42 | 43 | 44 | 45 | output$rng.se <- renderDygraph({ 46 | if (!is.null(sta$hyd)){ 47 | jhyd <- sta$hyd %>% 48 | dplyr::select(Date,Flow) %>% 49 | mutate(year=year(Date), julian=yday(Date)) %>% 50 | dplyr::select(-Date) %>% 51 | spread(year,Flow) %>% 52 | mutate(julian=as.POSIXct(as.Date(julian-1, origin = as.Date("2001-01-01")))) 53 | 54 | don=xts( x=jhyd[,-1], order.by=jhyd$julian) 55 | p<-dygraph(don) %>% 56 | dyHighlight(highlightSeriesOpts = list(strokeWidth = 3)) %>% 57 | dyAxis("x", 58 | axisLabelFormatter=JS('function(d){ 59 | var monthNames = ["Jan", "Feb", "Mar", "Apr", "May", "Jun","Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]; 60 | return monthNames[d.getMonth()]; 61 | }'), 62 | valueFormatter = 'function(ms) { return moment(ms).format("DD MMM"); }') 63 | # %>% dyLegend(show = "never") 64 | 65 | # nice effect here, but screws with everything else 66 | p$x$css = " 67 | .dygraph-legend > span {display:none;} 68 | .dygraph-legend > span.highlight { display: inline; } 69 | " 70 | return(p) 71 | } 72 | }) 73 | 74 | 75 | output$tab.se <- renderFormattable({ 76 | req(rng <- input$rng.se_date_window) 77 | if (!is.null(sta$hyd)){ 78 | jb <- yday(rng[1]) 79 | je <- yday(rng[2]) 80 | if ( je==1 ) je <- 365 81 | 82 | sta$hyd %>% 83 | mutate(julian=yday(Date)) %>% 84 | filter(julian>=jb & julian<=je ) %>% 85 | dplyr::summarise(mean = mean(Flow,na.rm=TRUE), 86 | st.Dev = sd(Flow,na.rm=TRUE), 87 | p5 = quantile(Flow,.05,na.rm=TRUE), 88 | median = median(Flow,na.rm=TRUE), 89 | p95 = quantile(Flow,.95,na.rm=TRUE), 90 | n = sum(!is.na(Flow)), 91 | .groups = "keep") %>% 92 | formattable() 93 | } 94 | }) 95 | 96 | -------------------------------------------------------------------------------- /md/bfnotes.md: -------------------------------------------------------------------------------- 1 | #### Hydrograph separation methods: 2 | 3 | 1. **BF.LH:** The Lyne-Hollick digital filter (Lyne and Hollick, 1979), 3-pass sweep with \\(\alpha=0.925\\) as discussed in Chapman (1999); 4 | 2. **BF.CM:** The Chapman-Maxwell digital filter (Chapman and Maxwell, 1996), using automatically computed recession coefficient (\\(k\\)); 5 | 3. **BF.BE:** The Boughton-Eckhardt digital filter (Boughton, 1993; Eckhardt, 2005) with computed \\(k\\) and \\(BFI_\text{max}=0.8\\); 6 | 4. **BF.JH:** The Jakeman-Hornberger digital filter (Jakeman and Hornberger, 1993) based on their IHACRES model with \\(C=0.3\\) and \\(\alpha=-\exp(-1/k)\\); 7 | 5. **BF.Cl:** The method of Clarifica Inc. (2002); 8 | 6. **BF.UKn:** The UK Institute of Hydrology (or Wallingford) method (Institute of Hydrology, 1980), sweeping minimum of Piggott et.al. (2005); 9 | 7. **BF.UKx:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping maximum of Piggott et.al. (2005); 10 | 8. **BF.UKm:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping median; 11 | 9. **BF.HYSEP.FI:** The HYSEP fixed-interval method (Sloto and Crouse, 1996), with known catchment area; 12 | 10. **BF.HYSEP.SI:** The HYSEP sliding-interval method (Sloto and Crouse, 1996), with known catchment area; 13 | 11. **BF.HYSEP.LM:** The HYSEP local minima method (Sloto and Crouse, 1996), with known catchment area; 14 | 12. **BF.PART1:** The PART method (Rutledge, 1998), with known catchment area, pass 1 of 3 antecedent recession requirement; 15 | 13. **BF.PART2:** The PART method (Rutledge, 1998), with known catchment area, pass 2 of 3 antecedent recession requirement; 16 | 14. **BF.PART3:** The PART method (Rutledge, 1998), with known catchment area, pass 3 of 3 antecedent recession requirement. 17 | 18 | #### References 19 | 20 | Boughton, W.C., 1993. A hydrograph-based model for estimating the water yield of ungauged catchments. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Newcastle: 317-324. 21 | 22 | Chapman, T.G. and A.I. Maxwell, 1996. Baseflow separation - comparison of numerical methods with tracer experiments.Institute Engineers Australia National Conference. Publ. 96/05, 539-545. 23 | 24 | Chapman T.G., 1999. A comparison of algorithms for stream flow recession and baseflow separation. Hydrological Processes 13: 710-714. 25 | 26 | Clarifica Inc., 2002. Water Budget in Urbanizing Watersheds: Duffins Creek Watershed. Report prepared for the Toronto and Region Conservation Authority. 27 | 28 | Eckhardt, K., 2005. How to construct recursive digital filters for baseflow separation. Hydrological Processes 19, 507-515. 29 | 30 | Institute of Hydrology, 1980. Low Flow Studies report. Wallingford, UK. 31 | 32 | Jakeman, A.J. and Hornberger G.M., 1993. How much complexity is warranted in a rainfall-runoff model? Water Resources Research 29: 2637-2649. 33 | 34 | Lyne, V. and M. Hollick, 1979. Stochastic time-variable rainfall-runoff modelling. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Perth: 89-92. 35 | 36 | Piggott, A.R., S. Moin, C. Southam, 2005. A revised approach to the UKIH method for the calculation of baseflow. Hydrological Sciences Journal 50(5): 911-920. 37 | 38 | Rutledge, A.T., 1998. Computer Programs for Describing the Recession of Ground-Water Discharge and for Estimating Mean Ground-Water Recharge and Discharge from Streamflow Records-Update, Water-Resources Investigation Report 98-4148. 39 | 40 | Sloto, R.A. and M.Y. Crouse, 1996. HYSEP: A Computer Program for Streamflow Hydrograph Separation and Analysis U.S. Geological Survey Water-Resources Investigations Report 96-4040. 41 | -------------------------------------------------------------------------------- /md/knotes.md: -------------------------------------------------------------------------------- 1 | ### Automated stream flow (linear decay) recession coefficient computation: 2 | 3 | The stream flow recession coefficient (k), describes the withdrawal of water from storage within the watershed (Linsley et.al., 1975). The recession coefficient is a means of determining the amount baseflow recedes after a given period of time: 4 | 5 | $$ b_t=kb_{t-1} $$ 6 | 7 | where *bt−1* represents the stream flow calculated at one time step prior to *bt* where *bt−1*<*bt*. 8 | 9 | 10 | 11 | Another interpretation is rate-of-change in discharge $[\text{m}^3\text{s}^{-1}\text{day}^{-1}]$: 12 | 13 | $$ \Delta b = \frac{b_t-b_{t-1}}{\text{(1 day)}} \approx (k-1)b$$ 14 | 15 | 16 | 17 | By plotting *bt−1* vs. *bt*, the recession coefficient can be determined by finding a linear function through the origin that envelopes the scatter above where *bt−1*/*bt* approaches unity. Here is where *k* is equivalent to the function's slope. 18 | 19 | The reasoning here is that where the difference between *bt−1* and *bt* is minimized, then those stream flow values are most-likely solely composed of baseflow, i.e., *"the withdrawal of water from storage within the watershed"* (Linsley et.al., 1975). Where *bt−1*/*bt* $\ll$ 1, it is an indication that stream flow has a larger runoff/quickflow component, and thus cannot be considered a period of baseflow recession. 20 | 21 | The recession coefficient is computed automatically using an iterative procedure whereby the recession curve is positioned to envelope the log-transformed discharge data versus subsequent discharge, on the condition that the former exceeds the latter. 22 | 23 | #### Note: 24 | 25 | By updating the plot to a user-defined stream flow recession coefficient, all *k*-dependent calculations used on the sHydrology web app will be affected; otherwise the automated recession coefficient is used by default. 26 | 27 |

28 | 29 | ### Automated first-order (inverse) hyperbolic stream flow recession coefficient computation: 30 | 31 | An alternative variant to the recession coefficient that assumes that stream flow follows an inverse hyperbolic function of the form: $$ \frac{1}{Q}-\frac{1}{Q_0}=\frac{t}{m} $$ 32 | 33 | where *1/Q* is the inverse discharge and *1/Q0* is the inverse of discharge at the beginning of a period of stream flow recession. The inverse of the slope of this function yields a first-cut estimate of the *m* parameter used in TOPMODEL (Beven and Kirkby, 1979). 34 | 35 | ![from Beven (2012)](images/topmodel_m.png) 36 | 37 | This equation is solved by isolating a number of recession events that appear to fit a similar trend. These inverted stream flow recession events are then plotted against the duration of the event and a final linear regression model is determined. The regression model should only be used when it appears that the underlying recession curves are roughly parallel to the final regression line. 38 | 39 | #### References 40 | 41 | Beven, K.J., M.J. Kirkby, 1979. A physically based, variable contributing area model of basin hydrology. Hydrological Sciences Bulletin 24(1): 43-69. 42 | 43 | Beven, K.J., 2012. Rainfall-Runoff modelling: the primer, 2\textsuperscript{nd} ed. John Wiley \& Sons, Ltd. 457pp. 44 | 45 | Linsley, R.K., M.A. Kohler, J.L.H. Paulhus, 1975. Hydrology for Engineers 2nd ed. McGraw-Hill. 482pp. 46 | -------------------------------------------------------------------------------- /server/trend/annual.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # annual flow summary 4 | ######################################################## 5 | flow_summary_annual <- function(hyd,carea,k=NULL,title=NULL,relative=FALSE){ 6 | if (!"BF.med" %in% colnames(hyd)){hyd <- baseflow_range(hyd,carea,k)} 7 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 8 | unit <- 'm?/s' 9 | if(!is.null(carea)){ 10 | hyd$BF.med <- hyd$BF.med * 31557.6/carea # mm/yr 11 | hyd$Flow <- hyd$Flow * 31557.6/carea # mm/yr 12 | unit <- 'mm/yr' 13 | } 14 | 15 | mQ <- mean(hyd$Flow, na.rm=TRUE) 16 | mBF <- mean(hyd$BF.med, na.rm=TRUE) 17 | 18 | if(relative){ 19 | hyd$Flow <- hyd$Flow - mQ 20 | hyd$BF.med <- hyd$BF.med - mBF 21 | } 22 | 23 | # NEW 24 | # summarize by year 25 | dfm35 <- df.annual.simple(hyd) 26 | df <- hyd %>% 27 | mutate(year = year(Date)) %>% 28 | group_by(year) %>% 29 | dplyr::summarise(mf = mean(Flow, na.rm = TRUE), mb = mean(BF.med, na.rm = TRUE), n = sum(!is.na(Flow))) 30 | 31 | df <- merge(x = df, y = dfm35, by = "year", all.x = TRUE) 32 | df$wmo <- df$wmo>=1 33 | df$wmoc <- '' 34 | df$wmoc[!df$wmo] = 'black' 35 | 36 | p <- ggplot(df, aes(year)) + 37 | theme_bw() + theme(legend.position=c(0.01,0.01), legend.justification=c(0,0), legend.title=element_blank(), 38 | legend.background = element_rect(fill=alpha('white', 0.4))) + 39 | geom_bar(stat="identity",aes(y=mf, fill='Total Flow', colour=wmo), size=1) + 40 | geom_bar(stat="identity",aes(y=mb, fill='Baseflow', colour=wmo), size=1 , width=0.75) + 41 | scale_fill_manual(values=c("Total Flow" = "#ef8a62", "Baseflow" = "#43a2ca"), guide=guide_legend(reverse=T)) + 42 | scale_colour_manual(values=c('TRUE'=NA, 'FALSE'="red"), guide=FALSE) + 43 | scale_x_continuous(breaks=seq(min(hyd$yr, na.rm=TRUE),max(hyd$yr, na.rm=TRUE),by=5)) 44 | 45 | # # OLD 46 | # p <- ggplot(hyd,aes(yr)) + 47 | # theme_bw() + theme(legend.position=c(0.01,0.01), legend.justification=c(0,0), legend.title=element_blank(), 48 | # legend.background = element_rect(fill=alpha('white', 0.4))) + 49 | # stat_summary(aes(y=Flow,fill='Total Flow'),fun.y="mean", geom="bar") + 50 | # stat_summary(aes(y=BF.med,fill='Baseflow', width=0.75),fun.y="mean", geom="bar") + 51 | # scale_fill_manual(values=c("Total Flow" = "#ef8a62", "Baseflow" = "#43a2ca"), guide=guide_legend(reverse=T)) + 52 | # scale_x_continuous(breaks=seq(min(hyd$yr, na.rm=TRUE),max(hyd$yr, na.rm=TRUE),by=5)) 53 | # 54 | 55 | if(!relative){ 56 | p <- p + geom_hline(yintercept = mQ, size=1, linetype='dotted') + 57 | annotate("text", x=min(hyd$yr), y=mQ, label=paste0("mean discharge = ",round(mQ,0),unit), hjust=0,vjust=-1,size=4) + 58 | geom_hline(yintercept = mBF, size=1, linetype='dotted') + 59 | annotate("text", x=min(hyd$yr), y=mBF, label=paste0("mean baseflow discharge = ",round(mBF,0),unit), hjust=0,vjust=-1,size=4) + 60 | labs(y = paste0("Discharge (",unit,")"), x=NULL) 61 | }else{ 62 | p <- p + labs(y = paste0("discharge relative to mean (",unit,")"), x=NULL) 63 | } 64 | 65 | if(!is.null(title)) p <- p + ggtitle(title) 66 | 67 | return(p) 68 | } 69 | 70 | ###################### 71 | ### plots 72 | ###################### 73 | output$yr.q <- renderPlot({isolate({ 74 | if (!sta$BFbuilt) separateHydrograph() 75 | if (!is.null(sta$hyd)){ 76 | flow_summary_annual(sta$hyd,sta$carea,sta$k,sta$label) 77 | } 78 | })}) 79 | 80 | output$yr.q.rel <- renderPlot({isolate({ 81 | if (!sta$BFbuilt) separateHydrograph() 82 | if (!is.null(sta$hyd)){ 83 | flow_summary_annual(sta$hyd,sta$carea,sta$k,sta$label,TRUE) 84 | } 85 | })}) -------------------------------------------------------------------------------- /server/statistics/saas_rf.R: -------------------------------------------------------------------------------- 1 | 2 | sass.rf.plot <- function(hyd, qp) { 3 | evnts <- hyd %>% 4 | dplyr::select(c('Date','Flow','evnt')) %>% 5 | mutate(new = ifelse(evnt > 0, 1, 0)) %>% 6 | mutate(new2 = cumsum(new)) %>% 7 | group_by(new2) %>% 8 | mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 9 | ungroup() %>% 10 | # filter(new==1, (pkflw>=qp*.9 & pkflw=qp) ) 12 | 13 | p1 <- evnts %>% ggplot(aes(pkflw)) + theme_bw() + geom_density() + xlab("peak flow (m3/s)") 14 | p2 <- evnts %>% ggplot(aes(dur)) + theme_bw() + geom_density() + xlab("duration (days)") 15 | p3 <- evnts %>% 16 | mutate(mnt=month(Date)) %>% 17 | group_by(mnt) %>% 18 | summarise(nevnt=n()) %>% 19 | mutate(mnt=month.abb[mnt]) %>% 20 | mutate(mnt=factor(mnt,levels=month.abb)) %>% 21 | ggplot(aes(mnt,nevnt)) + theme_bw() + geom_bar(stat='identity') + scale_x_discrete(drop=FALSE) + labs(x="timing (month)",y="count") 22 | 23 | grid.arrange(p1, p2, p3, nrow = 1, top=sta$label) 24 | } 25 | 26 | 27 | output$saas.rf.2 <- renderPlot({ 28 | req(rng <- input$rng.saas_date_window) 29 | if (!is.null(sta$hyd)){ 30 | qp <- returnQ(sta$hyd, 2) 31 | sass.rf.plot(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],], qp) 32 | } 33 | }) 34 | 35 | 36 | output$saas.rf.10 <- renderPlot({ 37 | req(rng <- input$rng.saas_date_window) 38 | if (!is.null(sta$hyd)){ 39 | qp <- returnQ(sta$hyd, 10) 40 | sass.rf.plot(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],], qp) 41 | # evnts <- sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] # %>% 42 | # dplyr::select(c('Date','Flow','evnt')) %>% 43 | # mutate(new = ifelse(evnt > 0, 1, 0)) %>% 44 | # mutate(new2 = cumsum(new)) %>% 45 | # group_by(new2) %>% 46 | # mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 47 | # ungroup() %>% 48 | # # filter(new==1, (pkflw>=qp*.9 & pkflw=qp) ) 50 | # 51 | # p1 <- evnts %>% ggplot(aes(pkflw)) + theme_bw() + geom_density() + xlab("peak flow (m3/s)") 52 | # p2 <- evnts %>% ggplot(aes(dur)) + theme_bw() + geom_density() + xlab("duration (days)") 53 | # p3 <- evnts %>% 54 | # mutate(mnt=month(Date)) %>% 55 | # group_by(mnt) %>% 56 | # summarise(nevnt=n()) %>% 57 | # mutate(mnt=month.abb[mnt]) %>% 58 | # mutate(mnt=factor(mnt,levels=month.abb)) %>% 59 | # ggplot(aes(mnt,nevnt)) + theme_bw() + geom_bar(stat='identity') + scale_x_discrete(drop=FALSE) + labs(x="timing (month)",y="count") 60 | # 61 | # grid.arrange(p1, p2, p3, nrow = 1, top=sta$label) 62 | } 63 | }) 64 | 65 | 66 | output$saas.rf.20 <- renderPlot({ 67 | req(rng <- input$rng.saas_date_window) 68 | if (!is.null(sta$hyd)){ 69 | qp <- returnQ(sta$hyd, 20) 70 | sass.rf.plot(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],], qp) 71 | # evnts <- sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 72 | # dplyr::select(c('Date','Flow','evnt')) %>% 73 | # mutate(new = ifelse(evnt > 0, 1, 0)) %>% 74 | # mutate(new2 = cumsum(new)) %>% 75 | # group_by(new2) %>% 76 | # mutate(pkflw=max(Flow, na.rm = TRUE), dur=n()) %>% 77 | # ungroup() %>% 78 | # # filter(new==1, (pkflw>=qp*.9 & pkflw=qp) ) 80 | # 81 | # p1 <- evnts %>% ggplot(aes(pkflw)) + theme_bw() + geom_density() + xlab("peak flow (m3/s)") 82 | # p2 <- evnts %>% ggplot(aes(dur)) + theme_bw() + geom_density() + xlab("duration (days)") 83 | # p3 <- evnts %>% 84 | # mutate(mnt=month(Date)) %>% 85 | # group_by(mnt) %>% 86 | # summarise(nevnt=n()) %>% 87 | # mutate(mnt=month.abb[mnt]) %>% 88 | # mutate(mnt=factor(mnt,levels=month.abb)) %>% 89 | # ggplot(aes(mnt,nevnt)) + theme_bw() + geom_bar(stat='identity') + scale_x_discrete(drop=FALSE) + labs(x="timing (month)",y="count") 90 | # 91 | # grid.arrange(p1, p2, p3, nrow = 1, top=sta$label) 92 | } 93 | }) -------------------------------------------------------------------------------- /functions/hydrograph_recession_coef.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # automated extraction of the baseflow recession coefficient k as in Linsley, Kohler, Paulhus (1975) pg.230 4 | # ref: Linsley, R.K., M.A. Kohler, J.L.H. Paulhus, 1975. Hydrology for Engineers 2nd ed. McGraw-Hill. 482pp. 5 | ######################################################## 6 | recession_coef <- function(Flow){ 7 | r2 <- 0 8 | m <- 1.0 9 | RPt <- recession_coef_Qp1(Flow) 10 | repeat{ 11 | fit <- lm(Q ~ 0 + Qp1, data=RPt) 12 | # summary(fit) 13 | m <- as.numeric(coef(fit)) 14 | r2 <- summary(fit)$r.squared 15 | if (r2>=0.999){break} 16 | RPt <- RPt[fit$residuals < 0,] 17 | } 18 | k <- 1/m 19 | return(k) 20 | } 21 | 22 | recession_coef_Qp1 <- function(Flow){ 23 | # collect recession points 24 | RP <- data.frame(Q=Flow, Qp1=rep(NA, length(Flow))) 25 | for(i in 2:length(Flow)) { 26 | RP$Qp1[i] <- RP$Q[i-1] 27 | } 28 | # View(RP) 29 | RP <- na.omit(RP) 30 | RP <- RP[RP$Qp1 <= RP$Q & RP$Q > 0,] 31 | return(RP) 32 | } 33 | 34 | recession_coef_plot <- function(Flow, k=NULL, title=NULL){ 35 | if (is.null(k)){k <- recession_coef(Flow)} 36 | RP <- recession_coef_Qp1(Flow) 37 | rng <- c(min(RP$Q),max(RP$Q)) 38 | mb <- as.numeric(1:10 %o% 10^(floor(log10(rng[1])):floor(log10(rng[2])))) 39 | t1 <- paste0('recession coefficient: ',round(k,3),'; n = ',length(RP$Q)) 40 | p <- ggplot(RP, aes(x = Qp1, y = Q)) + 41 | theme_bw() + theme(panel.grid.minor = element_line(colour="grey90", size=0.5)) + 42 | #geom_abline(slope=1/k,intercept=0, color="orange",size=2) + 43 | geom_segment(aes(x=rng[1],xend=rng[2],y=rng[1],yend=rng[2]/k), color="orange",size=2) + 44 | geom_point(size=2, colour='blue', alpha=0.2) + 45 | #geom_abline(slope=1/k,intercept=0, size=0.5) + 46 | geom_segment(aes(x=rng[1],xend=rng[2],y=rng[1],yend=rng[2]/k), size=0.5) + 47 | scale_x_log10(minor_breaks = mb) + scale_y_log10(minor_breaks = mb) + 48 | annotate("text", x=0.9*rng[2], y=1.3*rng[1], label=t1, hjust=1,vjust=1,size=4) + 49 | labs(x = "Discharge (day after)", y = gglabcms) 50 | 51 | if(!is.null(title)) p <- p + ggtitle(title) 52 | 53 | return(p) 54 | } 55 | 56 | ######################################################## 57 | # first-order hyperbolic streamflow recession coefficient (m) 58 | # of Beven and Kirkby (1979) 59 | ######################################################## 60 | recession_coef_plot_m <- function(dfin, k=NULL, title=NULL){ 61 | if (is.null(k)){k <- recession_coef(dfin$Flow)} 62 | 63 | # identifying recessions, adding a sequential counter 64 | if (is.null(dfin$qtyp)){dfin <- parse_hydrograph(dfin,k)} # 3: Baseflow_Recession 65 | df <- dfin 66 | df <- df[!(df$Flow<=0),] 67 | df$f1 <- NA 68 | df[df$qtyp==3,]$f1 <- 1 69 | df$nts <- ave(df$f1, rev(cumsum(rev(is.na(df$f1)))), FUN=cumsum) 70 | df$f1 <- NULL 71 | 72 | # group recession periods 73 | df$grp <- 0 74 | df[df$nts %in% 1,]$grp <- 1 75 | df$grp <- cumsum(df$grp) 76 | df <- df[complete.cases(df),] # removing NA rows 77 | df$grp <- as.factor(df$grp) 78 | df$invQ <- 1/df$Flow 79 | df <- df[df$nts>=1 & df$nts<32,] 80 | df = df %>% group_by(grp) %>% dplyr::filter(n()>5) %>% mutate(invQ.first = invQ[1]) 81 | df$invQ.norm <- df$invQ - df$invQ.first 82 | 83 | # master regression 84 | t1 <- paste0('first-order hyperbolic streamflow\nrecession coefficient:\n m = ',round(1/coef(lm(df$invQ.norm~df$nts))[2],1),' (n = ',length(df$invQ.norm),')') 85 | 86 | # (Inverse or) first-order hyperbolic streamflow recession 87 | p <- ggplot(df) + theme_bw() + 88 | theme(legend.position="none") + 89 | geom_line(aes(nts,invQ.norm,colour=grp),alpha=0.3) + 90 | stat_smooth(aes(nts,invQ.norm),method="lm", formula=y~x-1, se=FALSE, size=2,alpha=0.5) + 91 | annotate("text", x=2, y=.95*max(df$invQ.norm), label=t1, hjust=0,vjust=1,size=4) + 92 | ylim(0,NA) + labs(x="duration of recession (days)",y=expression(1/Q-1/Q[0])) 93 | 94 | if(!is.null(title)) p <- p + ggtitle(title) 95 | 96 | return(p) 97 | } -------------------------------------------------------------------------------- /server/statistics/mam.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # MAM frequency 4 | ######################################################## 5 | mam_frequency <- function(hyd, dist='lp3', s = 7, n = 2.5E4, ci = 0.90, title=NULL) { 6 | hyd <- hyd[!(hyd$Flow<=0),] 7 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 8 | hyd$mam <- rollapply(hyd$Flow, s, mean, fill = NA) 9 | agg <- aggregate(Flow ~ yr, hyd, max) 10 | input_data <- agg[,2] 11 | 12 | ci <- BootstrapCI(series=input_data, # flow data 13 | distribution=dist, # distribution 14 | n.resamples = n, # number of re-samples to conduct 15 | ci = ci) # confidence interval level 16 | 17 | # generate frequency plot 18 | return(frequencyPlot(input_data, agg[,1], ci$ci, title, inverted=TRUE)) 19 | } 20 | 21 | mam_histogram <- function(hyd, s) { 22 | hyd$yr <- as.numeric(format(hyd$Date, "%Y")) 23 | hyd$mam <- rollapply(hyd$Flow, s, mean, fill = NA) 24 | df <- hyd %>% 25 | group_by(yr) %>% 26 | summarise( 27 | Value = min(mam), 28 | Date = Date[which.min(mam)]) %>% 29 | ungroup() 30 | return(df) 31 | } 32 | 33 | ###################### 34 | ### plots 35 | ###################### 36 | output$mam.q1 <- renderPlot({ 37 | input$mam.regen 38 | isolate({ 39 | mdl <- input$mam.freq 40 | nrsm <- input$mam.rsmpl 41 | ci <- input$mam.ci 42 | if (!is.null(sta$hyd)){ 43 | withProgress(message = 'rendering plot 1 of 3..', value = 0.1, {mam_frequency(sta$hyd, mdl, 1, nrsm, ci, paste0(sta$label,'\nannual extreme minimum (1-day MAM)'))}) 44 | } 45 | }) 46 | }) 47 | 48 | output$mam.q7 <- renderPlot({ 49 | input$mam.regen 50 | isolate({ 51 | mdl <- input$mam.freq 52 | nrsm <- input$mam.rsmpl 53 | ci <- input$mam.ci 54 | if (!is.null(sta$hyd)){ 55 | withProgress(message = 'rendering plot 2 of 3..', value = 0.5, {mam_frequency(sta$hyd, mdl, 7, nrsm, ci, paste0(sta$label,'\n7-day MAM'))}) 56 | } 57 | }) 58 | }) 59 | 60 | output$mam.q30 <- renderPlot({ 61 | input$mam.regen 62 | isolate({ 63 | mdl <- input$mam.freq 64 | nrsm <- input$mam.rsmpl 65 | ci <- input$mam.ci 66 | if (!is.null(sta$hyd)){ 67 | withProgress(message = 'rendering plot 3 of 3..', value = 0.8, {mam_frequency(sta$hyd, mdl, 30, nrsm, ci, paste0(sta$label,'\n30-day MAM'))}) 68 | } 69 | }) 70 | }) 71 | 72 | output$hist.q1 <- renderPlot({ 73 | isolate({ 74 | if (!is.null(sta$hyd)){ 75 | df <- mam_histogram(sta$hyd,1) 76 | df$mo <- as.numeric(format(df$Date, "%m")) 77 | df$mnt <- format(df$Date, "%b") 78 | df$mnt <- ordered(df$mnt, levels = c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')) 79 | 80 | ggplot(df,aes(mnt)) + 81 | theme_bw() + 82 | geom_histogram(stat='count') + 83 | scale_x_discrete(drop = FALSE) + 84 | labs(x=NULL, title=paste0(sta$label,'\noccurrence of annual extreme minima')) 85 | } 86 | }) 87 | }) 88 | 89 | output$hist.q7 <- renderPlot({ 90 | isolate({ 91 | if (!is.null(sta$hyd)){ 92 | df <- mam_histogram(sta$hyd,7) 93 | df$mo <- as.numeric(format(df$Date, "%m")) 94 | df$mnt <- format(df$Date, "%b") 95 | df$mnt <- ordered(df$mnt, levels = c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')) 96 | 97 | ggplot(df,aes(mnt)) + 98 | theme_bw() + 99 | geom_histogram(stat='count') + 100 | scale_x_discrete(drop = FALSE) + 101 | labs(x=NULL, title=paste0(sta$label,'\ndistribution of 7-day MAM occurrence')) 102 | } 103 | }) 104 | }) 105 | 106 | output$hist.q30 <- renderPlot({ 107 | isolate({ 108 | if (!is.null(sta$hyd)){ 109 | df <- mam_histogram(sta$hyd,30) 110 | df$mo <- as.numeric(format(df$Date, "%m")) 111 | df$mnt <- format(df$Date, "%b") 112 | df$mnt <- ordered(df$mnt, levels = c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')) 113 | 114 | ggplot(df,aes(mnt)) + 115 | theme_bw() + 116 | geom_histogram(stat='count') + 117 | scale_x_discrete(drop = FALSE) + 118 | labs(x=NULL, title=paste0(sta$label,'\ndistribution of 30-day MAM occurrence')) 119 | } 120 | }) 121 | }) -------------------------------------------------------------------------------- /md/ihanotes.md: -------------------------------------------------------------------------------- 1 | ### Indicators of Hydrologic Alteration (IHA) 2 | 3 | Indicators of Hydrologic Alteration is a suite of statistical measures used to characterize the in-stream flow regime. The means and coefficients of variation (CV) of each IHA statistics are separated into 5 groups. Test's for significant (p<0.05) change in IHAs are completed via the t-test on means and Lewontin (1996) on CVs. 4 | 5 | #### Groups (*after* Richter et.al., 1996): 6 | 7 | 1. **MAGNITUDE** 8 | 9 | This group includes 12 parameters, each of which measures the central tendency (mean) of the daily water conditions for a given month. The monthly mean of the daily water conditions describes "normal" daily conditions for the month, and thus provides a general measure of habitat availability or suitability. The similarity of monthly means within a year reflects conditions of relative hydrologic constancy, whereas inter-annual variation (e.g., coefficient of variation) in the mean water condition for a given month provides an expression of environmental contingency (Colwell 1974; Poff & Ward 1989). The terms *constancy* and *contingency* as used here refer to the degree to which monthly means vary from month to month (constancy) and the extent to which flows vary within any given month (contingency). 10 | 11 | 2. **MAGNITUDE AND DURATION OF ANNUAL EXTREME CONDITIONS** 12 | 13 | The 10 parameters in this group measure the magnitude of extreme (minimum and maximum) annual water conditions of various duration, ranging from daily to seasonal. The durations we used follow natural or human-imposed cycles and include the 1-day, 3-day, 7-day (weekly), 30-day (monthly), and 90-day (seasonal) extremes. For any given year, the 1-day maximum (or minimum) is represented by the highest (or lowest) single daily value occurring during the year; the multi-day maximum (or minimum) is represented by the highest (or lowest) multi-day average value occurring during the year. The mean magnitude of high and low water extremes of various duration provide measures of environmental stress and disturbance during the year; conversely, such extremes may be necessary precursors or triggers for the reproduction of certain species. The inter-annual variation (e.g., coefficient of variation) in the magnitude of these extremes provides another expression of contingency. 14 | 15 | 3. **TIMING OF ANNUAL EXTREME CONDITIONS** 16 | 17 | Group 3 includes two parameters, one measuring the Julian date of the 1-day annual minimum water condition and the other measuring the Julian date of the 1-day maximum water condition. The timing of the highest and lowest water conditions within annual cycles provides another measure of environmental disturbance or stress by describing the seasonal nature of these stresses. Key life-cycle phases (e.g., reproduction) may be intimately linked to the timing of annual extremes; thus human-induced changes in timing may cause reproductive failure, stress, or mortality. The inter-annual variation in timing of extreme events reflects environmental contingency. 18 | 19 | 4. **FREQUENCY AND DURATION OF HIGH AND LOW PULSES** 20 | 21 | The four parameters in group 4 include two that measure the number of annual occurrences during which the magnitude of the water condition exceeds an upper threshold or remains below a lower threshold, respectively, and two that measure the mean duration of such high and low pulses. These measures of frequency and duration of high and low water conditions together portray the pulsing behavior of environmental variation within a year and provide measures of the shape of these environmental pulses. Hydrologic pulses are defined here as those periods within a year in which the daily mean water condition either rises above the 75th percentile (high pulse) or drops below the 25th percentile (low pulse) of all daily values for the preimpact time period. 22 | 23 | 5. **RATE AND FREQUENCY OF CHANGE IN CONDITIONS** 24 | 25 | The four parameters in group 5 measure the number and mean rate of both positive and negative changes in water conditions from one day to the next. The rate and frequency of change in water conditions can be described in terms of the abruptness and number of intra-annual cycles of environmental variation and can provide a measure of the rate and frequency of intra-annual environmental change. 26 | 27 | #### References 28 | 29 | Richter, B.D., J.V. Baumgertner, J. Powell, D.P. Braun, 1996. A Method for Assessing Hydrologic Alteration within Ecosystems. Conservation Biology 10(4): 1163-1174. 30 | 31 | Lewontin, R.C. 1966. On the measurement of relative variability. Systematic Zoology 15: 141-142. 32 | -------------------------------------------------------------------------------- /server/trend/cumu.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # cumulative flow summary 4 | ######################################################## 5 | flow_summary_cumu <- function(hyd,carea,title=NULL,DTrng=NULL){ 6 | if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 7 | 8 | # infill NAs 9 | df <- data.frame(d=hyd$Date, q=hyd$Flow, b=hyd$BF.med) %>% 10 | mutate(Date = as.Date(d)) %>% 11 | complete(Date = seq.Date(min(d), max(d), by="day")) %>% 12 | replace_na(list(q=mean(hyd$Flow,na.rm=TRUE),b=mean(hyd$BF.med,na.rm=TRUE))) 13 | 14 | if(!is.null(carea)){ 15 | # df <- data.frame(d=hyd$Date, c=cumsum(hyd$Flow)*86.4/carea, b=cumsum(hyd$BF.med)*86.4/carea) 16 | df <- data.frame(d=df$Date, c=cumsum(df$q)*86.4/carea, b=cumsum(df$b)*86.4/carea, infil=is.na(df$d)) 17 | unit = expression('Cumulative streamflow ' ~ (mm)) 18 | }else{ 19 | # df <- data.frame(d=hyd$Date, c=cumsum(hyd$Flow)*86400, b=cumsum(hyd$BF.med)*86400) 20 | df <- data.frame(d=df$Date, c=cumsum(df$q)*86400, b=cumsum(df$b)*86400, infil=is.na(df$d)) 21 | unit = expression('Cumulative streamflow ' ~ (m^3)) 22 | } 23 | 24 | # blank-out infilled data 25 | df$c[df$infil] = NA 26 | df$b[df$infil] = NA 27 | 28 | pwc <- piecewise.regression.line(data.frame(x=df$d,y=df$c)) 29 | pwb <- piecewise.regression.line(data.frame(x=df$d,y=df$b)) 30 | 31 | p <- ggplot(df, aes(d)) + 32 | theme_bw() + theme(legend.position=c(0.03,0.97), legend.justification=c(0,1), legend.title=element_blank()) + 33 | theme(panel.grid.major = element_line(colour = "#808080"), panel.grid.minor = element_line(colour = "#808080")) + 34 | geom_line(aes(y=c, color="Total Flow"), size=2) + 35 | geom_line(aes(y=b, color="Baseflow"), size=2) + 36 | geom_line(aes(x=d,y=v), pwc$df, color="blue", size=1, alpha=0.7) + 37 | geom_line(aes(x=d,y=v), pwb$df, color="blue", size=1, alpha=0.7) + 38 | { if (length(pwc$brk$x)>0) geom_point(aes(x=pwc$brk$x,y=pwc$brk$y), shape=19, size=5, color="blue") } + 39 | { if (length(pwb$brk$x)>0) geom_point(aes(x=pwb$brk$x,y=pwb$brk$y), shape=19, size=5, color="blue") } + 40 | geom_segment(aes(x=min(d,na.rm=TRUE),xend=max(d,na.rm=TRUE),y=0,yend=max(c,na.rm=TRUE)),size=1,linetype="dotted") + 41 | geom_segment(aes(x=min(d,na.rm=TRUE),xend=max(d,na.rm=TRUE),y=0,yend=max(b,na.rm=TRUE)),size=1,linetype="dotted") + 42 | scale_colour_manual(values=c("Total Flow" = "#ef8a62", "Baseflow" = "#43a2ca")) + 43 | labs(x = NULL, y = unit) + 44 | scale_x_date() 45 | 46 | if(!is.null(title)) p <- p + ggtitle(title) 47 | 48 | return(p) 49 | } 50 | 51 | flow_summary_cumu_bf <- function(hyd,carea,title=NULL,DTrng=NULL){ 52 | if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 53 | # df <- data.frame(d=hyd$Date, b=rollmean(hyd$BF.med/hyd$Flow, 365, fill=NA)) 54 | df <- data.frame(d=hyd$Date, b=rollsum(hyd$BF.med, 365, fill=NA)/rollsum(hyd$Flow, 365, fill=NA)) 55 | 56 | p <- ggplot(df, aes(d,b)) + 57 | theme_bw() + #theme(legend.position=c(0.03,0.97), legend.justification=c(0,1), legend.title=element_blank()) + 58 | geom_line() + 59 | labs(x = NULL, y = "Baseflow Index (BFI)") + 60 | scale_x_date() 61 | 62 | if(!is.null(title)) p <- p + ggtitle(title) 63 | 64 | return(p) 65 | } 66 | 67 | 68 | ###################### 69 | ### plots 70 | ###################### 71 | output$cum.q <- renderPlot({ 72 | input$mouseup 73 | isolate({ 74 | if (!sta$BFbuilt) separateHydrograph() 75 | if (!is.null(sta$hyd)){ 76 | rng <- input$rng.cd_date_window 77 | sfx <- '' 78 | if(!is.null(rng)) sfx <- paste0(': ',substr(rng[1],1,4),'-',substr(rng[2],1,4)) 79 | withProgress( 80 | message = 'rendering cumulative discharge plot..', value = 0.5, { 81 | flow_summary_cumu(sta$hyd,sta$carea,paste0(sta$label,'\ncumulative discharge',sfx),rng) 82 | } 83 | ) 84 | } 85 | }) 86 | }) 87 | 88 | output$cum.bf <- renderPlot({ 89 | input$mouseup 90 | isolate({ 91 | if (!sta$BFbuilt) separateHydrograph() 92 | if (!is.null(sta$hyd)){ 93 | rng <- input$rng.cd_date_window 94 | sfx <- '' 95 | if(!is.null(rng)) sfx <- paste0(': ',substr(rng[1],1,4),'-',substr(rng[2],1,4)) 96 | withProgress( 97 | message = 'rendering baseflow index plot..', value = 0.5, { 98 | flow_summary_cumu_bf(sta$hyd,sta$carea,paste0(sta$label,'\nbaseflow index',sfx),rng) 99 | } 100 | ) 101 | } 102 | }) 103 | }) 104 | 105 | output$rng.cd <- renderDygraph({ 106 | if (!is.null(sta$hyd)){ 107 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 108 | colnames(qxts) <- 'Discharge' 109 | dygraph(qxts) %>% 110 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 111 | dyAxis(name='y', label=dylabcms) %>% 112 | dyRangeSelector(fillColor='', height=80) 113 | } 114 | }) -------------------------------------------------------------------------------- /functions/hydrograph_parsing.R: -------------------------------------------------------------------------------- 1 | ########################################################## 2 | ################ Hydrograph parsing ###################### 3 | ########################################################## 4 | # By M. Marchildon 5 | # 6 | # Nov, 2018 7 | ########################################################## 8 | 9 | 10 | 11 | ######################################################## 12 | # Hydrograph parsing 13 | ######################################################## 14 | parse_hydrograph <- function(hyd, k, abthrs=0.25, hghthrs=0.95){ 15 | ## parameters 16 | qeff <- hyd$Flow - Clarifica(hyd$Flow) 17 | qeff[qeff<=0] <- NA 18 | rlt <- quantile(qeff, abthrs, na.rm = TRUE) # rising limb threshold 19 | qHigh <- quantile(hyd$Flow, hghthrs, na.rm = TRUE) # "high" discharge threshold 20 | 21 | ## Parse hydrograph -- qtyp code: 22 | # 0: unknown 23 | # 1: Rising_Limb 24 | # 2: Falling_Limb 25 | # 3: Baseflow_Recession 26 | # 4: Missing 27 | ## 28 | 29 | # rising limb (1) 30 | hyd$qtyp <- rollapply(hyd$Flow, 2, function(x) if(any(is.na(x))){4}else{if(x[2]>x[1] && x[2]-x[1]>rlt){1}else{0}},fill=0) 31 | 32 | # baseflow recession (3) 33 | t1 <- rollapply(hyd$Flow, 2, function(x) if(all(xnval) break 92 | if (e.beg[i]) break 93 | } 94 | if (i>nval) break 95 | i.next=i 96 | 97 | q.under = q.remain[i-1] * k # [m3/s] termed underlying flow (in Reed etal., 1975): "flow which would have been observed if the rainfall event under consideration had not occurred." 98 | repeat{ 99 | if (!is.na(q.remain[i])){ 100 | if (q.under>q.remain[i]) q.under = q.remain[i] 101 | q.remain[i] = q.remain[i] - q.under 102 | } 103 | s = s + q.under * 86400.0 # [m?] 104 | q.under = q.under * k 105 | i = i+1 106 | if (q.under < 0.01 | i>nval) break 107 | } 108 | q.evnt[isv] <- s / carea / 1000.0 # event total [mm] 109 | } 110 | # q.evnt[q.evnt==0] <- NA 111 | hyd$evnt <- round(q.evnt,1) 112 | return(hyd) 113 | } 114 | -------------------------------------------------------------------------------- /server/trend/daily.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ######################################################## 4 | # annual-average daily discharge 5 | ######################################################## 6 | flow_summary_daily <- function(hyd,carea,k=NULL,title=NULL,DTrng=NULL,minmaxmean=FALSE){ 7 | if (!"BF.med" %in% colnames(hyd)){hyd <- baseflow_range(hyd,carea,k)} 8 | hyd$doy <- as.numeric(format(hyd$Date, "%j")) 9 | unit <- 'm?/s' 10 | if(!is.null(carea)){ 11 | hyd$BF.med <- hyd$BF.med * 31557.6/carea # mm/yr 12 | hyd$Flow <- hyd$Flow * 31557.6/carea # mm/yr 13 | unit <- 'mm/yr' 14 | } 15 | 16 | if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 17 | 18 | hyd$dQ <- rollapply(hyd$Flow,5,mean,align='center',partial=TRUE) 19 | hyd$dBF <- rollapply(hyd$BF.med,5,mean,align='center',partial=TRUE) 20 | dQ <- aggregate(dQ ~ doy, hyd, mean)[,2] 21 | dQn <- aggregate(dQ ~ doy, hyd, min)[,2] 22 | dQx <- aggregate(dQ ~ doy, hyd, max)[,2] 23 | dBF <- aggregate(dBF ~ doy, hyd, mean)[,2] 24 | df <- data.frame(doy=seq(1,366),dQ,dQn,dQx,dBF) 25 | df$doy <- as.Date(df$doy - 1, origin = "2008-01-01") 26 | 27 | if (minmaxmean) { 28 | plotnam = "Range of observed mean-daily discharge" 29 | p <- ggplot(df,aes(doy)) + 30 | theme_bw() + theme(legend.position=c(0.03,0.8), legend.justification=c(0,0), legend.title=element_blank(), 31 | legend.background = element_rect(fill=alpha('white', 0.4))) + 32 | geom_line(aes(y=dQ, linetype="mean")) + 33 | geom_line(aes(y=dQn, linetype="min")) + 34 | geom_line(aes(y=dQx, linetype="max")) + 35 | scale_linetype_manual(values=c("min" = "dashed", "mean"="solid", "max" = "dashed")) + 36 | scale_x_date(date_labels="%b", date_breaks = 'month') + 37 | labs(y = paste0("Discharge (",unit,")"), x='Day of year') 38 | } else { 39 | plotnam = "Julian-day mean of mean-daily discharge" 40 | p <- ggplot(df,aes(doy)) + 41 | theme_bw() + theme(legend.position=c(0.03,0.03), legend.justification=c(0,0), legend.title=element_blank(), 42 | legend.background = element_rect(fill=alpha('white', 0.4))) + 43 | geom_area(aes(y=dQ,fill='Total Flow')) + geom_area(aes(y=dBF,fill='Baseflow')) + 44 | scale_fill_manual(values=c("Total Flow" = "#ef8a62", "Baseflow" = "#43a2ca"), guide=guide_legend(reverse=T)) + 45 | scale_x_date(date_labels="%b", date_breaks = 'month') + 46 | labs(y = paste0("Discharge (",unit,")"), x='Day of year') 47 | } 48 | 49 | if(!is.null(carea)) p <- p + scale_y_continuous(sec.axis = sec_axis( trans=~.*carea/31557.6, name=gglabcms) ) 50 | 51 | if(!is.null(title)) p <- p + ggtitle(paste0(plotnam,"\n",title)) 52 | 53 | return(p) 54 | } 55 | 56 | # flow_summary_box <- function(hyd, carea, title, DTrng=NULL) { 57 | # hyd <- hyd %>% mutate(Date=as.Date(Date), mnt=factor(strftime(Date, format="%b"),levels=c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'))) 58 | # 59 | # if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 60 | # 61 | # unit <- 'm?/s' 62 | # if(!is.null(carea)){ 63 | # hyd$Flow <- hyd$Flow * 31557.6/carea # mm/yr 64 | # unit <- 'mm/yr' 65 | # } 66 | # 67 | # # collect all boxplot stats for selected range 68 | # m1 <- matrix(nrow=12,ncol=5) 69 | # t1 <- by(hyd$Flow,hyd$mnt,boxplot.stats) 70 | # for (i in 1:12){ 71 | # m1[i,] <- t1[[i]][[1]] 72 | # } 73 | # 74 | # ggplot(hyd) + 75 | # theme_bw() + 76 | # geom_boxplot(aes(x = mnt, y = Flow), size = 1) + #, outlier.shape = NA) + 77 | # # coord_cartesian(ylim = c(0,max(m1[,5]))*1.05) + 78 | # scale_y_log10(name = paste0("Discharge (",unit,")"), sec.axis = sec_axis( trans=~.*carea/31557.6, name=gglabcms)) + 79 | # ggtitle(title) + xlab('Month') 80 | # } 81 | 82 | 83 | 84 | ###################### 85 | ### plots 86 | ###################### 87 | output$dy.q <- renderPlot({ 88 | input$mouseup 89 | isolate( 90 | if (!is.null(sta$hyd)){ 91 | rng <- input$rng.mdd_date_window 92 | flow_summary_daily(sta$hyd,sta$carea,sta$k,sta$label,rng) 93 | } 94 | ) 95 | }) 96 | 97 | output$dy.qmmm <- renderPlot({ 98 | input$mouseup 99 | isolate( 100 | if (!is.null(sta$hyd)){ 101 | rng <- input$rng.mdd_date_window 102 | flow_summary_daily(sta$hyd,sta$carea,sta$k,sta$label,rng,minmaxmean=TRUE) 103 | } 104 | ) 105 | }) 106 | 107 | # output$dy.qbox <- renderPlot({ 108 | # input$mouseup 109 | # isolate( 110 | # if (!is.null(sta$hyd)){ 111 | # rng <- input$rng.mdd_date_window 112 | # flow_summary_box(sta$hyd,sta$carea,sta$label,rng) 113 | # } 114 | # ) 115 | # }) 116 | 117 | output$rng.mdd <- renderDygraph({ 118 | if (!is.null(sta$hyd)){ 119 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 120 | colnames(qxts) <- 'Discharge' 121 | dygraph(qxts) %>% 122 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 123 | dyAxis(name='y', label=dylabcms) %>% 124 | dyRangeSelector(strokeColor = '', height=80) 125 | } 126 | }) -------------------------------------------------------------------------------- /server/statistics/saas.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | ###################### 5 | ### PLOTS 6 | ###################### 7 | 8 | output$rng.saas <- renderDygraph({ 9 | if (!is.null(sta$hyd)){ 10 | if (!sta$BFbuilt) separateHydrograph() 11 | qxts <- xts(sta$hyd[, c('Flow','BF.med')], order.by = sta$hyd$Date) 12 | colnames(qxts) <- c('Discharge',"Baseflow") 13 | dygraph(qxts) %>% 14 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 15 | dyAxis(name='y', label=dylabcms) %>% 16 | dyRangeSelector(fillColor='', height=60) 17 | } 18 | }) 19 | 20 | saas.stat <- function(hyd) { 21 | hyd %>% 22 | mutate(Month=month(Date)) %>% 23 | group_by(Month) %>% 24 | dplyr::summarise(mean = mean(Flow,na.rm=TRUE), 25 | st.Dev = sd(Flow,na.rm=TRUE), 26 | p5 = quantile(Flow,.05,na.rm=TRUE), 27 | p125 = quantile(Flow,.125,na.rm=TRUE), 28 | p375 = quantile(Flow,.375,na.rm=TRUE), 29 | median = median(Flow,na.rm=TRUE), 30 | p625 = quantile(Flow,.625,na.rm=TRUE), 31 | p875 = quantile(Flow,.875,na.rm=TRUE), 32 | p95 = quantile(Flow,.95,na.rm=TRUE), 33 | n = sum(!is.na(Flow)), 34 | .groups = "keep") %>% 35 | ungroup() %>% 36 | mutate(Month=month.abb[Month]) 37 | } 38 | saas.stat.bf <- function(hyd) { 39 | hyd %>% 40 | mutate(Month=month(Date)) %>% 41 | group_by(Month) %>% 42 | dplyr::summarise(mean = mean(BF.med,na.rm=TRUE), 43 | st.Dev = sd(BF.med,na.rm=TRUE), 44 | p5 = quantile(BF.med,.05,na.rm=TRUE), 45 | p125 = quantile(BF.med,.125,na.rm=TRUE), 46 | p375 = quantile(BF.med,.375,na.rm=TRUE), 47 | median = median(BF.med,na.rm=TRUE), 48 | p625 = quantile(BF.med,.625,na.rm=TRUE), 49 | p875 = quantile(BF.med,.875,na.rm=TRUE), 50 | p95 = quantile(BF.med,.95,na.rm=TRUE), 51 | n = sum(!is.na(BF.med)), 52 | .groups = "keep") %>% 53 | ungroup() %>% 54 | mutate(Month=month.abb[Month]) 55 | } 56 | 57 | output$saas.mmbf <- renderPlot({ 58 | req(rng <- input$rng.saas_date_window) 59 | if (!is.null(sta$hyd)){ 60 | # sta$hyd %>% 61 | sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 62 | mutate(mnt=month(Date)) %>% 63 | mutate(mnt=month.abb[mnt]) %>% 64 | ggplot() + 65 | theme_bw() + 66 | geom_boxplot(aes(x = reorder(mnt, montho(Date)), y = BF.med), size = 1) + #, outlier.shape = NA) 67 | labs(title = sta$label, y="Monthly median baseflow magnitude (m³/s)") 68 | } 69 | }) 70 | 71 | output$saas.mmbf2 <- renderPlot({ 72 | req(rng <- input$rng.saas_date_window) 73 | if (!is.null(sta$hyd)){ 74 | saas.stat.bf(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],]) %>% 75 | mutate(Month=factor(Month,levels=montha)) %>% 76 | # fct_reorder(Month, montha) %>% 77 | ggplot(aes(x=Month, group = 1)) + 78 | theme_bw() + 79 | theme(legend.position = c(.05,.95), 80 | legend.justification = c(0,1)) + 81 | geom_line(aes(y=p875, linetype='87.5%')) + 82 | geom_line(aes(y=p625, linetype='62.5%')) + #, linetype='dashed') + 83 | geom_line(aes(y=median, linetype='50%'), linewidth=1) + 84 | geom_line(aes(y=p375, linetype='37.5%')) + #, linetype='dashed') + 85 | geom_line(aes(y=p125, linetype='12.5%')) + 86 | scale_linetype_manual(name= "exceedance", values = c('solid','dashed','solid','dashed','solid')) + 87 | labs(title = sta$label, y="Monthly exceedances of baseflow (m³/s)", x="Month") 88 | } 89 | }) 90 | 91 | output$saas.m95q <- renderPlot({ 92 | req(rng <- input$rng.saas_date_window) 93 | if (!is.null(sta$hyd)){ 94 | saas.stat(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],]) %>% 95 | mutate(Month=factor(Month,levels=montha)) %>% 96 | # fct_reorder(Month, montha) %>% 97 | ggplot(aes(x=Month, group = 1)) + 98 | theme_bw() + 99 | theme(legend.position = c(.05,.95), 100 | legend.justification = c(0,1)) + 101 | geom_line(aes(y=p875, linetype='87.5%')) + 102 | geom_line(aes(y=p625, linetype='62.5%')) + #, linetype='dashed') + 103 | geom_line(aes(y=median, linetype='50%'), linewidth=1) + 104 | geom_line(aes(y=p375, linetype='37.5%')) + #, linetype='dashed') + 105 | geom_line(aes(y=p125, linetype='12.5%')) + 106 | scale_linetype_manual(name= "exceedance", values = c('solid','dashed','solid','dashed','solid')) + 107 | labs(title = sta$label, y="Monthly exceedances of total streamflow magnitude (m³/s)") 108 | } 109 | }) 110 | 111 | 112 | ###################### 113 | ### TABLES 114 | ###################### 115 | output$tabSAAS.mmbf <- renderFormattable({ 116 | req(rng <- input$rng.saas_date_window) 117 | saas.stat.bf(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],]) %>% formattable() 118 | # saas.stat.bf(sta$hyd) %>% formattable() 119 | }) 120 | 121 | output$tabSAAS.m95q <- renderFormattable({ 122 | req(rng <- input$rng.saas_date_window) 123 | saas.stat(sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],]) %>% formattable() 124 | # saas.stat(sta$hyd) %>% formattable() 125 | }) 126 | 127 | -------------------------------------------------------------------------------- /ui/statistics/eflows.R: -------------------------------------------------------------------------------- 1 | 2 | fluidPage( 3 | h2('E-Flows'), 4 | tabsetPanel(type = "tabs", 5 | tabPanel(title = 'Streamflow Analysis and Assessment Software', 6 | sidebarLayout( 7 | sidebarPanel( 8 | # plotOutput("cumu.iah",height=300), br(), 9 | # h4("select date range 1:"), 10 | dygraphOutput("rng.saas",height=300), br(), 11 | shiny::includeMarkdown("md/dtrng.md"), br(), 12 | p("NOTE: certain SAAS plots shown here will not render for short period (<10yr) hydrographs") 13 | # h4("select date range 2:"), 14 | # dygraphOutput("rng.iah2",height=240) 15 | ), 16 | mainPanel( 17 | fluidRow( 18 | h2('Streamflow Analysis and Assessment Software (SAAS)'), 19 | h5("(after Metcalfe et.al., 2013)"), 20 | # p("NOTE: Group descriptions given below. Values shown in red show a significant change (p<0.05)"), 21 | 22 | hr(), 23 | h5("Hydrologic regime components and associated indicators selected to assess hydrologic alteration:"), 24 | 25 | h3("Baseflow"), 26 | shiny::includeMarkdown("md/saas_mmbf.md"), br(), 27 | plotOutput('saas.mmbf'), br(), 28 | plotOutput('saas.mmbf2'), 29 | formattableOutput('tabSAAS.mmbf'), hr(), br(), 30 | 31 | h3("Subsistence flow"), 32 | p("Monthly exceedance flow magnitudes of total streamflow (preliminary assessment)"), 33 | plotOutput('saas.m95q'), 34 | formattableOutput('tabSAAS.m95q'), hr(), br(), 35 | 36 | h3("High flow pulses (less than bankfull)"), 37 | p("Monthly median frequency and duration (days) of flow events less than the bankfull flow magnitude."), 38 | plotOutput('saas.hfp'), hr(), br(), 39 | 40 | h3("Channel forming flow"), 41 | p("Magnitude, duration (days) and timing (month) of flows with a recurrence interval > 1.5 years."), 42 | plotOutput('saas.cff'), hr(), br(), 43 | 44 | h3("Riparian flow"), 45 | p("Magnitude, duration (days) and timing (month) of flows with recurrence intervals of 2, 10, and 20 years."), 46 | h4("2 year recurrence"), 47 | plotOutput('saas.rf.2'), 48 | h4("10 year recurrence"), 49 | plotOutput('saas.rf.10'), 50 | h4("20 year recurrence"), 51 | plotOutput('saas.rf.20'), hr(), br(), 52 | 53 | h3("Rate of change of flow"), 54 | p("Monthly median rate-of-change of flow (m3/sec/hr) for rising and falling limbs of flow events."), 55 | plotOutput('saas.roc') 56 | 57 | ) 58 | ) 59 | ) 60 | ), 61 | tabPanel( 62 | title = 'Indicators of Hydrologic Alteration', br(), 63 | sidebarLayout( 64 | sidebarPanel( 65 | plotOutput("cumu.iah",height=300), br(), 66 | h4("select date range 1:"), 67 | dygraphOutput("rng.iah1",height=240), br(), 68 | h4("select date range 2:"), 69 | dygraphOutput("rng.iah2",height=240), br(), 70 | shiny::includeMarkdown("md/dtrng.md") 71 | ), 72 | mainPanel( 73 | fluidRow( 74 | h2('Indicators of Hydrologic Alteration (IHA)'), hr(), 75 | htmlOutput("hdr.iha"), 76 | h5("NOTE: Group descriptions given below. Values shown in red show a significant change (p<0.05)"), 77 | h4("Group 1: Magnitude of monthly water conditions"), 78 | formattableOutput('tabIHA.01'), 79 | h4("Group 2: Magnitude and duration of annual extreme water conditions"), 80 | formattableOutput('tabIHA.02'), 81 | h4("Group 3: Timing (julian date) of annual extreme water conditions"), 82 | formattableOutput('tabIHA.03'), 83 | h4("Group 4: Frequency and duration of high/low pulses"), 84 | formattableOutput('tabIHA.04'), 85 | h4("Group 5: Rate and frequency of change in conditions"), 86 | formattableOutput('tabIHA.05') 87 | ), hr(), 88 | shiny::includeMarkdown("md/ihanotes.md") 89 | ) 90 | ) 91 | ) 92 | ) 93 | ) -------------------------------------------------------------------------------- /server/trend/monthly_bf.R: -------------------------------------------------------------------------------- 1 | 2 | ######################################################## 3 | # Baseflow summary 4 | ######################################################## 5 | baseflow_boxplot <- function(hyd,carea,k=NULL,title=NULL, DTrng=NULL){ 6 | if (!"BF.med" %in% colnames(hyd)){hyd <- baseflow_range(hyd,carea,k)} 7 | hyd$mnt <- format(hyd$Date, "%b") 8 | hyd$mnt <- as.factor(hyd$mnt) 9 | unit <- 'm?/s' 10 | if(!is.null(carea)){ 11 | hyd$BF.med <- hyd$BF.med * 2592/carea # mm/30 days 12 | unit <- 'mm' #'mm/month' 13 | } 14 | # print(DTrng) 15 | # if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 16 | hyd2 <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 17 | 18 | # collect all boxplot stats for selected range 19 | m1 <- matrix(nrow=12,ncol=5) 20 | t1 <- by(hyd$BF.med,hyd$mnt,boxplot.stats) 21 | for (i in 1:12){ 22 | m1[i,] <- t1[[i]][[1]] 23 | } 24 | 25 | p <- ggplot() + theme_bw() 26 | 27 | if(is.null(DTrng)) { 28 | p <- p + geom_boxplot(aes(x = reorder(mnt, montho(Date)), y = BF.med), hyd, size = 1, outlier.shape = NA) 29 | } else { 30 | p <- p + 31 | geom_boxplot(aes(x = reorder(mnt, montho(Date)), y = BF.med, color='black'), hyd, size = 1, outlier.shape = NA) + 32 | geom_boxplot(aes(x = reorder(mnt, montho(Date)), y = BF.med, colour='red'), hyd2, width=0.5, outlier.shape=NA, fill=NA) 33 | } 34 | 35 | p <- p + coord_cartesian(ylim = c(0,max(m1[,5]))*1.05) + 36 | labs(x=NULL,y = paste0("median separated baseflow (",unit,")"), title=NULL) 37 | 38 | if(!is.null(DTrng)) p <- p + 39 | theme(legend.position = c(.99,.99), legend.justification = c(1, 1),) + 40 | scale_colour_manual(name=element_blank(), values=c('black'='black','red'='red'), labels=c('full record','selected record')) 41 | 42 | if(!is.null(title)) p <- p + ggtitle(title) 43 | 44 | return(p) 45 | } 46 | 47 | baseflow_BFI <- function(hyd,carea,k=NULL,title=NULL, DTrng=NULL){ 48 | if (!"BF.med" %in% colnames(hyd)){hyd <- baseflow_range(hyd,carea,k)} 49 | if(!is.null(DTrng)) hyd <- hyd[hyd$Date >= DTrng[1] & hyd$Date <= DTrng[2],] 50 | 51 | hyd$mnt <- format(hyd$Date, "%b") 52 | hyd$mnt <- as.factor(hyd$mnt) 53 | hyd$BFI <- hyd$BF.med/hyd$Flow 54 | 55 | # BFI.sum <- ddply(hyd, .(reorder(mnt, montho(hyd$Date))), summarize, 56 | # mean = round(mean(BFI, na.rm = TRUE), 2), 57 | # sd = round(sd(BFI, na.rm = TRUE), 2), 58 | # n = length(Flow)) 59 | BFI.sum <- ddply(hyd, .(reorder(mnt, montho(hyd$Date))), summarize, 60 | mean = sum(BF.med, na.rm = TRUE)/sum(Flow, na.rm = TRUE), 61 | sd = sd(BFI, na.rm = TRUE), 62 | n = length(Flow)) 63 | names(BFI.sum)[names(BFI.sum) == 'reorder(mnt, montho(hyd$Date))'] <- 'mnt' 64 | BFI.sum$se <- 1.96*BFI.sum$sd/sqrt(BFI.sum$n) 65 | meanBFI <- sum(hyd$BF.med, na.rm = TRUE)/sum(hyd$Flow, na.rm = TRUE) #mean(hyd$BFI, na.rm = TRUE) 66 | 67 | p <- ggplot(BFI.sum, aes(x = mnt, y = mean, group=1)) + 68 | theme_bw() + 69 | geom_point() + 70 | geom_hline(yintercept = meanBFI, size=1, linetype='dotted') + 71 | annotate("text", x='Oct', y=meanBFI, label=paste0("annual BFI = ",round(meanBFI,2)), hjust=0,vjust=-1,size=4) + 72 | # geom_line(size=1,linetype='dotted') + 73 | geom_errorbar(aes(ymin=mean-se,ymax=mean+se)) + 74 | # geom_ribbon(aes(ymin=mean-se,ymax=mean+se),alpha=0.15) + 75 | labs(x=NULL,y = "Baseflow Index (BFI)", title=NULL) 76 | 77 | if(!is.null(title)) p <- p + ggtitle(title) 78 | 79 | return(p) 80 | } 81 | 82 | 83 | ###################### 84 | ### plots 85 | ###################### 86 | output$BF.mnt <- renderPlot({ 87 | input$mouseup 88 | isolate( 89 | if (!is.null(sta$hyd)){ 90 | rng <- input$rng.bf_date_window 91 | sfx <- '' 92 | if(!is.null(rng)) sfx <- paste0(': ',substr(rng[1],1,4),'-',substr(rng[2],1,4)) 93 | baseflow_boxplot(sta$hyd,sta$carea,sta$k,paste0(sta$label,'\nmonthly baseflow range',sfx),rng) 94 | } 95 | ) 96 | }) 97 | 98 | output$BFI.mnt <- renderPlot({ 99 | input$mouseup 100 | isolate( 101 | if (!is.null(sta$hyd)){ 102 | rng <- input$rng.bf_date_window 103 | sfx <- '' 104 | if(!is.null(rng)) sfx <- paste0(': ',substr(rng[1],1,4),'-',substr(rng[2],1,4)) 105 | baseflow_BFI(sta$hyd,sta$carea,sta$k,paste0(sta$label,'\nmonthly baseflow index (BFI)',sfx),rng) 106 | } 107 | ) 108 | }) 109 | 110 | output$rng.bf <- renderDygraph({ 111 | if (!is.null(sta$hyd)){ 112 | if (!sta$BFbuilt) separateHydrograph() 113 | qxts <- xts(cbind(sta$hyd$Flow, sta$hyd$BF.med), order.by = sta$hyd$Date) 114 | colnames(qxts) <- c('Discharge','Baseflow') 115 | dygraph(qxts) %>% 116 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 117 | dyAxis(name='y', label=dylabcms) %>% 118 | dyRangeSelector(fillColor='', height=80) 119 | } 120 | }) 121 | 122 | output$tab.mntbf <- renderFormattable({ 123 | req(rng <- input$rng.bf_date_window) 124 | if (!is.null(sta$hyd)){ 125 | if (!sta$BFbuilt) separateHydrograph() 126 | sta$hyd[sta$hyd$Date >= rng[1] & sta$hyd$Date <= rng[2],] %>% 127 | mutate(Month=month(Date)) %>% 128 | group_by(Month) %>% 129 | dplyr::summarise(mean = mean(BF.med,na.rm=TRUE), 130 | st.Dev = sd(BF.med,na.rm=TRUE), 131 | p5 = quantile(BF.med,.05,na.rm=TRUE), 132 | median = median(BF.med,na.rm=TRUE), 133 | p95 = quantile(BF.med,.95,na.rm=TRUE), 134 | n = sum(!is.na(BF.med)), 135 | .groups = "keep") %>% 136 | ungroup()%>% 137 | mutate(Month=month.abb[Month]) %>% 138 | formattable() 139 | } 140 | }) 141 | 142 | output$info.mntbf <- renderUI({ 143 | req(rng <- input$rng.bf_date_window) 144 | DTb <- as.Date(strftime(rng[[1]], "%Y-%m-%d")) 145 | DTe <- as.Date(strftime(rng[[2]], "%Y-%m-%d")) 146 | isolate({ 147 | por <- as.integer(difftime(DTe, DTb, units = "days")) 148 | shiny::HTML(paste0( 149 | '', 150 | paste0( 151 | '

Baseflow distribution summary:

', 152 | sta$label,'; ',strftime(DTb, "%b %Y"),' to ',strftime(DTe, "%b %Y"),' (',por+1,' days)' 153 | ), 154 | '' 155 | )) 156 | }) 157 | }) -------------------------------------------------------------------------------- /functions/iha.R: -------------------------------------------------------------------------------- 1 | ################################################## 2 | #### Indicators of Hydrologic Alteration (IHA) 3 | #### modified from https://rdrr.io/rforge/IHA/ 4 | #### accessed 2019-02-21 5 | #### Richter, B.D., J.V. Baumgertner, J. Powell, D.P. Braun, 1996. A Method for Assessing Hydrologic Alteration within Ecosystems. Conservation Biology 10(4): 1163-1174. 6 | ################################################## 7 | # GROUP 1: Magnitude of monthly water conditions 8 | mean.cv <- function(x) { 9 | mean <- mean(x,na.=TRUE) 10 | cv <- sd(x,na.=TRUE)/abs(mean) 11 | c(mean = mean, cv = cv) 12 | } 13 | water.year <- function(x){ 14 | yr <- year(x) 15 | ifelse(lubridate::month(x) > 9, yr + 1, yr) 16 | } 17 | water.month <- function(x, abbr=FALSE){ 18 | x <- c(4:12, 1:3)[lubridate::month(x)] 19 | if (abbr) { 20 | labels <- c("Oct", "Nov", "Dec", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep") 21 | } else { 22 | labels <- c("October", "November", "December", "January", "February", "March","April", "May", "June", "July", "August", "September") 23 | } 24 | ordered(x, levels = 1:12, labels = labels) 25 | } 26 | group1 <- function (x, FUN=median, abbr=FALSE) { 27 | stopifnot(is.zoo(x)) 28 | idx <- index(x) 29 | yr <- water.year(idx) 30 | mo <- water.month(idx, abbr) 31 | res <- tapply(coredata(x), list(mo, yr), FUN) 32 | # res <- tapply(coredata(x), mo, FUN) 33 | return(t(res)) 34 | } 35 | 36 | # GROUP 2: Magnitude and duration of annual extreme weather conditions 37 | runmean.iha <- function(x, year = NULL, mimic.tnc = F){ 38 | window <- c(1, 3, 7, 30, 90) 39 | vrunmean <- Vectorize(runmean, vectorize.args = 'k') 40 | if (mimic.tnc){ # should the function perform the calculation like the TNC IHA software (years be split before the running mean is calculated) 41 | sx <- split(coredata(x), year) 42 | rollx <- lapply(sx, vrunmean, k = window, alg = 'fast', endrule = 'NA') 43 | rollx <- do.call('rbind', rollx) 44 | } else { 45 | rollx <- vrunmean(coredata(x), k = window, alg = 'fast', endrule = 'NA') 46 | } 47 | colnames(rollx) <- sprintf('w%s', window) 48 | return(rollx) 49 | } 50 | group2Funs <- function(x){ 51 | rng <- as.numeric(apply(x, 2, range, na.rm=T)) 52 | baseindex <- min(x[,3], na.rm = T) / mean(x[,1], na.rm = T) 53 | zeros <- length(which(x[,1] == 0)) 54 | ans <- c(rng, zeros, baseindex) 55 | nms <- sprintf(c('%1$s Day Min', '%1$s Day Max'), rep(c(1, 3, 7, 30, 90), each=2)) 56 | names(ans) <- c(nms, 'Zero flow days', 'Base index') 57 | ans 58 | } 59 | group2 <- function(x, mimic.tnc = T, ...){ 60 | stopifnot(is.zoo(x)) 61 | yr <- water.year(index(x)) 62 | rollx <- runmean.iha(x, year = yr, mimic.tnc = mimic.tnc) 63 | xd <- cbind(year = yr, as.data.frame(rollx)) 64 | res <- ddply(xd, .(year), function(x) group2Funs(x[,-1]), ...) 65 | return(res) 66 | } 67 | 68 | # GROUP 3: Timing of Annual Extream Water conditions 69 | yday2 <- function(x){ # This function does the same as yday from the lubridate package but, does it like TNC's version of the IHA software where they count days as if every year was leap year; every year has 366 days. 70 | is.leap.year <- leap_year(x) 71 | is.janfeb <- month(x) < 3L 72 | ans <- yday(x) 73 | ans <- ifelse(!is.janfeb & !is.leap.year, ans + 1, ans) 74 | ans 75 | } 76 | which.min.zoo <- function(x) { 77 | index(x)[which.min(coredata(x))] 78 | } 79 | which.max.zoo <- function(x){ 80 | index(x)[which.max(coredata(x))] 81 | } 82 | which.range.zoo <- function(x){ 83 | c(which.min.zoo(x), which.max.zoo(x)) 84 | } 85 | group3 <- function (x, mimic.tnc = F){ 86 | ihaRange <- function(x, mimic.tnc){ 87 | if (mimic.tnc){ # should the function perform the calculation like the TNC IHA software 88 | return(yday2(which.range.zoo(x))) 89 | } else { 90 | return(yday(c(which.range.zoo(x)))) 91 | } 92 | } 93 | stopifnot(is.zoo(x)) 94 | yr <- water.year(index(x)) 95 | sx <- split(x, yr) 96 | res <- sapply(sx, ihaRange, mimic.tnc = mimic.tnc) 97 | dimnames(res)[[1]] <- c("Min", "Max") 98 | return(t(res)) 99 | } 100 | 101 | # GROUP 4: Frequency and Duration of High/Low Pulses 102 | pulses <- function(x, q){ 103 | runs <- findInterval(x, q, rightmost.closed = T) 104 | runs.length <- as.data.frame(unclass(rle(runs))) 105 | runs.length$values <- as.factor(c("low", "med", "high")[runs.length$values + 1]) 106 | return(runs.length) 107 | } 108 | pulse.numbers <- function (x) { 109 | summary(x)[c("low", "high")] 110 | } 111 | pulse.location <- function (x, XFUN = median) { 112 | tapply(x$lengths, x$values, FUN = XFUN)[c("low", "high")] 113 | } 114 | rle.start <- function (x){ 115 | pl <- cumsum(c(1, x$length)) 116 | start <- pl[-length(pl)] 117 | return(start) 118 | } 119 | group4 <- function(x, thresholds = NULL){ 120 | stopifnot(is.zoo(x)) 121 | if (is.null(thresholds)){ 122 | thresholds <- quantile(coredata(x), probs = c(0.25, 0.75)) 123 | } 124 | stopifnot(identical(length(thresholds), 2L)) 125 | p <- pulses(coredata(x), thresholds) 126 | st.date <- index(x)[rle.start(p)] 127 | st.date.wy <- water.year(st.date) 128 | numbers <- sapply(split(p$values, st.date.wy), pulse.numbers) 129 | ldp <- split(as.data.frame(p), st.date.wy) 130 | lengths <- sapply(ldp, FUN = pulse.location) 131 | res <- cbind(number = t(numbers), length = t(lengths)) 132 | colnames(res) <- c('Low pulse number', 'High pulse number', 'Low pulse length', 'High pulse length') 133 | return(res[, c(1,3,2,4), drop = F]) 134 | } 135 | 136 | # GROUP 5: Rate and frequency of change in conditions 137 | meandiff <- function (x, FUN = median, na.rm = T) { 138 | d <- diff(x) 139 | ind <- d > 0 140 | c(FUN(d[d > 0], na.rm = na.rm), FUN(d[d < 0], na.rm = na.rm), length(monotonic.segments(d)$values) - 1) 141 | } 142 | monotonic.segments <- function (x, diff = T) { 143 | if (!diff) 144 | x <- diff(x) 145 | f <- rep(1, length(x)) 146 | f[x > 0] <- 2 147 | f[x < 0] <- 0 148 | f.runs <- rle(f) 149 | i <- which(f.runs$values == 1) 150 | if (identical(i[1], as.integer(1))) { 151 | f.runs$values[1] <- f.runs$values[2] 152 | i <- i[-1] 153 | } 154 | if (length(i) > 0) 155 | f.runs$values[i] <- f.runs$values[i - 1] 156 | f <- inverse.rle(f.runs) 157 | f.runs <- rle(f) 158 | return(f.runs) 159 | } 160 | group5 <- function (x){ 161 | yr <- water.year(index(x)) 162 | sx <- split(as.numeric(x), yr) 163 | res <- sapply(sx, FUN = meandiff) 164 | dimnames(res)[[1]] <- c("Rise rate", "Fall rate", "Reversals") 165 | return(t(res)) 166 | } -------------------------------------------------------------------------------- /functions/hydrograph_frequency_analysis.R: -------------------------------------------------------------------------------- 1 | ######################################################################### 2 | # R-script for flood frequency analysis (general function call) # 3 | # based on: # 4 | # http://www.headwateranalytics.com/blog/flood-frequency-analysis-in-r # 5 | # 2016-12-31 # 6 | ######################################################################### 7 | 8 | FrequencyAnalysis <- function(series, distribution, nep = nonexceeds()) { 9 | 10 | distribution <- tolower(distribution) # dist=c("gev", "wei", "gum", "ln3", "lp3") 11 | transformed <- FALSE 12 | 13 | # add log Pearson Type 3 to list of distributions supported 14 | # by lmomco package 15 | base.dist <- c('lp3', dist.list()) 16 | 17 | if( any(distribution %in% base.dist) ) { 18 | 19 | # log transform series 20 | if( distribution == 'lp3' ) { 21 | series <- log10(series) 22 | transformed <- TRUE 23 | distribution <- 'pe3' 24 | } 25 | 26 | # compute L-moments 27 | samLmom <- lmom.ub(series) 28 | 29 | # estimate distribution parameters 30 | distPar <- lmom2par(samLmom, type = distribution) 31 | 32 | # compute quantiles for nonexceedances 33 | quant <- par2qua(f = nep, para = distPar) 34 | 35 | if( distribution == 'pe3' & transformed ) { 36 | distribution <- 'lp3' 37 | quant <- 10^quant 38 | } 39 | 40 | # return result as list object 41 | return( 42 | list( 43 | distribution = list( 44 | name = distribution, 45 | logTransformed = transformed, 46 | parameters = distPar), 47 | output = data.frame(nep = nep, rp = prob2T(nep), estimate = quant) 48 | ) ) 49 | 50 | } else { 51 | stop( 52 | sprintf('Distribution \'%s\' not recognized!', distribution)) 53 | } 54 | } 55 | 56 | 57 | ######################################################################### 58 | 59 | BootstrapCI <- function(series, distribution, n.resamples=1E3, nep=nonexceeds(), ci=0.90) { 60 | 61 | # compute frequency analysis 62 | fa <- FrequencyAnalysis(series=series, distribution=distribution, nep=nep) 63 | 64 | # extract fitted model parameters and flag as to whether the 65 | # distribution is based on log transformed data 66 | base.params <- fa$distribution$parameters 67 | isTransformed <- fa$distribution$logTransformed 68 | 69 | # create output matrices to store parameter sets and quantile estimates 70 | param.sets <- matrix(NA, nrow = n.resamples, ncol = length(base.params$para)) 71 | quantile.estimates <- matrix(NA, nrow = n.resamples, ncol = length(nep), 72 | dimnames = list(NULL, nep) ) 73 | 74 | # begin bootstrapping procedure 75 | for(i in 1:n.resamples) { 76 | 77 | valid.moments <- FALSE 78 | j <- 0 79 | 80 | # allow up to 20 re-tries to re-sample 81 | while(!valid.moments & j < 20) { 82 | 83 | # sample 'n' random variates from base distribution 84 | data <- rlmomco(n=length(series), base.params) 85 | 86 | # compute sample l-moments 87 | sample.moms = lmom.ub(data) 88 | 89 | valid.moments <- are.lmom.valid(sample.moms) 90 | j <- j + 1 91 | } 92 | 93 | # error handling 94 | if(!valid.moments) { 95 | stop("Bootstrapping failed to sample valid l-moments") 96 | } else { 97 | # estimate distribution parameters 98 | dist.par <- lmom2par(sample.moms, base.params$type) 99 | 100 | # store the distribution parameters 101 | param.sets[i,] <- dist.par$para 102 | 103 | # estimate quantiles at NEP 104 | estimated <- qlmomco(nep, dist.par) 105 | 106 | # convert quantile estimates to real values if 107 | # distribution was transformed 108 | if(isTransformed) estimated <- 10^estimated 109 | 110 | # store the quantiles at the desired AEP values 111 | quantile.estimates[i,] <- estimated 112 | } 113 | 114 | } 115 | 116 | # now calculate confidence limits for quantiles 117 | p <- c((1-ci)/2, (1+ci)/2) 118 | ci <- sapply(colnames(quantile.estimates), 119 | FUN=function(x){ 120 | quantile(quantile.estimates[,x], probs=p, na.rm=TRUE)}) 121 | 122 | # now return list object containing output 123 | return( 124 | list( 125 | ci = data.frame( 126 | nonexceed_prob = nep, 127 | lower = as.vector(ci[1,]), 128 | true = fa$output$estimate, 129 | upper = as.vector(ci[2,]) ), 130 | parameters = param.sets, 131 | quantiles = quantile.estimates) 132 | ) 133 | 134 | } 135 | 136 | 137 | ######################################################################### 138 | 139 | frequencyPlot <- function(series, years, ci, title=NULL, inverted=FALSE) { 140 | 141 | # determine plotting positions 142 | if(inverted) { 143 | bwpeaks <- data.frame(PROB = 1-pp(series, sort = FALSE), FLOW = series) 144 | nep <- 1-ci$nonexceed_prob 145 | lorg <- c(0, 0) 146 | lpos <- c(.01, .01) 147 | } else { 148 | bwpeaks <- data.frame(PROB = pp(series, sort = FALSE), FLOW = series) 149 | nep <- ci$nonexceed_prob 150 | lorg <- c(1, 0) 151 | lpos <- c(.99, .01) 152 | } 153 | bwpeaks$year = years 154 | 155 | # xbreaks <- c(0.002,0.01,0.1,0.25,0.5,0.8,0.9,0.95,0.975,0.99,0.995, 0.998) 156 | xbreaks <- c(0.002,0.01,0.1,1/3,0.5,0.8,0.9,0.95,0.975,0.99,0.995, 0.998) 157 | log.range <- log10(range(series, ci[,ncol(ci)], na.rm = TRUE)) #ci[,1] 158 | lower <- 10^floor(log.range[1]) 159 | upper <- 10^ceiling(log.range[2]) 160 | cap <- lower 161 | ybreaks <- NULL 162 | while(cap < upper) { 163 | ybreaks <- c(ybreaks, seq(cap, cap*9, by = cap)) 164 | cap <- cap * 10 165 | } 166 | 167 | # now plot 168 | p <- ggplot(bwpeaks) + 169 | geom_point(aes(x=PROB, y=FLOW, colour=year)) + 170 | scale_color_continuous(type = "viridis") + 171 | theme_bw() + theme(panel.grid.major = element_line(colour = "#808080"), 172 | panel.grid.minor = element_line(colour = "#808080"), 173 | legend.justification = lorg, legend.position = lpos) + 174 | scale_y_continuous(trans="log10", breaks=ybreaks, name=gglabcms) + 175 | scale_x_continuous(trans=probability_trans(distribution="norm"), 176 | breaks=xbreaks, labels=signif(prob2T(xbreaks), digits=3), 177 | name="Return period (years)") + 178 | geom_line(data=ci, aes(x=nep, y=true), color="red") + 179 | geom_line(data=ci, aes(x=nep, y=lower), color="red", lty=2) + 180 | geom_line(data=ci, aes(x=nep, y=upper), color="red", lty=2) 181 | 182 | if(!is.null(title)) p <- p + ggtitle(title) 183 | 184 | return(p) 185 | } 186 | -------------------------------------------------------------------------------- /md/about.md: -------------------------------------------------------------------------------- 1 | # **sHydrology** 2 | #### *A Shiny-Leaflet interface to a stream flow database.* 3 | 4 | #### Current functionality: 5 | * Select gauge from a map 6 | * filter locations based on period of record 7 | * View entire stream flow time series 8 | * Dynamic hydrograph zooming: 9 | * drag-and-click zoom 10 | * double-click to full extent 11 | * optionnally use date picker 12 | * Execute a suite of hydrograph separation algorithms (14 in total, see below) 13 | * display min/max range (blue band) and median separated baseflow (dotted line) 14 | * Hydrograph dis-aggregation 15 | * Automatic recession coefficient computation 16 | * (Peak/Low) flow frequency analysis 17 | * In-stream flow regime analysis 18 | * Trend analysis 19 | * View data as a table, and export data as *.csv 20 | 21 | ## Hydrograph analysis 22 | ### Automatic recession coefficient computation: 23 | The recession coefficient (Linsley et.al., 1975) is computed automatically using an iterative procedure whereby the recession curve is positioned to envelope the log-transformed discharge data versus subsequent discharge, on the condition that the former exceeds the latter. 24 | 25 | The recession coefficient *k* is the inverse of the slope of the computed recession curve. The resulting fit can be viewed/adjusted in the *recession coefficient* window. 26 | 27 | The recession coefficient is required for many of the following hydrograph analyses, and is a common input parameter to many hydrologic models. 28 | 29 | 30 | ### Hydrograph separation methods: 31 | "Baseflow" is separated from the hydrographs using 14 automatic procedures listed below. Standard baseflow model parameters (as documented in the literature) are also listed where applicable. The user may alter these parameters from the *settings: baseflow separation* window *(yet to be completed)*. 32 | 33 | 1. **BF.LH:** The Lyne-Hollick digital filter (Lyne and Hollick, 1979), 3-pass sweep with \\(\alpha=0.925\\) as discussed in Chapman (1999); 34 | 2. **BF.CM:** The Chapman-Maxwell digital filter (Chapman and Maxwell, 1996), using automatically computed recession coefficient (\\(k\\)); 35 | 3. **BF.BE:** The Boughton-Eckhardt digital filter (Boughton, 1993; Eckhardt, 2005) with computed \\(k\\) and \\(BFI_\text{max}=0.8\\); 36 | 4. **BF.JH:** The Jakeman-Hornberger digital filter (Jakeman and Hornberger, 1993) based on their IHACRES model with \\(C=0.3\\) and \\(\alpha=-\exp(-1/k)\\); 37 | 5. **BF.Cl:** The method of Clarifica Inc. (2002); 38 | 6. **BF.UKn:** The UK Institute of Hydrology (or Wallingford) method (Institute of Hydrology, 1980), sweeping minimum of Piggott et.al. (2005); 39 | 7. **BF.UKx:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping maximum of Piggott et.al. (2005); 40 | 8. **BF.UKm:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping median; 41 | 9. **BF.HYSEP.FI:** The HYSEP fixed-interval method (Sloto and Crouse, 1996), with known catchment area; 42 | 10. **BF.HYSEP.SI:** The HYSEP sliding-interval method (Sloto and Crouse, 1996), with known catchment area; 43 | 11. **BF.HYSEP.LM:** The HYSEP local minima method (Sloto and Crouse, 1996), with known catchment area; 44 | 12. **BF.PART1:** The PART method (Rutledge, 1998), with known catchment area, pass 1 of 3 antecedent recession requirement; 45 | 13. **BF.PART2:** The PART method (Rutledge, 1998), with known catchment area, pass 2 of 3 antecedent recession requirement; 46 | 14. **BF.PART3:** The PART method (Rutledge, 1998), with known catchment area, pass 3 of 3 antecedent recession requirement. 47 | 48 | On the *Long-term trend analysis: monthly baseflow* window, computed baseflow is summarized on a monthly basis in the form of box-whisker plots. The distribution plotted here is built from the median monthly baseflow computed for every month of record using each of the 14 separation methods listed below. Where applicable, the baseflow values have bee normalized by the stream gauge's catchment area thereby providing the values in equivalent mm/month, which can be used as a first-approximation to basin-averaged groundwater recharge. 49 | 50 | ## Hydrograph summary plots: 51 | #### Annual flow summary 52 | Provides the long-term (calendar-year) annual volumes and deviations of total flow and separated baseflow. 53 | 54 | #### Daily average hydrograph 55 | After applying a 5-day rolling average to the hydrograph, both total flow and baseflow are averaged on a daily basis, to illustrate the seasonality of the annual hydrograph *(deprecated)*. 56 | 57 | #### Monthly baseflow 58 | Computed baseflow is summarized on a monthly basis in the form of box-whisker plots. The distribution plotted here is built from the median monthly baseflow computed for every month of record using each of the 14 separation methods listed above. 59 | 60 | #### Cumulative discharge and BFI 61 | Total and baseflow discharge is accumulated and compared to the long-term trend; this can help identify periods in time where the flow regime has evidently been altered. 62 | 63 | A rolling-average Baseflow Index (BFI) plot has been added to further identify changes to the flow regime. 64 | 65 | Both plots will automatically be refreshed depending on the time range selected on the hydrograph to the left; this allow quick insight into how the flow regime compares over different time periods. 66 | 67 | ## Hydrograph statistical analysis: 68 | #### Peak flow frequency 69 | Peak flow frequency curves were modified (with gratitude) from [headwateranalytics.com](http://www.headwateranalytics.com/blog/flood-frequency-analysis-in-r) *(accessed December, 2016)*. 70 | 71 | The method allows for the use of 5 distributions: Log-Pearson type 3 *(default)*, Weibull, Gumbel, Generalized Extreme Value (GEV), and the three-parameter lognormal models. (The user may change the distribution and refresh the plots.) 72 | 73 | By default, 90% confidence intervals are then plotted based in the bootstrap technique from 10,000 samples assuming a Log-Pearson III distribution. 74 | 75 | #### Low flow frequency 76 | Using the same procedure as above, 3 low flow frequency plots are provided base on the mean annual minimum (MAM) over *n* consecutive days: 77 | 78 | 1. 1-day MAM (i.e., the annual extreme minimum) 79 | 2. 7-day MAM 80 | 3. 30-day MAM 81 | 82 | Like before, the user may change the distribution and refresh the plots. 83 | 84 | #### Hydrologic flow regime 85 | 86 | **IHA** 87 | 88 | The Indicators of Hydrologic Alteration (Richter et.al., 1996) has been included and allows the user to dynamically compare IHA statistics between two time periods using the hydrograph view-pane. 89 | 90 | The calculation of IHA statistics is accomplished using the R-IAH package written by Jason Law and is found here: https://rdrr.io/rforge/IHA/ *(accessed February, 2019)*. 91 | 92 | **SAAS** 93 | 94 | *to do* 95 | 96 | #### Recession scatter plot 97 | The recession scatter plot is used to visualize the results of the automatic recession coefficient computation. The recession curve can be viewed and adjusted by manually changing the recession coefficient in the *parameters: recession coefficient* tab. 98 | -------------------------------------------------------------------------------- /functions/HYDAT_query.R: -------------------------------------------------------------------------------- 1 | ########################################################## 2 | ############## HYDAT/SQLite querying ##################### 3 | ########################################################## 4 | # By M. Marchildon 5 | # 6 | # Nov, 2018 7 | ########################################################## 8 | 9 | library(RSQLite) 10 | 11 | ########################################################################################### 12 | ## connect to the HYDAT sqlite3 file (see queries below) 13 | ########################################################################################### 14 | dbcnxn <- function(dbFP){ 15 | if(!file.exists(dbFP)){ 16 | print(paste0(" ERROR: ",dbFP," cannot be found")) 17 | } else { 18 | dbc <- dbConnect(RSQLite::SQLite(), dbname=dbFP) 19 | # get a list of all tables 20 | # dbListTables(dbc) 21 | return(dbc) 22 | } 23 | } 24 | 25 | 26 | ########################################################################################### 27 | ## build location table 28 | ########################################################################################### 29 | qStaLoc.table <- function(dbc, prov=NULL){ 30 | # get the STATIONS table as a data.frame 31 | tblSta <- dbGetQuery(dbc,'select * from STATIONS') 32 | if (!is.null(prov)){tblSta <- tblSta[tblSta$PROV_TERR_STATE_LOC == prov,]} 33 | tblSta <- tblSta[!is.na(tblSta$DRAINAGE_AREA_GROSS),] 34 | tblSta <- tblSta[!is.na(tblSta$LATITUDE),] 35 | 36 | # query date ranges 37 | YRb <- vector('numeric',length=length(tblSta$STATION_NUMBER)) 38 | YRe <- vector('numeric',length=length(tblSta$STATION_NUMBER)) 39 | Cnt <- vector('numeric',length=length(tblSta$STATION_NUMBER)) 40 | Qual <- vector('numeric',length=length(tblSta$STATION_NUMBER)) 41 | i <- 0 42 | print(paste0(" ** ",date())) 43 | for (s in tblSta$STATION_NUMBER){ 44 | q <- dbGetQuery(dbc, paste0('select * from DLY_FLOWS where STATION_NUMBER = "',s,'"')) 45 | i <- i + 1 46 | if (nrow(q)==0) { 47 | # print(paste0('no data for station ',s)) 48 | YRb[i] <- NA 49 | YRe[i] <- NA 50 | Cnt[i] <- 0 51 | Qual[i] <- NA 52 | } else { 53 | YRb[i] <- min(q$YEAR) 54 | YRe[i] <- max(q$YEAR) 55 | Cnt[i] <- 365.24*nrow(q) 56 | Qual[i] <- (max(q$YEAR)-min(q$YEAR)+1)/nrow(q) 57 | } 58 | } 59 | tblSta$YRb <- YRb # StartYear 60 | tblSta$YRe <- YRe # EndYear 61 | tblSta$CNT <- Cnt 62 | tblSta$LID <- tblSta$STATION_NUMBER 63 | tblSta$IID <- tblSta$STATION_NUMBER 64 | tblSta <- tblSta[!is.na(tblSta$YRb),] 65 | tblSta <- tblSta[!is.na(tblSta$YRe),] 66 | colnames(tblSta)[1] <- "NAM1" 67 | colnames(tblSta)[2] <- "NAM2" 68 | colnames(tblSta)[7] <- "LAT" 69 | colnames(tblSta)[8] <- "LNG" 70 | colnames(tblSta)[9] <- "DA" 71 | 72 | return(tblSta) 73 | } 74 | 75 | qStaLoc <- function(dbc, staID){ 76 | # get the STATIONS table as a data.frame 77 | l <- dbGetQuery(dbc, paste0('select * from STATIONS where STATION_NUMBER = "',staID,'"')) 78 | 79 | info <- vector("list", 11) 80 | names(info) <- c("LOC_ID","INT_ID","LOC_NAME","LOC_NAME_ALT1","LAT","LNG","SW_DRAINAGE_AREA_KM2","CNT","YRb","YRe","QUAL") #c("LID","IID","NAM1","NAM2","LAT","LNG","DA","CNT","YRb","YRe","QUAL") 81 | 82 | q <- dbGetQuery(dbc, paste0('select * from DLY_FLOWS where STATION_NUMBER = "',staID,'"')) 83 | if (nrow(q)==0) { 84 | # print(paste0('no data for station ',s)) 85 | info$YRb <- NA 86 | info$YRe <- NA 87 | info$Cnt <- 0 88 | info$Qual <- NA 89 | } else { 90 | info$YRb <- min(q$YEAR) 91 | info$YRe <- max(q$YEAR) 92 | info$CNT <- 365.24*nrow(q) 93 | info$QUAL <- (max(q$YEAR)-min(q$YEAR)+1)/nrow(q) 94 | } 95 | info$LOC_ID <- staID 96 | info$INT_ID <- staID 97 | info$LOC_NAME <- staID 98 | info$LOC_NAME_ALT1 <- l$STATION_NAME 99 | info$LAT <- l$LATITUDE 100 | info$LNG <- l$LONGITUDE 101 | info$SW_DRAINAGE_AREA_KM2 <- l$DRAINAGE_AREA_GROSS 102 | 103 | return(info) 104 | } 105 | 106 | 107 | ########################################################################################### 108 | ## collect location info 109 | ########################################################################################### 110 | qStaInfo <- function(dbc,staID){ 111 | return(data.frame(qStaLoc(dbc,staID))) 112 | } 113 | qStaCarea <- function(dbc,staID){ 114 | qSta <- dbGetQuery(dbc, paste0('select * from STATIONS where STATION_NUMBER = "',staID,'"')) 115 | return(qSta$DRAINAGE_AREA_GROSS) 116 | } 117 | qStaAgg <- function(LOC_ID) { LOC_ID } 118 | 119 | 120 | ########################################################################################### 121 | ## HYDAT temporal Query 122 | ########################################################################################### 123 | qTemporal <- function(dbc,staID){ 124 | qFlow <- dbGetQuery(dbc, paste0('select * from DLY_FLOWS where STATION_NUMBER = "',staID,'"')) 125 | # qFlow <- dbGetQuery(dbc, 'select * from DLY_FLOWS where STATION_NUMBER = "02HB002"') 126 | # print(qFlow) 127 | DTb <- zoo::as.Date(paste0(as.numeric(qFlow[1,2]),'-',as.numeric(qFlow[1,3]),'-01')) 128 | DTe <- zoo::as.Date(paste0(as.numeric(tail(qFlow[2],1)),'-',as.numeric(tail(qFlow[3],1)),'-01')) 129 | POR <- as.numeric(DTe-DTb) 130 | Flow <- vector('numeric', length=POR) 131 | Flag <- vector('character', length=POR) 132 | Date <- vector('character', length=POR) 133 | cnt <- 0 134 | 135 | for(i in 1:nrow(qFlow)){ 136 | yr <- qFlow[i,2] 137 | mo <- as.numeric(qFlow[i,3]) 138 | 139 | for(d in 1:qFlow[i,5]){ 140 | cnt <- cnt + 1 141 | Date[cnt] <- paste0(yr,'-',mo,'-',d) 142 | Flow[cnt] <- qFlow[i,(d-1)*2+12] 143 | Flag[cnt] <- qFlow[i,(d-1)*2+13] 144 | } 145 | } 146 | 147 | Date <- zoo::as.Date(Date) 148 | # anyDuplicated(Date) 149 | Flow <- round(Flow,5) 150 | Flag <- as.character(Flag) 151 | 152 | Flag[is.na(Flag)] <- "" 153 | Flag[Flag == "B"] <- "ice_conditions" 154 | Flag[Flag == "E"] <- "estimate" 155 | Flag[Flag == "A"] <- "partial" 156 | Flag[Flag == "D"] <- "dry_conditions" 157 | Flag[Flag == "S"] <- "samples_collected_this_day" 158 | Flag[Flag == "R"] <- "realtime_uncorrected" 159 | 160 | hyd <- data.frame(Date,Flow,Flag) 161 | hyd <- hyd[!is.na(hyd$Date),] 162 | hyd <- hyd[!is.na(hyd$Flow),] 163 | 164 | return(hyd) 165 | } 166 | 167 | 168 | 169 | ########################################################################################### 170 | ## HYDAT temporal Query (of many stations) 171 | ########################################################################################### 172 | qTemporal.many <- function(dbc,stalst){ 173 | stStations <- paste0( 'STATION_NUMBER = "',stalst[1],'"') 174 | for (i in 2:length(stalst)) { 175 | stStations <- paste0(stStations, ' OR STATION_NUMBER = "', stalst[i], '"') 176 | } 177 | qFlow <- dbGetQuery(dbc, paste0('select * from DLY_FLOWS where ', stStations)) 178 | Station <- vector('character', length=nrow(qFlow)) 179 | Flow <- vector('numeric', length=nrow(qFlow)) 180 | Flag <- vector('character', length=nrow(qFlow)) 181 | Date <- vector('character', length=nrow(qFlow)) 182 | cnt <- 0 183 | 184 | for(i in 1:nrow(qFlow)){ 185 | sta <- qFlow[i,1] 186 | yr <- qFlow[i,2] 187 | mo <- as.numeric(qFlow[i,3]) 188 | 189 | for(d in 1:qFlow[i,5]){ 190 | cnt <- cnt + 1 191 | Date[cnt] <- paste0(yr,'-',mo,'-',d) 192 | Station[cnt] <- sta 193 | Flow[cnt] <- qFlow[i,(d-1)*2+12] 194 | Flag[cnt] <- qFlow[i,(d-1)*2+13] 195 | } 196 | } 197 | 198 | Date <- as.Date(Date) 199 | # anyDuplicated(Date) 200 | Flag[is.na(Flag)] <- "" 201 | hyd <- data.frame(Station,Date,Flow,Flag) 202 | hyd <- hyd[!is.na(hyd$Date),] 203 | hyd <- hyd[!is.na(hyd$Flow),] 204 | return(hyd) 205 | } 206 | 207 | 208 | 209 | 210 | ########################################################################################### 211 | ## Dummies 212 | ########################################################################################### 213 | get.supplimental <- function(info=NULL) NULL 214 | 215 | 216 | 217 | ########################################################################################### 218 | ## Query 219 | ########################################################################################### 220 | idbc <- dbcnxn('dat/Hydat.sqlite3') 221 | ldbc <- idbc 222 | -------------------------------------------------------------------------------- /server/statistics/iha.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ######################################################## 4 | # indicators of hydrologic alteration 5 | ######################################################## 6 | 7 | output$tabIHA.01 <- renderFormattable({ 8 | input$mouseup 9 | isolate({ 10 | # Group 1: Magnitude of monthly water conditions 11 | if (!is.null(sta$hyd)){ 12 | withProgress( 13 | message = 'rendering Group 1: Magnitude of monthly water conditions..', value = 0.5, { 14 | # merge datasets 15 | g1 <- group1(getzoo1(), median) 16 | t1 <- t(apply(g1, 2, mean.cv)) # mean of monthly medians 17 | g2 <- group1(getzoo2(), median) 18 | t2 <- t(apply(g2, 2, mean.cv)) # mean of monthly medians 19 | tm <- merge(t1, t2, by=0, all=TRUE) %>% 20 | rename('Month'='Row.names', 'range 1 mean'='mean.x', 'range 1 CV'='cv.x', 'range 2 mean'='mean.y', 'range 2 CV'='cv.y') %>% 21 | mutate_at(vars(-Month), funs(round(., 2))) 22 | 23 | # test for differences 24 | dftest <- data.frame(t(sapply(intersect(colnames(g1),colnames(g2)), function(x) f(g1[,x], g2[,x])))) 25 | tm <- merge(tm, dftest, by.x='Month', by.y=0 , all=TRUE) %>% 26 | arrange(factor(Month, levels = c('October','November','December','January','February','March','April','May','June','July','August','September'))) 27 | 28 | createFormattable(tm) 29 | } 30 | ) 31 | } 32 | }) 33 | }) 34 | 35 | output$tabIHA.02 <- renderFormattable({ 36 | input$mouseup 37 | isolate({ 38 | # Group 2: Magnitude and duration of annual extreme weather conditions 39 | if (!is.null(sta$hyd)){ 40 | withProgress( 41 | message = 'rendering Group 2: Magnitude and duration of annual extreme weather conditions..', value = 0.5, { 42 | # merge datasets 43 | g1 <- group2(getzoo1())[-1] 44 | t1 <- t(apply(g1, 2, mean.cv)) 45 | g2 <- group2(getzoo2())[-1] 46 | t2 <- t(apply(g2, 2, mean.cv)) 47 | tm <- merge(t1, t2, by=0, all=TRUE) %>% 48 | rename('indicator'='Row.names', 'range 1 mean'='mean.x', 'range 1 CV'='cv.x', 'range 2 mean'='mean.y', 'range 2 CV'='cv.y') %>% 49 | mutate_at(vars(-indicator), funs(round(., 2))) 50 | 51 | # test for differences 52 | dftest <- data.frame(t(sapply(intersect(colnames(g1),colnames(g2)), function(x) f(g1[,x], g2[,x])))) 53 | createFormattable(merge(tm, dftest, by.x='indicator', by.y=0 , all=TRUE)) 54 | } 55 | ) 56 | } 57 | }) 58 | }) 59 | 60 | output$tabIHA.03 <- renderFormattable({ 61 | input$mouseup 62 | isolate({ 63 | # Group 3: Timing of Annual Extream Water conditions 64 | if (!is.null(sta$hyd)){ 65 | withProgress( 66 | message = 'rendering Group 3: Timing of Annual Extream Water Conditions..', value = 0.5, { 67 | # merge datasets 68 | g1 <- group3(getzoo1()) 69 | t1 <- t(apply(g1, 2, mean.cv)) 70 | g2 <- group3(getzoo2()) 71 | t2 <- t(apply(g2, 2, mean.cv)) 72 | tm <- merge(t1, t2, by=0, all=TRUE) %>% 73 | rename('indicator'='Row.names', 'range 1 mean'='mean.x', 'range 1 CV'='cv.x', 'range 2 mean'='mean.y', 'range 2 CV'='cv.y') %>% 74 | mutate_at(vars(-indicator), funs(round(., 2))) 75 | 76 | # test for differences 77 | dftest <- data.frame(t(sapply(intersect(colnames(g1),colnames(g2)), function(x) f(g1[,x], g2[,x])))) 78 | createFormattable(merge(tm, dftest, by.x='indicator', by.y=0 , all=TRUE)) 79 | } 80 | ) 81 | } 82 | }) 83 | }) 84 | 85 | output$tabIHA.04 <- renderFormattable({ 86 | input$mouseup 87 | isolate({ 88 | # Group 4: Frequency and Duration of High/Low Pulses 89 | if (!is.null(sta$hyd)){ 90 | withProgress( 91 | message = 'rendering Group 4: Frequency and Duration of High/Low Pulses..', value = 0.5, { 92 | # merge datasets 93 | g1 <- group4(getzoo1()) 94 | t1 <- t(apply(g1, 2, mean.cv)) 95 | g2 <- group4(getzoo2()) 96 | t2 <- t(apply(g2, 2, mean.cv)) 97 | tm <- merge(t1, t2, by=0, all=TRUE) %>% 98 | rename('indicator'='Row.names', 'range 1 mean'='mean.x', 'range 1 CV'='cv.x', 'range 2 mean'='mean.y', 'range 2 CV'='cv.y') %>% 99 | mutate_at(vars(-indicator), funs(round(., 2))) 100 | 101 | # test for differences 102 | dftest <- data.frame(t(sapply(intersect(colnames(g1),colnames(g2)), function(x) f(g1[,x], g2[,x])))) 103 | createFormattable(merge(tm, dftest, by.x='indicator', by.y=0 , all=TRUE)) 104 | } 105 | ) 106 | } 107 | }) 108 | }) 109 | 110 | output$tabIHA.05 <- renderFormattable({ 111 | input$mouseup 112 | isolate({ 113 | # Group 5: Rate and frequency of change in conditions 114 | if (!is.null(sta$hyd)){ 115 | withProgress( 116 | message = 'rendering Group 5: Rate and frequency of change in conditions..', value = 0.5, { 117 | # merge datasets 118 | g1 <- group5(getzoo1()) 119 | t1 <- t(apply(g1, 2, mean.cv)) 120 | g2 <- group5(getzoo2()) 121 | t2 <- t(apply(g2, 2, mean.cv)) 122 | tm <- merge(t1, t2, by=0, all=TRUE) %>% 123 | rename('indicator'='Row.names', 'range 1 mean'='mean.x', 'range 1 CV'='cv.x', 'range 2 mean'='mean.y', 'range 2 CV'='cv.y') %>% 124 | mutate_at(vars(-indicator), funs(round(., 2))) 125 | 126 | # test for differences 127 | dftest <- data.frame(t(sapply(intersect(colnames(g1),colnames(g2)), function(x) f(g1[,x], g2[,x])))) 128 | createFormattable(merge(tm, dftest, by.x='indicator', by.y=0 , all=TRUE)) 129 | } 130 | ) 131 | } 132 | }) 133 | }) 134 | 135 | 136 | ###################### 137 | ### functions 138 | ###################### 139 | f <- function(x,y){ 140 | # https://stackoverflow.com/questions/15865112/r-find-matching-columns-in-two-data-frames-for-t-test-statistics-r-beginner 141 | mtest <- t.test(x,y) # compare means 142 | x1 <- c(x[!is.na(x)],y[!is.na(y)]) 143 | y1 <- c(replicate(length(x[!is.na(x)]), 1),replicate(length(y[!is.na(y)]), 2)) 144 | ctest <- asymptotic_test(x1,y1) # compare CVs 145 | data.frame(pvalm = mtest$p.value, 146 | pvalc = ctest$p_value) 147 | } 148 | 149 | createFormattable <- function(tm) { 150 | formattable(tm, align =c("l","c","c","c","c", "c", "c"), list( 151 | `range 1 mean` = formatter("span", style = ~ style(color = ifelse(`pvalm` < 0.05, "red", "black"))), 152 | `range 2 mean` = formatter("span", style = ~ style(color = ifelse(`pvalm` < 0.05, "red", "black"))), 153 | `range 1 CV` = formatter("span", style = ~ style(color = ifelse(`pvalc` < 0.05, "red", "black"))), 154 | `range 2 CV` = formatter("span", style = ~ style(color = ifelse(`pvalc` < 0.05, "red", "black"))), 155 | `pvalm` = FALSE, `pvalc` = FALSE # hide columns 156 | ) 157 | ) 158 | } 159 | 160 | getzoo1 <- function() { 161 | z <- read.zoo(sta$hyd[,1:2]) 162 | rng <- input$rng.iah1_date_window 163 | if (!is.null(rng)) { 164 | z <- window(z,start=as.Date(rng[1]),end=as.Date(rng[2])) 165 | } else { 166 | z <- window(z,start=sta$DTb,end=median(sta$hyd$Date)) 167 | } 168 | return(z) 169 | } 170 | getzoo2 <- function() { 171 | z <- read.zoo(sta$hyd[,1:2]) 172 | rng <- input$rng.iah2_date_window 173 | if (!is.null(rng)) { 174 | z <- window(z,start=as.Date(rng[1]),end=as.Date(rng[2])) 175 | } else { 176 | z <- window(z,start=median(sta$hyd$Date),end=sta$DTe) 177 | } 178 | return(z) 179 | } 180 | 181 | ###################### 182 | ### plots 183 | ###################### 184 | output$cumu.iah <- renderPlot({ 185 | if (!is.null(sta$hyd)){ 186 | if (!sta$BFbuilt) separateHydrograph() 187 | withProgress( 188 | message = 'rendering cumulative discharge plot..', value = 0.5, { 189 | flow_summary_cumu(sta$hyd,sta$carea,paste0(sta$label,'\ncumulative discharge')) 190 | } 191 | ) 192 | } 193 | }) 194 | 195 | output$rng.iah1 <- renderDygraph({ 196 | if (!is.null(sta$hyd)){ 197 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 198 | colnames(qxts) <- 'Discharge' 199 | dygraph(qxts) %>% 200 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 201 | dyAxis(name='y', label=dylabcms) %>% 202 | dyRangeSelector(fillColor='', height=60, dateWindow=c(sta$DTb,median(sta$hyd$Date))) 203 | } 204 | }) 205 | output$rng.iah2 <- renderDygraph({ 206 | if (!is.null(sta$hyd)){ 207 | qxts <- xts(sta$hyd$Flow, order.by = sta$hyd$Date) 208 | colnames(qxts) <- 'Discharge' 209 | dygraph(qxts) %>% 210 | dyOptions(axisLineWidth = 1.5, fillGraph = TRUE, stepPlot = TRUE) %>% 211 | dyAxis(name='y', label=dylabcms) %>% 212 | dyRangeSelector(fillColor='', height=60, dateWindow=c(median(sta$hyd$Date),sta$DTe)) 213 | } 214 | }) 215 | 216 | 217 | yr.fmt <- function(odt) format(as.Date(odt), format="%Y") 218 | 219 | iha.dates <- reactive({ 220 | rng1 <- input$rng.iah1_date_window 221 | rng2 <- input$rng.iah2_date_window 222 | if (!is.null(rng1) & !is.null(rng2)) { 223 | paste0("(",yr.fmt(rng1[1]),"-",yr.fmt(rng1[2])," vs. ",yr.fmt(rng2[1]),"-",yr.fmt(rng2[2]),")") 224 | } 225 | }) 226 | 227 | # (1967-1988 vs. 1989-2021) -------------------------------------------------------------------------------- /functions/hydrograph_separation.R: -------------------------------------------------------------------------------- 1 | ########################################################## 2 | ############## Hydrograph separation ##################### 3 | ########################################################## 4 | # By M. Marchildon 5 | # 6 | # Dec 24, 2018 7 | ########################################################## 8 | 9 | 10 | 11 | 12 | ######################################################## 13 | # recession days 14 | # time (in days) after peak discharge from which quick flow ceases and total flow is entirely slow flow 15 | # ref: Linsley, R.K., M.A. Kohler, J.L.H. Paulhus, 1975. Hydrology for Engineers 2nd ed. McGraw-Hill. 482pp. 16 | ######################################################## 17 | Ndays <- function(cArea_km2){ 18 | if (is.null(cArea_km2)){return(1)}else if(cArea_km2==0){return(1)}else{return(0.827*cArea_km2^0.2)} 19 | } 20 | 21 | 22 | 23 | 24 | ######################################################## 25 | # digital filter methods of automatic baseflow separaion 26 | ######################################################## 27 | digital_filter <- function(Q, k=NULL, method = "Chapman-Maxwell", nPasses = 1, param=NULL){ 28 | # c("lyne-hollick","chapman","chapman-maxwell","boughton-eckhardt","jakeman-hornberger","tularam-ilahee") 29 | method <- tolower(method) 30 | if (is.null(k)){k <- recession_coef(Q)} 31 | 32 | if (method=="lyne-hollick"){ 33 | # Lyne, V. and M. Hollick, 1979. Stochastic time-variable rainfall-runoff modelling. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Perth: 89-92. 34 | #k <- 0.925 # Ranges from 0.9 to 0.95 (Nathan and McMahon, 1990). 35 | #nPasses = 3 # Commonly used (Chapman, 1999) 36 | a <- k 37 | b <- (1-k)/2 38 | c <- 1.0*b 39 | } else 40 | 41 | if (method=="chapman"){ 42 | # Chapman, T.G., 1991. Comment on the evaluation of automated techniques for base flow and recession analyses, by R.J. Nathan and T.A. McMahon. Water Resource Research 27(7): 1783-1784 43 | a <- (3*k-1)/(3-k) 44 | b <- (1-k)/(3-k) 45 | c <- 1.0*b 46 | } else 47 | 48 | if (method=="chapman-maxwell"){ 49 | # Chapman, T.G. and A.I. Maxwell, 1996. Baseflow separation - comparison of numerical methods with tracer experiments.Institute Engineers Australia National Conference. Publ. 96/05, 539-545. 50 | a <- k/(2-k) 51 | b <- (1-k)/(2-k) 52 | c <- 0 53 | } else 54 | 55 | if (method=="boughton-eckhardt"){ 56 | # Boughton, W.C., 1993. A hydrograph-based model for estimating the water yield of ungauged catchments. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Newcastle: 317-324. 57 | # Eckhardt, K., 2005. How to construct recursive digital filters forbaseflow separation. Hydrological Processes 19, 507-515. 58 | BFImax <- param #0.8 59 | BC <- (1-k)*BFImax/(1-BFImax) 60 | a <- k/(1+BC) 61 | b <- BC/(1+BC) 62 | c <- 0 63 | rm(BFImax); rm(BC) 64 | } else 65 | 66 | if (method=="jakeman-hornberger"){ 67 | # IHACRES 68 | # Jakeman, A.J. and Hornberger G.M., 1993. How much complexity is warranted in a rainfall-runoff model? Water Resources Research 29: 2637-2649. 69 | JHC <- param #0.3 70 | JHalpha <- -exp(-1/k) # see: Jakeman and Hornberger (1993), eq.7 - assuming daily timestep. 71 | a <- k/(1+JHC) 72 | b <- JHC/(1+JHC) 73 | c <- JHalpha*b 74 | rm(JHC); rm(JHalpha) 75 | } else 76 | 77 | if (method=="tularam-ilahee"){ 78 | # Tularam, A.G., Ilahee, M., 2008. Exponential Smoothing Method of Base Flow Separation and its Impact on Continuous Loss Estimates. American Journal of Environmental Sciences 4(2):136-144. 79 | a <- k 80 | b <- 1-a 81 | c <- 0 82 | }else{ 83 | stop( 84 | sprintf('Digital filter \'%s\' not recognized', method)) 85 | } 86 | 87 | return(digital_filter_compute(Q,a,b,c,nPasses)) 88 | } 89 | # Main algorithm 90 | digital_filter_compute <- function(Q,a,b,c,nPasses){ 91 | f2 <- Q 92 | for(i in 1:nPasses){ 93 | if (i > 1){f2 <- rev(f2)} 94 | f1 <- stats::filter(f2,c(b,c),method="convolution",sides=1) 95 | f2 <- stats::filter(na.locf(f1, na.rm = FALSE, fromLast = TRUE),a,method="recursive") 96 | } 97 | if (nPasses %% 2 == 0){f2 <- rev(f2)} 98 | f2 <- ifelse(f2 > Q, Q, f2) 99 | f2 <- ifelse(f2 < 0, NA, f2) 100 | return(as.numeric(f2)) 101 | } 102 | 103 | 104 | ######################################################## 105 | # UKIH/Wallingford (smoothed minima) technique 106 | ######################################################## 107 | UKIH <- function(Q, method, BlockSizeDays=5){ 108 | # Institute of Hydrology, 1980. Low Flow Studies report. Wallingford, UK. 109 | # Piggott, A.R., S. Moin, C. Southam, 2005. A revised approach to the UKIH method for the calculation of baseflow. Hydrological Sciences Journal 50(5): 911-920. 110 | # method <- c("SweepingMin","SweepingMax","SweepingMean","SweepingMedian","FromFirstPointOfOrigin") 111 | 112 | chkP <- 0.9 # UKIH method default = 0.9 See Piggot et al., 2005 113 | method <- tolower(method) 114 | N <- BlockSizeDays 115 | 116 | col = paste0(rep("b",N),seq(1, N)) 117 | Qout <- data.frame(id=seq(1:length(Q))) 118 | 119 | for(k in 1:N){ # calculating for every segmentation as recommended by Piggot et al., 2005 120 | BF <- rollapply(Q[k:length(Q)], width=N, min, by=N) # Find N-day block min 121 | BF <- rollapply(BF, 3, function(x) if(!any(is.na(x)) & chkP*x[2]<=min(x[1],x[3])){x[2]}else{NA}, fill=NA) # filter out turning points 122 | BF <- c(rep(NA,k-1),rep(BF,each=N,len=length(Q)-k+1)) # build complete dataset 123 | BF[BF!=Q] <- NA 124 | BF <- na.fill(BF,"extend") 125 | Qout[,paste(col[k])] <- ifelse(BF > Q, Q, BF) 126 | } 127 | Qout = Qout[,2:(N+1)] # trim first column 128 | 129 | if(method=="sweepingmin"){ 130 | return(apply(Qout, 1, min)) #, na.rm = TRUE 131 | } else 132 | if(method=="sweepingmax"){ 133 | return(apply(Qout, 1, max)) 134 | } else 135 | if(method=="sweepingmean"){ 136 | return(apply(Qout, 1, mean)) 137 | } else 138 | if(method=="sweepingmedian"){ 139 | return(apply(Qout, 1, median)) 140 | } else 141 | if(method=="fromfirstpointoforigin"){ 142 | return(Qout[,1]) 143 | } else 144 | if(method=="all"){ 145 | return(Qout) 146 | }else{ 147 | stop( 148 | sprintf('UKIH method \'%s\' not recognized', method)) 149 | } 150 | } 151 | 152 | 153 | ######################################################## 154 | # HYSEP technique 155 | ######################################################## 156 | HYSEP <- function(Q, method, cArea_km2=NULL){ 157 | # Sloto, R.A. and M.Y. Crouse, 1996. HYSEP: A Computer Program for Streamflow Hydrograph Separation and Analysis U.S. Geological Survey Water-Resources Investigations Report 96-4040. 158 | # method <- c("FixedInterval","SlidingInterval","LocalMinimum") 159 | 160 | if (is.null(cArea_km2)){N<-5}else{N <- max(min(as.integer(round(2*Ndays(cArea_km2),0)),11),3)} # N = 2N* in Sloto and Crouse (1996) 161 | method <- tolower(method) 162 | 163 | if(method=="fixedinterval"){ 164 | return(na.locf(rollapply(Q, width=N, min, by=N, fill=NA, align='left'), na.rm = FALSE)) 165 | } else 166 | if(method=="slidinginterval"){ 167 | BF <- rollapply(Q, width=N, min, fill="extend") 168 | return(ifelse(BF > Q, Q, BF)) 169 | } else 170 | if(method=="localminimum"){ 171 | BF <- rollapply(Q, width=N, min, fill=NA) 172 | BF[BF!=Q] <- NA 173 | BF <- na.fill(BF,"extend") 174 | return(ifelse(BF > Q, Q, BF)) 175 | }else{ 176 | stop( 177 | sprintf('HYSEP method \'%s\' not recognized', method)) 178 | } 179 | } 180 | 181 | 182 | ######################################################## 183 | # PART technique 184 | ######################################################## 185 | PART <- function(Q, cArea_km2=NULL, anterec=1){ 186 | # Rutledge, A.T., 1998. Computer Programs for Describing the Recession of Ground-Water Discharge and for Estimating Mean Ground-Water Recharge and Discharge from Streamflow Records-Update, Water-Resources Investigation Report 98-4148. 187 | # designed for daily streamflow, translated from the part.f source code (3-pass antecedent recession requirement seems only to be used when reporting mean/long-term baseflow) 188 | # LogDeclineThresh = 0.1 ' default value as per the document listed above 189 | 190 | if (is.null(cArea_km2)){N<-3}else{N <- ceiling(Ndays(cArea_km2))} 191 | N <- N + anterec - 1 # in Rutledge (1998), the 'antecedent requirement' ranged 1 to 3, and is provided in 3 separate BF estimates, never given together 192 | lgt <- 0.1 193 | 194 | BF <- rollapply(Q, width=list(-N:0), function(x) if(!any(is.na(x)) & all(x==cummin(x))){x[N+1]}else{NA}, fill=NA, align='right') 195 | BF <- rollapply(BF, width=2, function(x) if(!any(is.na(x)) & all(cummin(x)>0) & log10(x[1])-log10(x[2])>lgt){NA}else{x[1]}, fill=NA, align='left') 196 | BF <- log10(BF) 197 | BF <- na.fill(BF,"extend") 198 | BF <- 10^BF 199 | return(ifelse(BF > Q, Q, BF)) 200 | } 201 | 202 | 203 | ######################################################## 204 | # Clarifica 205 | ######################################################## 206 | Clarifica <- function(Q){ 207 | # the Clarifica technique (a.k.a. Graham method); named in (Clarifica, 2002) as a "forward and backward-step averaging approach." 208 | # ref: Clarifica Inc., 2002. Water Budget in Urbanizing Watersheds: Duffins Creek Watershed. Report prepared for the Toronto and Region Conservation Authority. 209 | # Clarifica method baseflow, 5-day avg running, 6-day min running 210 | 211 | # 6-day running minimum discharge 212 | BF <- rollapply(Q, width=6, min, by=1, fill=NA, align='right') 213 | 214 | # 5-day running average (3 days previous, 1 day ahead) 215 | BF <- rollapply(BF, width=list(1:-3), mean, by=1, fill=NA, align='right') 216 | 217 | return(ifelse(BF > Q, Q, BF)) 218 | } 219 | 220 | 221 | 222 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sHyStreamflow (formerly sHydrology Analysis) 2 | 3 | > NOTE: this code will see little support going forward. The active repo can be found [here](https://github.com/OWRC/sHyStreamflow). 4 | 5 | A Shiny-Leaflet interface to a stream flow database and companion to [sHydrology (map)](https://github.com/maseology/sHydrology). 6 | 7 | Currently built to view WSC HYDAT (sqlite3 format) stream flow data [click here](http://collaboration.cmc.ec.gc.ca/cmc/hydrometrics/www/). 8 | 9 | Can also be modified to hit agency databases, see [Oak Ridges Moraine Groundwater Program](http://oakridgeswater.ca). 10 | 11 | Further details can be read in [sHydrologyUM.pdf](/doc/sHydrologyUM.pdf). *(..to be updated)* 12 | 13 | ### Current functionality (version 1.4.2): 14 | * View entire stream flow time series 15 | * Dynamic hydrograph zooming: 16 | * drag-and-click zoom 17 | * double-click to full extent 18 | * optionally use date picker 19 | * Perform as suite of hydrograph separation algorithms (14 in total, see below) 20 | * display min/max range (green band) and median separated baseflow (dotted line) 21 | * Perform automatic hydrograph dis-aggregation to isolate rising/falling limbs, and stream flow recession 22 | * Perform flow frequency & flow regime analyses 23 | * Automatic recession coefficient computation 24 | * E-Flow/flow regime analysis tools 25 | * View data as a table, and export data as *.csv 26 | 27 | ### Screenshot: 28 | ![Screenshot](/images/screenshot.png) 29 | 30 | ## Functionality 31 | ### Required R-dependent packages: 32 | * shiny 33 | * shinyjs 34 | * markdown 35 | * jsonlite 36 | * lubridate 37 | * date 38 | * zoo 39 | * xts 40 | * broom 41 | * plyr 42 | * dplyr 43 | * tidyr 44 | * purrr 45 | * formattable 46 | * lmomco 47 | * caTools 48 | * ggplot2 49 | * dygraphs 50 | * scales 51 | * segmented 52 | * DT 53 | * RSQLite 54 | * cvequality 55 | 56 | ### Automatic recession coefficient computation: 57 | Two forms of streamflow recession coefficients are computed automatically using iterative procedures: 58 | 59 | 1. The ($b_t=kb_{t-1}$; Linsley et.al., 1975) recession curve is positioned to envelope the log-transformed discharge data versus subsequent discharge, on the condition that the former exceeds the latter. 60 | 1. The first-order (inverse) hyperbolic stream flow recession coefficient of the form: $\frac{1}{Q}-\frac{1}{Q_0}=\frac{t}{m}$. The inverse of the slope of this function yields a first-cut estimate of the *m* parameter used in TOPMODEL (Beven and Kirkby, 1979). 61 | 62 | The recession coefficient *k* is the inverse of the slope of the computed recession curve. 63 | 64 | The recession coefficient is required for many of the following hydrograph analyses, and is a common input parameter to many hydrologic models. 65 | 66 | The recession scatter plot is used to visualize the results of the automatic recession coefficient computation. The recession curve can be viewed and adjusted by manually changing the recession coefficient. 67 | 68 | ### Hydrograph separation methods (found in *\pkg\hydrograph_separation.R*): 69 | "Baseflow" is separated from the hydrographs using 14 automatic procedures listed below. Standard baseflow model parameters (as documented in the literature) are also listed where applicable. 70 | 71 | Computed baseflow is summarized on a monthly basis in the form of box-whisker plots. The distribution plotted here is built from the median monthly baseflow computed for every month of record using each of the 14 separation methods listed below. Where applicable, the baseflow values have bee normalized by the stream gauge's catchment area thereby providing the values in equivalent mm/month, which can be used as a first-approximation to basin-averaged groundwater recharge. 72 | 73 | 1. **BF.LH:** The Lyne-Hollick digital filter (Lyne and Hollick, 1979), 3-pass sweep with *α=0.925* as discussed in Chapman (1999); 74 | 2. **BF.CM:** The Chapman-Maxwell digital filter (Chapman and Maxwell, 1996), using automatically computed recession coefficient (*k*); 75 | 3. **BF.BE:** The Boughton-Eckhardt digital filter (Boughton, 1993; Eckhardt, 2005) with computed *k* and *BFImax=0.8*; 76 | 4. **BF.JH:** The Jakeman-Hornberger digital filter (Jakeman and Hornberger, 1993) based on their IHACRES model with *C=0.3* and *α=-0.8*; 77 | 5. **BF.Cl:** The 'Clarifica' method of Clarifica Inc. (2002); 78 | 6. **BF.UKn:** The UK Institute of Hydrology (or Wallingford) method (Institute of Hydrology, 1980), sweeping minimum of Piggott et.al. (2005); 79 | 7. **BF.UKx:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping maximum of Piggott et.al. (2005); 80 | 8. **BF.UKm:** The UK Institute of Hydrology/Wallingford method (Institute of Hydrology, 1980), sweeping median; 81 | 9. **BF.HYSEP.FI:** The HYSEP fixed-interval method (Sloto and Crouse, 1996), with known catchment area; 82 | 10. **BF.HYSEP.SI:** The HYSEP sliding-interval method (Sloto and Crouse, 1996), with known catchment area; 83 | 11. **BF.HYSEP.LM:** The HYSEP local minima method (Sloto and Crouse, 1996), with known catchment area; 84 | 12. **BF.PART1:** The PART method (Rutledge, 1998), with known catchment area, pass 1 of 3 antecedent recession requirement; 85 | 13. **BF.PART2:** The PART method (Rutledge, 1998), with known catchment area, pass 2 of 3 antecedent recession requirement; 86 | 14. **BF.PART3:** The PART method (Rutledge, 1998), with known catchment area, pass 3 of 3 antecedent recession requirement. 87 | 88 | ### Hydrograph parsing 89 | 90 | This algorithm is used to parse the hydrograph into three main constituents: 91 | 92 | 1. The rising limb (*qtyp* code 4) – the rapid increase in discharge following a storm/melt event; 93 | 2. The falling limb (*qtyp* code 1) – the rapid decrease in discharge following the rising limb; and, 94 | 3. Streamflow recession (*qtyp* code 2) – the gradual decline in discharge as the watershed drains. 95 | 96 | Event volumes are calculated using an algorithm that locates the onset of a rising limb and projects streamflow recession as if the event had never occurred. This projected streamflow, termed "underlying flow" by Reed et.al. (1975), is subtracted from the total observed flow to approximate the runoff volume associated with the event as indicated by the hydrograph. The calculation of event volumes, in effect, *"discretizes"* the continuous hydrograph such that it can be better compared with measured (i.e., rainfall/snowmelt) event volumes. 97 | 98 | ![from etal (1975)](md/images/Reed1_small.png) 99 | 100 | ### Hydrograph trend analysis: 101 | #### Annual trend 102 | Provides the long-term (calendar-year) absolute and relative annual volumes of total flow and separated baseflow. 103 | 104 | #### Daily average hydrograph (discontinued) 105 | After applying a 5-day rolling average to the hydrograph, both total flow and baseflow are averaged on a daily basis, to illustrate the seasonality of the annual hydrograph. 106 | 107 | #### Seasonal trend 108 | Provide the annual hydrograph faceted into the four seasons. 109 | 110 | #### Monthly range baseflow 111 | Computed baseflow is summarized on a monthly basis in the form of box-whisker plots. The distribution plotted here is built from the median monthly baseflow computed for every month of record using each of the 14 separation methods listed below. 112 | 113 | Boxplots and Baseflow index (BFI: the ratio of baseflow to total flow) are computed using the 14 hydrograph separation methods listed above. Boxplots follow the method of McGill et.al. (1978): box represents the 25% to 75% quantile, while the centre line represents median (50% quantile). Whiskers represent the observation less than or equal to the box extents ±1.5 * IQR (inter-quartile range). 114 | 115 | Monthly BFIs given by the monthly medians of calculated baseflow (from 14 hydrograph separation methods) and are bounded by the 95% confidence interval. 116 | 117 | #### Cumulative discharge plot 118 | The overall accumulation of total and baseflow discharge is presented here with a piece-wise regression plotted to identify historical changes to the flow regime. 119 | 120 | ### Peak & Low flow frequency 121 | Peak and low flow frequency curves were modified (with gratitude) from [headwateranalytics.com](http://www.headwateranalytics.com/blog/flood-frequency-analysis-in-r) *(accessed December, 2016)*. 122 | 123 | Three forms of low flow statistics are available, the extreme annual minimum daily discharge, the 7-day mean annual minimum (MAM) and the 30-day MAM. 124 | 125 | All frequency curves are accompanied by a histogram plotting the season distribution of extreme occurrence. 126 | 127 | The method allows for the use of 5 distributions: Log-Pearson type 3 *(default)*, Weibull, Gumbel, Generalized Extreme Value (GEV), and the three-parameter log-normal models. (The user may change the distribution model in the *Settings* tab.) 128 | 129 | By default, 90% confidence intervals are then plotted based in the bootstrap technique from 10,000 samples. 130 | 131 | ### Recession scatter plot and duration 132 | The recession scatter plot is used to visualize the results of the automatic recession coefficient computation. The recession curve can be adjusted by manually changing the recession coefficient. 133 | 134 | Recession duration is presented as a histogram of the number of consecutive days under a recession period. (Recession periods determined from the hydrograph parsing routine.) 135 | 136 | ### Indicators of Hydrologic Alteration (IHA) 137 | Indicators of Hydrologic Alteration is a suite of statistical measures used to characterize the in-stream flow regime (Richter et.al., 1996). 138 | 139 | 140 | ## Instructions 141 | 142 | As coded, *sHyStreamflow* is built to view the Water Survey of Canada (WSC) **HY**drological **DAT**abase (HYDAT) which can be downloaded [here](https://collaboration.cmc.ec.gc.ca/cmc/hydrometrics/www/). 143 | 144 | Download and extract the SQLite format of the database typically compressed as *'Hydat_sqlite3_YYYYMMDD.zip'*, where *'YYYYMMDD'* is the date of release. Extract the SQLite file *'Hydat.sqlite3'* and place in the included */dat* directory. 145 | 146 | Using [RStudio](https://https://www.rstudio.com/), install the required packages (see above), and set the station name of interest on *Line 13* of the main app file: *app.R*. 147 | 148 | Run *app.R* externally such that the app will open on your default web browser. (The app must be run externally in order to extract *.csv files.) 149 | 150 | The *'Hydat.sqlite3'* file is roughly 1GB in size and thus cannot be hosted on GitHub. 151 | 152 | 153 | ## Current version: 1.4.2 154 | **Task list:** 155 | 156 | - [x] Build main Leaflet/Shiny interface 157 | - [x] Write hydrograph separation routines 158 | - [ ] Add user-definable parameter adjustment 159 | - [x] Add flow summary section 160 | - [x] Write ecological/environment flow (E-Flow) statistics 161 | - [x] Flow duration curve/return periods 162 | - [x] Peak flow frequency/return periods 163 | - [ ] Tests for stationarity (Mann-Kendall, double-mass, etc.) 164 | - [x] Low flow frequency/return period analysis 165 | - [ ] Drought indices (i.e., MDSI) 166 | - [x] Incorporation of catchment precipitation *(unavailable when using HYDAT)* 167 | - [x] Hydrograph parsing (rising limb, falling limb, baseflow recession) 168 | - [x] Continuous to discrete hydrograph translation 169 | 170 | ### License 171 | 172 | sHydrology hosted on GitHub is released under the MIT license. 173 | 174 | ### Contributors 175 | 176 | Mason Marchildon P.Eng M.ASc, Hydrologist for the [Oak Ridges Moraine Groundwater Program](http://oakridgeswater.ca/) 177 | 178 | ## Release notes 179 | 180 | **version 1.6 - April 2021** 181 | 182 | * added printer-friendly hydrograph on main page 183 | * added date selector to hydrograph page 184 | * added discharge duration to median plot 185 | * updated cumulative plots (included break point) 186 | 187 | **version 1.5 - December 2020** 188 | 189 | * added station aggregation 190 | * re-organized function files 191 | * added station information to table section 192 | 193 | **version 1.4.2 - June 2020** 194 | 195 | * bug fixes 196 | 197 | **version 1.4.1 - May 2020** 198 | 199 | * fixed *"Include all computations"* button on Data-table download tab 200 | 201 | **version 1.4 - May 2020** 202 | 203 | * darkened grid lines on certain plots 204 | * removed fill from Dygraph date range selectors 205 | * added "rug plots" to all density plots 206 | * added monthly histograms of peak and MAM occurrences 207 | * bug fix: rolling mean BFI on cumulative discharge page was overestimating true BFI values 208 | * added better handling of *NA* values on cumulative discharge plots 209 | * added piece-wise regression on top of cumulative discharge plots 210 | * added data quality indication on annual summary page 211 | * added box whisker of complete series in "monthly summary" for reference 212 | * added recession duration page 213 | * added four plot faceted seasonal summary page 214 | * updated IHA page to show i) piece-wise regression ii) statistical testing between date ranges 215 | 216 | **version 1.3 - March 2020** 217 | 218 | * baseflow hydrograph: fix so that zoom is maintained when switching to full (14 baseflow hydrograph) view 219 | * added a temporary fix to the "event yields" bars in the disaggregated hydrograph (issue: https://github.com/rstudio/dygraphs/issues/237 also https://github.com/ramnathv/htmlwidgets/issues/356) 220 | * added totals to plots on opening page (FDC & monthly discharge) 221 | * added logarithmic gridlines onto FDC 222 | * added baseflow description to annual summary 223 | * changed "seasonal summary" to "monthly summary" 224 | * peak flow analysis: added indication that daily mean discharges are (likely) being applied. 225 | 226 | **version 1.2.4 - 2019-12-05** 227 | 228 | * general improvements 229 | * added Indicators of Hydrologic Alteration (IHA) *(modified from https://rdrr.io/rforge/IHA/)* 230 | * added first-order (inverse) hyperbolic stream flow recession coefficient computation 231 | * added capability to ingest precipitation *(not available in HYDAT mode)* 232 | 233 | **version 1.2.1 - 2018-11-07** 234 | 235 | * bug fix: axis labelling 236 | * reorganized code for better HYDAT integration 237 | * added description to stream flow recession coefficient 238 | * fixed stream flow recession coefficient button actions 239 | * fixed hydrograph parsing bugs 240 | * updated about page 241 | 242 | **version 1.2 - 2018-05-15** 243 | 244 | * code reorganization 245 | 246 | **version 1.1 - 2018-05-04** 247 | 248 | * general tab reorganization 249 | * using optimized APIs for quicker data access 250 | * added BFI to cumulative plots 251 | * bug fixes 252 | 253 | **version 1.0.1 - 2018-01-16** 254 | 255 | * fixed bug where contributing area = 0 cause plot failure 256 | 257 | **version 1.0 - 2018-01-12** 258 | 259 | * initial release 260 | 261 | ## References 262 | 263 | Beven, K.J., M.J. Kirkby, 1979. A physically based, variable contributing area model of basin hydrology. Hydrological Sciences Bulletin 24(1): 43-69. 264 | 265 | Boughton, W.C., 1993. A hydrograph-based model for estimating the water yield of ungauged catchments. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Newcastle: 317-324. 266 | 267 | Chapman, T.G. and A.I. Maxwell, 1996. Baseflow separation - comparison of numerical methods with tracer experiments.Institute Engineers Australia National Conference. Publ. 96/05, 539-545. 268 | 269 | Chapman T.G., 1999. A comparison of algorithms for stream flow recession and baseflow separation. Hydrological Processes 13: 710-714. 270 | 271 | Clarifica Inc., 2002. Water Budget in Urbanizing Watersheds: Duffins Creek Watershed. Report prepared for the Toronto and Region Conservation Authority. 272 | 273 | Eckhardt, K., 2005. How to construct recursive digital filters for baseflow separation. Hydrological Processes 19, 507-515. 274 | 275 | Institute of Hydrology, 1980. Low Flow Studies report. Wallingford, UK. 276 | 277 | Jakeman, A.J. and Hornberger G.M., 1993. How much complexity is warranted in a rainfall-runoff model? Water Resources Research 29: 2637-2649. 278 | 279 | Linsley, R.K., M.A. Kohler, J.L.H. Paulhus, 1975. Hydrology for Engineers 2nd ed. McGraw-Hill. 482pp. 280 | 281 | Lyne, V. and M. Hollick, 1979. Stochastic time-variable rainfall-runoff modelling. Hydrology and Water Resources Symposium, Institution of Engineers Australia, Perth: 89-92. 282 | 283 | McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of box plots. The American Statistician 32, 12-16. 284 | 285 | Piggott, A.R., S. Moin, C. Southam, 2005. A revised approach to the UKIH method for the calculation of baseflow. Hydrological Sciences Journal 50(5): 911-920. 286 | 287 | Reed, D.W., P. Johnson, J.M. Firth, 1975. A Non-Linear Rainfall-Runoff Model, Providing for Variable Lag Time. Journal of Hydrology 25: 295–305. 288 | 289 | Richter, B.D., J.V. Baumgertner, J. Powell, D.P. Braun, 1996. A Method for Assessing Hydrologic Alteration within Ecosystems. Conservation Biology 10(4): 1163-1174. 290 | 291 | Rutledge, A.T., 1998. Computer Programs for Describing the Recession of Ground-Water Discharge and for Estimating Mean Ground-Water Recharge and Discharge from Streamflow Records-Update, Water-Resources Investigation Report 98-4148. 292 | 293 | Sloto, R.A. and M.Y. Crouse, 1996. HYSEP: A Computer Program for Streamflow Hydrograph Separation and Analysis U.S. Geological Survey Water-Resources Investigations Report 96-4040. --------------------------------------------------------------------------------