Commit 09c3ca7e authored by unknown's avatar unknown
Browse files

v0.2.0.0 embeding dygraphs functions to avoid user to install the last version...

v0.2.0.0 embeding dygraphs functions to avoid user to install the last version of this package from GitHub
parent de7d3405
Package: airGRteaching
Type: Package
Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Interface)
Version: 0.1.11.26
Date: 2018-02-07
Version: 0.2.0.0
Date: 2018-03-13
Authors@R: c(person("Olivier", "Delaigue", role = c("aut", "cre"), email = "airGR@irstea.fr"), person("Laurent", "Coron", role = c("aut")), person("Pierre", "Brigode", role = c("aut")), person("Guillaume", "Thirel", role = c("ctb")))
Depends: airGR (>= 1.0.9.43)
Imports: devtools, dygraphs (>= 1.1.1.4), markdown, plotrix, shiny, shinyjs, xts
Imports: devtools, dygraphs (>= 1.1.1.4), htmlwidgets (>= 1.1), markdown, plotrix, shiny, shinyjs, xts
Description: Add-on package to the airGR package that simplifies its use and is aimed at being used for teaching hydrology. The package provides 1) three functions that allow to complete very simply a hydrological modelling exercise 2) plotting functions to help students to explore observed data and to interpret the results of calibration and simulation of the GR models 3) a shiny graphical interface that allows for displaying the impact of model parameters on hydrographs and models internal variables.
License: GPL-2
NeedsCompilation: no
......
......@@ -33,6 +33,19 @@ export(.TypeModelGR)
#####################################
## Export dygraphs ##
#####################################
export(computeYaxisRange)
export(dyBarSeries)
export(dyGroup)
export(dyStackedBarGroup)
export(dyStackedRibbonGroup)
export(mergeLists)
export(resolveStemPlot)
#####################################
## Import ##
#####################################
......
......@@ -2,10 +2,16 @@
## 0.1.11.25 Release Notes (2018-02-01)
## 0.2.0.0 Release Notes (2018-03-13)
CRAN-compatibility updates
- embeding dygraphs functions to avoid user to install the last version of this package from GitHub
## 0.1.11.26 Release Notes (2018-02-01)
Bug fixes
- bug fixed when C1 or C2 is modified after calibration; the calibration button is now reset
- bug fixed in ShinyGR() when C1 (or C2) is modified after calibration; the calibration button is now reset
- bug fixed in warm-up, calibration and simulation periods checks in CalGR() and SimGR() functions
Deprecated and defunct
......@@ -17,6 +23,7 @@
## 0.1.10.0 Release Notes (2018-01-30)
Deprecated and defunct
- ObsGR() function (and relatives arguments in CalGR() and SimGR()) has been renamed PrepGR()
......
......@@ -2,11 +2,11 @@
## function to generate a message to reinstall the dygraph package
## =================================================================================
.onAttach <- function(lib, pkg) {
packageStartupMessage("\nThe airGRteaching needs the last version of the 'dygraphs' package that is only available on GitHub at the moment.\n",
"Please, make sure at the first use of airGRteaching to install 'dygraphs' with the following command:\n",
"\tdevtools::install_github(c(\"ramnathv/htmlwidgets\", \"rstudio/dygraphs\"), force = TRUE)")
}
# .onAttach <- function(lib, pkg) {
# packageStartupMessage("\nThe airGRteaching needs the last version of the 'dygraphs' package that is only available on GitHub at the moment.\n",
# "Please, make sure at the first use of airGRteaching to install 'dygraphs' with the following command:\n",
# "\tdevtools::install_github(c(\"ramnathv/htmlwidgets\", \"rstudio/dygraphs\"), force = TRUE)")
# }
......
......@@ -86,7 +86,7 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
dg <- dygraphs::dySeries(dygraph = dg, name = "Qobs", axis = 'y' , color = col.Q[1L], drawPoints = TRUE)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsim", axis = 'y' , color = col.Q[2L])
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsup", axis = 'y' , color = col.Q[3L], label = Qsup.name, strokePattern = "dashed")
dg <- dygraphs::dyStackedBarGroup(dygraph = dg, name = rev(grep("^P", colnames(data.xts), value = TRUE)), axis = "y2", color = (col.Precip))
dg <- airGRteaching::dyStackedBarGroup(dygraph = dg, name = rev(grep("^P", colnames(data.xts), value = TRUE)), axis = "y2", color = (col.Precip))
dg <- dygraphs::dyAxis(dygraph = dg, name = "y" , label = ylab[1L],
valueRange = range(data.xts[, grep("^Q", colnames(data.xts))], na.rm = TRUE) * c(0.01, 1.59))
dg <- dygraphs::dyAxis(dygraph = dg, name = "y2", label = ylab[2L], independentTicks = FALSE,
......
## Code from the last version of the 'dygraphs' package that is only available on GitHub
## Will be removed from airGRteaching when the last ‘dygraphs’ version will be available on the CRAN
## https://github.com/rstudio/dygraphs
## License MIT
## RStudio Team
## Many thanks to J.J. Allaire and Petr Shevtsov
#' dygraph series group
#'
#' Add a data series group to a dygraph plot. Note that options will use the default
#' global setting (as determined by \code{\link{dyOptions}}) when not specified
#' explicitly. Importantly, any dySeries options passed can be passed as a vector of values
#' and will be replicated across all series named as part of the group. If arguments differ in
#' length than the number of series named, then the argument vector will be
#' cycled across the named series.
#'
#' NOTE: dyGroup will turn off \code{stackedGraph}, as the option will calculated cumulatives using
#' all series in the underlying dygraph, not just a subset.
#'
#' The dyGroup function can also replicated similar arguments across multiple series, or
#' be used to apply a grouped custom plotter - i.e., multi-column plotter - to a subset of the
#' dygraph data series.
#'
#' @inheritParams dySeries
#' @inheritParams dyOptions
#'
#' @param dygraph Dygraph to add a series definition to
#' @param name character vector of the series within data set. If no name is specified then
#' series are bound to implicitly based on their order within the underlying
#' time series object. This parameter can also be a character vector of length
#' 3 that specifies a set of input column names to use as the lower, value,
#' and upper for a series with a shaded bar drawn around it.
#' @param label Labels to display for series (uses name if no label defined)
#' @param color Colors for series. These can be of the form "#AABBCC" or
#' "rgb(255,100,200)" or "yellow", etc. Note that if you specify a custom
#' color for one series then you must specify one for all series. If not
#' specified then the global colors option (typically based on equally-spaced
#' points around a color wheel). Note also that global and per-series color
#' specification cannot be mixed.
#' @param axis Y-axis to associate the series with ("y" or "y2")
#' @param stepPlot When set, display the graph as a step plot instead of a line
#' plot.
#' @param stemPlot When set, display the graph as a stem plot instead of a line
#' plot.
#' @param fillGraph Should the area underneath the graph be filled? This option
#' is not compatible with error bars.
#' @param drawPoints Draw a small dot at each point, in addition to a line going
#' through the point. This makes the individual data points easier to see, but
#' can increase visual clutter in the chart.
#' @param pointSize The size of the dot to draw on each point in pixels. A dot
#' is always drawn when a point is "isolated", i.e. there is a missing point
#' on either side of it. This also controls the size of those dots.
#' @param pointShape The shape of the dot to draw. Can be one of the following:
#' "dot" (default), "triangle", "square", "diamond", "pentagon", "hexagon",
#' "circle", "star", "plus" or "ex".
#' @param strokeWidth The width of the lines connecting data points. This can be
#' used to increase the contrast or some graphs.
#' @param strokePattern A predefined stroke pattern type ("dotted", "dashed", or
#' "dotdash") or a custom pattern array where the even index is a draw and odd
#' is a space in pixels. If \code{NULL} then it draws a solid line. The array
#' should have an even length as any odd length array could be expressed as
#' a smaller even length array.
#' @param strokeBorderWidth Draw a border around graph lines to make crossing
#' lines more easily distinguishable. Useful for graphs with many lines.
#' @param strokeBorderColor Color for the line border used if
#' \code{strokeBorderWidth} is set.
#'
#' @param plotter A function which plots the series group. See the
#' \href{http://dygraphs.com/tests/plotters.html}{dygraphs documentation} for
#' additional details on plotting functions.
#'
#' @return Dygraph with additional series
#'
#' @examples
#' \dontrun{
#' library(dygraphs)
#'
#' lungDeaths <- cbind(ldeaths, mdeaths, fdeaths)
#'
#' dygraph(lungDeaths, main = "Deaths from Lung Disease (UK)") %>%
#' dySeries("fdeaths", stepPlot = TRUE, color = "red") %>%
#' dyGroup(c("mdeaths", "ldeaths"), drawPoints = TRUE, color = c("blue", "green"))
#' }
#'
#' @note See the
#' \href{https://rstudio.github.io/dygraphs/gallery-series-options.html}{online
#' documentation} for additional details and examples.
#'
#' @export
dyGroup <- function(dygraph,
name = NULL,
label = NULL,
color = NULL,
axis = "y",
stepPlot = NULL,
stemPlot = NULL,
fillGraph = NULL,
drawPoints = NULL,
pointSize = NULL,
pointShape = NULL,
strokeWidth = NULL,
strokePattern = NULL,
strokeBorderWidth = NULL,
strokeBorderColor = NULL,
plotter = NULL) {
# get a reference to the underlying data and labels
data <- attr(dygraph$x, "data")
labels <- names(data)
if (length(plotter)>1) message('dyGroup: pass only a single plotter option')
# auto-bind name if necessary
autobind <- attr(dygraph$x, "autoSeries")
if (length(name) == 1) {
dygraph<-dySeries(dygraph = dygraph,
name = name,
label = label,
color = color,
plotter = plotter)
return(dygraph)
}
# Plotter-mod! Added the plotter != NULL test to keep base capability while
# expanding to include group plotters
# Get the cols where this series is located and verify that they are
# available within the underlying dataset
cols <- which(labels %in% name)
if (length(cols) != length(name)) {
stop("One or more of the specified series were not found. ",
"Valid series names are: ", paste(labels[-1], collapse = ", "))
}
# Data series named here are "consumed" from the automatically generated
# list of series (they'll be added back in below)
cols <- which(dygraph$x$attrs$labels %in% name)
dygraph$x$data <- dygraph$x$data[-c(cols)]
dygraph$x$attrs$labels <- dygraph$x$attrs$labels[-c(cols)]
# MUST turn off native stacking option, as underlying dygraph
# will include custom-plotted points in the stacked calculation
if (length(dygraph$x$attrs$stackedGraph)>0) {
if (dygraph$x$attrs$stackedGraph) warning(
"dyGroup is incompatible with stackedGraph... stackedGraph now FALSE")
dygraph$x$attrs$stackedGraph <- FALSE;
}
# Resolve stemPlot into a custom plotter if necessary
plotter <- airGRteaching::resolveStemPlot(stemPlot, plotter)
if (!is.null(pointShape))
dygraph$x$pointShape <- list()
l<-length(name)
# add color if specified
if (!is.null(color)) {
#grab the names of all named series
names_ <- names(dygraph$x$attrs$series)
#grab any colors already set
colors_ <- dygraph$x$attrs$colors
# if no colors passed thus far, set up the color vector for
# the series defined previously
if(is.null(colors_)) {
colors_ <- vector('character', length(names_))
}
names(colors_) <- names_
for(i in 1:l) colors_[[name[i]]] <- rep(color, length.out = l)[i]
# all options must be unnamed vectors
names(colors_) <- NULL
# attrs$colors <- as.list(c(attrs$colors, color))
dygraph$x$attrs$colors <- colors_
}
# repeat (most of) the steps from dySeries, just in a loop
for (i in 1:l) {
# copy attrs for modification
attrs <- dygraph$x$attrs
# create series object
series <- list()
series$name <- name[i]
# take the passed options and extend to the length of the name vector; it's
# up to the User to make sure the vectors are of the desired length
suppressWarnings({
# for the axis, however, we enforce the same axis across all series named
# in the group. We can't stop the user from changing the axis of one or more
# series later, but at least we can control for some mistakes here
series$options$axis <- rep(match.arg(axis, c("y", "y2")),
length.out = l)[1]
if(!is.null(stepPlot)) series$options$stepPlot <- rep(
stepPlot, length.out = l)[i]
if(!is.null(fillGraph)) series$options$fillGraph <- rep(
fillGraph, length.out = l)[i]
if(!is.null(drawPoints)) series$options$drawPoints <- rep(
drawPoints, length.out = l)[i]
if(!is.null(pointSize)) series$options$pointSize <- rep(
pointSize, length.out = l)[i]
if(!is.null(strokeWidth)) series$options$strokeWidth <- rep(
strokeWidth, length.out = l)[i]
if(!is.null(strokePattern)) series$options$strokePattern <- rep(
resolveStrokePattern(strokePattern), length.out = l)[i]
if(!is.null(strokeBorderWidth)) series$options$strokeBorderWidth <- rep(
strokeBorderWidth, length.out = l)[i]
if(!is.null(strokeBorderColor)) series$options$strokeBorderColor <- rep(
strokeBorderColor, length.out = l)[i]
# one can use this to pass a group plotter or any combination of individual series plotters
series$options$plotter <- htmlwidgets::JS(plotter)
})
# KEY! Adding a group designator to aid in group plotters
# By concatenating the names provided in the name age, it becomes
# a unique identifier than won't be duplicated unless the entire group of names
# passed gets re-passed together a second time, which would obviously override
# the first set of options
series$options$group <- paste0(name, collapse = "")
seriesData <- data[[series$name]]
# default the label if we need to
if (is.null(series$label))
series$label <- series$name
# add label
attrs$labels <- c(attrs$labels, series$label)
# get whatever options might have previously existed for the series, then merge
base <- attrs$series[[series$label]]
series$options <- airGRteaching::mergeLists(base, series$options)
# set options
attrs$series[[series$label]] <- series$options
# set attrs
dygraph$x$attrs <- attrs
# set point shape
if (!is.null(pointShape[i])) {
shapes <- c("dot", "triangle", "square", "diamond", "pentagon",
"hexagon", "circle", "star", "plus", "ex")
if (!is.element(pointShape[i], shapes)) {
stop("Invalid value for pointShape parameter. ",
"Should be one of the following: ",
"'dot', 'triangle', 'square', 'diamond', 'pentagon', ",
"'hexagon', 'circle', 'star', 'plus' or 'ex'")
}
if (pointShape[i] != "dot") {
dygraph$x$pointShape[[series$label]] <- rep(pointShape, length.out = l)
}
}
# add data
dygraph$x$data[[length(dygraph$x$data) + 1]] <- seriesData
}
# return modified dygraph
dygraph
}
## Code from the last version of the 'dygraphs' package that is only available on GitHub
## Will be removed from airGRteaching when the last ‘dygraphs’ version will be available on the CRAN
## https://github.com/rstudio/dygraphs
## License MIT
## RStudio Team
## Many thanks to J.J. Allaire and Petr Shevtsov
#' @rdname Plotters
#' @export
#'
dyStackedBarGroup <- function(dygraph, name, ...) {
dots <- list(...)
if(length(name) < 2) {
dygraph <- do.call(airGRteaching::dyBarSeries, c(list(dygraph = dygraph, name = unlist(name)), dots))
return(dygraph)
}
file <- system.file("plotters/stackedbargroup.js", package = "airGRteaching")
plotter_ <- paste0(readLines(file, skipNul = TRUE), collapse = "\n")
dygraph <- do.call(airGRteaching::dyGroup, c(list(dygraph = dygraph, name = name, plotter = plotter_), dots))
dygraph <- airGRteaching::computeYaxisRange(dygraph, name)
dygraph
}
#' @rdname Plotters
#' @export
dyBarSeries <- function(dygraph, name, ...) {
file <- system.file("plotters/barseries.js", package = "airGRteaching")
plotter_ <- paste0(readLines(file, skipNul = TRUE), collapse = "\n")
dots <- list(...)
do.call(dygraphs::dySeries, c(list(dygraph = dygraph, name = name, plotter = plotter_), dots))
}
#' @rdname Plotters
#' @export
dyStackedRibbonGroup <- function(dygraph, name, ...) {
dots <- list(...)
if(length(name) < 2) {
dygraph <- do.call('dyFilledLine', c(list(dygraph = dygraph, name = name), dots))
return(dygraph)
}
file <- system.file("plotters/stackedribbongroup.js", package = "airGRteaching")
plotter_ <- paste0(readLines(file, skipNul = TRUE), collapse = "\n")
dygraph <- do.call(airGRteaching::dyGroup, c(list(dygraph = dygraph, name = name, plotter = plotter_), dots))
dygraph <- airGRteaching::computeYaxisRange(dygraph, name)
dygraph
}
computeYaxisRange <- function(dygraph, name) {
# most of what happens from here on out is a simplified version of the
# stackPoints and computeYaxis functions in the underlying dygraph package.
# Since we can't modify the Yaxis range from within the specialized plotter,
# we need to calculate an appropriate valueRange for the group's axis here, then
# reconcile that against user-provided ranges and then pass into the widget... this
# way we ensure that the newly stacked data (but initially unstacked to the widget)
# doesn't get cutoff by an axis range - computed by the widget - that won't consider
# the points stacked
attrs <- dygraph$x$attrs
data <- attr(dygraph$x, "data")
cols <- which(names(data) %in% name)
#get all the series, minus the x axis, that are not part of the group
data_ <- data[-c(1, cols)]
name_ <- names(data)[which(!names(data) %in% name)][-1]
#grab the axis for the group, we'll calculate the new range only on this axis
series <- attrs$series[[name[1]]]
axisNm <- series$axis
if (!is.null(axisNm)) {
axis <- attrs$axes[[axisNm]]
valueRange <- axis$valueRange
} else {
axisNm<-"y"
axis <- attrs$axes[[axisNm]] <- NULL
valueRange <- NULL
}
if(is.null(valueRange)) {
valueRange <- c(0, 0)
}
# get the group data fields
data <- data[cols]
for(i in 1:length(data)) {
# get the data points
points <- data[i][[1]]
# fill NAs... we're not saving this data back into the graph, so this is OK
is.na(points) <- 0
# add to cumulativeList
if(!exists('cumulativeYval')) cumulativeYval <- points
else cumulativeYval <- cumulativeYval + points
# calculate extremes
extremes <- range(cumulativeYval)
}
for(i in 1:length(data_)) {
if (length(data_)==0) break
# ranges are calcuated separately, so skip those from other axes
series_ <- attrs$series[[name_[i]]]
if (!is.null(series_$axis) && series_$axis != axisNm) next
points <- data_[i][[1]]
# fill NAs
is.na(points) <- 0
# getExtremes
extremes_ <- range(points)
extremes[1] <- min(extremes[1], extremes_[1])
extremes[2] <- max(extremes[2], extremes_[2])
}
valueRange[1] <- min(extremes[1], valueRange[1])
valueRange[2] <- max(extremes[2], valueRange[2])
# add a little padding since we're hard-setting the range
valueRange[2] <- valueRange[2] + 0.05 * abs(valueRange[2] - valueRange[1])
axis$options$valueRange <- valueRange
attrs$axes[[axisNm]] <- axis$options
# return modified dygraph
dygraph$x$attrs <- airGRteaching::mergeLists(dygraph$x$attrs, attrs)
return (dygraph)
}
\ No newline at end of file
## Code from the last version of the 'dygraphs' package that is only available on GitHub
## Will be removed from airGRteaching when the last ‘dygraphs’ version will be available on the CRAN
## https://github.com/rstudio/dygraphs
## License MIT
## RStudio Team
## Many thanks to J.J. Allaire and Petr Shevtsov
# provide a custom plotter if stemPlot has been specified
resolveStemPlot <- function(stemPlot, plotter) {
# check for stemPlot argument
if (isTRUE(stemPlot)) {
# verify that a custom plotter hasn't been specified
if (!is.null(plotter)) {
stop("stemPlot provides it's own plotter so is incompatible with ",
"specifying a custom plotter", call. = FALSE)
}
# provide custom plotter JS
"function stemPlotter(e) {
var ctx = e.drawingContext;
var points = e.points;
var y_bottom = e.dygraph.toDomYCoord(0);
ctx.fillStyle = e.color;
for (var i = 0; i < points.length; i++) {
var p = points[i];
var center_x = p.canvasx;
var center_y = p.canvasy;
ctx.beginPath();
ctx.moveTo(center_x, y_bottom);
ctx.lineTo(center_x, center_y);
ctx.stroke();
ctx.beginPath();
ctx.arc(center_x, center_y, 3, 0, 2*Math.PI);
ctx.stroke();
}
}"
} else {
# specified plotter
plotter
}
}
\ No newline at end of file
## Code from the last version of the 'dygraphs' package that is only available on GitHub
## Will be removed from airGRteaching when the last ‘dygraphs’ version will be available on the CRAN
## https://github.com/rstudio/dygraphs
## License MIT
## RStudio Team
## Many thanks to J.J. Allaire and Petr Shevtsov
mergeLists <- function (base_list, overlay_list, recursive = TRUE) {
if (length(base_list) == 0)
overlay_list
else if (length(overlay_list) == 0)
base_list
else {
merged_list <- base_list
for (name in names(overlay_list)) {
base <- base_list[[name]]
overlay <- overlay_list[[name]]
if (is.list(base) && is.list(overlay) && recursive)
merged_list[[name]] <- mergeLists(base, overlay)
else {
merged_list[[name]] <- NULL
merged_list <- append(merged_list,
overlay_list[which(names(overlay_list) %in% name)])
}
}
merged_list
}
}
\ No newline at end of file
......@@ -538,7 +538,7 @@ shinyServer(function(input, output, session) {
dg3 <- dygraphs::dyOptions(dg3, fillAlpha = 1.0,
axisLineColor = op$fg, axisLabelColor = op$fg,
titleHeight = 10, retainDateWindow = FALSE)
dg3 <- dygraphs::dyStackedRibbonGroup(dg3, name = names,
dg3 <- airGRteaching::dyStackedRibbonGroup(dg3, name = names,
color = colors, strokeBorderColor = "black")
dg3 <- dygraphs::dySeries(dg3, name = "Qobs", fillGraph = FALSE, drawPoints = TRUE, color = op$fg)
dg3 <- dygraphs::dySeries(dg3, name = "Qsim", fillGraph = FALSE, color = "orangered")
......@@ -562,7 +562,7 @@ shinyServer(function(input, output, session) {
dg4 <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("precip. [mm/", getPrep()$TMGR$TimeUnit, "]"))
dg4 <- dygraphs::dyOptions(dg4, colors = "#428BCA", drawXAxis = FALSE, retainDateWindow = FALSE)
dg4 <-