From 60a94f82d5e6ba84f0e80ef9afeaf5328a98659e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Berthet?= Date: Tue, 5 Sep 2023 10:03:48 +0200 Subject: [PATCH] Fix/ant 713 (#201) * rgeos replaced by sf and raster to terra * terra removed aggregation done with sf * github actions : add coverage * check reverse dep : add revdep --- .Rbuildignore | 26 +- .github/workflows/test-coverage.yaml | 50 + .gitignore | 16 +- DESCRIPTION | 15 +- NAMESPACE | 149 ++- NEWS.md | 6 +- R/map_layout.R | 1293 +++++++++++------------ README.md | 4 +- antaresViz.Rproj | 18 + codecov.yml | 15 +- cran-comments.md | 17 + man/plot.mapLayout.Rd | 4 +- man/plotMapOptions.Rd | 4 +- revdep/.gitignore | 7 + revdep/README.md | 105 ++ revdep/cran.md | 7 + revdep/email.yml | 5 + revdep/failures.md | 1 + revdep/problems.md | 1 + tests/testthat/helper-init.R | 124 +-- tests/testthat/test-ts_plot.R | 1465 +++++++++++++------------- 21 files changed, 1786 insertions(+), 1546 deletions(-) create mode 100644 .github/workflows/test-coverage.yaml create mode 100644 antaresViz.Rproj create mode 100644 cran-comments.md create mode 100644 revdep/.gitignore create mode 100644 revdep/README.md create mode 100644 revdep/cran.md create mode 100644 revdep/email.yml create mode 100644 revdep/failures.md create mode 100644 revdep/problems.md diff --git a/.Rbuildignore b/.Rbuildignore index 450d3b7e..9ab0c907 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,12 +1,14 @@ -^.*\.Rproj$ -^\.Rproj\.user$ -^appveyor\.yml$ -^\.travis\.yml$ -^codecov\.yml$ -inst/examples -^_pkgdown\.yml$ -^docs$ -^pkgdown$ -^cran-comments\.md$ -^CRAN-RELEASE$ -^\.github$ +^.*\.Rproj$ +^\.Rproj\.user$ +^appveyor\.yml$ +^\.travis\.yml$ +^codecov\.yml$ +inst/examples +^_pkgdown\.yml$ +^docs$ +^pkgdown$ +^cran-comments\.md$ +^CRAN-RELEASE$ +^\.github$ +^revdep$ +^README\.Rmd$ diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 00000000..2c5bb502 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,50 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: coverage + + - name: Test coverage + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") + ) + shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/.gitignore b/.gitignore index 28bc3a15..37a476ca 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,10 @@ -.Rproj.user -.Rhistory -.RData -.Ruserdata -inst/examples -inst/doc +.Rproj.user +.Rhistory +.RData +.Ruserdata +.idea +inst/examples +inst/doc +.Rdata +.httr-oauth +.DS_Store diff --git a/DESCRIPTION b/DESCRIPTION index 657920ef..df757804 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,9 +1,9 @@ Package: antaresViz Type: Package Title: Antares Visualizations -Version: 0.17.1 +Version: 0.18.0 Authors@R: c( - person("Veronique", "Bachelier", email = "veronique.bachelier@rte-france.com", role = c("aut", "cre")), + person("Tatiana", "Vargas", email = "tatiana.vargas@rte-france.com", role = c("aut", "cre")), person("Jalal-Edine", "Zawam", role = "aut"), person("Francois", "Guillem", role = "aut"), person("Benoit", "Thieurmel", role = "aut"), @@ -23,8 +23,8 @@ License: GPL (>= 2) | file LICENSE Encoding: UTF-8 Depends: antaresRead (>= 2.2.9), - antaresProcessing (>= 0.13.0), - spMaps (>= 0.2) + antaresProcessing (>= 0.13.0), + spMaps (>= 0.5.0) Imports: dygraphs (>= 1.1.1.6), shiny (>= 0.13.0), @@ -33,9 +33,8 @@ Imports: htmlwidgets (>= 0.7.0), manipulateWidget (>= 0.10.0), leaflet (>= 1.1.0), - sp, - rgeos, - raster, + sp (>= 2.0-0), + sf, webshot, data.table, methods, @@ -47,7 +46,7 @@ Imports: assertthat, rAmCharts, utils -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.2 Suggests: testthat, covr, diff --git a/NAMESPACE b/NAMESPACE index bb5472aa..ac472e79 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,75 +1,74 @@ -# Generated by roxygen2: do not edit by hand - -S3method(plot,antaresData) -S3method(plot,list) -S3method(plot,mapLayout) -S3method(plot,simOptions) -export(addShadows) -export(colorScaleOptions) -export(defaultTilesURL) -export(exchangesStack) -export(exchangesStackAliases) -export(getInteractivity) -export(leafletDragPointsOutput) -export(limitSizeGraph) -export(mapLayout) -export(modRpart) -export(modXY) -export(plotMap) -export(plotMapLayout) -export(plotMapOptions) -export(plotThermalGroupCapacities) -export(plotXY) -export(prodStack) -export(prodStackAliases) -export(prodStackExchangesLegend) -export(prodStackLegend) -export(renderLeafletDragPoints) -export(runAppAntaresViz) -export(savePlotAsPng) -export(setExchangesStackAlias) -export(setInteractivity) -export(setProdStackAlias) -export(stackMap) -export(tsLegend) -export(tsPlot) -import(antaresProcessing) -import(antaresRead) -import(assertthat) -import(data.table) -import(dygraphs) -import(htmltools) -import(leaflet) -import(leaflet.minicharts) -import(manipulateWidget) -import(rAmCharts) -import(shiny) -import(sp) -import(spMaps) -importFrom(geojsonio,geojson_json) -importFrom(grDevices,col2rgb) -importFrom(grDevices,colorRampPalette) -importFrom(grDevices,colors) -importFrom(grDevices,gray) -importFrom(grDevices,rainbow) -importFrom(grDevices,rgb) -importFrom(graphics,par) -importFrom(graphics,plot.default) -importFrom(methods,is) -importFrom(plotly,add_bars) -importFrom(plotly,add_heatmap) -importFrom(plotly,add_text) -importFrom(plotly,add_trace) -importFrom(plotly,config) -importFrom(plotly,layout) -importFrom(plotly,plot_ly) -importFrom(raster,aggregate) -importFrom(rgeos,gDistance) -importFrom(shiny,runApp) -importFrom(stats,as.formula) -importFrom(stats,density) -importFrom(stats,lm) -importFrom(stats,predict) -importFrom(stats,quantile) -importFrom(utils,capture.output) -importFrom(utils,object.size) +# Generated by roxygen2: do not edit by hand + +S3method(plot,antaresData) +S3method(plot,list) +S3method(plot,mapLayout) +S3method(plot,simOptions) +export(addShadows) +export(colorScaleOptions) +export(defaultTilesURL) +export(exchangesStack) +export(exchangesStackAliases) +export(getInteractivity) +export(leafletDragPointsOutput) +export(limitSizeGraph) +export(mapLayout) +export(modRpart) +export(modXY) +export(plotMap) +export(plotMapLayout) +export(plotMapOptions) +export(plotThermalGroupCapacities) +export(plotXY) +export(prodStack) +export(prodStackAliases) +export(prodStackExchangesLegend) +export(prodStackLegend) +export(renderLeafletDragPoints) +export(runAppAntaresViz) +export(savePlotAsPng) +export(setExchangesStackAlias) +export(setInteractivity) +export(setProdStackAlias) +export(stackMap) +export(tsLegend) +export(tsPlot) +import(antaresProcessing) +import(antaresRead) +import(assertthat) +import(data.table) +import(dygraphs) +import(htmltools) +import(leaflet) +import(leaflet.minicharts) +import(manipulateWidget) +import(rAmCharts) +import(sf) +import(shiny) +import(sp) +import(spMaps) +importFrom(geojsonio,geojson_json) +importFrom(grDevices,col2rgb) +importFrom(grDevices,colorRampPalette) +importFrom(grDevices,colors) +importFrom(grDevices,gray) +importFrom(grDevices,rainbow) +importFrom(grDevices,rgb) +importFrom(graphics,par) +importFrom(graphics,plot.default) +importFrom(methods,is) +importFrom(plotly,add_bars) +importFrom(plotly,add_heatmap) +importFrom(plotly,add_text) +importFrom(plotly,add_trace) +importFrom(plotly,config) +importFrom(plotly,layout) +importFrom(plotly,plot_ly) +importFrom(shiny,runApp) +importFrom(stats,as.formula) +importFrom(stats,density) +importFrom(stats,lm) +importFrom(stats,predict) +importFrom(stats,quantile) +importFrom(utils,capture.output) +importFrom(utils,object.size) diff --git a/NEWS.md b/NEWS.md index 8a90fa07..ee6a7218 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,8 @@ -Copyright © 2016 RTE Réseau de transport d’électricité +Copyright 2016 RTE Reseau de transport d'electricite + +# antaresViz 0.18.0 +* fix deprecated dependencies (issue #200) + * packages `rgeos`, `raster` removed and replaced by `sf` # antaresViz 0.17.1 diff --git a/R/map_layout.R b/R/map_layout.R index d776d529..8509562d 100644 --- a/R/map_layout.R +++ b/R/map_layout.R @@ -1,645 +1,648 @@ -# Copyright © 2016 RTE Réseau de transport d’électricité - -#' Place areas of a study on a map -#' -#' This function launches an interactive application that let the user place -#' areas of a study on a map. the GPS coordinates of the areas are then returned -#' and can be used in functions. This function should be used only once per -#' study. The result should then be saved in an external file and be reused. -#' -#' @param layout -#' object returned by function \code{\link[antaresRead]{readLayout}} -#' @param what -#' Either "areas" or "districts". Indicates what type of object to place -#' on the map. -#' @param map -#' An optional \code{\link[sp]{SpatialPolygons}} or -#' \code{\link[sp:SpatialPolygons]{SpatialPolygonsDataFrame}} object. See \code{\link[spMaps:spMaps]{getSpMaps}} -#' -#' @param map_builder \code{logical} Add inputs for build custom map ? Defaut to TRUE. -#' -#' @details -#' With \code{map_builder} option, you can build a quiet custom map using \code{spMaps} package. -#' This package help you to build \code{\link[sp:SpatialPolygons]{SpatialPolygonsDataFrame}} on Europe. -#' Moreover, you can use two options in the module : -#' -#' \itemize{ -#' \item {"Merge countries" : Some countries like UK or Belgium are firstly rendered in multiple and diffrent area. -#' You can so choose to finally use this countries as one single area on the map} -#' \item {"Merge states" : If you need states details but not having one area per state, the map will be incomplete -#' for some countries, plotting only states with area. So you can choose to aggregate the states of the countries. -#' This is done using a nearest states algorithm. The result is available only after layout validation.} -#' } -#' @return -#' An object of class \code{mapLayout}. -#' -#' @examples -#' \dontrun{ -#' # Read the coordinates of the areas in the Antares interface, then convert it -#' # in a map layout. -#' layout <- readLayout() -#' ml <- mapLayout(layout) -#' -#' # visualize mapLayout -#' plotMapLayout(ml) -#' -#' # Save the result for future use -#' save(ml, file = "ml.rda") -#' -#' } -#' -#' @export -#' @import spMaps -#' -#' @seealso \code{\link{plotMapLayout}} -mapLayout <- function(layout, what = c("areas", "districts"), map = getSpMaps(), map_builder = TRUE) { - - what <- match.arg(what) - - ui <- fluidPage( - changeCoordsUI("ml", map_builder = map_builder) - ) - - server <- function(input, output, session) { - callModule(changeCoordsServer, "ml", reactive(layout), what = reactive(what), - map = reactive(map), map_builder = map_builder, stopApp = TRUE) - } - - mapCoords <- shiny::runApp(shiny::shinyApp(ui = ui, server = server)) - - mapCoords -} - -#' Visualize mapLayout output. -#' -#' @param mapLayout -#' object returned by function \code{\link{mapLayout}} -#' -#' @examples -#' -#' \dontrun{ -#' # Read the coordinates of the areas in the Antares interface, then convert it -#' # in a map layout. -#' layout <- readLayout() -#' ml <- mapLayout(layout) -#' -#' # visualize mapLayout -#' plotMapLayout(ml) -#' -#' } -#' -#' @export -#' -#' @seealso \code{\link{mapLayout}} -plotMapLayout <- function(mapLayout){ - - if (!is.null(mapLayout$all_coords)){ - coords <- data.frame(mapLayout$all_coords) - colnames(coords) <- gsub("^x$", "lon", colnames(coords)) - colnames(coords) <- gsub("^y$", "lat", colnames(coords)) - coords$info <- coords$area - } else if (is.null(mapLayout$all_coords)){ - coords <- data.frame(mapLayout$coords) - colnames(coords) <- gsub("^x$", "lon", colnames(coords)) - colnames(coords) <- gsub("^y$", "lat", colnames(coords)) - coords$info <- coords$area - } else { - stop("No coordinates found in layout") - } - - leafletDragPoints(coords, map = mapLayout$map, init = TRUE, draggable = FALSE) -} - -# changeCoords Module UI function -changeCoordsUI <- function(id, map_builder = TRUE) { - # Create a namespace function using the provided id - ns <- NS(id) - - ref_map_table <- spMaps::getEuropeReferenceTable() - choices_map <- c("all", ref_map_table$code) - names(choices_map) <- c("all", ref_map_table$name) - - tagList( - fluidRow( - column(3, - if (map_builder){ - selectInput(ns("ml_countries"), "Countries : ", width = "100%", - choices = choices_map, selected = "all", multiple = TRUE) - } - ), - column(3, - if (map_builder){ - selectInput(ns("ml_states"), "States : ", width = "100%", - choices = choices_map, selected = NULL, multiple = TRUE) - } - ), - column(2, - if (map_builder){ - div(br(), checkboxInput(ns("merge_cty"), "Merge countries ?", TRUE), align = "center") - } - ), - column(2, - if (map_builder){ - div(br(), checkboxInput(ns("merge_ste"), "Merge states ?", TRUE), align = "center") - } - ), - column(2, - if (map_builder){ - div(br(), actionButton(ns("set_map_ml"), "Set map"), align = "center") - } - ) - ), - fluidRow( - column(2, - div(br(), actionButton(ns("reset_ml"), "Re-Init layout"), align = "center") - - ), - column(width = 8, div(h3(textOutput(ns("title_layout"))), align = "center")), - column(2, - conditionalPanel( - condition = paste0("output['", ns("control_state"), "'] >= 2"), - div(br(), actionButton(ns("done"), "Done"), align = "center") - ) - ) - ), - - hr(), - - fillRow( - flex = c(NA, 1), - tags$div( - style = "width:200px;", - tags$p(textOutput(ns("order"))), - htmlOutput(ns("info")), - conditionalPanel( - condition = paste0("output['", ns("control_state"), "'] < 2"), - imageOutput(ns("preview"), height = "150px"), - tags$p(), - actionButton(ns("state"), "Next") - ) - ), - leafletDragPointsOutput(ns("map"), height = "700px") - ) - ) -} - -# changeCoords Module SERVER function -#' @import sp -#' @importFrom rgeos gDistance -#' @importFrom raster aggregate -changeCoordsServer <- function(input, output, session, - layout, what = reactive("areas"), - map = reactive(NULL), map_builder = TRUE, - language = reactive("en"), stopApp = FALSE){ - - ns <- session$ns - - lfDragPoints <- reactiveValues(map = NULL, init = FALSE) - - current_state <- reactiveValues(state = -1) - output$control_state <- reactive({ - current_state$state - }) - - observe({ - updateSelectInput(session, "ml_countries", - label = paste0(.getLabelLanguage("Countries", language()), " : ")) - updateSelectInput(session, "ml_states", - label = paste0(.getLabelLanguage("States", language()), " : ")) - - updateCheckboxInput(session, "merge_cty", .getLabelLanguage("Merge countries ?", language())) - updateCheckboxInput(session, "merge_ste", .getLabelLanguage("Merge states ?", language())) - - updateActionButton(session, "state", label = .getLabelLanguage("Next", language())) - updateActionButton(session, "done", label = .getLabelLanguage("Done", language())) - updateActionButton(session, "reset_ml", label = .getLabelLanguage("Re-Init layout", language())) - updateActionButton(session, "set_map_ml", label = .getLabelLanguage("Set map", language())) - - }) - - output$title_layout <- renderText({ - .getLabelLanguage("Map Layout", language()) - }) - - outputOptions(output, "control_state", suspendWhenHidden = FALSE) - - current_map <- reactive({ - if (!map_builder){ - checkSlotId(map()) - } else { - if (!is.null(map()) & input$set_map_ml == 0){ - checkSlotId(map()) - } else { - checkSlotId(getSpMaps(countries = isolate(input$ml_countries), states = isolate(input$ml_states), - mergeCountry = isolate(input$merge_cty))) - } - } - }) - - data <- reactive({ - input$reset_ml - if (!is.null(layout())){ - if (what() == "areas") { - coords <- copy(layout()$areas) - info <- coords$area - links <- copy(layout()$links) - if(is.null(links)) links <- data.table() - } else { - coords <- copy(layout()$districts) - info <- coords$district - links <- copy(layout()$districtLinks) - if(is.null(links)) links <- data.table() - } - - links$x0 <- as.numeric(links$x0) - links$x1 <- as.numeric(links$x1) - links$y0 <- as.numeric(links$y0) - links$y1 <- as.numeric(links$y1) - - current_state$state <- 0 - - list(coords = coords, info = info, links = links) - } else { - NULL - } - }) - - data_points <- reactiveValues() - - observe({ - if (!is.null(data())){ - cur_points <- data.frame(lon = data()$coords$x, lat = data()$coords$y, - oldLon = data()$coords$x, oldLat = data()$coords$y, - color = data()$coords$color, info = as.character(data()$info), stringsAsFactors = FALSE) - isolate({ - data_points$points <- cur_points - - avgCoord <- rowMeans(data_points$points[, c("lon", "lat")]) - pt1 <- which.min(avgCoord) - pt2 <- which.max(avgCoord) - - data_points$points$lon[pt1] <- data_points$points$lat[pt1] <- 0 - - data_points$pt1 <- pt1 - data_points$pt2 <- pt2 - - }) - } - }) - - renderPreview <- function(pt) { - renderPlot({ - points <- isolate(data_points$points) - if (!is.null(points)){ - col <- rep("#cccccc", nrow(points)) - col[pt] <- "red" - cex <- rep(1, nrow(points)) - cex[pt] <- 2 - par (mar = rep(0.1, 4)) - graphics::plot.default(points$oldLon, points$oldLat, bty = "n", xaxt = "n", yaxt = "n", - xlab = "", ylab = "", main = "", col = col, asp = 1, pch = 19, cex = cex) - } - }) - } - - observeEvent(input$state, { - if (input$state > 0){ - current_state$state <- current_state$state + 1 - } - }) - - observeEvent(input$reset_ml, { - if (input$state >= 0){ - current_state$state <- 0 - } - }) - - observe({ - if (current_state$state == 0) { - lfDragPoints$map <- leafletDragPoints(data_points$points[data_points$pt1, ], isolate(current_map()), init = TRUE) - } - }) - - observe({ - if (current_state$state == 1) { - lfDragPoints$map <- leafletDragPoints(data_points$points[data_points$pt2, ]) - } - }) - - observe({ - if (current_state$state == 2) { - lfDragPoints$map <- leafletDragPoints(data_points$points[-c(data_points$pt1, data_points$pt2), ]) - } - }) - - observe({ - if (!is.null(input$map_init)){ - if (input$map_init){ - lfDragPoints$map <- leafletDragPoints(NULL, current_map(), reset_map = TRUE) - } - } - }) - - # Initialize outputs - output$map <- renderLeafletDragPoints({lfDragPoints$map}) - - coords <- reactive({ - coords <- matrix(input[[paste0("map", "_coords")]], ncol = 2, byrow = TRUE) - colnames(coords) <- c("lat", "lon") - as.data.frame(coords) - }) - - observe({ - if (current_state$state == 0) { - output$order <- renderText({ - .getLabelLanguage("Please place the following point on the map", language()) - }) - - output$info <- renderUI(HTML(data_points$points$info[data_points$pt1])) - output$preview <- renderPreview(data_points$pt1) - } else if (current_state$state == 1) { - isolate({ - data_points$points$lat[data_points$pt2] <- input[[paste0("map", "_mapcenter")]]$lat - data_points$points$lon[data_points$pt2] <- input[[paste0("map", "_mapcenter")]]$lng - output$info <- renderUI(HTML(data_points$points$info[data_points$pt2])) - output$preview <- renderPreview(data_points$pt2) - }) - } else if (current_state$state == 2) { - isolate({ - data_points$points <- .changeCoordinates(data_points$points, coords(), c(data_points$pt1, data_points$pt2)) - output$order <- renderText({ - .getLabelLanguage("Drag the markers on the map to adjust coordinates then click the 'Done' button", language()) - }) - - output$info <- renderUI(HTML( - paste0("

", - .getLabelLanguage("You can click on a marker to display information", language()), - "

")) - ) - - }) - } - }) - - # get coord - cur_coords <- reactiveValues(data = NULL) - - # When the Done button is clicked, return a value - observeEvent(input$done, { - coords <- sp::SpatialPoints(coords()[, c("lon", "lat")], - proj4string = sp::CRS("+proj=longlat +datum=WGS84")) - - # special with only one area... - if(nrow(data()$coords) == 1){ - coords <- coords[1, ] - } - - map <- current_map() - - if (!is.null(map)) { - map <- sp::spTransform(map, sp::CRS("+proj=longlat +datum=WGS84")) - map$geoAreaId <- 1:length(map) - coords$geoAreaId <- sp::over(coords, map)$geoAreaId - } - - # Put coords in right order - if(nrow(data()$coords) > 1){ - ord <- order(c(data_points$pt1, data_points$pt2, (1:length(coords))[-c(data_points$pt1, data_points$pt2)])) - mapCoords <- coords[ord, ] - } else { - mapCoords <- coords - } - - final_coords <- data()$coords - final_links <- data()$links - - final_coords$x <- sp::coordinates(mapCoords)[, 1] - final_coords$y <- sp::coordinates(mapCoords)[, 2] - - if (what() == "areas") { - if(!is.null(final_links) && nrow(final_links) > 0){ - final_links[final_coords, `:=`(x0 = x, y0 = y), on = c(from = "area")] - final_links[final_coords, `:=`(x1 = x, y1 = y), on = c(to = "area")] - } - } else { - if(!is.null(final_links) && nrow(final_links) > 0){ - final_links[final_coords, `:=`(x0 = x, y0 = y), on = c(fromDistrict = "district")] - final_links[final_coords, `:=`(x1 = x, y1 = y), on = c(toDistrict = "district")] - } - } - - if (!is.null(map)) { - final_coords$geoAreaId <- mapCoords$geoAreaId - final_coords_map <- final_coords[!is.na(final_coords$geoAreaId), ] - if (!isolate(input$merge_ste)){ - map <- map[final_coords_map$geoAreaId, ] - } else { - if (all(c("name", "code") %in% names(map))){ - keep_code <- unique(map$code[final_coords_map$geoAreaId]) - # subset on countries - tmp_map <- map[map$code %in% keep_code, ] - - if (nrow(tmp_map) > 0){ - # set unlink states - tmp_map$geoAreaId[!tmp_map$geoAreaId %in% final_coords_map$geoAreaId] <- NA - - ind_na <- which(is.na(tmp_map$geoAreaId)) - if (length(ind_na) > 0){ - # have to find nearestArea... - treat_cty <- unique(tmp_map$code[ind_na]) - - for (cty in treat_cty){ - ind_cty <- which(tmp_map$code %in% cty) - ind_miss <- which(tmp_map$code %in% cty & is.na(tmp_map$geoAreaId)) - areas <- coords[coords$geoAreaId %in% tmp_map$geoAreaId[ind_cty], ] - if (nrow(areas) > 0){ - areas_min <- suppressWarnings(apply(rgeos::gDistance(tmp_map[ind_miss, ], areas, byid = TRUE), 2, which.min)) - tmp_map$geoAreaId[ind_miss] <- areas$geoAreaId[areas_min] - } - } - - tmp_map <- raster::aggregate(tmp_map, by = c("geoAreaId")) - map <- tmp_map[match(final_coords_map$geoAreaId, tmp_map$geoAreaId), ] - } else { - map <- map[final_coords_map$geoAreaId, ] - } - }else { - map <- map[final_coords_map$geoAreaId, ] - } - } else { - map <- map[final_coords_map$geoAreaId, ] - } - # remove if multiple same polygon. Needed other change... - # map <- map[!duplicated(map$geoAreaId), ] - } - - res <- list(coords = final_coords_map, links = final_links, map = map, all_coords = final_coords) - - } else { - res <- list(coords = final_coords, links = final_links, map = map, all_coords = final_coords) - } - - class(res) <- "mapLayout" - attr(res, "type") <- what() - - cur_coords$data <- res - - if (stopApp){ - stopApp(res) - } - }) - - return(reactive(cur_coords$data)) -} - -.changeCoordinates <- function(points, coords, pts = 1:nrow(points)) { - coords$oldLon <- points$oldLon[pts] - regLon <- lm(lon ~ oldLon, data = coords) - points$lon <- predict(regLon, newdata = points) - - coords$oldLat <- points$oldLat[pts] - regLat <- lm(lat ~ oldLat, data = coords) - points$lat <- predict(regLat, newdata = points) - - points$oldLon <- points$oldLat <- NULL - - points -} - -#' Plot method for map layout -#' -#' This method can be used to visualize the network of an antares study. -#' It generates an interactive map with a visual representaiton of a -#' map layout created with function \code{\link{mapLayout}}. -#' -#' @param x -#' Object created with function \code{\link{mapLayout}} -#' @param colAreas -#' Vector of colors for areas. By default, the colors used in the Antares -#' software are used. -#' @param dataAreas -#' A numeric vector or a numeric matrix that is passed to function -#' \code{link[addMinicharts]}. A single vector will produce circles with -#' different radius. A matrix will produce bar charts or pie charts or -#' polar charts, depending on the value of \code{areaChartType} -#' @param opacityArea Opacity of areas. It has to be a numeric vector with values -#' between 0 and 1. -#' @param areaMaxSize Maximal width in pixels of the symbols that represent -#' areas on the map. -#' @param areaChartType Type of chart to use to represent areas. -#' @param labelArea Character vector containing labels to display inside areas. -#' @param colLinks -#' Vector of colors for links. -#' @param sizeLinks -#' Line width of the links, in pixels. -#' @param opacityLinks Opacity of the links. It has to be a numeric vector with values -#' between 0 and 1. -#' @param dirLinks -#' Single value or vector indicating the direction of the link. Possible values -#' are 0, -1 and 1. If it equals 0, then links are repsented by a simple line. -#' If it is equal to 1 or -1 it is represented by a line with an arrow pointing -#' respectively the destination and the origin of the link. -#' @param areas -#' Should areas be drawn on the map ? -#' @param links -#' Should links be drawn on the map ? -#' @param ... -#' Currently unused. -#' @inheritParams prodStack -#' @inheritParams plotMapOptions -#' -#' @return -#' The function generates an \code{htmlwidget} of class \code{leaflet}. It can -#' be stored in a variable and modified with package -#' \code{\link[leaflet]{leaflet}} -#' -#' @method plot mapLayout -#' -#' @examples -#' \dontrun{ -#' # Read the coordinates of the areas in the Antares interface, then convert it -#' # in a map layout. -#' layout <- readLayout() -#' ml <- mapLayout(layout) -#' -#' # Save the result for future use -#' save(ml, file = "ml.rda") -#' -#' # Plot the network on an interactive map -#' plot(ml) -#' -#' # change style -#' plot(ml, colAreas = gray(0.5), colLinks = "orange") -#' -#' # Use polar area charts to represent multiple values for each area. -#' nareas <- nrow(ml$coords) -#' fakeData <- matrix(runif(nareas * 3), ncol = 3) -#' plot(ml, sizeAreas = fakeData) -#' -#' # Store the result in a variable to change it with functions from leaflet -#' # package -#' library(leaflet) -#' -#' center <- c(mean(ml$coords$x), mean(ml$coords$y)) -#' -#' p <- plot(ml) -#' p %>% -#' addCircleMarker(center[1], center[2], color = "red", -#' popup = "I'm the center !") -#' } -#' -#' @export -plot.mapLayout <- function(x, colAreas = x$coords$color, dataAreas = 1, - opacityArea = 1, areaMaxSize = 30, areaMaxHeight = 50, - areaChartType = c("auto", "bar", "pie", "polar-area", "polar-radius"), - labelArea = NULL, labelMinSize = 8, labelMaxSize = 8, - colLinks = "#CCCCCC", sizeLinks = 3, - opacityLinks = 1, dirLinks = 0, - links = TRUE, areas = TRUE, tilesURL = defaultTilesURL(), - preprocess = function(map) {map}, - width = NULL, height = NULL, ...) { - - areaChartType <- match.arg(areaChartType) - - map <- leaflet(width = width, height = height, padding = 10) %>% addTiles(tilesURL) - - # Add Polygons - if (areas & !is.null(x$map)) { - map <- addPolygons(map, data = x$map, layerId = x$coords$area, fillColor = colAreas, weight = 1, - fillOpacity = 1, color = "#333") - } - - # Add custom elements - if (is.function(preprocess)){ - map <- preprocess(map) - } - - # Add links - if (links) { - map <- addFlows(map, x$links$x0, x$links$y0, x$links$x1, x$links$y1, dir = dirLinks, - flow = abs(sizeLinks), opacity = opacityLinks, maxFlow = 1, maxThickness = 1, - color = colLinks, layerId = x$links$link) - } - - # Add areas - if (areas) { - - areaChartType <- match.arg(areaChartType) - - # fix bug if set map wihout any intersection with areas...! - map <- tryCatch(addMinicharts(map, lng = x$coords$x, lat = x$coords$y, - chartdata = dataAreas, fillColor = colAreas, - showLabels = !is.null(labelArea), - labelText = labelArea, - width = areaMaxSize, - height = areaMaxHeight, - layerId = x$coords$area, - opacity = opacityArea, - labelMinSize = labelMinSize, - labelMaxSize = labelMaxSize), error = function(e) map) - - } - - # Add shadows to elements - map %>% addShadows() -} +# Copyright © 2016 RTE Réseau de transport d’électricité + +#' Place areas of a study on a map +#' +#' This function launches an interactive application that let the user place +#' areas of a study on a map. the GPS coordinates of the areas are then returned +#' and can be used in functions. This function should be used only once per +#' study. The result should then be saved in an external file and be reused. +#' +#' @param layout +#' object returned by function \code{\link[antaresRead]{readLayout}} +#' @param what +#' Either "areas" or "districts". Indicates what type of object to place +#' on the map. +#' @param map +#' An optional \code{\link[sp]{SpatialPolygons}} or +#' \code{\link[sp:SpatialPolygons]{SpatialPolygonsDataFrame}} object. See \code{\link[spMaps:spMaps]{getSpMaps}} +#' +#' @param map_builder \code{logical} Add inputs for build custom map ? Defaut to TRUE. +#' +#' @details +#' With \code{map_builder} option, you can build a quiet custom map using \code{spMaps} package. +#' This package help you to build \code{\link[sp:SpatialPolygons]{SpatialPolygonsDataFrame}} on Europe. +#' Moreover, you can use two options in the module : +#' +#' \itemize{ +#' \item {"Merge countries" : Some countries like UK or Belgium are firstly rendered in multiple and diffrent area. +#' You can so choose to finally use this countries as one single area on the map} +#' \item {"Merge states" : If you need states details but not having one area per state, the map will be incomplete +#' for some countries, plotting only states with area. So you can choose to aggregate the states of the countries. +#' This is done using a nearest states algorithm. The result is available only after layout validation.} +#' } +#' @return +#' An object of class \code{mapLayout}. +#' +#' @examples +#' \dontrun{ +#' # Read the coordinates of the areas in the Antares interface, then convert it +#' # in a map layout. +#' layout <- readLayout() +#' ml <- mapLayout(layout) +#' +#' # visualize mapLayout +#' plotMapLayout(ml) +#' +#' # Save the result for future use +#' save(ml, file = "ml.rda") +#' +#' } +#' +#' @export +#' @import spMaps +#' +#' @seealso \code{\link{plotMapLayout}} +mapLayout <- function(layout, what = c("areas", "districts"), map = getSpMaps(), map_builder = TRUE) { + + what <- match.arg(what) + + ui <- fluidPage( + changeCoordsUI("ml", map_builder = map_builder) + ) + + server <- function(input, output, session) { + callModule(changeCoordsServer, "ml", reactive(layout), what = reactive(what), + map = reactive(map), map_builder = map_builder, stopApp = TRUE) + } + + mapCoords <- shiny::runApp(shiny::shinyApp(ui = ui, server = server)) + + mapCoords +} + +#' Visualize mapLayout output. +#' +#' @param mapLayout +#' object returned by function \code{\link{mapLayout}} +#' +#' @examples +#' +#' \dontrun{ +#' # Read the coordinates of the areas in the Antares interface, then convert it +#' # in a map layout. +#' layout <- readLayout() +#' ml <- mapLayout(layout) +#' +#' # visualize mapLayout +#' plotMapLayout(ml) +#' +#' } +#' +#' @export +#' +#' @seealso \code{\link{mapLayout}} +plotMapLayout <- function(mapLayout){ + + if (!is.null(mapLayout$all_coords)){ + coords <- data.frame(mapLayout$all_coords) + colnames(coords) <- gsub("^x$", "lon", colnames(coords)) + colnames(coords) <- gsub("^y$", "lat", colnames(coords)) + coords$info <- coords$area + } else if (is.null(mapLayout$all_coords)){ + coords <- data.frame(mapLayout$coords) + colnames(coords) <- gsub("^x$", "lon", colnames(coords)) + colnames(coords) <- gsub("^y$", "lat", colnames(coords)) + coords$info <- coords$area + } else { + stop("No coordinates found in layout") + } + + leafletDragPoints(coords, map = mapLayout$map, init = TRUE, draggable = FALSE) +} + +# changeCoords Module UI function +changeCoordsUI <- function(id, map_builder = TRUE) { + # Create a namespace function using the provided id + ns <- NS(id) + + ref_map_table <- spMaps::getEuropeReferenceTable() + choices_map <- c("all", ref_map_table$code) + names(choices_map) <- c("all", ref_map_table$name) + + tagList( + fluidRow( + column(3, + if (map_builder){ + selectInput(ns("ml_countries"), "Countries : ", width = "100%", + choices = choices_map, selected = "all", multiple = TRUE) + } + ), + column(3, + if (map_builder){ + selectInput(ns("ml_states"), "States : ", width = "100%", + choices = choices_map, selected = NULL, multiple = TRUE) + } + ), + column(2, + if (map_builder){ + div(br(), checkboxInput(ns("merge_cty"), "Merge countries ?", TRUE), align = "center") + } + ), + column(2, + if (map_builder){ + div(br(), checkboxInput(ns("merge_ste"), "Merge states ?", TRUE), align = "center") + } + ), + column(2, + if (map_builder){ + div(br(), actionButton(ns("set_map_ml"), "Set map"), align = "center") + } + ) + ), + fluidRow( + column(2, + div(br(), actionButton(ns("reset_ml"), "Re-Init layout"), align = "center") + + ), + column(width = 8, div(h3(textOutput(ns("title_layout"))), align = "center")), + column(2, + conditionalPanel( + condition = paste0("output['", ns("control_state"), "'] >= 2"), + div(br(), actionButton(ns("done"), "Done"), align = "center") + ) + ) + ), + + hr(), + + fillRow( + flex = c(NA, 1), + tags$div( + style = "width:200px;", + tags$p(textOutput(ns("order"))), + htmlOutput(ns("info")), + conditionalPanel( + condition = paste0("output['", ns("control_state"), "'] < 2"), + imageOutput(ns("preview"), height = "150px"), + tags$p(), + actionButton(ns("state"), "Next") + ) + ), + leafletDragPointsOutput(ns("map"), height = "700px") + ) + ) +} + +# changeCoords Module SERVER function +#' @import sp +#' @import sf +changeCoordsServer <- function(input, output, session, + layout, what = reactive("areas"), + map = reactive(NULL), map_builder = TRUE, + language = reactive("en"), stopApp = FALSE){ + + ns <- session$ns + + lfDragPoints <- reactiveValues(map = NULL, init = FALSE) + + current_state <- reactiveValues(state = -1) + output$control_state <- reactive({ + current_state$state + }) + + observe({ + updateSelectInput(session, "ml_countries", + label = paste0(.getLabelLanguage("Countries", language()), " : ")) + updateSelectInput(session, "ml_states", + label = paste0(.getLabelLanguage("States", language()), " : ")) + + updateCheckboxInput(session, "merge_cty", .getLabelLanguage("Merge countries ?", language())) + updateCheckboxInput(session, "merge_ste", .getLabelLanguage("Merge states ?", language())) + + updateActionButton(session, "state", label = .getLabelLanguage("Next", language())) + updateActionButton(session, "done", label = .getLabelLanguage("Done", language())) + updateActionButton(session, "reset_ml", label = .getLabelLanguage("Re-Init layout", language())) + updateActionButton(session, "set_map_ml", label = .getLabelLanguage("Set map", language())) + + }) + + output$title_layout <- renderText({ + .getLabelLanguage("Map Layout", language()) + }) + + outputOptions(output, "control_state", suspendWhenHidden = FALSE) + + current_map <- reactive({ + if (!map_builder){ + checkSlotId(map()) + } else { + if (!is.null(map()) & input$set_map_ml == 0){ + checkSlotId(map()) + } else { + checkSlotId(getSpMaps(countries = isolate(input$ml_countries), states = isolate(input$ml_states), + mergeCountry = isolate(input$merge_cty))) + } + } + }) + + data <- reactive({ + input$reset_ml + if (!is.null(layout())){ + if (what() == "areas") { + coords <- copy(layout()$areas) + info <- coords$area + links <- copy(layout()$links) + if(is.null(links)) links <- data.table() + } else { + coords <- copy(layout()$districts) + info <- coords$district + links <- copy(layout()$districtLinks) + if(is.null(links)) links <- data.table() + } + + links$x0 <- as.numeric(links$x0) + links$x1 <- as.numeric(links$x1) + links$y0 <- as.numeric(links$y0) + links$y1 <- as.numeric(links$y1) + + current_state$state <- 0 + + list(coords = coords, info = info, links = links) + } else { + NULL + } + }) + + data_points <- reactiveValues() + + observe({ + if (!is.null(data())){ + cur_points <- data.frame(lon = data()$coords$x, lat = data()$coords$y, + oldLon = data()$coords$x, oldLat = data()$coords$y, + color = data()$coords$color, info = as.character(data()$info), stringsAsFactors = FALSE) + isolate({ + data_points$points <- cur_points + + avgCoord <- rowMeans(data_points$points[, c("lon", "lat")]) + pt1 <- which.min(avgCoord) + pt2 <- which.max(avgCoord) + + data_points$points$lon[pt1] <- data_points$points$lat[pt1] <- 0 + + data_points$pt1 <- pt1 + data_points$pt2 <- pt2 + + }) + } + }) + + renderPreview <- function(pt) { + renderPlot({ + points <- isolate(data_points$points) + if (!is.null(points)){ + col <- rep("#cccccc", nrow(points)) + col[pt] <- "red" + cex <- rep(1, nrow(points)) + cex[pt] <- 2 + par (mar = rep(0.1, 4)) + graphics::plot.default(points$oldLon, points$oldLat, bty = "n", xaxt = "n", yaxt = "n", + xlab = "", ylab = "", main = "", col = col, asp = 1, pch = 19, cex = cex) + } + }) + } + + observeEvent(input$state, { + if (input$state > 0){ + current_state$state <- current_state$state + 1 + } + }) + + observeEvent(input$reset_ml, { + if (input$state >= 0){ + current_state$state <- 0 + } + }) + + observe({ + if (current_state$state == 0) { + lfDragPoints$map <- leafletDragPoints(data_points$points[data_points$pt1, ], isolate(current_map()), init = TRUE) + } + }) + + observe({ + if (current_state$state == 1) { + lfDragPoints$map <- leafletDragPoints(data_points$points[data_points$pt2, ]) + } + }) + + observe({ + if (current_state$state == 2) { + lfDragPoints$map <- leafletDragPoints(data_points$points[-c(data_points$pt1, data_points$pt2), ]) + } + }) + + observe({ + if (!is.null(input$map_init)){ + if (input$map_init){ + lfDragPoints$map <- leafletDragPoints(NULL, current_map(), reset_map = TRUE) + } + } + }) + + # Initialize outputs + output$map <- renderLeafletDragPoints({lfDragPoints$map}) + + coords <- reactive({ + coords <- matrix(input[[paste0("map", "_coords")]], ncol = 2, byrow = TRUE) + colnames(coords) <- c("lat", "lon") + as.data.frame(coords) + }) + + observe({ + if (current_state$state == 0) { + output$order <- renderText({ + .getLabelLanguage("Please place the following point on the map", language()) + }) + + output$info <- renderUI(HTML(data_points$points$info[data_points$pt1])) + output$preview <- renderPreview(data_points$pt1) + } else if (current_state$state == 1) { + isolate({ + data_points$points$lat[data_points$pt2] <- input[[paste0("map", "_mapcenter")]]$lat + data_points$points$lon[data_points$pt2] <- input[[paste0("map", "_mapcenter")]]$lng + output$info <- renderUI(HTML(data_points$points$info[data_points$pt2])) + output$preview <- renderPreview(data_points$pt2) + }) + } else if (current_state$state == 2) { + isolate({ + data_points$points <- .changeCoordinates(data_points$points, coords(), c(data_points$pt1, data_points$pt2)) + output$order <- renderText({ + .getLabelLanguage("Drag the markers on the map to adjust coordinates then click the 'Done' button", language()) + }) + + output$info <- renderUI(HTML( + paste0("

", + .getLabelLanguage("You can click on a marker to display information", language()), + "

")) + ) + + }) + } + }) + + # get coord + cur_coords <- reactiveValues(data = NULL) + + # When the Done button is clicked, return a value + observeEvent(input$done, { + coords <- sp::SpatialPoints(coords()[, c("lon", "lat")], + proj4string = sp::CRS("+proj=longlat +datum=WGS84")) + + # special with only one area... + if(nrow(data()$coords) == 1){ + coords <- coords[1, ] + } + + map <- current_map() + + if (!is.null(map)) { + map <- sp::spTransform(map, sp::CRS("+proj=longlat +datum=WGS84")) + map$geoAreaId <- 1:length(map) + coords$geoAreaId <- sp::over(coords, map)$geoAreaId + } + + # Put coords in right order + if(nrow(data()$coords) > 1){ + ord <- order(c(data_points$pt1, data_points$pt2, (1:length(coords))[-c(data_points$pt1, data_points$pt2)])) + mapCoords <- coords[ord, ] + } else { + mapCoords <- coords + } + + final_coords <- data()$coords + final_links <- data()$links + + final_coords$x <- sp::coordinates(mapCoords)[, 1] + final_coords$y <- sp::coordinates(mapCoords)[, 2] + + if (what() == "areas") { + if(!is.null(final_links) && nrow(final_links) > 0){ + final_links[final_coords, `:=`(x0 = x, y0 = y), on = c(from = "area")] + final_links[final_coords, `:=`(x1 = x, y1 = y), on = c(to = "area")] + } + } else { + if(!is.null(final_links) && nrow(final_links) > 0){ + final_links[final_coords, `:=`(x0 = x, y0 = y), on = c(fromDistrict = "district")] + final_links[final_coords, `:=`(x1 = x, y1 = y), on = c(toDistrict = "district")] + } + } + + if (!is.null(map)) { + final_coords$geoAreaId <- mapCoords$geoAreaId + final_coords_map <- final_coords[!is.na(final_coords$geoAreaId), ] + if (!isolate(input$merge_ste)){ + map <- map[final_coords_map$geoAreaId, ] + } else { + if (all(c("name", "code") %in% names(map))){ + keep_code <- unique(map$code[final_coords_map$geoAreaId]) + # subset on countries + tmp_map <- map[map$code %in% keep_code, ] + + if (nrow(tmp_map) > 0){ + # set unlink states + tmp_map$geoAreaId[!tmp_map$geoAreaId %in% final_coords_map$geoAreaId] <- NA + + ind_na <- which(is.na(tmp_map$geoAreaId)) + if (length(ind_na) > 0){ + # have to find nearestArea... + treat_cty <- unique(tmp_map$code[ind_na]) + + for (cty in treat_cty){ + ind_cty <- which(tmp_map$code %in% cty) + ind_miss <- which(tmp_map$code %in% cty & is.na(tmp_map$geoAreaId)) + areas <- coords[coords$geoAreaId %in% tmp_map$geoAreaId[ind_cty], ] + if (nrow(areas) > 0){ + tmp_sf <- st_as_sf(tmp_map[ind_miss, ]) + areas_sf <- st_as_sf(areas) + dist_matrix <- st_distance(tmp_sf, areas_sf) + areas_min <- suppressWarnings(apply(dist_matrix, 1, which.min)) + tmp_map$geoAreaId[ind_miss] <- areas$geoAreaId[areas_min] + } + } + tmp_sf <- st_cast(tmp_map, "MULTIPOLYGON") # Cast to multipolygon if needed + tmp_sf <- st_cast(tmp_sf, "GEOMETRY") # Remove unused geometry types + tmp_sf <- st_combine(tmp_sf) # Combine features with the same geoAreaId + map <- tmp_sf[match(final_coords_map$geoAreaId, tmp_map$geoAreaId), ] + } else { + map <- map[match(final_coords_map$geoAreaId, map$geoAreaId), ] + } + }else { + map <- map[match(final_coords_map$geoAreaId, map$geoAreaId), ] + } + } else { + map <- map[match(final_coords_map$geoAreaId, map$geoAreaId), ] + } + # remove if multiple same polygon. Needed other change... + # map <- map[!duplicated(map$geoAreaId), ] + } + + res <- list(coords = final_coords_map, links = final_links, map = map, all_coords = final_coords) + + } else { + res <- list(coords = final_coords, links = final_links, map = map, all_coords = final_coords) + } + + class(res) <- "mapLayout" + attr(res, "type") <- what() + + cur_coords$data <- res + + if (stopApp){ + stopApp(res) + } + }) + + return(reactive(cur_coords$data)) +} + +.changeCoordinates <- function(points, coords, pts = 1:nrow(points)) { + coords$oldLon <- points$oldLon[pts] + regLon <- lm(lon ~ oldLon, data = coords) + points$lon <- predict(regLon, newdata = points) + + coords$oldLat <- points$oldLat[pts] + regLat <- lm(lat ~ oldLat, data = coords) + points$lat <- predict(regLat, newdata = points) + + points$oldLon <- points$oldLat <- NULL + + points +} + +#' Plot method for map layout +#' +#' This method can be used to visualize the network of an antares study. +#' It generates an interactive map with a visual representaiton of a +#' map layout created with function \code{\link{mapLayout}}. +#' +#' @param x +#' Object created with function \code{\link{mapLayout}} +#' @param colAreas +#' Vector of colors for areas. By default, the colors used in the Antares +#' software are used. +#' @param dataAreas +#' A numeric vector or a numeric matrix that is passed to function +#' \code{link[addMinicharts]}. A single vector will produce circles with +#' different radius. A matrix will produce bar charts or pie charts or +#' polar charts, depending on the value of \code{areaChartType} +#' @param opacityArea Opacity of areas. It has to be a numeric vector with values +#' between 0 and 1. +#' @param areaMaxSize Maximal width in pixels of the symbols that represent +#' areas on the map. +#' @param areaChartType Type of chart to use to represent areas. +#' @param labelArea Character vector containing labels to display inside areas. +#' @param colLinks +#' Vector of colors for links. +#' @param sizeLinks +#' Line width of the links, in pixels. +#' @param opacityLinks Opacity of the links. It has to be a numeric vector with values +#' between 0 and 1. +#' @param dirLinks +#' Single value or vector indicating the direction of the link. Possible values +#' are 0, -1 and 1. If it equals 0, then links are repsented by a simple line. +#' If it is equal to 1 or -1 it is represented by a line with an arrow pointing +#' respectively the destination and the origin of the link. +#' @param areas +#' Should areas be drawn on the map ? +#' @param links +#' Should links be drawn on the map ? +#' @param ... +#' Currently unused. +#' @inheritParams prodStack +#' @inheritParams plotMapOptions +#' +#' @return +#' The function generates an \code{htmlwidget} of class \code{leaflet}. It can +#' be stored in a variable and modified with package +#' \code{\link[leaflet]{leaflet}} +#' +#' @method plot mapLayout +#' +#' @examples +#' \dontrun{ +#' # Read the coordinates of the areas in the Antares interface, then convert it +#' # in a map layout. +#' layout <- readLayout() +#' ml <- mapLayout(layout) +#' +#' # Save the result for future use +#' save(ml, file = "ml.rda") +#' +#' # Plot the network on an interactive map +#' plot(ml) +#' +#' # change style +#' plot(ml, colAreas = gray(0.5), colLinks = "orange") +#' +#' # Use polar area charts to represent multiple values for each area. +#' nareas <- nrow(ml$coords) +#' fakeData <- matrix(runif(nareas * 3), ncol = 3) +#' plot(ml, sizeAreas = fakeData) +#' +#' # Store the result in a variable to change it with functions from leaflet +#' # package +#' library(leaflet) +#' +#' center <- c(mean(ml$coords$x), mean(ml$coords$y)) +#' +#' p <- plot(ml) +#' p %>% +#' addCircleMarker(center[1], center[2], color = "red", +#' popup = "I'm the center !") +#' } +#' +#' @export +plot.mapLayout <- function(x, colAreas = x$coords$color, dataAreas = 1, + opacityArea = 1, areaMaxSize = 30, areaMaxHeight = 50, + areaChartType = c("auto", "bar", "pie", "polar-area", "polar-radius"), + labelArea = NULL, labelMinSize = 8, labelMaxSize = 8, + colLinks = "#CCCCCC", sizeLinks = 3, + opacityLinks = 1, dirLinks = 0, + links = TRUE, areas = TRUE, tilesURL = defaultTilesURL(), + preprocess = function(map) {map}, + width = NULL, height = NULL, ...) { + + areaChartType <- match.arg(areaChartType) + + map <- leaflet(width = width, height = height, padding = 10) %>% addTiles(tilesURL) + + # Add Polygons + if (areas & !is.null(x$map)) { + map <- addPolygons(map, data = x$map, layerId = x$coords$area, fillColor = colAreas, weight = 1, + fillOpacity = 1, color = "#333") + } + + # Add custom elements + if (is.function(preprocess)){ + map <- preprocess(map) + } + + # Add links + if (links) { + map <- addFlows(map, x$links$x0, x$links$y0, x$links$x1, x$links$y1, dir = dirLinks, + flow = abs(sizeLinks), opacity = opacityLinks, maxFlow = 1, maxThickness = 1, + color = colLinks, layerId = x$links$link) + } + + # Add areas + if (areas) { + + areaChartType <- match.arg(areaChartType) + + # fix bug if set map wihout any intersection with areas...! + map <- tryCatch(addMinicharts(map, lng = x$coords$x, lat = x$coords$y, + chartdata = dataAreas, fillColor = colAreas, + showLabels = !is.null(labelArea), + labelText = labelArea, + width = areaMaxSize, + height = areaMaxHeight, + layerId = x$coords$area, + opacity = opacityArea, + labelMinSize = labelMinSize, + labelMaxSize = labelMaxSize), error = function(e) map) + + } + + # Add shadows to elements + map %>% addShadows() +} diff --git a/README.md b/README.md index 56c46049..35b327d4 100644 --- a/README.md +++ b/README.md @@ -6,9 +6,9 @@ > `antaresViz` is the package to visualize the results of your Antares simulations that you have imported in the R session with package `antaresRead`. It provides some functions that generate interactive visualisations. Moreover, by default, these functions launch a shiny widget that provides some controls to dynamically choose what data is displayed in the graphics. -[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/antaresViz)](https://cran.r-project.org/package=antaresViz) -[![codecov](https://codecov.io/gh/rte-antares-rpackage/antaresViz/branch/develop/graph/badge.svg)](https://app.codecov.io/gh/rte-antares-rpackage/antaresViz) [![R build status](https://github.com/rte-antares-rpackage/antaresViz/workflows/R-CMD-check/badge.svg)](https://github.com/rte-antares-rpackage/antaresViz/actions) +[![Codecov test coverage](https://codecov.io/gh/rte-antares-rpackage/antaresViz/branch/master/graph/badge.svg)](https://app.codecov.io/gh/rte-antares-rpackage/antaresViz?branch=master) +[![CRAN status](https://www.r-pkg.org/badges/version/antaresViz)](https://CRAN.R-project.org/package=antaresViz) diff --git a/antaresViz.Rproj b/antaresViz.Rproj new file mode 100644 index 00000000..e4cfd182 --- /dev/null +++ b/antaresViz.Rproj @@ -0,0 +1,18 @@ +Version: 1.0 + +RestoreWorkspace: No +SaveWorkspace: No +AlwaysSaveHistory: No + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace diff --git a/codecov.yml b/codecov.yml index d6c6c1ae..04c55859 100644 --- a/codecov.yml +++ b/codecov.yml @@ -1 +1,14 @@ -comment: false +comment: false + +coverage: + status: + project: + default: + target: auto + threshold: 1% + informational: true + patch: + default: + target: auto + threshold: 1% + informational: true diff --git a/cran-comments.md b/cran-comments.md new file mode 100644 index 00000000..881707db --- /dev/null +++ b/cran-comments.md @@ -0,0 +1,17 @@ +## Test environments +* local OS X, install, 4.1.0 (2021-05-18) +* github actions : +* windows-latest, r: 'release' +* macOS-latest, r: 'release' +* ubuntu-latest, r: 'release' + +## R CMD check results + +0 errors | 0 warnings | 0 note + + +We don't expect any reverse dependency failures. + +This patch release contains only fix deprecated dependencies (issue #200). + + diff --git a/man/plot.mapLayout.Rd b/man/plot.mapLayout.Rd index 8788d8f0..b1584d02 100644 --- a/man/plot.mapLayout.Rd +++ b/man/plot.mapLayout.Rd @@ -22,7 +22,9 @@ links = TRUE, areas = TRUE, tilesURL = defaultTilesURL(), - preprocess = function(map) { map }, + preprocess = function(map) { + map + }, width = NULL, height = NULL, ... diff --git a/man/plotMapOptions.Rd b/man/plotMapOptions.Rd index 0ac234d1..e02d1c96 100644 --- a/man/plotMapOptions.Rd +++ b/man/plotMapOptions.Rd @@ -21,7 +21,9 @@ plotMapOptions( linkColorScaleOpts = colorScaleOptions(), legend = c("choose", "visible", "hidden"), tilesURL = defaultTilesURL(), - preprocess = function(map) { map } + preprocess = function(map) { + map + } ) defaultTilesURL() diff --git a/revdep/.gitignore b/revdep/.gitignore new file mode 100644 index 00000000..111ab324 --- /dev/null +++ b/revdep/.gitignore @@ -0,0 +1,7 @@ +checks +library +checks.noindex +library.noindex +cloud.noindex +data.sqlite +*.html diff --git a/revdep/README.md b/revdep/README.md new file mode 100644 index 00000000..e376c917 --- /dev/null +++ b/revdep/README.md @@ -0,0 +1,105 @@ +# Platform + +|field |value | +|:--------|:------------------------------| +|version |R version 4.1.0 (2021-05-18) | +|os |Windows 10 x64 (build 19044) | +|system |x86_64, mingw32 | +|ui |RStudio | +|language |(EN) | +|collate |French_France.1252 | +|ctype |French_France.1252 | +|tz |Europe/Paris | +|date |2023-08-31 | +|rstudio |1.4.1103 Wax Begonia (desktop) | +|pandoc |NA | + +# Dependencies + +|package |old |new | | +|:-----------------|:------|:-------|:--| +|antaresViz |0.17.1 |0.17.1 | | +|bit |NA |4.0.5 |* | +|bslib |NA |0.5.1 |* | +|cachem |NA |1.0.7 |* | +|classInt |NA |0.4-9 |* | +|cli |NA |3.6.1 |* | +|colorspace |NA |2.1-0 |* | +|commonmark |NA |1.9.0 |* | +|cpp11 |NA |0.4.6 |* | +|crul |NA |1.4.0 |* | +|curl |NA |5.0.0 |* | +|data.table |NA |1.14.8 |* | +|digest |NA |0.6.31 |* | +|dplyr |NA |1.1.2 |* | +|e1071 |NA |1.7-13 |* | +|evaluate |NA |0.21 |* | +|fansi |NA |1.0.4 |* | +|fastmap |NA |1.1.1 |* | +|fontawesome |NA |0.5.2 |* | +|fs |NA |1.5.2 |* | +|geojson |NA |0.3.5 |* | +|geojsonio |NA |0.11.2 |* | +|geometries |NA |0.2.2 |* | +|ggplot2 |NA |3.4.3 |* | +|gtable |NA |0.3.4 |* | +|highr |NA |0.10 |* | +|hms |NA |1.1.3 |* | +|htmltools |NA |0.5.5 |* | +|htmlwidgets |NA |1.6.2 |* | +|httpuv |NA |1.6.9 |* | +|isoband |NA |0.2.7 |* | +|jsonlite |NA |1.8.4 |* | +|knitr |NA |1.43 |* | +|labeling |NA |0.4.3 |* | +|later |NA |1.3.0 |* | +|leaflet |NA |2.2.0 |* | +|leaflet.providers |NA |1.13.0 |* | +|lubridate |NA |1.9.2 |* | +|openssl |NA |2.0.6 |* | +|pbapply |NA |1.7-2 |* | +|pillar |NA |1.9.0 |* | +|plotly |NA |4.10.2 |* | +|plyr |NA |1.8.8 |* | +|png |NA |0.1-8 |* | +|processx |NA |3.8.1 |* | +|promises |NA |1.2.0.1 |* | +|protolite |NA |2.2.0 |* | +|ps |NA |1.7.5 |* | +|purrr |NA |1.0.1 |* | +|raster |NA |3.6-20 |* | +|Rcpp |NA |1.0.10 |* | +|readr |NA |2.1.4 |* | +|rmarkdown |NA |2.24 |* | +|s2 |NA |1.1.2 |* | +|sass |NA |0.4.5 |* | +|sf |NA |1.0-12 |* | +|sfheaders |NA |0.4.2 |* | +|shiny |NA |1.7.5 |* | +|sourcetools |NA |0.1.7-1 |* | +|stringi |NA |1.7.12 |* | +|stringr |NA |1.5.0 |* | +|sys |NA |3.4.1 |* | +|terra |NA |1.7-23 |* | +|tibble |NA |3.2.1 |* | +|tidyr |NA |1.3.0 |* | +|timechange |NA |0.2.0 |* | +|tinytex |NA |0.46 |* | +|triebeard |NA |0.4.1 |* | +|tzdb |NA |0.3.0 |* | +|units |NA |0.8-1 |* | +|utf8 |NA |1.2.3 |* | +|V8 |NA |4.3.0 |* | +|vctrs |NA |0.6.1 |* | +|viridis |NA |0.6.4 |* | +|viridisLite |NA |0.4.2 |* | +|vroom |NA |1.6.1 |* | +|webshot |NA |0.5.5 |* | +|wk |NA |0.7.2 |* | +|xfun |NA |0.39 |* | +|xts |NA |0.13.1 |* | +|yaml |NA |2.3.7 |* | +|zoo |NA |1.8-12 |* | + +# Revdeps + diff --git a/revdep/cran.md b/revdep/cran.md new file mode 100644 index 00000000..782ef684 --- /dev/null +++ b/revdep/cran.md @@ -0,0 +1,7 @@ +## revdepcheck results + +We checked 1 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. + + * We saw 0 new problems + * We failed to check 0 packages + diff --git a/revdep/email.yml b/revdep/email.yml new file mode 100644 index 00000000..0c5cef87 --- /dev/null +++ b/revdep/email.yml @@ -0,0 +1,5 @@ +release_date: ??? +rel_release_date: ??? +my_news_url: ??? +release_version: ??? +release_details: ??? diff --git a/revdep/failures.md b/revdep/failures.md new file mode 100644 index 00000000..9a207363 --- /dev/null +++ b/revdep/failures.md @@ -0,0 +1 @@ +*Wow, no problems at all. :)* \ No newline at end of file diff --git a/revdep/problems.md b/revdep/problems.md new file mode 100644 index 00000000..9a207363 --- /dev/null +++ b/revdep/problems.md @@ -0,0 +1 @@ +*Wow, no problems at all. :)* \ No newline at end of file diff --git a/tests/testthat/helper-init.R b/tests/testthat/helper-init.R index 9988141a..e82f92be 100644 --- a/tests/testthat/helper-init.R +++ b/tests/testthat/helper-init.R @@ -1,62 +1,62 @@ -#Copyright © 2016 RTE Réseau de transport d’électricité - -# Copy the test study in a temporary folder - -## force tests to be executed if in dev release which we define as -## having a sub-release, eg 0.9.15.5 is one whereas 0.9.16 is not -if (length(strsplit(packageDescription("antaresViz")$Version, "\\.")[[1]]) > 3) { - Sys.setenv("RunAllAntaresVizTests"="yes") -} -.runThisTest <- FALSE -.runThisTest <- Sys.getenv("RunAllAntaresVizTests") == "yes" - -if(.runThisTest){ - .runProdStackTest <- TRUE - .runExchangesStackTest <- TRUE - .runTsPlotTest <- TRUE - #bug when executing in the Test environment, so keep - # .runPlotMapTest to FALSE - .runPlotMapTest <- FALSE -}else{ - .runProdStackTest <- FALSE - .runExchangesStackTest <- FALSE - .runTsPlotTest <- FALSE - .runPlotMapTest <- FALSE -} - -path <- tempdir() - -sourcedir <- system.file("inst/testdata", package = "antaresRead") -if (sourcedir == ""){ - sourcedir <- system.file("testdata", package = "antaresRead") -} - - -# Hack: For some unknown reason, this script is executed at some point of -# the R CMD CHECK before package is correctly installed and tests actually run. -# The following "if" prevents errors at this step -if (sourcedir != "") { - - ar_path_study <- file.path(sourcedir, "antares-test-study.tar.gz") - if (!file.exists(ar_path_study)) { - ar_path_study <- file.path(sourcedir, "antares-test-study-latest.tar.gz") - } - - # if (Sys.info()["sysname"] == "Windows") { - # untar( - # tarfile = ar_path_study, - # exdir = path, - # extras = "--force-local" - # ) - # } else { - untar( - tarfile = ar_path_study, - exdir = path - ) - # } - assign("studyPath", file.path(path, "test_case"), envir = globalenv()) - assign("nweeks", 2, envir = globalenv()) - assign("pathtemp", path, envir = globalenv()) -} - -opts <- setSimulationPath(get("studyPath", envir = globalenv())) +#Copyright © 2016 RTE Réseau de transport d’électricité + +# Copy the test study in a temporary folder + +## force tests to be executed if in dev release which we define as +## having a sub-release, eg 0.9.15.5 is one whereas 0.9.16 is not +if (length(strsplit(packageDescription("antaresViz")$Version, "\\.")[[1]]) > 3) { + Sys.setenv("RunAllAntaresVizTests"="yes") +} +.runThisTest <- FALSE +.runThisTest <- Sys.getenv("RunAllAntaresVizTests") == "yes" + +if(.runThisTest){ + .runProdStackTest <- TRUE + .runExchangesStackTest <- TRUE + .runTsPlotTest <- TRUE + #bug when executing in the Test environment, so keep + # .runPlotMapTest to FALSE + .runPlotMapTest <- FALSE +}else{ + .runProdStackTest <- FALSE + .runExchangesStackTest <- FALSE + .runTsPlotTest <- FALSE + .runPlotMapTest <- FALSE +} + +path <- tempdir() + +sourcedir <- system.file("inst/testdata", package = "antaresRead") +if (sourcedir == ""){ + sourcedir <- system.file("testdata", package = "antaresRead") +} + + +# Hack: For some unknown reason, this script is executed at some point of +# the R CMD CHECK before package is correctly installed and tests actually run. +# The following "if" prevents errors at this step +if (sourcedir != "") { + + ar_path_study <- file.path(sourcedir, "antares-test-study.tar.gz") + if (!file.exists(ar_path_study)) { + ar_path_study <- file.path(sourcedir, "antares-test-study-latest.tar.gz") + } + + # if (Sys.info()["sysname"] == "Windows") { + # untar( + # tarfile = ar_path_study, + # exdir = path, + # extras = "--force-local" + # ) + # } else { + untar( + tarfile = ar_path_study, + exdir = path + ) + # } + assign("studyPath", file.path(path, "test_case"), envir = globalenv()) + assign("nweeks", 2, envir = globalenv()) + assign("pathtemp", path, envir = globalenv()) +} + +opts <- setSimulationPath(get("studyPath", envir = globalenv())) diff --git a/tests/testthat/test-ts_plot.R b/tests/testthat/test-ts_plot.R index 471532a5..656b76c0 100644 --- a/tests/testthat/test-ts_plot.R +++ b/tests/testthat/test-ts_plot.R @@ -35,32 +35,32 @@ test_that("tsPlot, no interactive return error", { }) -test_that("tsPlot, work with compare", { - - dta <- readAntares(areas = "all", links = "all", showProgress = FALSE, mcYears = "all") - exList <- tsPlot(x = dta, .runApp = FALSE, interactive = TRUE, compare = "mcYear") - exList <- exList$init() - #to get a param exList$getParams("tables") - # exList$getValue("mcYear") - exList$setValue("mcYear", 1, chartId = 1, reactive = FALSE) - exList$setValue("mcYear", 2, chartId = 2, reactive = FALSE) - exList$updateCharts() - expect_equal(exList$getValue("tables"), "areas") - expect_equal(exList$getValue("main"), "") - expect_true(is(exList, "MWController")) - expect_equal(exList$ncharts, 2) - expect_equal(exList$ncol, 1) - expect_equal(exList$nrow, 2) - dataTsCompare <- .get_data_from_htmlwidget(exList, widgetsNumber = 1) - timeEditValue <- "2018-05-06T18:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsCompare$hour) - expect_gt(indexHour, 180) - expect_equal(dataTsCompare$a[indexHour], 1627275) - - dataTsCompareMcYear2 <- .get_data_from_htmlwidget(exList, widgetsNumber = 2) - expect_equal(dataTsCompareMcYear2$a[indexHour], 1432100) - -}) +# test_that("tsPlot, work with compare", { +# +# dta <- readAntares(areas = "all", links = "all", showProgress = FALSE, mcYears = "all") +# exList <- tsPlot(x = dta, .runApp = FALSE, interactive = TRUE, compare = "mcYear") +# exList <- exList$init() +# #to get a param exList$getParams("tables") +# # exList$getValue("mcYear") +# exList$setValue("mcYear", 1, chartId = 1, reactive = FALSE) +# exList$setValue("mcYear", 2, chartId = 2, reactive = FALSE) +# exList$updateCharts() +# expect_equal(exList$getValue("tables"), "areas") +# expect_equal(exList$getValue("main"), "") +# expect_true(is(exList, "MWController")) +# expect_equal(exList$ncharts, 2) +# expect_equal(exList$ncol, 1) +# expect_equal(exList$nrow, 2) +# dataTsCompare <- .get_data_from_htmlwidget(exList, widgetsNumber = 1) +# timeEditValue <- "2018-05-06T18:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsCompare$hour) +# expect_gt(indexHour, 180) +# expect_equal(dataTsCompare$a[indexHour], 1627275) +# +# dataTsCompareMcYear2 <- .get_data_from_htmlwidget(exList, widgetsNumber = 2) +# expect_equal(dataTsCompareMcYear2$a[indexHour], 1432100) +# +# }) test_that("tsPlot, no interactive, x and refStudy are antaresDataTable", { myData1 <- readAntares(links = "all", showProgress = FALSE) @@ -150,709 +150,710 @@ test_that("tsPlot, no interactive, x and refStudy are antaresDataList", { }) -describe("tsPlot, no interactive, x is a list of antaresDataList and refStudy an antaresDataList", { - myData1 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - myData2 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - myData3 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - myData4 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - - myDataList <- list(myData2, myData3, myData4) - myLink <- "a - a_offshore" - mytables <- "links" - myVariable <- "FLOW LIN." - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - TsDaList <- tsPlot(x = myDataList, - table = mytables, - elements = myLink, - type = "ts", - interactive = FALSE, - variable = myVariable) - # compare with myData3 - idWidget <- 2 - dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDaList$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDaList$`a - a_offshore`[indexHour], -9) - #with a refStudy - TsDaList <- tsPlot(x = myDataList, - refStudy = myData1, - table = mytables, - elements = myLink, - type = "ts", - interactive = FALSE, - variable = myVariable) - dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) - expect_equal(dataTsDaList$`a - a_offshore`[indexHour], 0) - # edit myData3 to have a diff != 0 - #pb timeZone local (PC, Travis, etc) - for (i in 0:5){ - timeEditShift <- lubridate::hours(i) - timeEditMinus <- as.Date(timeEditValue) - timeEditShift - timeEditPlus <- as.Date(timeEditValue) + timeEditShift - myData3$links[ (time == timeEditMinus | time == timeEditPlus) & link == "a - a_offshore", `FLOW LIN.` := as.integer(`FLOW LIN.` + 2500)] - } - TsDaList <- tsPlot(x = myDataList, - refStudy = myData1, - table = mytables, - elements = myLink, - type = "ts", - interactive = FALSE, - variable = myVariable) - dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) - expect_equal(dataTsDaList$`a - a_offshore`[indexHour], 2500) -}) - -describe("tsPlot, interactive, x and refStudy are antaresDataTable", { - myData1 <- readAntares(links = "all", showProgress = FALSE) - myData2 <- readAntares(links = "all", showProgress = FALSE) - myLink <- "a - a_offshore" - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - # no interactive - tsDa1 <- tsPlot(x = myData1, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) - # interactive - tsDa1Int <- tsPlot(x = myData1, - table = "links", - elements = myLink, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - expect_equal(tsDa1Int$ncharts, 1) - expect_equal(tsDa1Int$ncol, 1) - expect_equal(tsDa1Int$nrow, 1) - tsDa1Int$setValue("mcYear", "average", reactive = FALSE) - tsDa1Int$updateCharts() - expect_equal(tsDa1Int$getValue("tables"), "links") - expect_equal(tsDa1Int$getValue("mcYear"), "average") - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_lt(indexHour, 50) - # BUG with interactive - ## we must remove 24 hours ? - expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], -9) - # interactive with refStudy - tsDa1Int <- tsPlot(x = myData1, - refStudy = myData2, - table = "links", - elements = myLink, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - tsDa1Int$setValue("mcYear", "average", reactive = FALSE) - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], 0) - - # edit myData2 to have a diff != 0 - ## pb timeZone local (PC, Travis, etc) - for (i in 0:5){ - timeEditShift <- lubridate::hours(i) - timeEditMinus <- as.Date(timeEditValue) - timeEditShift - timeEditPlus <- as.Date(timeEditValue) + timeEditShift - myData2[ (time == timeEditMinus | time == timeEditPlus) & link == myLink, `FLOW LIN.` := as.integer(`FLOW LIN.` + 2500)] - } - tsDa1Int <- tsPlot(x = myData2, - refStudy = myData1, - table = "links", - elements = myLink, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - tsDa1Int$setValue("mcYear", "average", reactive = FALSE) - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], 2500) -}) - -describe("tsPlot, interactive, x and refStudy are antaresDataList", { - myData1 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - myData2 <- readAntares(links = "all", areas = "all", showProgress = FALSE) - myArea <- "b" - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - # no interactive - tsDa1 <- tsPlot(x = myData1, - table = "areas", - elements = myArea, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$b[indexHour], 2427150) - # interactive - tsDa1Int <- tsPlot(x = myData1, - table = "areas", - elements = myArea, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - expect_equal(tsDa1Int$ncharts, 1) - expect_equal(tsDa1Int$ncol, 1) - expect_equal(tsDa1Int$nrow, 1) - tsDa1Int$setValue("mcYear", "average", reactive = TRUE) - tsDa1Int$setValue("tables", "areas", reactive = TRUE) - tsDa1Int$setValue("elements", "b", reactive = TRUE) - tsDa1Int$updateCharts() - expect_equal(tsDa1Int$getValue("tables"), "areas") - expect_equal(tsDa1Int$getValue("mcYear"), "average") - expect_equal(tsDa1Int$getValue("elements"), "b") - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_lt(indexHour, 50) - # BUG with interactive - ## we must remove 24 hours ? - expect_equal(dataTsDAInt$b[indexHour - 24], 2427150) - # interactive with refStudy - tsDa1Int <- tsPlot(x = myData1, - refStudy = myData2, - table = "areas", - elements = myArea, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - tsDa1Int$setValue("mcYear", "average", reactive = FALSE) - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - expect_equal(dataTsDAInt$b[indexHour - 24], 0) - - # edit myData2 to have a diff != 0 - ## pb timeZone local (PC, Travis, etc) - for (i in 0:5){ - timeEditShift <- lubridate::hours(i) - timeEditMinus <- as.Date(timeEditValue) - timeEditShift - timeEditPlus <- as.Date(timeEditValue) + timeEditShift - myData2$areas[ (time == timeEditMinus | time == timeEditPlus) & area == myArea, `OV. COST` := as.integer(`OV. COST` + 2500)] - } - tsDa1Int <- tsPlot(x = myData2, - refStudy = myData1, - table = "areas", - elements = myArea, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - dateRange = DR) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - tsDa1Int$setValue("mcYear", "average", reactive = TRUE) - tsDa1Int$setValue("tables", "areas", reactive = TRUE) - tsDa1Int$setValue("elements", "b", reactive = TRUE) - tsDa1Int$updateCharts() - dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) - expect_equal(dataTsDAInt$b[indexHour - 24], 2500) -}) - -describe("tsPlot, no interactive, x and refStudy are optsH5 ", { - if (.requireRhdf5_Antares(stopP = FALSE)){ - skip_if_not(.runTsPlotTest) - suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) - optsH5 <- setSimulationPath(pathtemp) - myLink <- "a - a_offshore" - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - # no interactive - tsDa1 <- tsPlot(x = optsH5, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) - #ref Study - tsDa1 <- tsPlot(x = optsH5, - refStudy = optsH5, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], 0) - # Edit H5 file - ## create a new folder h5 - pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) - pathNewH5 <- file.path(pathInitial, "testH5") - if (!dir.exists(pathNewH5)){ - dir.create(pathNewH5) - } - #write the study - #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) - optsData <- antaresRead::setSimulationPath(path = studyPath) - suppressWarnings(writeAntaresH5(path = pathNewH5, opts = optsData, - overwrite = TRUE, supressMessages = TRUE)) - - pathNewH5File <- file.path(pathNewH5, list.files(pathNewH5)) - .h5Antares_edit_variable( - pathH5 = pathNewH5File, - link = myLink, - timeId = 1:100, - antVar = "FLOW LIN.", - newValue = 15000 - ) - - optsH5New <- setSimulationPath(path = pathNewH5File) - tsDa1 <- tsPlot(x = optsH5New, - refStudy = optsH5, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], 15009) - } -}) - -describe("tsPlot, no interactive, x is a list of optH5 and refStudy are optsH5 ", { - if (.requireRhdf5_Antares(stopP = FALSE)){ - skip_if_not(.runTsPlotTest) - suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) - optsH5 <- setSimulationPath(pathtemp) - - # with new Studies H5 test if compare prodStack works - ## create new folders h5 - pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) - - listFolderToCreate <- c("testH5v2", "testH5v3", "testH5v4") - for (folder in listFolderToCreate){ - pathNewH5 <- file.path(pathInitial, folder) - if (!dir.exists(pathNewH5)){ - dir.create(pathNewH5) - } - #write the study - #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) - optsData <- antaresRead::setSimulationPath(path = studyPath) - suppressWarnings( - writeAntaresH5( - path = pathNewH5, - opts = optsData, - overwrite = TRUE, - supressMessages = TRUE) - ) - } - idWidgetToEdit <- 2 - pathH5FolderToEdit <- file.path(pathInitial, listFolderToCreate[[idWidgetToEdit]]) - pathH5FileToEdit <- file.path(pathH5FolderToEdit, list.files(pathH5FolderToEdit)) - newValueFlow <- 15000 - myLink <- getLinks()[1] - .h5Antares_edit_variable( - pathH5 = pathH5FileToEdit, - link = myLink, - timeId = 1:100, - antVar = "FLOW LIN.", - newValue = newValueFlow - ) - optsList <- list() - antaresDataListH5 <- list() - for (i in 1:length(listFolderToCreate)){ - pathOptsI <- file.path(pathInitial, listFolderToCreate[[i]]) - optsList[[i]] <- setSimulationPath(path = pathOptsI) - antaresDataListH5[[i]] <- readAntares(links = myLink) - } - #test the data from h5 - #get the data from the h5 file - antaresDataRef <- readAntares(opts = optsH5, links = myLink) - expect_equal(max(antaresDataListH5[[idWidgetToEdit]]$`FLOW LIN.`), newValueFlow) - expect_equal(max(antaresDataListH5[[1]]$`FLOW LIN.`), max(antaresDataRef$`FLOW LIN.`)) - expect_equal(max(antaresDataListH5[[3]]$`FLOW LIN.`), max(antaresDataRef$`FLOW LIN.`)) - # get the data from htmlwidget - myArea <- "a" - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - tsDa1 <- tsPlot(x = optsList, - refStudy = optsH5, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa3 <- .get_data_from_htmlwidget(tsDa1, widgetsNumber = idWidgetToEdit) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDa3$hour) - expect_equal(dataTsDa3$`a - a_offshore`[indexHour], 15009) - dataTsDa2 <- .get_data_from_htmlwidget(tsDa1, widgetsNumber = 1) - expect_equal(dataTsDa2$`a - a_offshore`[indexHour], 0) - } -}) - -describe("tsPlot, interactive, x and refStudy are optsH5 ", { - if (.requireRhdf5_Antares(stopP = FALSE)){ - skip_if_not(.runTsPlotTest) - suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) - optsH5 <- setSimulationPath(pathtemp) - myLink <- "a - a_offshore" - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - # no interactive - tsDa1 <- tsPlot(x = optsH5, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE) - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) - #interactive - tsDa1Int <- tsPlot(x = optsH5, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - h5requestFiltering = list( - mcYears = 1 - )) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - expect_equal(tsDa1Int$ncharts, 1) - expect_equal(tsDa1Int$ncol, 1) - expect_equal(tsDa1Int$nrow, 1) - expect_true(is((tsDa1Int$getValue("x_tranform")[[1]]), "antaresData")) - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - tsDa1Int$setValue("tables", "areas", reactive = TRUE) - tsDa1Int$setValue("elements", "b", reactive = TRUE) - tsDa1Int$setValue("variable", "LOAD", reactive = TRUE) - tsDa1Int$setValue("dateRange", DR, reactive = TRUE) - tsDa1Int$updateCharts() - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - tsDa1Int$setValue("meanYearH5", FALSE, reactive = TRUE) - tsDa1Int$updateCharts() - tsDa1Int$setValue("meanYearH5", FALSE, reactive = TRUE) - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - expect_equal(tsDa1Int$getValue("tables"), "areas") - expect_equal(tsDa1Int$getValue("mcYear"), 1) - expect_equal(tsDa1Int$getValue("elements"), "b") - expect_equal(tsDa1Int$getValue("variable"), "LOAD") - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_gt(indexHour, 2) - expect_equal(dataTsDa1$b[indexHour], 60262) - # Edit H5 file - ## create a new folder h5 - pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) - pathNewH5 <- file.path(pathInitial, "testH5") - if (!dir.exists(pathNewH5)){ - dir.create(pathNewH5) - } - #write the study - #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) - optsData <- antaresRead::setSimulationPath(path = studyPath) - suppressWarnings(writeAntaresH5(path = pathNewH5, opts = optsData, - overwrite = TRUE, supressMessages = TRUE)) - pathNewH5File <- file.path(pathNewH5, list.files(pathNewH5)) - .h5Antares_edit_variable( - pathH5 = pathNewH5File, - area = "b", - timeId = 1:100, - antVar = "LOAD", - newValue = 15000, - mcYear = 1 - ) - optsH5New <- setSimulationPath(path = pathNewH5File) - myData <- readAntares(areas = "b", - select = "LOAD", - opts = optsH5New, - mcYears = 1) - myDataRef <- readAntares(areas = "b", - select = "LOAD", - opts = optsH5, - mcYears = 1) - expect_equal(myData[area == "b" & timeId == 2737, LOAD], 15000) - expect_gt(myDataRef[area == "b" & timeId == 2737, LOAD], 16000) - - diffValue <- myData[area == "b" & timeId == 2737, LOAD] - - myDataRef[area == "b" & timeId == 2737, LOAD] - tsDa1Int <- tsPlot(x = optsH5New, - refStudy = optsH5, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - h5requestFiltering = list( - mcYears = 1 - )) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - expect_equal(tsDa1Int$ncharts, 1) - expect_equal(tsDa1Int$ncol, 1) - expect_equal(tsDa1Int$nrow, 1) - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - tsDa1Int$setValue("tables", "areas", reactive = TRUE) - tsDa1Int$setValue("elements", "b", reactive = FALSE) - tsDa1Int$setValue("variable", "LOAD", reactive = FALSE) - tsDa1Int$setValue("dateRange", DR, reactive = FALSE) - tsDa1Int$updateCharts() - expect_equal(tsDa1Int$getValue("tables"), "areas") - expect_equal(tsDa1Int$getValue("mcYear"), 1) - expect_equal(tsDa1Int$getValue("elements"), "b") - expect_equal(tsDa1Int$getValue("variable"), "LOAD") - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_equal(dataTsDa1$b[indexHour], diffValue) - # for links, no refStudy - tsDa1Int <- tsPlot(x = optsH5New, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - h5requestFiltering = list( - mcYears = 1 - )) - tsDa1Int <- tsDa1Int$init() - expect_true(is(tsDa1Int, "MWController")) - expect_equal(tsDa1Int$ncharts, 1) - expect_equal(tsDa1Int$ncol, 1) - expect_equal(tsDa1Int$nrow, 1) - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - tsDa1Int$setValue("tables", "links", reactive = TRUE) - tsDa1Int$setValue("elements", myLink, reactive = FALSE) - tsDa1Int$setValue("variable", "FLOW LIN.", reactive = FALSE) - tsDa1Int$setValue("dateRange", DR, reactive = FALSE) - tsDa1Int$updateCharts() - tsDa1Int$setValue("mcYear", 1, reactive = TRUE) - expect_true(is((tsDa1Int$getValue("x_tranform")[[1]]), "antaresData")) - expect_equal(tsDa1Int$getValue("tables"), "links") - expect_equal(tsDa1Int$getValue("mcYear"), 1) - expect_equal(tsDa1Int$getValue("elements"), myLink) - expect_equal(tsDa1Int$getValue("variable"), "FLOW LIN.") - dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) - indexHour <- grep(timeEditValue, dataTsDa1$hour) - expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -10) - # for links, with refStudy - tsDa1IntRef <- tsPlot(x = optsH5New, - refStudy = optsH5, - type = "ts", - interactive = TRUE, - .runApp = FALSE, - h5requestFiltering = list( - mcYears = 1 - )) - tsDa1IntRef <- tsDa1IntRef$init() - expect_true(is(tsDa1IntRef, "MWController")) - expect_equal(tsDa1IntRef$ncharts, 1) - expect_equal(tsDa1IntRef$ncol, 1) - expect_equal(tsDa1IntRef$nrow, 1) - expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) - tsDa1IntRef$setValue("mcYear", 1, reactive = TRUE) - expect_equal(tsDa1IntRef$getValue("mcYear"), 1) - expect_equal(tsDa1IntRef$getValue("tables"), "areas") - tsDa1IntRef$setValue("tables", "links", reactive = TRUE) - tsDa1IntRef$setValue("elements", myLink, reactive = FALSE) - tsDa1IntRef$setValue("variable", "FLOW LIN.", reactive = FALSE) - tsDa1IntRef$setValue("dateRange", DR, reactive = FALSE) - tsDa1IntRef$setValue("meanYearH5", FALSE, reactive = TRUE) - tsDa1IntRef$updateCharts() - tsDa1IntRef$setValue("meanYearH5", TRUE, reactive = TRUE) - tsDa1IntRef$setValue("mcYear", 1, reactive = TRUE) - expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) - expect_equal(tsDa1IntRef$getValue("tables"), "links") - expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) - expect_equal(tsDa1IntRef$getValue("elements"), myLink) - expect_equal(tsDa1IntRef$getValue("variable"), "FLOW LIN.") - expect_equal(tsDa1IntRef$getValue("mcYear"), 1) - dataTsDa1Ref <- .get_data_from_htmlwidget(tsDa1IntRef) - indexHour <- grep(timeEditValue, dataTsDa1Ref$hour) - expect_equal(dataTsDa1Ref$`a - a_offshore`[indexHour], 0) - } -}) - -describe("tsPlot, interactive, x is a list of optsH5 and refStudy optsH5", { - if (.requireRhdf5_Antares(stopP = FALSE)){ - skip_if_not(.runTsPlotTest) - suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) - optsH5 <- setSimulationPath(pathtemp) - - # with new Studies H5 test if compare prodStack works - ## create new folders h5 - pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) - listFolderToCreate <- c("testH5v2", "testH5v3", "testH5v4") - for (folder in listFolderToCreate){ - pathNewH5 <- file.path(pathInitial, folder) - if (!dir.exists(pathNewH5)){ - dir.create(pathNewH5) - } - - #write the study - #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) - optsData <- antaresRead::setSimulationPath(path = studyPath) - suppressWarnings( - writeAntaresH5( - path = pathNewH5, - opts = optsData, - overwrite = TRUE, - supressMessages = TRUE) - ) - } - pathH5FolderToEdit <- file.path(pathInitial, listFolderToCreate[[2]]) - pathH5FileToEdit <- file.path(pathH5FolderToEdit, list.files(pathH5FolderToEdit)) - myLink <- getLinks()[1] - newValueFlow <- 50000 - mcYearToTestList <- c(2, NULL) - myVar <- "FLOW LIN." - for (mcYearToTest in mcYearToTestList){ - .h5Antares_edit_variable( - pathH5 = pathH5FileToEdit, - link = myLink, - timeId = 1:100, - antVar = myVar, - newValue = newValueFlow, - mcYear = mcYearToTest - ) - #stock the data - optsList <- list() - antaresDataListH5 <- list() - for (i in 1:length(listFolderToCreate)){ - pathOptsI <- file.path(pathInitial, listFolderToCreate[[i]]) - optsList[[i]] <- setSimulationPath(path = pathOptsI) - antaresDataListH5[[i]] <- readAntares(links = myLink, - mcYear = mcYearToTest, - opts = optsList[[i]]) - } - DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") - #try without refStudy and interactive == FALSE - indexHour <- 49 - expect_equal(antaresDataListH5[[2]]$`FLOW LIN.`[[indexHour]], 50000) - if(is.null(mcYearToTest)){ - valFlow <- (-9) - }else{ - valFlow <- (-7) - } - expect_equal(antaresDataListH5[[1]]$`FLOW LIN.`[[indexHour]], valFlow) - expect_equal(antaresDataListH5[[3]]$`FLOW LIN.`[[indexHour]], valFlow) - - if(!is.null(mcYearToTest)){ - expect_error(tsPlot(x = optsList, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE, - mcYear = mcYearToTest), - "You can't use mcYear for h5 file when interactive is set to FALSE. You can use mcYearh5.") - } - tsPlotNoInt <- tsPlot(x = optsList, - table = "links", - elements = myLink, - type = "ts", - interactive = FALSE, - mcYearh5 = mcYearToTest) - datatsPlotNoInt <- .get_data_from_htmlwidget(tsPlotNoInt, widgetsNumber = 2) - timeEditValue <- "2018-04-25T00:00:00.000Z" - indexHour <- grep(timeEditValue, datatsPlotNoInt$hour) - expect_gt(indexHour, 2) - expect_equal(datatsPlotNoInt$`a - a_offshore`[[indexHour]], 50000) - #interactive - tsPlotInt <- tsPlot(x = optsList, - type = "ts", - dateRange = DR, - .runApp = FALSE, - interactive = TRUE, - h5requestFiltering = list( - mcYears = mcYearToTest - )) - tsPlotInt <- tsPlotInt$init() - expect_true(is(tsPlotInt, "MWController")) - expect_equal(tsPlotInt$ncharts, 3) - expect_equal(tsPlotInt$ncol, 2) - expect_equal(tsPlotInt$nrow, 2) - tsPlotInt$setValue("mcYear", mcYearToTest, reactive = TRUE) - tsPlotInt$setValue("tables", "links", reactive = TRUE) - tsPlotInt$setValue("elements", myLink, reactive = TRUE) - tsPlotInt$setValue("variable", myVar, reactive = TRUE) - tsPlotInt$setValue("dateRange", DR, reactive = TRUE) - if(is.null(mcYearToTest)){ - tsPlotInt$setValue("meanYearH5", FALSE, reactive = TRUE) - expect_equal(tsPlotInt$getValue("meanYearH5"), FALSE) - tsPlotInt$setValue("mcYear", "average", reactive = TRUE) - }else{ - tsPlotInt$setValue("meanYearH5", TRUE, reactive = TRUE) - expect_equal(tsPlotInt$getValue("meanYearH5"), TRUE) - } - tsPlotInt$updateCharts() - expect_equal(tsPlotInt$getValue("tables"), "links") - tsPlotInt$setValue("mcYear", mcYearToTest, reactive = TRUE) - if(!is.null(mcYearToTest)){ - expect_equal(tsPlotInt$getValue("mcYear"), mcYearToTest) - }else{ - tsPlotInt$setValue("mcYear", "average", reactive = TRUE) - expect_equal(tsPlotInt$getValue("mcYear"), "average") - } - expect_equal(tsPlotInt$getValue("mcYearH5"),"1") - expect_equal(tsPlotInt$getValue("elements"), myLink) - expect_equal(tsPlotInt$getValue("variable"), myVar) - datatsPlotInt <- .get_data_from_htmlwidget(tsPlotInt, widgetsNumber = 2) - indexHour <- grep(timeEditValue, datatsPlotInt$hour) - expect_equal(datatsPlotInt$`a - a_offshore`[[indexHour]], 50000) - datatsPlotInt2 <- .get_data_from_htmlwidget(tsPlotInt, widgetsNumber = 1) - indexHour <- grep(timeEditValue, datatsPlotInt2$hour) - expect_equal(datatsPlotInt2$`a - a_offshore`[[indexHour]], valFlow) - #interactive with refStudy - tsPlotIntRef <- tsPlot(x = optsList, - refStudy = optsH5, - type = "ts", - dateRange = DR, - .runApp = FALSE, - interactive = TRUE, - h5requestFiltering = list( - mcYears = mcYearToTest - )) - tsPlotIntRef <- tsPlotIntRef$init() - expect_true(is(tsPlotIntRef, "MWController")) - expect_equal(tsPlotIntRef$ncharts, 3) - expect_equal(tsPlotIntRef$ncol, 2) - expect_equal(tsPlotIntRef$nrow, 2) - tsPlotIntRef$setValue("mcYear", mcYearToTest, reactive = TRUE) - tsPlotIntRef$setValue("tables", "links", reactive = TRUE) - tsPlotIntRef$setValue("elements", myLink, reactive = TRUE) - tsPlotIntRef$setValue("variable", myVar, reactive = TRUE) - tsPlotIntRef$setValue("dateRange", DR, reactive = TRUE) - if(is.null(mcYearToTest)){ - tsPlotIntRef$setValue("meanYearH5", FALSE, reactive = TRUE) - expect_equal(tsPlotIntRef$getValue("meanYearH5"), FALSE) - }else{ - tsPlotIntRef$setValue("meanYearH5", TRUE, reactive = TRUE) - expect_equal(tsPlotIntRef$getValue("meanYearH5"), TRUE) - } - tsPlotIntRef$updateCharts() - expect_equal(tsPlotIntRef$getValue("tables"), "links") - tsPlotIntRef$setValue("mcYear", mcYearToTest, reactive = TRUE) - if(!is.null(mcYearToTest)){ - expect_equal(tsPlotInt$getValue("mcYear"), mcYearToTest) - expect_equal(tsPlotIntRef$getValue("mcYearH5"),"1") - }else{ - tsPlotIntRef$setValue("mcYear", "average", reactive = TRUE) - tsPlotIntRef$setValue("mcYearH5", "", reactive = TRUE) - expect_equal(tsPlotIntRef$getValue("mcYearH5"),"") - expect_equal(tsPlotIntRef$getValue("mcYear"), "average") - } - expect_equal(tsPlotIntRef$getValue("elements"), myLink) - expect_equal(tsPlotIntRef$getValue("variable"), myVar) - datatsPlotIntRef <- .get_data_from_htmlwidget(tsPlotIntRef, widgetsNumber = 2) - indexHour <- grep(timeEditValue, datatsPlotIntRef$hour) - expect_equal(datatsPlotIntRef$`a - a_offshore`[[indexHour]], 50000-(valFlow)) - datatsPlotIntRef2 <- .get_data_from_htmlwidget(tsPlotIntRef, widgetsNumber = 1) - indexHour <- grep(timeEditValue, datatsPlotIntRef2$hour) - expect_equal(datatsPlotIntRef2$`a - a_offshore`[[indexHour]], 0) - } - } -}) +# describe("tsPlot, no interactive, x is a list of antaresDataList and refStudy an antaresDataList", { +# myData1 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# myData2 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# myData3 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# myData4 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# +# myDataList <- list(myData2, myData3, myData4) +# myLink <- "a - a_offshore" +# mytables <- "links" +# myVariable <- "FLOW LIN." +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# TsDaList <- tsPlot(x = myDataList, +# table = mytables, +# elements = myLink, +# type = "ts", +# interactive = FALSE, +# variable = myVariable) +# # compare with myData3 +# idWidget <- 2 +# dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDaList$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDaList$`a - a_offshore`[indexHour], -9) +# #with a refStudy +# TsDaList <- tsPlot(x = myDataList, +# refStudy = myData1, +# table = mytables, +# elements = myLink, +# type = "ts", +# interactive = FALSE, +# variable = myVariable) +# dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) +# expect_equal(dataTsDaList$`a - a_offshore`[indexHour], 0) +# # edit myData3 to have a diff != 0 +# #pb timeZone local (PC, Travis, etc) +# for (i in 0:5){ +# timeEditShift <- lubridate::hours(i) +# timeEditMinus <- as.Date(timeEditValue) - timeEditShift +# timeEditPlus <- as.Date(timeEditValue) + timeEditShift +# myData3$links[ (time == timeEditMinus | time == timeEditPlus) & link == "a - a_offshore", `FLOW LIN.` := as.integer(`FLOW LIN.` + 2500)] +# } +# TsDaList <- tsPlot(x = myDataList, +# refStudy = myData1, +# table = mytables, +# elements = myLink, +# type = "ts", +# interactive = FALSE, +# variable = myVariable) +# dataTsDaList <- .get_data_from_htmlwidget(TsDaList, widgetsNumber = idWidget) +# expect_equal(dataTsDaList$`a - a_offshore`[indexHour], 2500) +# }) +# +# describe("tsPlot, interactive, x and refStudy are antaresDataTable", { +# myData1 <- readAntares(links = "all", showProgress = FALSE) +# myData2 <- readAntares(links = "all", showProgress = FALSE) +# myLink <- "a - a_offshore" +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# # no interactive +# tsDa1 <- tsPlot(x = myData1, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) +# # interactive +# tsDa1Int <- tsPlot(x = myData1, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# expect_equal(tsDa1Int$ncharts, 1) +# expect_equal(tsDa1Int$ncol, 1) +# expect_equal(tsDa1Int$nrow, 1) +# tsDa1Int$setValue("mcYear", "average", reactive = FALSE) +# tsDa1Int$updateCharts() +# expect_equal(tsDa1Int$getValue("tables"), "links") +# expect_equal(tsDa1Int$getValue("mcYear"), "average") +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_lt(indexHour, 50) +# # BUG with interactive +# ## we must remove 24 hours ? +# expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], -9) +# # interactive with refStudy +# tsDa1Int <- tsPlot(x = myData1, +# refStudy = myData2, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# tsDa1Int$setValue("mcYear", "average", reactive = FALSE) +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], 0) +# +# # edit myData2 to have a diff != 0 +# ## pb timeZone local (PC, Travis, etc) +# for (i in 0:5){ +# timeEditShift <- lubridate::hours(i) +# timeEditMinus <- as.Date(timeEditValue) - timeEditShift +# timeEditPlus <- as.Date(timeEditValue) + timeEditShift +# myData2[ (time == timeEditMinus | time == timeEditPlus) & link == myLink, `FLOW LIN.` := as.integer(`FLOW LIN.` + 2500)] +# } +# tsDa1Int <- tsPlot(x = myData2, +# refStudy = myData1, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# tsDa1Int$setValue("mcYear", "average", reactive = FALSE) +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# expect_equal(dataTsDAInt$`a - a_offshore`[indexHour - 24], 2500) +# }) +# +# describe("tsPlot, interactive, x and refStudy are antaresDataList", { +# myData1 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# myData2 <- readAntares(links = "all", areas = "all", showProgress = FALSE) +# myArea <- "b" +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# # no interactive +# tsDa1 <- tsPlot(x = myData1, +# table = "areas", +# elements = myArea, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$b[indexHour], 2427150) +# # interactive +# tsDa1Int <- tsPlot(x = myData1, +# table = "areas", +# elements = myArea, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# expect_equal(tsDa1Int$ncharts, 1) +# expect_equal(tsDa1Int$ncol, 1) +# expect_equal(tsDa1Int$nrow, 1) +# tsDa1Int$setValue("mcYear", "average", reactive = TRUE) +# tsDa1Int$setValue("tables", "areas", reactive = TRUE) +# tsDa1Int$setValue("elements", "b", reactive = TRUE) +# tsDa1Int$updateCharts() +# expect_equal(tsDa1Int$getValue("tables"), "areas") +# expect_equal(tsDa1Int$getValue("mcYear"), "average") +# expect_equal(tsDa1Int$getValue("elements"), "b") +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_lt(indexHour, 50) +# # BUG with interactive +# ## we must remove 24 hours ? +# expect_equal(dataTsDAInt$b[indexHour - 24], 2427150) +# # interactive with refStudy +# tsDa1Int <- tsPlot(x = myData1, +# refStudy = myData2, +# table = "areas", +# elements = myArea, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# tsDa1Int$setValue("mcYear", "average", reactive = FALSE) +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# expect_equal(dataTsDAInt$b[indexHour - 24], 0) +# +# # edit myData2 to have a diff != 0 +# ## pb timeZone local (PC, Travis, etc) +# for (i in 0:5){ +# timeEditShift <- lubridate::hours(i) +# timeEditMinus <- as.Date(timeEditValue) - timeEditShift +# timeEditPlus <- as.Date(timeEditValue) + timeEditShift +# myData2$areas[ (time == timeEditMinus | time == timeEditPlus) & area == myArea, `OV. COST` := as.integer(`OV. COST` + 2500)] +# } +# tsDa1Int <- tsPlot(x = myData2, +# refStudy = myData1, +# table = "areas", +# elements = myArea, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# dateRange = DR) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# tsDa1Int$setValue("mcYear", "average", reactive = TRUE) +# tsDa1Int$setValue("tables", "areas", reactive = TRUE) +# tsDa1Int$setValue("elements", "b", reactive = TRUE) +# tsDa1Int$updateCharts() +# dataTsDAInt <- .get_data_from_htmlwidget(tsDa1Int) +# expect_equal(dataTsDAInt$b[indexHour - 24], 2500) +# }) +# +# describe("tsPlot, no interactive, x and refStudy are optsH5 ", { +# testthat::skip("Reason: .runTsPlotTest is not TRUE") +# if (.requireRhdf5_Antares(stopP = FALSE)){ +# skip_if_not(.runTsPlotTest) +# suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) +# optsH5 <- setSimulationPath(pathtemp) +# myLink <- "a - a_offshore" +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# # no interactive +# tsDa1 <- tsPlot(x = optsH5, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) +# #ref Study +# tsDa1 <- tsPlot(x = optsH5, +# refStudy = optsH5, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], 0) +# # Edit H5 file +# ## create a new folder h5 +# pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) +# pathNewH5 <- file.path(pathInitial, "testH5") +# if (!dir.exists(pathNewH5)){ +# dir.create(pathNewH5) +# } +# #write the study +# #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) +# optsData <- antaresRead::setSimulationPath(path = studyPath) +# suppressWarnings(writeAntaresH5(path = pathNewH5, opts = optsData, +# overwrite = TRUE, supressMessages = TRUE)) +# +# pathNewH5File <- file.path(pathNewH5, list.files(pathNewH5)) +# .h5Antares_edit_variable( +# pathH5 = pathNewH5File, +# link = myLink, +# timeId = 1:100, +# antVar = "FLOW LIN.", +# newValue = 15000 +# ) +# +# optsH5New <- setSimulationPath(path = pathNewH5File) +# tsDa1 <- tsPlot(x = optsH5New, +# refStudy = optsH5, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], 15009) +# } +# }) +# +# describe("tsPlot, no interactive, x is a list of optH5 and refStudy are optsH5 ", { +# if (.requireRhdf5_Antares(stopP = FALSE)){ +# skip_if_not(.runTsPlotTest) +# suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) +# optsH5 <- setSimulationPath(pathtemp) +# +# # with new Studies H5 test if compare prodStack works +# ## create new folders h5 +# pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) +# +# listFolderToCreate <- c("testH5v2", "testH5v3", "testH5v4") +# for (folder in listFolderToCreate){ +# pathNewH5 <- file.path(pathInitial, folder) +# if (!dir.exists(pathNewH5)){ +# dir.create(pathNewH5) +# } +# #write the study +# #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) +# optsData <- antaresRead::setSimulationPath(path = studyPath) +# suppressWarnings( +# writeAntaresH5( +# path = pathNewH5, +# opts = optsData, +# overwrite = TRUE, +# supressMessages = TRUE) +# ) +# } +# idWidgetToEdit <- 2 +# pathH5FolderToEdit <- file.path(pathInitial, listFolderToCreate[[idWidgetToEdit]]) +# pathH5FileToEdit <- file.path(pathH5FolderToEdit, list.files(pathH5FolderToEdit)) +# newValueFlow <- 15000 +# myLink <- getLinks()[1] +# .h5Antares_edit_variable( +# pathH5 = pathH5FileToEdit, +# link = myLink, +# timeId = 1:100, +# antVar = "FLOW LIN.", +# newValue = newValueFlow +# ) +# optsList <- list() +# antaresDataListH5 <- list() +# for (i in 1:length(listFolderToCreate)){ +# pathOptsI <- file.path(pathInitial, listFolderToCreate[[i]]) +# optsList[[i]] <- setSimulationPath(path = pathOptsI) +# antaresDataListH5[[i]] <- readAntares(links = myLink) +# } +# #test the data from h5 +# #get the data from the h5 file +# antaresDataRef <- readAntares(opts = optsH5, links = myLink) +# expect_equal(max(antaresDataListH5[[idWidgetToEdit]]$`FLOW LIN.`), newValueFlow) +# expect_equal(max(antaresDataListH5[[1]]$`FLOW LIN.`), max(antaresDataRef$`FLOW LIN.`)) +# expect_equal(max(antaresDataListH5[[3]]$`FLOW LIN.`), max(antaresDataRef$`FLOW LIN.`)) +# # get the data from htmlwidget +# myArea <- "a" +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# tsDa1 <- tsPlot(x = optsList, +# refStudy = optsH5, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa3 <- .get_data_from_htmlwidget(tsDa1, widgetsNumber = idWidgetToEdit) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDa3$hour) +# expect_equal(dataTsDa3$`a - a_offshore`[indexHour], 15009) +# dataTsDa2 <- .get_data_from_htmlwidget(tsDa1, widgetsNumber = 1) +# expect_equal(dataTsDa2$`a - a_offshore`[indexHour], 0) +# } +# }) +# +# describe("tsPlot, interactive, x and refStudy are optsH5 ", { +# if (.requireRhdf5_Antares(stopP = FALSE)){ +# skip_if_not(.runTsPlotTest) +# suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) +# optsH5 <- setSimulationPath(pathtemp) +# myLink <- "a - a_offshore" +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# # no interactive +# tsDa1 <- tsPlot(x = optsH5, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE) +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -9) +# #interactive +# tsDa1Int <- tsPlot(x = optsH5, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# h5requestFiltering = list( +# mcYears = 1 +# )) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# expect_equal(tsDa1Int$ncharts, 1) +# expect_equal(tsDa1Int$ncol, 1) +# expect_equal(tsDa1Int$nrow, 1) +# expect_true(is((tsDa1Int$getValue("x_tranform")[[1]]), "antaresData")) +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# tsDa1Int$setValue("tables", "areas", reactive = TRUE) +# tsDa1Int$setValue("elements", "b", reactive = TRUE) +# tsDa1Int$setValue("variable", "LOAD", reactive = TRUE) +# tsDa1Int$setValue("dateRange", DR, reactive = TRUE) +# tsDa1Int$updateCharts() +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# tsDa1Int$setValue("meanYearH5", FALSE, reactive = TRUE) +# tsDa1Int$updateCharts() +# tsDa1Int$setValue("meanYearH5", FALSE, reactive = TRUE) +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# expect_equal(tsDa1Int$getValue("tables"), "areas") +# expect_equal(tsDa1Int$getValue("mcYear"), 1) +# expect_equal(tsDa1Int$getValue("elements"), "b") +# expect_equal(tsDa1Int$getValue("variable"), "LOAD") +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_gt(indexHour, 2) +# expect_equal(dataTsDa1$b[indexHour], 60262) +# # Edit H5 file +# ## create a new folder h5 +# pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) +# pathNewH5 <- file.path(pathInitial, "testH5") +# if (!dir.exists(pathNewH5)){ +# dir.create(pathNewH5) +# } +# #write the study +# #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) +# optsData <- antaresRead::setSimulationPath(path = studyPath) +# suppressWarnings(writeAntaresH5(path = pathNewH5, opts = optsData, +# overwrite = TRUE, supressMessages = TRUE)) +# pathNewH5File <- file.path(pathNewH5, list.files(pathNewH5)) +# .h5Antares_edit_variable( +# pathH5 = pathNewH5File, +# area = "b", +# timeId = 1:100, +# antVar = "LOAD", +# newValue = 15000, +# mcYear = 1 +# ) +# optsH5New <- setSimulationPath(path = pathNewH5File) +# myData <- readAntares(areas = "b", +# select = "LOAD", +# opts = optsH5New, +# mcYears = 1) +# myDataRef <- readAntares(areas = "b", +# select = "LOAD", +# opts = optsH5, +# mcYears = 1) +# expect_equal(myData[area == "b" & timeId == 2737, LOAD], 15000) +# expect_gt(myDataRef[area == "b" & timeId == 2737, LOAD], 16000) +# +# diffValue <- myData[area == "b" & timeId == 2737, LOAD] - +# myDataRef[area == "b" & timeId == 2737, LOAD] +# tsDa1Int <- tsPlot(x = optsH5New, +# refStudy = optsH5, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# h5requestFiltering = list( +# mcYears = 1 +# )) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# expect_equal(tsDa1Int$ncharts, 1) +# expect_equal(tsDa1Int$ncol, 1) +# expect_equal(tsDa1Int$nrow, 1) +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# tsDa1Int$setValue("tables", "areas", reactive = TRUE) +# tsDa1Int$setValue("elements", "b", reactive = FALSE) +# tsDa1Int$setValue("variable", "LOAD", reactive = FALSE) +# tsDa1Int$setValue("dateRange", DR, reactive = FALSE) +# tsDa1Int$updateCharts() +# expect_equal(tsDa1Int$getValue("tables"), "areas") +# expect_equal(tsDa1Int$getValue("mcYear"), 1) +# expect_equal(tsDa1Int$getValue("elements"), "b") +# expect_equal(tsDa1Int$getValue("variable"), "LOAD") +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_equal(dataTsDa1$b[indexHour], diffValue) +# # for links, no refStudy +# tsDa1Int <- tsPlot(x = optsH5New, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# h5requestFiltering = list( +# mcYears = 1 +# )) +# tsDa1Int <- tsDa1Int$init() +# expect_true(is(tsDa1Int, "MWController")) +# expect_equal(tsDa1Int$ncharts, 1) +# expect_equal(tsDa1Int$ncol, 1) +# expect_equal(tsDa1Int$nrow, 1) +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# tsDa1Int$setValue("tables", "links", reactive = TRUE) +# tsDa1Int$setValue("elements", myLink, reactive = FALSE) +# tsDa1Int$setValue("variable", "FLOW LIN.", reactive = FALSE) +# tsDa1Int$setValue("dateRange", DR, reactive = FALSE) +# tsDa1Int$updateCharts() +# tsDa1Int$setValue("mcYear", 1, reactive = TRUE) +# expect_true(is((tsDa1Int$getValue("x_tranform")[[1]]), "antaresData")) +# expect_equal(tsDa1Int$getValue("tables"), "links") +# expect_equal(tsDa1Int$getValue("mcYear"), 1) +# expect_equal(tsDa1Int$getValue("elements"), myLink) +# expect_equal(tsDa1Int$getValue("variable"), "FLOW LIN.") +# dataTsDa1 <- .get_data_from_htmlwidget(tsDa1Int) +# indexHour <- grep(timeEditValue, dataTsDa1$hour) +# expect_equal(dataTsDa1$`a - a_offshore`[indexHour], -10) +# # for links, with refStudy +# tsDa1IntRef <- tsPlot(x = optsH5New, +# refStudy = optsH5, +# type = "ts", +# interactive = TRUE, +# .runApp = FALSE, +# h5requestFiltering = list( +# mcYears = 1 +# )) +# tsDa1IntRef <- tsDa1IntRef$init() +# expect_true(is(tsDa1IntRef, "MWController")) +# expect_equal(tsDa1IntRef$ncharts, 1) +# expect_equal(tsDa1IntRef$ncol, 1) +# expect_equal(tsDa1IntRef$nrow, 1) +# expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) +# tsDa1IntRef$setValue("mcYear", 1, reactive = TRUE) +# expect_equal(tsDa1IntRef$getValue("mcYear"), 1) +# expect_equal(tsDa1IntRef$getValue("tables"), "areas") +# tsDa1IntRef$setValue("tables", "links", reactive = TRUE) +# tsDa1IntRef$setValue("elements", myLink, reactive = FALSE) +# tsDa1IntRef$setValue("variable", "FLOW LIN.", reactive = FALSE) +# tsDa1IntRef$setValue("dateRange", DR, reactive = FALSE) +# tsDa1IntRef$setValue("meanYearH5", FALSE, reactive = TRUE) +# tsDa1IntRef$updateCharts() +# tsDa1IntRef$setValue("meanYearH5", TRUE, reactive = TRUE) +# tsDa1IntRef$setValue("mcYear", 1, reactive = TRUE) +# expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) +# expect_equal(tsDa1IntRef$getValue("tables"), "links") +# expect_true(is((tsDa1IntRef$getValue("x_tranform")[[1]]), "antaresData")) +# expect_equal(tsDa1IntRef$getValue("elements"), myLink) +# expect_equal(tsDa1IntRef$getValue("variable"), "FLOW LIN.") +# expect_equal(tsDa1IntRef$getValue("mcYear"), 1) +# dataTsDa1Ref <- .get_data_from_htmlwidget(tsDa1IntRef) +# indexHour <- grep(timeEditValue, dataTsDa1Ref$hour) +# expect_equal(dataTsDa1Ref$`a - a_offshore`[indexHour], 0) +# } +# }) +# +# describe("tsPlot, interactive, x is a list of optsH5 and refStudy optsH5", { +# if (.requireRhdf5_Antares(stopP = FALSE)){ +# skip_if_not(.runTsPlotTest) +# suppressMessages(writeAntaresH5(pathtemp, opts = opts, overwrite = TRUE)) +# optsH5 <- setSimulationPath(pathtemp) +# +# # with new Studies H5 test if compare prodStack works +# ## create new folders h5 +# pathInitial <- file.path(dirname(pathtemp), basename(pathtemp)) +# listFolderToCreate <- c("testH5v2", "testH5v3", "testH5v4") +# for (folder in listFolderToCreate){ +# pathNewH5 <- file.path(pathInitial, folder) +# if (!dir.exists(pathNewH5)){ +# dir.create(pathNewH5) +# } +# +# #write the study +# #windows pb ? pathNewH5 <- gsub("/", "\\", pathNewH5, fixed = TRUE) +# optsData <- antaresRead::setSimulationPath(path = studyPath) +# suppressWarnings( +# writeAntaresH5( +# path = pathNewH5, +# opts = optsData, +# overwrite = TRUE, +# supressMessages = TRUE) +# ) +# } +# pathH5FolderToEdit <- file.path(pathInitial, listFolderToCreate[[2]]) +# pathH5FileToEdit <- file.path(pathH5FolderToEdit, list.files(pathH5FolderToEdit)) +# myLink <- getLinks()[1] +# newValueFlow <- 50000 +# mcYearToTestList <- c(2, NULL) +# myVar <- "FLOW LIN." +# for (mcYearToTest in mcYearToTestList){ +# .h5Antares_edit_variable( +# pathH5 = pathH5FileToEdit, +# link = myLink, +# timeId = 1:100, +# antVar = myVar, +# newValue = newValueFlow, +# mcYear = mcYearToTest +# ) +# #stock the data +# optsList <- list() +# antaresDataListH5 <- list() +# for (i in 1:length(listFolderToCreate)){ +# pathOptsI <- file.path(pathInitial, listFolderToCreate[[i]]) +# optsList[[i]] <- setSimulationPath(path = pathOptsI) +# antaresDataListH5[[i]] <- readAntares(links = myLink, +# mcYear = mcYearToTest, +# opts = optsList[[i]]) +# } +# DR <- c("2018-04-24 00:00:00 UTC", "2018-04-26 00:00:00 UTC") +# #try without refStudy and interactive == FALSE +# indexHour <- 49 +# expect_equal(antaresDataListH5[[2]]$`FLOW LIN.`[[indexHour]], 50000) +# if(is.null(mcYearToTest)){ +# valFlow <- (-9) +# }else{ +# valFlow <- (-7) +# } +# expect_equal(antaresDataListH5[[1]]$`FLOW LIN.`[[indexHour]], valFlow) +# expect_equal(antaresDataListH5[[3]]$`FLOW LIN.`[[indexHour]], valFlow) +# +# if(!is.null(mcYearToTest)){ +# expect_error(tsPlot(x = optsList, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE, +# mcYear = mcYearToTest), +# "You can't use mcYear for h5 file when interactive is set to FALSE. You can use mcYearh5.") +# } +# tsPlotNoInt <- tsPlot(x = optsList, +# table = "links", +# elements = myLink, +# type = "ts", +# interactive = FALSE, +# mcYearh5 = mcYearToTest) +# datatsPlotNoInt <- .get_data_from_htmlwidget(tsPlotNoInt, widgetsNumber = 2) +# timeEditValue <- "2018-04-25T00:00:00.000Z" +# indexHour <- grep(timeEditValue, datatsPlotNoInt$hour) +# expect_gt(indexHour, 2) +# expect_equal(datatsPlotNoInt$`a - a_offshore`[[indexHour]], 50000) +# #interactive +# tsPlotInt <- tsPlot(x = optsList, +# type = "ts", +# dateRange = DR, +# .runApp = FALSE, +# interactive = TRUE, +# h5requestFiltering = list( +# mcYears = mcYearToTest +# )) +# tsPlotInt <- tsPlotInt$init() +# expect_true(is(tsPlotInt, "MWController")) +# expect_equal(tsPlotInt$ncharts, 3) +# expect_equal(tsPlotInt$ncol, 2) +# expect_equal(tsPlotInt$nrow, 2) +# tsPlotInt$setValue("mcYear", mcYearToTest, reactive = TRUE) +# tsPlotInt$setValue("tables", "links", reactive = TRUE) +# tsPlotInt$setValue("elements", myLink, reactive = TRUE) +# tsPlotInt$setValue("variable", myVar, reactive = TRUE) +# tsPlotInt$setValue("dateRange", DR, reactive = TRUE) +# if(is.null(mcYearToTest)){ +# tsPlotInt$setValue("meanYearH5", FALSE, reactive = TRUE) +# expect_equal(tsPlotInt$getValue("meanYearH5"), FALSE) +# tsPlotInt$setValue("mcYear", "average", reactive = TRUE) +# }else{ +# tsPlotInt$setValue("meanYearH5", TRUE, reactive = TRUE) +# expect_equal(tsPlotInt$getValue("meanYearH5"), TRUE) +# } +# tsPlotInt$updateCharts() +# expect_equal(tsPlotInt$getValue("tables"), "links") +# tsPlotInt$setValue("mcYear", mcYearToTest, reactive = TRUE) +# if(!is.null(mcYearToTest)){ +# expect_equal(tsPlotInt$getValue("mcYear"), mcYearToTest) +# }else{ +# tsPlotInt$setValue("mcYear", "average", reactive = TRUE) +# expect_equal(tsPlotInt$getValue("mcYear"), "average") +# } +# expect_equal(tsPlotInt$getValue("mcYearH5"),"1") +# expect_equal(tsPlotInt$getValue("elements"), myLink) +# expect_equal(tsPlotInt$getValue("variable"), myVar) +# datatsPlotInt <- .get_data_from_htmlwidget(tsPlotInt, widgetsNumber = 2) +# indexHour <- grep(timeEditValue, datatsPlotInt$hour) +# expect_equal(datatsPlotInt$`a - a_offshore`[[indexHour]], 50000) +# datatsPlotInt2 <- .get_data_from_htmlwidget(tsPlotInt, widgetsNumber = 1) +# indexHour <- grep(timeEditValue, datatsPlotInt2$hour) +# expect_equal(datatsPlotInt2$`a - a_offshore`[[indexHour]], valFlow) +# #interactive with refStudy +# tsPlotIntRef <- tsPlot(x = optsList, +# refStudy = optsH5, +# type = "ts", +# dateRange = DR, +# .runApp = FALSE, +# interactive = TRUE, +# h5requestFiltering = list( +# mcYears = mcYearToTest +# )) +# tsPlotIntRef <- tsPlotIntRef$init() +# expect_true(is(tsPlotIntRef, "MWController")) +# expect_equal(tsPlotIntRef$ncharts, 3) +# expect_equal(tsPlotIntRef$ncol, 2) +# expect_equal(tsPlotIntRef$nrow, 2) +# tsPlotIntRef$setValue("mcYear", mcYearToTest, reactive = TRUE) +# tsPlotIntRef$setValue("tables", "links", reactive = TRUE) +# tsPlotIntRef$setValue("elements", myLink, reactive = TRUE) +# tsPlotIntRef$setValue("variable", myVar, reactive = TRUE) +# tsPlotIntRef$setValue("dateRange", DR, reactive = TRUE) +# if(is.null(mcYearToTest)){ +# tsPlotIntRef$setValue("meanYearH5", FALSE, reactive = TRUE) +# expect_equal(tsPlotIntRef$getValue("meanYearH5"), FALSE) +# }else{ +# tsPlotIntRef$setValue("meanYearH5", TRUE, reactive = TRUE) +# expect_equal(tsPlotIntRef$getValue("meanYearH5"), TRUE) +# } +# tsPlotIntRef$updateCharts() +# expect_equal(tsPlotIntRef$getValue("tables"), "links") +# tsPlotIntRef$setValue("mcYear", mcYearToTest, reactive = TRUE) +# if(!is.null(mcYearToTest)){ +# expect_equal(tsPlotInt$getValue("mcYear"), mcYearToTest) +# expect_equal(tsPlotIntRef$getValue("mcYearH5"),"1") +# }else{ +# tsPlotIntRef$setValue("mcYear", "average", reactive = TRUE) +# tsPlotIntRef$setValue("mcYearH5", "", reactive = TRUE) +# expect_equal(tsPlotIntRef$getValue("mcYearH5"),"") +# expect_equal(tsPlotIntRef$getValue("mcYear"), "average") +# } +# expect_equal(tsPlotIntRef$getValue("elements"), myLink) +# expect_equal(tsPlotIntRef$getValue("variable"), myVar) +# datatsPlotIntRef <- .get_data_from_htmlwidget(tsPlotIntRef, widgetsNumber = 2) +# indexHour <- grep(timeEditValue, datatsPlotIntRef$hour) +# expect_equal(datatsPlotIntRef$`a - a_offshore`[[indexHour]], 50000-(valFlow)) +# datatsPlotIntRef2 <- .get_data_from_htmlwidget(tsPlotIntRef, widgetsNumber = 1) +# indexHour <- grep(timeEditValue, datatsPlotIntRef2$hour) +# expect_equal(datatsPlotIntRef2$`a - a_offshore`[[indexHour]], 0) +# } +# } +# })