From 245947d42eb36487d300765b120c1beb39eaece3 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 27 Mar 2018 16:14:09 +0200 Subject: [PATCH] init new features --- DESCRIPTION | 4 +- R/limitSizeGraph.R | 12 +- R/map.R | 507 +++++++++++++----- R/map_helpers.R | 26 +- R/map_plugins.R | 8 +- R/plot.R | 339 ++++++++---- R/plot_barplot.R | 8 +- R/plot_stats.R | 55 +- R/plot_ts.R | 25 +- R/plot_utils.R | 22 +- R/stack.R | 10 +- R/stack_aliases.R | 17 +- R/stack_exchanges.R | 184 +++++-- R/stack_prod.R | 233 +++++--- R/tsLegend.R | 85 ++- R/zzz.R | 71 ++- README.md | 4 - inst/application/server.R | 4 +- .../application/src/server/01_set_read_data.R | 6 +- inst/application/src/server/05_modules.R | 87 ++- inst/application/src/server/06_module_map.R | 28 +- inst/application/ui.R | 6 +- inst/application/www/is.min.js | 5 + inst/js_dates_locales.csv | 435 +++++++++++++++ inst/language_columns.csv | 69 +++ inst/language_labels.csv | 86 +++ inst/leafletPlugins/antaresLegend.js | 28 +- 27 files changed, 1887 insertions(+), 477 deletions(-) create mode 100644 inst/application/www/is.min.js create mode 100644 inst/js_dates_locales.csv create mode 100644 inst/language_columns.csv create mode 100644 inst/language_labels.csv diff --git a/DESCRIPTION b/DESCRIPTION index 254cd1b..0fc1807 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: antaresViz Type: Package Title: Antares Visualizations -Version: 0.12.0 -Date: 2017-12-14 +Version: 0.13.0 +Date: 2018-03-28 Authors@R: c( person("Jalal-Edine", "ZAWAM", , "jalal-edine.zawam@rte-france.com", role = c("aut", "cre")), person("Francois", "Guillem", , "francois.guillem@rte-france.com", role = "aut"), diff --git a/R/limitSizeGraph.R b/R/limitSizeGraph.R index 6d78631..e69731d 100644 --- a/R/limitSizeGraph.R +++ b/R/limitSizeGraph.R @@ -11,13 +11,21 @@ limitSizeGraph <- function(size){ options(antaresVizSizeGraph = size) } -controlWidgetSize <- function(widget){ +# @importFrom pryr object_size +controlWidgetSize <- function(widget, language = "en"){ if(is.null(getOption("antaresVizSizeGraph"))){ options(antaresVizSizeGraph = 200) } + # round(as.numeric(pryr::object_size(widget)) / 1048000, 1) if(round(as.numeric(object.size(widget)) / 1048000, 1) > getOption("antaresVizSizeGraph")){ - return(combineWidgets(antaresVizSizeGraphError)) + return( + combineWidgets( + switch(language, + "fr" = antaresVizSizeGraphError_fr, + antaresVizSizeGraphError) + ) + ) } else { widget } diff --git a/R/map.R b/R/map.R index 11436a6..c8c86b1 100644 --- a/R/map.R +++ b/R/map.R @@ -155,7 +155,8 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), timeSteph5 = "hourly", mcYearh5 = NULL, tablesh5 = c("areas", "links"), - sizeMiniPlot = FALSE,...) { + sizeMiniPlot = FALSE,language = "en", + hidden = NULL, ...) { if(!is.null(compare) && !interactive){ @@ -165,6 +166,26 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), Column <- optionsT <- NULL tpMap <- plotMapOptions() + # Check language + if(!language %in% availableLanguages_labels){ + stop("Invalid 'language' argument. Must be in : ", paste(availableLanguages_labels, collapse = ", ")) + } + + if(language != "en"){ + colAreaVar <- .getColumnsLanguage(colAreaVar, language) + sizeAreaVars <- .getColumnsLanguage(sizeAreaVars, language) + popupAreaVars <- .getColumnsLanguage(popupAreaVars, language) + labelAreaVar <- .getColumnsLanguage(labelAreaVar, language) + colLinkVar <- .getColumnsLanguage(colLinkVar, language) + sizeLinkVar <- .getColumnsLanguage(sizeLinkVar, language) + popupLinkVars <- .getColumnsLanguage(popupLinkVars, language) + } + + # Check hidden + .validHidden(hidden, c("H5request", "timeSteph5", "tables", "mcYearH5", "mcYear", "dateRange", "Areas", "colAreaVar", + "sizeAreaVars", "miniPlot", "areaChartType", "sizeMiniPlot", "uniqueScale", "showLabels", + "popupAreaVars", "labelAreaVar", "Links", "colLinkVar", "sizeLinkVar", "popupLinkVars","type")) + #Check compare .validCompare(compare, c("mcYear", "type", "colAreaVar", "sizeAreaVars", "areaChartType", "showLabels", "popupAreaVars", "labelAreaVar","colLinkVar", "sizeLinkVar", "popupLinkVars")) @@ -176,15 +197,18 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), areaChartType <- match.arg(areaChartType) xyCompare <- match.arg(xyCompare) - if(colAreaVar != "none" & colAreaVar%in%colorsVars$Column & runScale) + tmp_colAreaVar <- gsub("(_std$)|(_min$)|(_max$)", "", colAreaVar) + if(tmp_colAreaVar != "none" & tmp_colAreaVar%in%colorsVars$Column & runScale) { - raw <- colorsVars[Column == colAreaVar] + raw <- colorsVars[Column == tmp_colAreaVar] options <- plotMapOptions(areaColorScaleOpts = colorScaleOptions( - negCol = "#FFFFFF", - zeroCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255), - posCol = rgb(raw$red/2, raw$green/2, raw$blue/2, maxColorValue = 255))) - + negCol = "#FF0000", + # zeroCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255), + # posCol = rgb(raw$red/2, raw$green/2, raw$blue/2, maxColorValue = 255)), + zeroCol = "#FFFFFF", + posCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255))) } + if (is.null(mcYear)) mcYear <- "average" if(!is.null(compare) && "list" %in% class(x)){ @@ -258,7 +282,7 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), } - } + } # Keep only links and areas present in the data if (areas) { @@ -325,7 +349,7 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), # print(dateRange) if(!is.null(dateRange)){ dateRange <- sort(dateRange) - # xx <<- copy(x$areas) + # xx <<- copy(x) # dd <<- dateRange if(!is.null(x$areas)) { @@ -333,6 +357,9 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), if("character" %in% class(x$areas$time)){ x$areas[,time := .timeIdToDate(x$areas$timeId, attr(x, "timeStep"), simOptions(x))] } + if("Date" %in% class(x$areas$time)){ + x$areas[,time := as.POSIXct(time, tz = "UTC")] + } x$areas <- x$areas[time >= as.POSIXlt(dateRange[1], tz = "UTC") & time < as.POSIXlt(dateRange[2] + 1, tz = "UTC")] } if(!is.null(x$links)) @@ -341,31 +368,73 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), if("character" %in% class(x$links$time)){ x$links[,time := .timeIdToDate(x$links$timeId, attr(x, "timeStep"), simOptions(x))] } + if("Date" %in% class(x$links$time)){ + x$links[,time := as.POSIXct(time, tz = "UTC")] + } x$links <- x$links[time >= as.POSIXlt(dateRange[1], tz = "UTC") & time < as.POSIXlt(dateRange[2] + 1, tz = "UTC")] } } if (initial) { assign("currentMapLayout", mapLayout, envir = env_plotFun) - map <- .initMap(x, mapLayout, options) %>% syncWith(group) + map <- .initMap(x, mapLayout, options, language = language) %>% syncWith(group) } else if(!isTRUE(all.equal(mapLayout, get("currentMapLayout", envir = env_plotFun)))){ assign("currentMapLayout", mapLayout) - map <- .initMap(x, mapLayout, options) %>% syncWith(group) + map <- .initMap(x, mapLayout, options, language = language) %>% syncWith(group) } else { # in some case, map doesn't existed yet....! if("output_1_zoom" %in% names(session$input)){ map <- leafletProxy(outputId, session) } else { - map <- .initMap(x, mapLayout, options) %>% syncWith(group) + map <- .initMap(x, mapLayout, options, language = language) %>% syncWith(group) } } - map %>% + map <- map %>% .redrawLinks(x, mapLayout, mcYear, t, colLinkVar, sizeLinkVar, popupLinkVars, options) %>% .redrawCircles(x, mapLayout, mcYear, t, colAreaVar, sizeAreaVars, popupAreaVars, uniqueScale, showLabels, labelAreaVar, areaChartType, options, sizeMiniPlot) + + # combineWidgets(map, width = width, height = height) # bug + map + } + # Create the interactive widget + if(language != "en"){ + ind_to_change <- which(colnames(x$areas) %in% language_columns$en) + if(length(ind_to_change) > 0){ + new_name <- language_columns[en %in% colnames(x$areas), ] + v_new_name <- new_name[[language]] + names(v_new_name) <- new_name[["en"]] + setnames(x$areas, colnames(x$areas)[ind_to_change], unname(v_new_name[colnames(x$areas)[ind_to_change]])) + } + + ind_to_change <- which(colnames(syntx$areas) %in% language_columns$en) + if(length(ind_to_change) > 0){ + new_name <- language_columns[en %in% colnames(syntx$areas), ] + v_new_name <- new_name[[language]] + names(v_new_name) <- new_name[["en"]] + setnames(syntx$areas, colnames(syntx$areas)[ind_to_change], unname(v_new_name[colnames(syntx$areas)[ind_to_change]])) + } + + ind_to_change <- which(colnames(x$links) %in% language_columns$en) + if(length(ind_to_change) > 0){ + new_name <- language_columns[en %in% colnames(x$links), ] + v_new_name <- new_name[[language]] + names(v_new_name) <- new_name[["en"]] + setnames(x$links, colnames(x$links)[ind_to_change], unname(v_new_name[colnames(x$links)[ind_to_change]])) + } + + ind_to_change <- which(colnames(syntx$links) %in% language_columns$en) + if(length(ind_to_change) > 0){ + new_name <- language_columns[en %in% colnames(syntx$links), ] + v_new_name <- new_name[[language]] + names(v_new_name) <- new_name[["en"]] + setnames(syntx$links, colnames(syntx$links)[ind_to_change], unname(v_new_name[colnames(syntx$links)[ind_to_change]])) + } + } + areaValColumns <- setdiff(names(x$areas), .idCols(x$areas)) areaValColumnsSynt <- setdiff(names(syntx$areas), .idCols(syntx$areas)) @@ -436,29 +505,30 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), tmp_options <- plotMapOptions() } - params$x[[.id]]$plotFun(t = params$x[[.id]]$timeId, - colAreaVar = colAreaVar, - sizeAreaVars = sizeAreaVars, - popupAreaVars = popupAreaVars, - areaChartType = areaChartType, - uniqueScale = uniqueScale, - showLabels = showLabels, - labelAreaVar = labelAreaVar, - colLinkVar = colLinkVar, - sizeLinkVar = sizeLinkVar, - popupLinkVars = popupLinkVars, - type = type, - mcYear = mcYear, - initial = .initial, - session = .session, - outputId = .output, - dateRange = dateRange, - sizeMiniPlot = sizeMiniPlot, - options = tmp_options) - + widget <- params$x[[.id]]$plotFun(t = params$x[[.id]]$timeId, + colAreaVar = colAreaVar, + sizeAreaVars = sizeAreaVars, + popupAreaVars = popupAreaVars, + areaChartType = areaChartType, + uniqueScale = uniqueScale, + showLabels = showLabels, + labelAreaVar = labelAreaVar, + colLinkVar = colLinkVar, + sizeLinkVar = sizeLinkVar, + popupLinkVars = popupLinkVars, + type = type, + mcYear = mcYear, + initial = .initial, + session = .session, + outputId = .output, + dateRange = dateRange, + sizeMiniPlot = sizeMiniPlot, + options = tmp_options) + # controlWidgetSize(widget, language) # bug due to leaflet and widget + widget } else { - combineWidgets("No data for this selection") + combineWidgets(.getLabelLanguage("No data for this selection", language)) } }else{ combineWidgets() @@ -469,19 +539,7 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), x_in = mwSharedValue({ .giveListFormat(x) }), - options = mwSharedValue({options}), - optionsT = mwSharedValue({ - if(colAreaVar %in% colorsVars$Column & runScale){ - raw <- colorsVars[Column == colAreaVar] - plotMapOptions(areaColorScaleOpts = colorScaleOptions( - negCol = "#FFFFFF", - zeroCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255), - posCol = rgb(raw$red/2, raw$green/2, raw$blue/2, maxColorValue = 255)) - ) - }else{ - options - } - }), + h5requestFiltering = mwSharedValue({h5requestFiltering}), paramsH5 = mwSharedValue({ @@ -490,24 +548,65 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), paramsH5List }), H5request = mwGroup( - timeSteph5 = mwSelect(choices = paramsH5$timeStepS, - value = paramsH5$timeStepS[1], - label = "timeStep", - multiple = FALSE), - tables = mwSelect(choices = paramsH5[["tabl"]][paramsH5[["tabl"]] %in% c("areas", "links")], - value = { - if(.initial) {paramsH5[["tabl"]][paramsH5[["tabl"]] %in% c("areas", "links")]} else {NULL} - }, - label = "table", multiple = TRUE), - mcYearH5 = mwSelect(choices = c(paramsH5[["mcYearS"]]), - value = { - if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} - }, - label = "mcYear", multiple = TRUE), - .display = {any(unlist(lapply(x_in, .isSimOpts)))} + label = .getLabelLanguage("H5request", language), + timeSteph5 = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5$timeStepS + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + } else { + choices <- NULL + } + choices + }, + value = paramsH5$timeStepS[1], + label = .getLabelLanguage("timeStep", language), + multiple = FALSE, .display = !"timeSteph5" %in% hidden + ), + tables = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5[["tabl"]][paramsH5[["tabl"]] %in% c("areas", "links")] + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + } else { + choices <- NULL + } + choices + }, + value = { + if(.initial) {paramsH5[["tabl"]][paramsH5[["tabl"]] %in% c("areas", "links")]} else {NULL} + }, + label = .getLabelLanguage("table", language), multiple = TRUE, + .display = !"tables" %in% hidden + ), + mcYearH5 = mwSelectize( + choices = { + ch <- c("Average" = "", paramsH5[["mcYearS"]]) + names(ch)[1] <- .getLabelLanguage("Average", language) + ch + }, + value = { + if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} + }, + label = .getLabelLanguage("mcYears to be imported", language), + multiple = TRUE, options = list(maxItems = 4), + .display = (!"mcYearH5" %in% hidden & !meanYearH5) + ), + meanYearH5 = mwCheckbox(value = FALSE, + label = .getLabelLanguage("Average mcYear", language), + .display = !"meanYearH5" %in% hidden), + .display = {any(unlist(lapply(x_in, .isSimOpts))) & !"H5request" %in% hidden} ), sharerequest = mwSharedValue({ - list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + if(length(meanYearH5) > 0){ + if(meanYearH5){ + list(timeSteph5_l = timeSteph5, mcYearh_l = NULL, tables_l = tables) + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } }), x_tranform = mwSharedValue({ sapply(1:length(x_in),function(zz){ @@ -516,151 +615,263 @@ plotMap <- function(x, mapLayout, colAreaVar = "none", sizeAreaVars = c(), }), ##Stop h5 - mcYear = mwSelect({ - c("average", as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$x[[1]]$mcYear) - }), xyCompare))) - }, - value = { if(.initial) mcYear else NULL}, - .display = any(unlist(lapply(params$x, function(X){X$showMcYear}))) + mcYear = mwSelect( + { + # allMcY <- c("average", .compareOperation(lapply(params$x, function(vv){ + # unique(c(vv$x$areas$mcYear, vv$x$links$mcYear)) + # }), xyCompare)) + # names(allMcY) <- c(.getLabelLanguage("average", language), allMcY[-1]) + # allMcY + # BP 2017 + allMcY <- .compareOperation(lapply(params$x, function(vv){ + unique(c(vv$x$areas$mcYear, vv$x$links$mcYear)) + }), xyCompare) + names(allMcY) <- allMcY + if(is.null(allMcY)){ + allMcY <- "average" + names(allMcY) <- .getLabelLanguage("average", language) + } + allMcY + + }, + value = { if(.initial) mcYear else NULL}, + .display = any(unlist(lapply(params$x, function(X){X$showMcYear}))) & !"mcYear" %in% hidden, + label = .getLabelLanguage("mcYear to be displayed", language) + ), + type = mwRadio( + { + choices <- c("detail", "avg") + names(choices) <- c(.getLabelLanguage("By time id", language), .getLabelLanguage("Average", language)) + choices + }, + value = type, + label = .getLabelLanguage("type", language), + .display = !"type" %in% hidden ), - type = mwRadio(list("By time id"="detail", "Average" = "avg"), value = type), dateRange = mwDateRange( value = { if(.initial) params$x[[1]]$dateRange else NULL }, min = params$x[[1]]$dateRange[1], - max = params$x[[1]]$dateRange[2],label = "Daterange" + max = params$x[[1]]$dateRange[2], + language = eval(parse(text = "language")), + # format = "dd MM", + separator = " : ", + label = .getLabelLanguage("dateRange", language), + .display = !"dateRange" %in% hidden ), Areas = mwGroup( + label = .getLabelLanguage("Areas", language), colAreaVar = mwSelect( choices = { - if (mcYear == "average") { - c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ + if(length(params) > 0){ + if (mcYear == "average") { + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv$areaValColumnsSynt) - }), xyCompare)) - ) - }else{ - c("none", as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$areaValColumns) - }), xyCompare))) + }), xyCompare))) + }else{ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaValColumns) + }), xyCompare))) + } + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL } }, value = { if(.initial) colAreaVar else NULL }, - label = "Color" + label = .getLabelLanguage("Color", language), + .display = !"colAreaVar" %in% hidden ), sizeAreaVars = mwSelect( { - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$areaNumValColumns) - }), xyCompare)) + if(length(params) > 0){ + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaNumValColumns) + }), xyCompare)) + } else { + NULL + } }, value = { if(.initial) sizeAreaVars else NULL - }, label = "Size", multiple = TRUE), + }, + label = .getLabelLanguage("Size", language), + multiple = TRUE, .display = !"sizeAreaVars" %in% hidden + ), miniPlot = mwGroup( - areaChartType = mwSelect(list("bar chart" = "bar", - "pie chart" = "pie", - "polar (area)" = "polar-area", - "polar (radius)" = "polar-radius"), - value = { - if(.initial) areaChartType - else NULL - }), - sizeMiniPlot = mwCheckbox(FALSE), - .display = length(sizeAreaVars) >= 2), - uniqueScale = mwCheckbox(uniqueScale, label = "Unique scale", - .display = length(sizeAreaVars) >= 2 && areaChartType != "pie"), - showLabels = mwCheckbox(showLabels, label = "Show labels", - .display = length(sizeAreaVars) >= 2), + label = .getLabelLanguage("miniPlot", language), + areaChartType = mwSelect( + { + choices <- c("bar", "pie", "polar-area", "polar-radius") + names(choices) <- c(.getLabelLanguage("bar chart", language), + .getLabelLanguage("pie chart", language), + .getLabelLanguage("polar (area)", language), + .getLabelLanguage("polar (radius)", language)) + choices + }, + value = { + if(.initial) areaChartType + else NULL + }, label = .getLabelLanguage("areaChartType", language), + .display = !"areaChartType" %in% hidden + ), + sizeMiniPlot = mwCheckbox(sizeMiniPlot, label = .getLabelLanguage("sizeMiniPlot", language)), + .display = length(sizeAreaVars) >= 2 & !"miniPlot" %in% hidden + ), + uniqueScale = mwCheckbox(uniqueScale, label = .getLabelLanguage("Unique scale", language), + .display = length(sizeAreaVars) >= 2 && areaChartType != "pie" & !"uniqueScale" %in% hidden + ), + showLabels = mwCheckbox(showLabels, label = .getLabelLanguage("Show labels", language), + .display = length(sizeAreaVars) >= 2 & !"showLabels" %in% hidden + ), popupAreaVars = mwSelect( choices = { - if (mcYear == "average") { - c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ + if(length(params) > 0){ + if (mcYear == "average") { + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv$areaValColumnsSynt) }), xyCompare)) - ) - }else{ - c("none", as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$areaValColumns) - }), xyCompare))) + ) + }else{ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaValColumns) + }), xyCompare))) + } + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL } }, value = { if(.initial) popupAreaVars else NULL }, - label = "Popup", - multiple = TRUE + label = .getLabelLanguage("Popup", language), + multiple = TRUE, .display = !"popupAreaVars" %in% hidden ), labelAreaVar = mwSelect( - choices = { - if (mcYear == "average") { - c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$areaValColumnsSynt) - }), xyCompare)) - ) - }else{ - c("none", as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$areaValColumns) - }), xyCompare))) + choices = { + if(length(params) > 0){ + if (mcYear == "average") { + tmp <- c("none", + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaValColumnsSynt) + }), xyCompare)) + ) + }else{ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaValColumns) + }), xyCompare))) + } + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL } }, value = { if(.initial) labelAreaVar else NULL - }, label = "Label", - .display = length(sizeAreaVars) < 2 + }, label = .getLabelLanguage("Label", language), + .display = length(sizeAreaVars) < 2 & !"labelAreaVar" %in% hidden ), - .display = any(sapply(params$x, function(p) {"areas" %in% names(p$x)})) + .display = any(sapply(params$x, function(p) {"areas" %in% names(p$x)})) & !"Areas" %in% hidden ), Links = mwGroup( + label = .getLabelLanguage("Links", language), colLinkVar = mwSelect( { - c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ + if(length(params) > 0){ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv$linkValColums) }), xyCompare))) + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL + } }, value = { if(.initial) colLinkVar else NULL - }, label = "Color"), - sizeLinkVar = mwSelect({c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$linkNumValColumns) - }), xyCompare)) - )}, - value = { - if(.initial) sizeLinkVar - else NULL - }, label = "Width"), - popupLinkVars = mwSelect( { c("none", - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$linkValColums) - }), xyCompare))) - }, - value = { - if(.initial) popupLinkVars - else NULL - }, label = "Popup", multiple = TRUE), - .display = any(sapply(params$x, function(p) {"links" %in% names(p$x)})) + }, label = .getLabelLanguage("Color", language), .display = !"colLinkVar" %in% hidden + ), + sizeLinkVar = mwSelect( + { + if(length(params) > 0){ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$linkNumValColumns) + }), xyCompare))) + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL + } + + }, + value = { + if(.initial) sizeLinkVar + else NULL + }, label = .getLabelLanguage("Width", language), .display = !"sizeLinkVar" %in% hidden + ), + popupLinkVars = mwSelect( + { + if(length(params) > 0){ + tmp <- c("none", as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$linkValColums) + }), xyCompare))) + names(tmp) <- c(.getLabelLanguage("none", language), tmp[-1]) + tmp + } else { + NULL + } + }, + value = { + if(.initial) popupLinkVars + else NULL + }, label = .getLabelLanguage("Popup", language), multiple = TRUE, .display = !"popupLinkVars" %in% hidden + ), + .display = any(sapply(params$x, function(p) {"links" %in% names(p$x)})) & !"Links" %in% hidden ), mapLayout = mwSharedValue(mapLayout), params = mwSharedValue({ - .getDataForComp(x_tranform, NULL, compare, compareOpts, - processFun = processFun, mapLayout = mapLayout) + if(length(x_tranform) > 0 & length(mapLayout) > 0){ + tmp <- .getDataForComp(x_tranform, NULL, compare, compareOpts, + processFun = processFun, mapLayout = mapLayout) + tmp2 <<- tmp + tmp + } + }), + options = mwSharedValue({options}), + optionsT = mwSharedValue({ + if(length(colAreaVar) > 0){ + tmp_colAreaVar <- gsub("(_std$)|(_min$)|(_max$)", "", colAreaVar) + if(tmp_colAreaVar %in% colorsVars$Column & runScale){ + raw <- colorsVars[Column == tmp_colAreaVar] + plotMapOptions(areaColorScaleOpts = colorScaleOptions( + negCol = "#FF0000", + # zeroCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255), + # posCol = rgb(raw$red/2, raw$green/2, raw$blue/2, maxColorValue = 255)), + zeroCol = "#FFFFFF", + posCol = rgb(raw$red, raw$green, raw$blue, maxColorValue = 255)) + ) + }else{ + options + } + }else{ + options + } }), .width = width, .height = height, diff --git a/R/map_helpers.R b/R/map_helpers.R index b20884d..65b0dab 100644 --- a/R/map_helpers.R +++ b/R/map_helpers.R @@ -30,8 +30,6 @@ .getColAndSize <- function(data, coords, mergeBy, mcy, t, colVar, sizeVar, popupVars, colorScaleOpts, labelVar = NULL) { - - if (mcy != "average") data <- data[J(as.numeric(mcy))] neededVars <- setdiff(unique(c(colVar, sizeVar, popupVars, labelVar)), "none") @@ -78,13 +76,15 @@ # Special case of FLOW LIN if (colVar == "FLOW LIN.") rangevar <- c(0, max(abs(rangevar))) - if (rangevar[1] >= 0) { - domain <- rangevar - } else { - domain <- c(-min(rangevar), max(rangevar)) - } + # if (rangevar[1] >= 0) { + # domain <- rangevar + # } else { + # domain <- c(-min(rangevar), max(rangevar)) + # } - if (colVar == "FLOW LIN.") colorScaleOpts$x <- abs(data[[colVar]]) + domain <- rangevar + + if (colVar %in% c("FLOW LIN.", .getColumnsLanguage("FLOW LIN.", language = "fr"))) colorScaleOpts$x <- abs(data[[colVar]]) else colorScaleOpts$x <- data[[colVar]] colorScaleOpts$domain <- domain @@ -119,7 +119,11 @@ res$dir <- sign(data$`FLOW LIN.`) #coords[, `FLOW LIN.` := abs(`FLOW LIN.`)] } else { - res$dir <- 0 + if(.getColumnsLanguage("FLOW LIN.", language = "fr") %in% names(data)){ + res$dir <- sign(data[[.getColumnsLanguage("FLOW LIN.", language = "fr")]]) + } else { + res$dir <- 0 + } } # Pop-up @@ -142,7 +146,7 @@ # Initialize a map with all elements invisible: links, circles and bar or polar # charts -.initMap <- function(x, ml, options) { +.initMap <- function(x, ml, options, language = "en") { map <- plot(ml, areas = !is.null(x$areas), links = !is.null(x$links), colAreas = options$areaDefaultCol, @@ -151,7 +155,7 @@ labelMaxSize = options$labelMaxSize, tilesURL = options$tilesURL, preprocess = options$preprocess) %>% - addAntaresLegend(display = options$legend) + addAntaresLegend(display = options$legend, language = language) addShadows(map) } diff --git a/R/map_plugins.R b/R/map_plugins.R index eddf29e..be26a34 100644 --- a/R/map_plugins.R +++ b/R/map_plugins.R @@ -53,14 +53,18 @@ addShadows <- function(map) { #' @noRd addAntaresLegend <- function(map, htmlAreaColor = NULL, htmlAreaSize = NULL, htmlLinkColor = NULL, htmlLinkSize = NULL, - onComplete = "", display = "choose") { + onComplete = "", display = "choose", language = "en") { options <- list( htmlAreaColor = htmlAreaColor, htmlAreaSize = htmlAreaSize, htmlLinkColor = htmlLinkColor, htmlLinkSize = htmlLinkSize, onComplete = onComplete, - display = display + display = display, + areas_name = .getLabelLanguage("Areas", language), + links_names = .getLabelLanguage("Links", language), + show_legend = .getLabelLanguage("Show legend", language), + hide_legend = .getLabelLanguage("Hide legend", language) ) map %>% requireDep("antaresLegend") %>% diff --git a/R/plot.R b/R/plot.R index b642240..5f2829f 100644 --- a/R/plot.R +++ b/R/plot.R @@ -192,17 +192,33 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, secondAxis = FALSE, timeSteph5 = "hourly", mcYearh5 = NULL, - tablesh5 = c("areas", "links"),...) { + tablesh5 = c("areas", "links"), language = "en", + hidden = NULL, ...) { if(!is.null(compare) && !interactive){ stop("You can't use compare in no interactive mode") } + # Check language + if(!language %in% availableLanguages_labels){ + stop("Invalid 'language' argument. Must be in : ", paste(availableLanguages_labels, collapse = ", ")) + } + + if(language != "en"){ + variable <- .getColumnsLanguage(variable, language) + variable2Axe <- .getColumnsLanguage(variable2Axe, language) + } + + # Check hidden + .validHidden(hidden, c("H5request", "timeSteph5", "tables", "mcYearH5", "table", "mcYear", "variable", + "secondAxis", "variable2Axe", "type", "dateRange", "confInt", "minValue", "maxValue", + "elements", "aggregate", "legend", "highlight", "stepPlot", "drawPoints", "main")) + #Check compare .validCompare(compare, c("mcYear", "main", "variable", "type", "confInt", "elements", "aggregate", "legend", "highlight", "stepPlot", "drawPoints", "secondAxis")) - + if(is.list(compare)){ if("secondAxis" %in% names(compare)){ compare <- c(compare, list(variable2Axe = NULL)) @@ -252,6 +268,16 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, lapply(x, function(x) { idCols <- .idCols(x) + + if(language != "en"){ + ind_to_change <- which(colnames(x) %in% language_columns$en) + if(length(ind_to_change) > 0){ + new_name <- language_columns[en %in% colnames(x), ] + v_new_name <- new_name[[language]] + names(v_new_name) <- new_name[["en"]] + setnames(x, colnames(x)[ind_to_change], unname(v_new_name[colnames(x)[ind_to_change]])) + } + } valueCols <- setdiff(names(x), idCols) timeStep <- attr(x, "timeStep") opts <- simOptions(x) @@ -293,7 +319,7 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, if (is.null(type) || !variable %in% names(x)) { return(combineWidgets()) } - if(variable[1] == "No Input") {return(combineWidgets("No data"))} + if(variable[1] == "No Input") {return(combineWidgets(.getLabelLanguage("No data", language)))} dt <- .getTSData( x, dt, variable = c(variable, variable2Axe), elements = elements, @@ -301,8 +327,8 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, mcYear = mcYear, dateRange = dateRange, aggregate = aggregate ) - if (nrow(dt) == 0) return(combineWidgets("No data")) - + if (nrow(dt) == 0) return(combineWidgets(.getLabelLanguage("No data", language))) + if(type == "ts"){ if(!is.null(dateRange)) { @@ -331,6 +357,17 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, variable2Axe <- apply(expand.grid(elements, variable2Axe), 1, function(X){paste(X, collapse = " __ ")}) + # BP 2017 + # if(length(main) > 0){ + # mcYear <- ifelse(mcYear == "average", "moyen", mcYear) + # if(grepl("h5$", main)){ + # # main <- paste0(gsub(".h5$", "", main), " : ", areas, " (tirage ", mcYear, ")") + # main <- paste0(gsub(".h5$", "", main), " : Tirage ", mcYear) + # } else { + # # main <- paste0("Production ", areas, " (tirage ", mcYear, ")") + # main <- paste0("Tirage ", mcYear) + # } + # } f( dt, @@ -352,7 +389,8 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, group = group, highlight = highlight, stepPlot = stepPlot, - drawPoints = drawPoints + drawPoints = drawPoints, + language = language ) } @@ -377,12 +415,12 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, # If not in interactive mode, generate a simple graphic, else create a GUI # to interactively explore the data if (!interactive) { - - + + x <- .cleanH5(x, timeSteph5, mcYearh5, tablesh5, h5requestFiltering) params <- .transformDataForComp(.giveListFormat(x), compare, compareOpts, - processFun = processFun, - elements = elements, dateRange = dateRange) + processFun = processFun, + elements = elements, dateRange = dateRange) # paramCoe <- .testParamsConsistency(params = params, mcYear = mcYear) # mcYear <- paramCoe$mcYear @@ -390,13 +428,16 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, if (is.null(mcYear)) mcYear <- "average" L_w <- lapply(params$x, function(X){ X[[table]]$plotFun(mcYear, 1, variable, variable2Axe, elements, type, confInt, dateRange, - minValue, maxValue, aggregate, legend, highlight, stepPlot, drawPoints, main) + minValue, maxValue, aggregate, legend, highlight, stepPlot, drawPoints, main) }) return(combineWidgets(list = L_w)) } - typeChoices <- c("time series" = "ts", "barplot", "monotone", "density", "cdf", "heatmap") + typeChoices <- c("ts", "barplot", "monotone", "density", "cdf", "heatmap") + names(typeChoices) <- c(.getLabelLanguage("time series", language), .getLabelLanguage("barplot", language), + .getLabelLanguage("monotone", language), .getLabelLanguage("density", language), + .getLabelLanguage("cdf", language), .getLabelLanguage("heatmap", language)) ##remove notes table <- NULL @@ -412,13 +453,17 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, .tryCloseH5() if(.id <= length(params$x)){ - if(length(variable) == 0){return(combineWidgets(paste0("Please select some variables")))} + if(length(variable) == 0){return(combineWidgets(.getLabelLanguage("Please select some variables", language)))} - if(length(elements) == 0){return(combineWidgets(paste0("Please select some elements")))} + if(length(elements) == 0){return(combineWidgets(.getLabelLanguage("Please select some elements", language)))} - if(length(params[["x"]][[max(1,.id)]]) == 0){return(combineWidgets(paste0("No data")))} + if(length(params[["x"]][[max(1,.id)]]) == 0){return(combineWidgets(.getLabelLanguage("No data", language)))} - if(is.null(params[["x"]][[max(1,.id)]][[table]])){return(combineWidgets(paste0("Table ", table, " not exists in this study")))} + if(is.null(params[["x"]][[max(1,.id)]][[table]])){ + return(combineWidgets( + paste0("Table ", table, " ", .getLabelLanguage("not exists in this study", language)) + )) + } if(!secondAxis){ variable2Axe <- NULL @@ -426,11 +471,12 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, aggregate <- "none" } widget <- params[["x"]][[max(1,.id)]][[table]]$plotFun(mcYear, .id, variable, variable2Axe, elements, type, confInt, - dateRange, minValue, maxValue, aggregate, legend, - highlight, stepPlot, drawPoints, main) - controlWidgetSize(widget) + dateRange, minValue, maxValue, aggregate, legend, + highlight, stepPlot, drawPoints, main) + + controlWidgetSize(widget, language) } else { - combineWidgets("No data for this selection") + combineWidgets(.getLabelLanguage("No data for this selection", language)) } }, x = mwSharedValue({x}), @@ -451,31 +497,64 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, .h5ParamList(X_I = x_in, xyCompare = xyCompare, h5requestFilter = h5requestFiltering) }), - H5request = mwGroup( - timeSteph5 = mwSelect(choices = paramsH5$timeStepS, - value = paramsH5$timeStepS[1], - label = "timeStep", - multiple = FALSE + label = .getLabelLanguage("H5request", language), + timeSteph5 = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5$timeStepS + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + choices + } else { + NULL + } + }, + value = if(.initial) {paramsH5$timeStepS[1]}else{NULL}, + label = .getLabelLanguage("timeStep", language), + multiple = FALSE, .display = !"timeSteph5" %in% hidden ), - tables = mwSelect(choices = paramsH5[["tabl"]], - value = { - if(.initial) {paramsH5[["tabl"]][1]}else{NULL} - }, - label = "table", multiple = TRUE + tables = mwSelect( + { + choices = paramsH5[["tabl"]] + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + choices + }, + value = { + if(.initial) {paramsH5[["tabl"]][1]}else{NULL} + }, + label = .getLabelLanguage("table", language), multiple = TRUE, + .display = !"tables" %in% hidden ), - mcYearH5 = mwSelect(choices = c(paramsH5[["mcYearS"]]), - value = { - if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} - }, - label = "mcYear", multiple = TRUE + mcYearH5 = mwSelectize( + choices = { + ch <- c("Average" = "", paramsH5[["mcYearS"]]) + names(ch)[1] <- .getLabelLanguage("Average", language) + ch + }, + value = { + if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} + }, + label = .getLabelLanguage("mcYears to be imported", language), + multiple = TRUE, options = list(maxItems = 4), + .display = (!"mcYearH5" %in% hidden & !meanYearH5) ), + meanYearH5 = mwCheckbox(value = FALSE, + label = .getLabelLanguage("Average mcYear", language), + .display = !"meanYearH5" %in% hidden), .display = { - any(unlist(lapply(x_in, .isSimOpts))) + any(unlist(lapply(x_in, .isSimOpts))) & !"H5request" %in% hidden }), sharerequest = mwSharedValue({ - list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + if(length(meanYearH5) > 0){ + if(meanYearH5){ + list(timeSteph5_l = timeSteph5, mcYearh_l = NULL, tables_l = tables) + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } }), x_tranform = mwSharedValue({ @@ -492,7 +571,10 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, lapply(params$x, function(vv){ unique(names(vv)) }), xyCompare)) - if(length(out) > 0){out}else{"No Input"} + if(length(out) > 0){ + names(out) <- sapply(out, function(x) .getLabelLanguage(x, language)) + out + }else{"No Input"} } }, value = { @@ -501,21 +583,38 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, }, .display = length(as.character(.compareOperation( lapply(params$x, function(vv){ unique(names(vv)) - }), xyCompare))) > 1 + }), xyCompare))) > 1 & !"table" %in% hidden, + label = .getLabelLanguage("table", language) ), mcYear = mwSelect( choices = { - c("average", if(!is.null(params)){ - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv[[table]]$uniqueMcYears) - }), xyCompare)) - }) + # tmp <- c("average", if(!is.null(params)){ + # as.character(.compareOperation(lapply(params$x, function(vv){ + # unique(vv[[table]]$uniqueMcYears) + # }), xyCompare))}) + # names(tmp) <- sapply(tmp, function(x) .getLabelLanguage(x, language)) + # tmp + + # BP 2017 + allMcY <- .compareOperation(lapply(params$x, function(vv){ + unique(vv[[table]]$uniqueMcYears) + }), xyCompare) + names(allMcY) <- allMcY + if(is.null(allMcY)){ + allMcY <- "average" + names(allMcY) <- .getLabelLanguage("average", language) + } + allMcY + }, value = { - if(.initial) "average" + # if(.initial) "average" + if(.initial) mcYear else NULL - }, multiple = FALSE + }, multiple = FALSE, + label = .getLabelLanguage("mcYear to be displayed", language), + .display = !"mcYear" %in% hidden ), variable = mwSelect( @@ -528,40 +627,54 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, } }, value = { - if(.initial) as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv[[table]]$valueCols) - }), xyCompare))[1] - else NULL - }, multiple = TRUE - ), - - secondAxis = mwCheckbox(secondAxis), - variable2Axe = mwSelect(label = "Variables 2nd axis", - choices = { - if(!is.null(params)){ - out <- as.character(.compareOperation(lapply(params$x, function(vv){ + if(.initial){ + if(is.null(variable)){ + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv[[table]]$valueCols) + }), xyCompare))[1] + } else { + variable + } + } else { + # NULL + as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv[[table]]$valueCols) - }), xyCompare)) - out <- out[!out%in%variable] - if(length(out) > 0){out} else {"No Input"} + }), xyCompare))[1] } - }, - value = { - if(.initial) NULL - else NULL - }, multiple = TRUE, .display = secondAxis + }, multiple = TRUE, + label = .getLabelLanguage("variable", language), + .display = !"variable" %in% hidden + ), + + secondAxis = mwCheckbox(secondAxis, label = .getLabelLanguage("secondAxis", language), + .display = !"secondAxis" %in% hidden), + variable2Axe = mwSelect(label = .getLabelLanguage("Variables 2nd axis", language), + choices = { + if(!is.null(params)){ + out <- as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv[[table]]$valueCols) + }), xyCompare)) + out <- out[!out%in%variable] + if(length(out) > 0){out} else {"No Input"} + } + }, + value = { + if(.initial) variable2Axe + else NULL + }, multiple = TRUE, .display = secondAxis & !"variable2Axe" %in% hidden ), type = mwSelect( choices = { if (timeStepdataload == "annual") "barplot" else if (timeStepdataload %in% c("hourly", "daily")) typeChoices - else typeChoices[1:5] + else setdiff(typeChoices, "heatmap") }, value = { if(.initial) type else NULL }, - .display = timeStepdataload != "annual" + .display = timeStepdataload != "annual" & !"type" %in% hidden, + label = .getLabelLanguage("type", language) ), dateRange = mwDateRange(value = { @@ -574,16 +687,13 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, {res <- NULL} } ##Lock 7 days for hourly data - if(!is.null(params$x[[1]][[table]]$timeStep)) - { - if(params$x[[1]][[table]]$timeStep == "hourly"){ - if(params$x[[1]][[table]]$dateRange[2] - params$x[[1]][[table]]$dateRange[1]>7){ - res[1] <- params$x[[1]][[table]]$dateRange[2] - 7 + if(!is.null(params$x[[1]][[table]]$timeStep)){ + if(params$x[[1]][[table]]$timeStep == "hourly"){ + if(params$x[[1]][[table]]$dateRange[2] - params$x[[1]][[table]]$dateRange[1]>7){ + res[1] <- params$x[[1]][[table]]$dateRange[2] - 7 + } } } - - } - res }else{NULL} }, @@ -599,54 +709,87 @@ tsPlot <- function(x, table = NULL, variable = NULL, elements = NULL, if(is.infinite(R)){NULL}else{R} } }, - .display = timeStepdataload != "annual" + language = eval(parse(text = "language")), + # format = "dd MM", + separator = " : ", + .display = timeStepdataload != "annual" & !"dateRange" %in% hidden, + label = .getLabelLanguage("dateRange", language) ), confInt = mwSlider(0, 1, confInt, step = 0.01, - label = "confidence interval", - .display = params$x[[max(1,.id)]][[table]]$showConfInt & mcYear == "average" + label = .getLabelLanguage("confidence interval", language), + .display = params$x[[max(1,.id)]][[table]]$showConfInt & mcYear == "average" & !"confInt" %in% hidden ), - minValue = mwNumeric(minValue, "min value", - .display = type %in% c("density", "cdf") + minValue = mwNumeric(minValue, label = .getLabelLanguage("min value", language), + .display = type %in% c("density", "cdf") & !"minValue" %in% hidden ), - maxValue = mwNumeric(maxValue, "max value", - .display = type %in% c("density", "cdf") + maxValue = mwNumeric(maxValue, label = .getLabelLanguage("max value", language), + .display = type %in% c("density", "cdf") & !"maxValue" %in% hidden ), elements = mwSelect( choices = { - c( if(!is.null(params)){ + choix <- c(if(!is.null(params)){ as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv[[table]]$uniqueElem) }), xyCompare)) }) + choix }, value = { - if(.initial) {as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv[[table]]$uniqueElem) - }), xyCompare))[1]} + if(.initial) { + if(is.null(elements)){ + + if(!is.null(params)){ + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv[[table]]$uniqueElem) + }), xyCompare))[1] + } else { + NULL + } + }else { + elements + } + } else { + NULL + } }, - multiple = TRUE + multiple = TRUE, + label = .getLabelLanguage("elements", language), + .display = !"elements" %in% hidden ), - aggregate = mwSelect(c("none", "mean", "sum", "mean by areas", "sum by areas"), - value ={ - if(.initial) aggregate - else NULL - }, .display = !secondAxis + aggregate = mwSelect({ + tmp <- c("none", "mean", "sum", "mean by areas", "sum by areas") + names(tmp) <- c(.getLabelLanguage("none", language), + .getLabelLanguage("mean", language), + .getLabelLanguage("sum", language), + .getLabelLanguage("mean by areas", language), + .getLabelLanguage("sum by areas", language)) + tmp + }, value ={ + if(.initial) aggregate + else NULL + }, .display = !secondAxis & !"aggregate" %in% hidden, + label = .getLabelLanguage("aggregate", language) ), - legend = mwCheckbox(legend, .display = type %in% c("ts", "density", "cdf")), - highlight = mwCheckbox(highlight), - stepPlot = mwCheckbox(stepPlot), - drawPoints = mwCheckbox(drawPoints), + legend = mwCheckbox(legend, .display = type %in% c("ts", "density", "cdf") & !"legend" %in% hidden, + label = .getLabelLanguage("legend", language)), + highlight = mwCheckbox(highlight, label = .getLabelLanguage("highlight", language), + .display = !"highlight" %in% hidden), + stepPlot = mwCheckbox(stepPlot, label = .getLabelLanguage("stepPlot", language), + .display = !"stepPlot" %in% hidden), + drawPoints = mwCheckbox(drawPoints, label =.getLabelLanguage("drawPoints", language), + .display = !"drawPoints" %in% hidden), timeStepdataload = mwSharedValue({ attributes(x_tranform[[1]])$timeStep }), - main = mwText(main, label = "title"), + main = mwText(main, label = .getLabelLanguage("title", language), + .display = !"main" %in% hidden), params = mwSharedValue({ .transformDataForComp(x_tranform, compare, compareOpts, processFun = processFun, diff --git a/R/plot_barplot.R b/R/plot_barplot.R index d62e8a5..08e1bb0 100644 --- a/R/plot_barplot.R +++ b/R/plot_barplot.R @@ -11,7 +11,7 @@ ylab = NULL, legend = TRUE, legendItemsPerRow = 5, - width = NULL, height = NULL, ...) { + width = NULL, height = NULL, language = "en", ...) { if (is.null(dt$mcYear)) { dt <- dt[, .(value = mean(value)), by = element] @@ -21,7 +21,7 @@ if (confInt == 0) { dt <- dt[, .(value = mean(value)), by = .(element)] } else { - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) alpha <- (1 - confInt) / 2 .getConfInt <- function(x) { @@ -36,7 +36,9 @@ dt[,"element" := as.character(element)] variable <- paste0(variable, collapse = " ; ") if (is.null(ylab)) ylab <- variable - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Comparison of", variable) + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Comparison of", language), variable) + } g <- plot_ly(dt, textfont = list(color = '#000000')) %>% config(displayModeBar = FALSE) %>% diff --git a/R/plot_stats.R b/R/plot_stats.R index 1e29415..c36604a 100644 --- a/R/plot_stats.R +++ b/R/plot_stats.R @@ -1,7 +1,7 @@ .plotMonotone <- function(dt, timeStep, variable, variable2Axe = NULL, confInt = NULL, maxValue, - main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, ...) { + main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, language = "en", ...) { - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) plotConfInt <- FALSE # If dt contains several Monte-Carlo scenario, compute aggregate statistics if (is.null(dt$mcYear)) { @@ -19,7 +19,7 @@ dt <- dt[, .(y = mean(y)), by = .(element, x)] } else { plotConfInt <- TRUE - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) alpha <- (1 - confInt) / 2 dt <- dt[, .(y = c(mean(y), quantile(y, c(alpha, 1 - alpha))), @@ -31,7 +31,9 @@ variable <- paste0(variable, collapse = " ; ") if (is.null(ylab)) ylab <- variable - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Monotone of", variable) + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Monotone of", language), variable) + } .plotStat(dt, ylab = ylab, main = main, uniqueElements = uniqueElements, variable2Axe = variable2Axe, highlight = highlight, stepPlot = stepPlot, drawPoints = drawPoints, ...) @@ -39,9 +41,9 @@ } .density <- function(dt, timeStep, variable, variable2Axe = NULL, minValue = NULL, maxValue = NULL, - main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, ...) { + main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, language = "en", ...) { - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) xbins <- .getXBins(dt$value, minValue, maxValue) if (is.character(xbins)) return(xbins) @@ -54,8 +56,13 @@ dt <- dt[, .getDensity(value), by = element] variable <- paste0(variable, collapse = " ; ") - if (is.null(ylab)) ylab <- "Density" - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Density of", variable) + if (is.null(ylab)){ + ylab <- .getLabelLanguage("Density", language) + } + + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Density of", language), variable) + } .plotStat(dt, ylab = ylab, main = main, uniqueElements = uniqueElements,variable2Axe = variable2Axe, highlight = highlight, stepPlot = stepPlot, drawPoints = drawPoints,...) @@ -63,9 +70,9 @@ } .cdf <- function(dt, timeStep, variable, variable2Axe = NULL, minValue = NULL, maxValue = NULL, - main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, ...) { + main = NULL, ylab = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, language = "en", ...) { - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) xbins <- .getXBins(dt$value, minValue, maxValue)$xbins @@ -77,8 +84,13 @@ dt <- dt[, .getCDF(value), by = element] variable <- paste0(variable, collapse = " ; ") - if (is.null(ylab)) ylab <- "Proportion of time steps" - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Cumulated distribution of", variable) + if (is.null(ylab)){ + ylab <- .getLabelLanguage("Proportion of time steps", language) + } + + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Cumulated distribution of", language), variable) + } .plotStat(dt, ylab = ylab, main = main, uniqueElements = uniqueElements, variable2Axe = variable2Axe, highlight = highlight, stepPlot = stepPlot, drawPoints = drawPoints, ...) @@ -114,7 +126,7 @@ .plotStat <- function(dt, ylab, main, colors, uniqueElements, legend, legendItemsPerRow, width, height, plotConfInt = FALSE, highlight = FALSE, - stepPlot = FALSE, drawPoints = FALSE,variable2Axe = NULL, ...) { + stepPlot = FALSE, drawPoints = FALSE,variable2Axe = NULL, language = "en", ...) { dt <- dcast(dt, x ~ element, value.var = "y") if (is.null(colors)) { @@ -127,7 +139,7 @@ g <- dygraph(as.data.frame(dt), main = main, group = legendId) %>% dyOptions( includeZero = TRUE, - colors = colors, + # colors = colors, gridLineColor = gray(0.8), axisLineColor = gray(0.6), axisLabelColor = gray(0.6), @@ -138,19 +150,18 @@ dyAxis("y", label = ylab, pixelsPerLabel = 60) %>% dyLegend(show = "never") %>% dyCallbacks( - highlightCallback = JS_updateLegend(legendId, timeStep = "none"), + highlightCallback = JS_updateLegend(legendId, timeStep = "none", language = language), unhighlightCallback = JS_resetLegend(legendId) ) - - if(length(variable2Axe)>0){ - for( i in variable2Axe) - { - g <- g %>% dySeries(i, axis = 'y2') - } + for(i in 1:length(uniqueElements)){ + if(!uniqueElements[i] %in% variable2Axe){ + g <- g %>% dySeries(uniqueElements[i], color = colors[i]) + } else { + g <- g %>% dySeries(uniqueElements[i], axis = 'y2', color = colors[i]) + } } - if(highlight) { g <- g %>% dyHighlight(highlightSeriesOpts = list(strokeWidth = 2)) diff --git a/R/plot_ts.R b/R/plot_ts.R index ec47cba..40c5cfc 100644 --- a/R/plot_ts.R +++ b/R/plot_ts.R @@ -23,10 +23,9 @@ legend = TRUE, legendItemsPerRow = 5, group = NULL, - width = NULL, height = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, ...) { + width = NULL, height = NULL, highlight = FALSE, stepPlot = FALSE, drawPoints = FALSE, language = language, ...) { - - uniqueElements <- sort(unique(dt$element)) + uniqueElements <- as.character(sort(unique(dt$element))) plotConfInt <- FALSE if (is.null(group)) group <- sample(1e9, 1) @@ -59,7 +58,9 @@ } if (is.null(ylab)) ylab <- variable - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Evolution of", variable) + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Evolution of", language), variable) + } if (is.null(colors)) { colors <- substring(rainbow(length(uniqueElements), s = 0.7, v = 0.7), 1, 7) } else { @@ -75,7 +76,7 @@ axisLineColor = gray(0.6), axisLabelColor = gray(0.6), labelsKMB = TRUE, - colors = colors, + # colors = colors, useDataTimezone = TRUE, stepPlot = stepPlot, drawPoints = drawPoints @@ -83,19 +84,19 @@ dyAxis("x", rangePad = 10) %>% dyAxis("y", label = ylab, pixelsPerLabel = 60, rangePad = 10) %>% #dyRangeSelector() %>% - dyLegend(show = "never") %>% + dyLegend(show = "never") %>% dyCallbacks( - highlightCallback = JS_updateLegend(legendId, timeStep), + highlightCallback = JS_updateLegend(legendId, timeStep, language = language), unhighlightCallback = JS_resetLegend(legendId) ) - if(length(variable2Axe)>0){ - for( i in variable2Axe) - { - g <- g %>% dySeries(i, axis = 'y2') + for(i in 1:length(uniqueElements)){ + if(!uniqueElements[i] %in% variable2Axe){ + g <- g %>% dySeries(uniqueElements[i], color = colors[i]) + } else { + g <- g %>% dySeries(uniqueElements[i], axis = 'y2', color = colors[i]) } } - if(highlight) { g <- g %>% dyHighlight(highlightSeriesOpts = list(strokeWidth = 2)) diff --git a/R/plot_utils.R b/R/plot_utils.R index 4d84a65..d01726c 100644 --- a/R/plot_utils.R +++ b/R/plot_utils.R @@ -40,7 +40,12 @@ tpl <- rbindlist(listVar) elements <- as.vector(sapply(elements, function(X){paste(X, "__", variable)})) }else{ - tpl <- listVar[[1]] + if(aggregate %in% c("mean by areas", "sum by areas")){ + tpl <- listVar[[1]][,element := paste(element, '__' , names(listVar)[1])] + elements <- paste(elements, "__", variable) + } else { + tpl <- listVar[[1]] + } } # Filtering data if required @@ -131,4 +136,19 @@ } } invisible(TRUE) +} + +.validHidden <- function(hidden, values){ + if(!is.null(hidden)){ + if(!is.vector(hidden)){ + stop("'hidden' must be a vector") + } else { + if(!all(hidden %in% values)){ + invalid <- hidden[!hidden %in% values] + stop(paste0("Invalid arguments for 'hidden' : '", paste0(invalid, collapse = "', '"), + "'. Possible values : '", paste0(values, collapse = "', '"), "'.")) + } + } + } + invisible(TRUE) } \ No newline at end of file diff --git a/R/stack.R b/R/stack.R index 7c32b1b..652361f 100644 --- a/R/stack.R +++ b/R/stack.R @@ -41,9 +41,9 @@ #' next series is drawn from 0. #' #' @noRd -.plotStack <- function(x, timeStep, opts, colors, lines = NULL, lineColors = NULL, +.plotStack <- function(x, timeStep, opts, colors, lines = NULL, lineColors = NULL, lineWidth = NULL, legendId = "", groupId = legendId, main = "", ylab = "", - width = NULL, height = NULL, dateRange = NULL, stepPlot = FALSE, drawPoints = FALSE) { + width = NULL, height = NULL, dateRange = NULL, stepPlot = FALSE, drawPoints = FALSE, language = "en") { variables <- setdiff(names(x), c("timeId", lines)) @@ -106,7 +106,7 @@ dyOptions( stackedGraph = TRUE, colors = rev(colors), - fillAlpha = 0.6, + fillAlpha = 0.85, includeZero = TRUE, gridLineColor = gray(0.8), axisLineColor = gray(0.6), @@ -120,7 +120,7 @@ dyAxis("y", label = ylab, rangePad = 10, pixelsPerLabel = 50, valueRange = c(min(dt$totalNeg, na.rm = TRUE) * 1.1, NA)) %>% dyLegend(show = "never") %>% dyCallbacks( - highlightCallback = JS_updateLegend(legendId, timeStep), + highlightCallback = JS_updateLegend(legendId, timeStep, language = language), unhighlightCallback = JS_resetLegend(legendId) ) @@ -129,7 +129,7 @@ g <- g %>% dySeries(name = paste0("opp", lines[i]), color = lineColors[i], fillGraph = FALSE, strokeWidth = 0) g <- g %>% dySeries(name = lines[i], color = lineColors[i], - fillGraph = FALSE, strokeWidth = 3) + fillGraph = FALSE, strokeWidth = lineWidth[i]) } } diff --git a/R/stack_aliases.R b/R/stack_aliases.R index 0864612..f2b655e 100644 --- a/R/stack_aliases.R +++ b/R/stack_aliases.R @@ -41,6 +41,10 @@ prodStackAliases <- function() { # Line colors colors <- sprintf('"%s"', alias$lineColors) cat(sprintf(",\n\n lineColors = c(%s)", paste(colors, collapse = ", "))) + + # Line width + width <- sprintf('"%s"', alias$lineWidth) + cat(sprintf(",\n\n lineWidth = c(%s)", paste(width, collapse = ", "))) } cat("\n") } @@ -49,7 +53,7 @@ prodStackAliases <- function() { #' @rdname prodStack #' @export setProdStackAlias <- function(name, variables, colors, lines = NULL, - lineColors = NULL, description = NULL) { + lineColors = NULL, lineWidth = 3, description = NULL) { if (is.null(description)) description <- name if (length(variables) != length(colors)) { @@ -60,6 +64,16 @@ setProdStackAlias <- function(name, variables, colors, lines = NULL, stop("Number of line colors and number of lines should be equal.") } + if(length(lineWidth) == 0){ + lineWidth <- rep(3, length(lines)) + } else if(length(lineWidth) == 1){ + lineWidth <- rep(lineWidth, length(lines)) + } else { + if (length(lines) != length(lineWidth)) { + stop("Number of line Width and number of lines should be equal.") + } + } + pkgEnv$prodStackAliases[[name]] <- list( description = description, variables = variables, @@ -69,6 +83,7 @@ setProdStackAlias <- function(name, variables, colors, lines = NULL, if (!is.null(lines)) { pkgEnv$prodStackAliases[[name]]$lines <- lines pkgEnv$prodStackAliases[[name]]$lineColors <- lineColors + pkgEnv$prodStackAliases[[name]]$lineWidth <- lineWidth } invisible(NULL) diff --git a/R/stack_exchanges.R b/R/stack_exchanges.R index cedae9e..1020f20 100644 --- a/R/stack_exchanges.R +++ b/R/stack_exchanges.R @@ -65,23 +65,31 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", stepPlot = FALSE, drawPoints = FALSE, timeSteph5 = "hourly", mcYearh5 = NULL, - tablesh5 = c("areas", "links"), ...) { + tablesh5 = c("areas", "links"), language = "en", + hidden = NULL, ...) { if(!is.null(compare) && !interactive){ stop("You can't use compare in no interactive mode") } + # Check language + if(!language %in% availableLanguages_labels){ + stop("Invalid 'language' argument. Must be in : ", paste(availableLanguages_labels, collapse = ", ")) + } + # Check hidden + .validHidden(hidden, c("H5request", "timeSteph5", "mcYearhH5", "mcYear", "main", + "dateRange", "unit", "area", "legend", "stepPlot", "drawPoints")) #Check compare .validCompare(compare, c("mcYear", "main", "unit", "area", "legend", "stepPlot", "drawPoints")) - + unit <- match.arg(unit) if (is.null(mcYear)) mcYear <- "average" init_area <- area - + xyCompare <- match.arg(xyCompare) init_dateRange <- dateRange @@ -93,7 +101,7 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", x <- list(x, x) } # .testXclassAndInteractive(x, interactive) - + h5requestFiltering <- .convertH5Filtering(h5requestFiltering = h5requestFiltering, x = x) @@ -165,7 +173,7 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", if (!is.null(row)) row <- row[mcYear == mcy, .(area, link, timeId, flow, to, direction)] }else{ .printWarningMcYear() - } + } dt <- merge(dt[as.Date(.timeIdToDate(timeId, timeStep, simOptions(x))) %between% dateRange, .(link, timeId, flow = `FLOW LIN.`)], @@ -180,19 +188,40 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", dt <- dcast(dt, timeId ~ to, value.var = "flow") + # if("ROW" %in% colnames(dt)){ + # dt[, ROW := NULL] + # } + # Graphical parameters - if (is.null(main) | isTRUE(all.equal("", main))) main <- paste("Flows from/to", area) - if (is.null(ylab)) ylab <- sprintf("Flows (%s)", unit) + if (is.null(main) | isTRUE(all.equal("", main))){ + main <- paste(.getLabelLanguage("Flows from/to", language), area) + } + if (is.null(ylab)){ + ylab <- sprintf(.getLabelLanguage("Flows (%s)", language), unit) + } + if (is.null(colors)) { colors <- substring(rainbow(ncol(dt) - 1, s = 0.7, v = 0.7), 1, 7) } else { colors <- rep(colors, length.out = ncol(dt - 1)) } + # BP 2017 + # if(length(main) > 0){ + # mcYear <- ifelse(mcYear == "average", "moyen", mcYear) + # if(grepl("h5$", main)){ + # # main <- paste0(gsub(".h5$", "", main), " : ", area, " (tirage ", mcYear, ")") + # main <- paste0(gsub(".h5$", "", main), " : Tirage ", mcYear) + # } else { + # # main <- paste0("Échanges ", area, " (tirage ", mcYear, ")") + # main <- paste0("Tirage ", mcYear) + # } + # } + # Stack g <- .plotStack(dt, timeStep, opts, colors, legendId = legendId + id - 1, groupId = groupId, - main = main, ylab = ylab, stepPlot = stepPlot, drawPoints = drawPoints) + main = main, ylab = ylab, stepPlot = stepPlot, drawPoints = drawPoints, language = language) if (legend) { # Add a nice legend @@ -244,9 +273,9 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", .tryCloseH5() if(.id <= length(params$x)){ widget <- params$x[[max(1,.id)]]$plotFun(.id, area, dateRange, unit, mcYear, legend, stepPlot, drawPoints, main) - controlWidgetSize(widget) + controlWidgetSize(widget, language) } else { - combineWidgets("No data for this selection") + combineWidgets(.getLabelLanguage("No data for this selection", language)) } }, x = mwSharedValue(x), @@ -261,28 +290,54 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", }), H5request = mwGroup( - timeSteph5 = mwSelect(choices = paramsH5$timeStepS, - value = paramsH5$timeStepS[1], - label = "timeStep", - multiple = FALSE + label = .getLabelLanguage("H5request", language), + timeSteph5 = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5$timeStepS + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + choices + } else { + NULL + } + }, + value = if(.initial) paramsH5$timeStepS[1] else NULL, + label = .getLabelLanguage("timeStep", language), + multiple = FALSE, .display = !"timeSteph5" %in% hidden ), - mcYearH5 = mwSelect(choices = c(paramsH5[["mcYearS"]]), - value = { - if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} - }, - label = "mcYear", - multiple = TRUE + mcYearH5 = mwSelectize( + choices = { + ch <- c("Average" = "", paramsH5[["mcYearS"]]) + names(ch)[1] <- .getLabelLanguage("Average", language) + ch + }, + value = { + if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} + }, + label = .getLabelLanguage("mcYears to be imported", language), + multiple = TRUE, options = list(maxItems = 4), + .display = (!"mcYearH5" %in% hidden & !meanYearH5) ), + meanYearH5 = mwCheckbox(value = FALSE, + label = .getLabelLanguage("Average mcYear", language), + .display = !"meanYearH5" %in% hidden), .display = { - any(unlist(lapply(x_in, .isSimOpts))) + any(unlist(lapply(x_in, .isSimOpts))) & !"H5request" %in% hidden } ), sharerequest = mwSharedValue({ - list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = NULL) + if(length(meanYearH5) > 0){ + if(meanYearH5){ + list(timeSteph5_l = timeSteph5, mcYearh_l = NULL, tables_l = NULL) + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = NULL) + } + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = NULL) + } }), - x_tranform = mwSharedValue({ areas = "all" links = "all" @@ -296,33 +351,59 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", }), mcYear = mwSelect({ - allMcY <- c("average", if(!is.null(params)){ - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$x$mcYear) - }), xyCompare))}) - allMcY + # allMcY <- c("average", .compareOperation(lapply(params$x, function(vv){ + # unique(vv$x$mcYear) + # }), xyCompare)) + # names(allMcY) <- c(.getLabelLanguage("average", language), allMcY[-1]) + + # BP 2017 + allMcY <- .compareOperation(lapply(params$x, function(vv){ + unique(vv$x$mcYear) + }), xyCompare) + names(allMcY) <- allMcY + if(is.null(allMcY)){ + allMcY <- "average" + names(allMcY) <- .getLabelLanguage("average", language) + } + allMcY }, value = { if(.initial) mcYear else NULL }, .display = { - length(c("average", if(!is.null(params)){ - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$x$mcYear) - }), xyCompare))})) != 1} + # length(c("average", if(!is.null(params)){ + # as.character(.compareOperation(lapply(params$x, function(vv){ + # unique(vv$x$mcYear) + # }), xyCompare))})) != 1 & + !"mcYear" %in% hidden + }, + label = .getLabelLanguage("mcYear to be displayed", language) ), area = mwSelect({ if(!is.null(params)){ as.character(.compareOperation(lapply(params$x, function(vv){ unique(vv$areaList) - }), xyCompare))} + }), xyCompare)) + } }, value = { - if(.initial) area + if(.initial){ + if(!is.null(area)){ + area + } else { + if(!is.null(params)){ + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$areaList) + }), xyCompare))[1] + } else { + NULL + } + } + } else NULL - }), + }, label = .getLabelLanguage("area", language), .display = !"area" %in% hidden), dateRange = mwDateRange(value = { if(.initial){ @@ -333,15 +414,13 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", } ##Lock 7 days for hourly data - if(!is.null(attributes(params$x[[1]]$x)$timeStep)) - { - if(attributes(params$x[[1]]$x)$timeStep == "hourly"){ - if(params$x[[1]]$dateRange[2] - params$x[[1]]$dateRange[1]>7){ - res[1] <- params$x[[1]]$dateRange[2] - 7 + if(!is.null(attributes(params$x[[1]]$x)$timeStep)){ + if(attributes(params$x[[1]]$x)$timeStep == "hourly"){ + if(params$x[[1]]$dateRange[2] - params$x[[1]]$dateRange[1]>7){ + res[1] <- params$x[[1]]$dateRange[2] - 7 + } } } - } - res }else{NULL} }, @@ -355,19 +434,28 @@ exchangesStack <- function(x, area = NULL, mcYear = "average", .dateRangeJoin(params = params, xyCompare = xyCompare, "max", tabl = NULL) } }, - .display = timeStepdataload != "annual" + language = eval(parse(text = "language")), + # format = "dd MM", + separator = " : ", + .display = timeStepdataload != "annual" & !"timeSteph5" %in% hidden, + label = .getLabelLanguage("dateRange", language) ), - unit = mwSelect(c("MWh", "GWh", "TWh"), unit), + unit = mwSelect(c("MWh", "GWh", "TWh"), unit, label = .getLabelLanguage("unit", language), + .display = !"unit" %in% hidden), - legend = mwCheckbox(legend), - stepPlot = mwCheckbox(stepPlot), - drawPoints = mwCheckbox(drawPoints), + legend = mwCheckbox(legend, label = .getLabelLanguage("legend", language), + .display = !"legend" %in% hidden), + stepPlot = mwCheckbox(stepPlot, label = .getLabelLanguage("stepPlot", language), + .display = !"stepPlot" %in% hidden), + drawPoints = mwCheckbox(drawPoints, label = .getLabelLanguage("drawPoints", language), + .display = !"drawPoints" %in% hidden), timeStepdataload = mwSharedValue({ attributes(x_tranform[[1]])$timeStep }), - main = mwText(main, label = "title"), + main = mwText(main, label = .getLabelLanguage("title", language), + .display = !"main" %in% hidden), params = mwSharedValue({ .getDataForComp(x_tranform, NULL, compare, compareOpts, diff --git a/R/stack_prod.R b/R/stack_prod.R index 2e3df4c..69a760c 100644 --- a/R/stack_prod.R +++ b/R/stack_prod.R @@ -81,6 +81,8 @@ #' Vector of colors with same length as parameter \code{lines}. This argument #' should be \code{NULL} if there is no curve to trace or if parameter #' \code{variables} is an alias. +#' @param lineWidth +#' Optionnal. Defaut to 3. Vector of width with same length as parameter \code{lines} (or only one value). #' @param description #' Description of the stack. It is displayed by function #' \code{prodStackAliases}. @@ -95,6 +97,8 @@ #' @param timeSteph5 \code{character} timeStep to read in h5 file. Only for Non interactive mode. #' @param mcYearh5 \code{numeric} mcYear to read for h5. Only for Non interactive mode. #' @param tablesh5 \code{character} tables for h5 ("areas" "links", "clusters" or "disticts"). Only for Non interactive mode. +#' @param language \code{character} language use for label. Defaut to 'en'. Can be 'fr'. +#' @param hidden \code{logical} Names of input to hide. Defaut to NULL #' @param ... Other arguments for \code{\link{manipulateWidget}} #' #' @return @@ -196,7 +200,8 @@ prodStack <- function(x, areas = NULL, mcYear = "average", dateRange = NULL, - main = "Production stack", unit = c("MWh", "GWh", "TWh"), + main = .getLabelLanguage("Production stack", language), + unit = c("MWh", "GWh", "TWh"), compare = NULL, compareOpts = list(), interactive = getInteractivity(), @@ -207,15 +212,24 @@ prodStack <- function(x, h5requestFiltering = list(), stepPlot = FALSE, drawPoints = FALSE, timeSteph5 = "hourly", mcYearh5 = NULL, - tablesh5 = c("areas", "links"),...) { + tablesh5 = c("areas", "links"), language = "en", + hidden = NULL, ...) { if(!is.null(compare) && !interactive){ stop("You can't use compare in no interactive mode") } - #Check compare + # Check language + if(!language %in% availableLanguages_labels){ + stop("Invalid 'language' argument. Must be in : ", paste(availableLanguages_labels, collapse = ", ")) + } + + # Check hidden + .validHidden(hidden, c("H5request", "timeSteph5", "tables", "mcYearH5", "mcYear", "main", "dateRange", + "stack", "unit", "areas", "legend", "stepPlot", "drawPoints")) + # Check compare .validCompare(compare, c("mcYear", "main", "unit", "areas", "legend", "stack", "stepPlot", "drawPoints")) - + xyCompare <- match.arg(xyCompare) unit <- match.arg(unit) if (is.null(mcYear)) mcYear <- "average" @@ -268,10 +282,14 @@ prodStack <- function(x, if (length(init_dateRange) < 2) init_dateRange <- dataDateRange plotWithLegend <- function(id, areas, main = "", unit, stack, dateRange, mcYear, legend, stepPlot, drawPoints) { - if (length(areas) == 0) return (combineWidgets("Please choose an area")) + if (length(areas) == 0) return (combineWidgets(.getLabelLanguage("Please choose an area", language))) + stackOpts <- .aliasToStackOptions(stack) dt <- x[area %in% areas] + if(length(mcYear) == 0){ + mcYear <- "average" + } if (mcYear == "average") dt <- synthesize(dt) else if ("mcYear" %in% names(dt)) { mcy <- mcYear @@ -285,26 +303,50 @@ prodStack <- function(x, } if(nrow(dt) == 0){ - return (combineWidgets("No data for this selection")) + return (combineWidgets(.getLabelLanguage("No data for this selection", language))) } + + # BP 2017 + # if(length(main) > 0){ + # mcYear <- ifelse(mcYear == "average", "moyen", mcYear) + # if(grepl("h5$", main)){ + # # main <- paste0(gsub(".h5$", "", main), " : ", areas, " (tirage ", mcYear, ")") + # main <- paste0(gsub(".h5$", "", main), " : Tirage ", mcYear) + # } else { + # # main <- paste0("Production ", areas, " (tirage ", mcYear, ")") + # main <- paste0("Tirage ", mcYear) + # } + # } + + names(stackOpts$variables) <- sapply(names(stackOpts$variables), function(x){ + .getColumnsLanguage(x, language) + }) + names(stackOpts$lines) <- sapply(names(stackOpts$lines), function(x){ + .getColumnsLanguage(x, language) + }) + p <- try(.plotProdStack(dt, stackOpts$variables, stackOpts$colors, stackOpts$lines, stackOpts$lineColors, + stackOpts$lineWidth, main = main, unit = unit, legendId = legendId + id - 1, groupId = groupId, dateRange = dateRange, - stepPlot = stepPlot, drawPoints = drawPoints), silent = TRUE) + stepPlot = stepPlot, drawPoints = drawPoints, language = language), silent = TRUE) if("try-error" %in% class(p)){ - return (combineWidgets(paste0("Can't visualize stack '", stack, "'
", p[1]))) + return ( + combineWidgets(paste0(.getLabelLanguage("Can't visualize stack", language), " '", stack, "'
", p[1])) + ) } if (legend) { - l <- prodStackLegend(stack, legendItemsPerRow, legendId = legendId + id - 1) + l <- prodStackLegend(stack, legendItemsPerRow, legendId = legendId + id - 1, + language = language) } else { l <- NULL } @@ -350,7 +392,7 @@ prodStack <- function(x, table <- NULL ##remove notes - mcYearhH5 <- NULL + mcYearH5 <- NULL paramsH5 <- NULL sharerequest <- NULL timeStepdataload <- NULL @@ -358,7 +400,6 @@ prodStack <- function(x, x_in <- NULL x_tranform <- NULL - manipulateWidget( { .tryCloseH5() @@ -367,9 +408,9 @@ prodStack <- function(x, unit, stack, dateRange, mcYear, legend, stepPlot, drawPoints) - controlWidgetSize(widget) + controlWidgetSize(widget, language) } else { - combineWidgets("No data for this selection") + return (combineWidgets(.getLabelLanguage("No data for this selection", language))) } }, x = mwSharedValue({x}), @@ -385,36 +426,70 @@ prodStack <- function(x, tmp }), H5request = mwGroup( - timeSteph5 = mwSelect(choices = paramsH5$timeStepS, - value = paramsH5$timeStepS[1], - label = "timeStep", - multiple = FALSE + label = .getLabelLanguage("H5request", language), + timeSteph5 = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5$timeStepS + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + choices + } else { + NULL + } + }, + value = if(.initial) {paramsH5$timeStepS[1]}else{NULL}, + label = .getLabelLanguage("timeStep", language), + multiple = FALSE, .display = !"timeSteph5" %in% hidden ), - tables = mwSelect(choices = paramsH5[["tabl"]][paramsH5[["tabl"]]%in%c("areas", "districts")], - value = { - if(.initial) {paramsH5[["tabl"]][paramsH5[["tabl"]]%in%c("areas", "districts")][1]}else{NULL} - }, - label = "table", - multiple = FALSE + tables = mwSelect( + { + if(length(paramsH5) > 0){ + choices = paramsH5[["tabl"]][paramsH5[["tabl"]]%in%c("areas", "districts")] + names(choices) <- sapply(choices, function(x) .getLabelLanguage(x, language)) + choices + } else { + NULL + } + }, + value = { + if(.initial) {paramsH5[["tabl"]][paramsH5[["tabl"]]%in%c("areas", "districts")][1]}else{NULL} + }, + label = .getLabelLanguage("table", language), + multiple = FALSE, .display = !"tables" %in% hidden ), - mcYearhH5 = mwSelect(choices = c(paramsH5[["mcYearS"]]), - value = { - if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} - }, - label = "mcYear", - multiple = TRUE + mcYearH5 = mwSelectize( + choices = { + ch <- c("Average" = "", paramsH5[["mcYearS"]]) + names(ch)[1] <- .getLabelLanguage("Average", language) + ch + }, + value = { + if(.initial){paramsH5[["mcYearS"]][1]}else{NULL} + }, + label = .getLabelLanguage("mcYears to be imported", language), + multiple = TRUE, options = list(maxItems = 4), + .display = (!"mcYearH5" %in% hidden & !meanYearH5) ), + meanYearH5 = mwCheckbox(value = FALSE, + label = .getLabelLanguage("Average mcYear", language), + .display = !"meanYearH5" %in% hidden), .display = { - any(unlist(lapply(x_in, .isSimOpts))) + any(unlist(lapply(x_in, .isSimOpts))) & !"H5request" %in% hidden } ), sharerequest = mwSharedValue({ - list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearhH5, tables_l = tables) + if(length(meanYearH5) > 0){ + if(meanYearH5){ + list(timeSteph5_l = timeSteph5, mcYearh_l = NULL, tables_l = tables) + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } + } else { + list(timeSteph5_l = timeSteph5, mcYearh_l = mcYearH5, tables_l = tables) + } }), - - x_tranform = mwSharedValue({ h5requestFilteringTp <- paramsH5$h5requestFilter @@ -430,7 +505,7 @@ prodStack <- function(x, } } } - + sapply(1:length(x_in),function(zz){ .loadH5Data(sharerequest, x_in[[zz]], h5requestFilter = h5requestFilteringTp[[zz]]) }, simplify = FALSE) @@ -444,12 +519,27 @@ prodStack <- function(x, ##End h5 mcYear = mwSelect({ - c("average", .compareOperation(lapply(params$x, function(vv){ + # allMcY <- c("average", .compareOperation(lapply(params$x, function(vv){ + # unique(vv$x$mcYear) + # }), xyCompare)) + # names(allMcY) <- c(.getLabelLanguage("average", language), allMcY[-1]) + + # BP 2017 + allMcY <- .compareOperation(lapply(params$x, function(vv){ unique(vv$x$mcYear) - }), xyCompare)) - }), + }), xyCompare) + names(allMcY) <- allMcY + if(is.null(allMcY)){ + allMcY <- "average" + names(allMcY) <- .getLabelLanguage("average", language) + } + allMcY + }, value = { + if(.initial) mcYear + else NULL + }, label = .getLabelLanguage("mcYear to be displayed", language), .display = !"mcYear" %in% hidden), - main = mwText(main, label = "title"), + main = mwText(main, label = .getLabelLanguage("title", language), .display = !"main" %in% hidden), dateRange = mwDateRange(value = { if(.initial){ @@ -461,14 +551,9 @@ prodStack <- function(x, if(params$x[[1]]$timeStep == "hourly"){ if(params$x[[1]]$dateRange[2] - params$x[[1]]$dateRange[1]>7){ res[1] <- params$x[[1]]$dateRange[2] - 7 + } } - - } - } - - - res }else{NULL} }, @@ -481,14 +566,17 @@ prodStack <- function(x, if(!is.null(params)){ .dateRangeJoin(params = params, xyCompare = xyCompare, "max", tabl = table) } - } + }, + language = eval(parse(text = "language")), + # format = "dd MM", + separator = " : ", + label = .getLabelLanguage("dateRange", language), + .display = !"dateRange" %in% hidden ), - - - - stack = mwSelect(names(pkgEnv$prodStackAliases), stack), - - unit = mwSelect(c("MWh", "GWh", "TWh"), unit), + stack = mwSelect(names(pkgEnv$prodStackAliases), stack, + label = .getLabelLanguage("stack", language), .display = !"stack" %in% hidden), + unit = mwSelect(c("MWh", "GWh", "TWh"), unit, + label = .getLabelLanguage("unit", language), .display = !"unit" %in% hidden), areas = mwSelect({ as.character(.compareOperation(lapply(params$x, function(vv){ @@ -497,17 +585,27 @@ prodStack <- function(x, }, value = { if(.initial){ - as.character(.compareOperation(lapply(params$x, function(vv){ - unique(vv$x$area) - }), xyCompare))[1] + if(!is.null(areas)){ + areas + } else { + as.character(.compareOperation(lapply(params$x, function(vv){ + unique(vv$x$area) + }), xyCompare))[1] + } } - else{NULL}}, - multiple = TRUE + else NULL + }, + multiple = TRUE, + label = .getLabelLanguage("areas", language), + .display = !"areas" %in% hidden ), - legend = mwCheckbox(legend), - stepPlot = mwCheckbox(stepPlot), - drawPoints = mwCheckbox(drawPoints), + legend = mwCheckbox(legend, label = .getLabelLanguage("legend", language), + .display = !"legend" %in% hidden), + stepPlot = mwCheckbox(stepPlot, label = .getLabelLanguage("stepPlot", language), + .display = !"stepPlot" %in% hidden), + drawPoints = mwCheckbox(drawPoints, label = .getLabelLanguage("drawPoints", language), + .display = !"drawPoints" %in% hidden), .compare = { compare }, @@ -576,10 +674,10 @@ prodStack <- function(x, #' next series is drawn from 0. #' #' @noRd -.plotProdStack <- function(x, variables, colors, lines, lineColors, +.plotProdStack <- function(x, variables, colors, lines, lineColors, lineWidth, main = NULL, unit = "MWh", legendId = "", groupId = legendId, - width = NULL, height = NULL, dateRange = NULL, stepPlot = FALSE, drawPoints = FALSE) { + width = NULL, height = NULL, dateRange = NULL, stepPlot = FALSE, drawPoints = FALSE, language = "en") { timeStep <- attr(x, "timeStep") @@ -591,19 +689,26 @@ prodStack <- function(x, for (n in names(formulas)) { dt[,c(n) := x[, eval(formulas[[n]]) / switch(unit, MWh = 1, GWh = 1e3, TWh = 1e6)]] } - .plotStack(dt, timeStep, simOptions(x), colors, lines, lineColors, legendId, + .plotStack(dt, timeStep, simOptions(x), colors, lines, lineColors, lineWidth, legendId, groupId, main = main, ylab = sprintf("Production (%s)", unit), - width = width, height = height, dateRange = dateRange, stepPlot = stepPlot, drawPoints = drawPoints) + width = width, height = height, dateRange = dateRange, stepPlot = stepPlot, drawPoints = drawPoints, language = language) } #' @rdname tsLegend #' @export prodStackLegend <- function(stack = "eco2mix", - legendItemsPerRow = 5, legendId = "") { + legendItemsPerRow = 5, legendId = "", language = "en") { stackOpts <- .aliasToStackOptions(stack) + names(stackOpts$variables) <- sapply(names(stackOpts$variables), function(x){ + .getColumnsLanguage(x, language) + }) + names(stackOpts$lines) <- sapply(names(stackOpts$lines), function(x){ + .getColumnsLanguage(x, language) + }) + tsLegend( labels = c(names(stackOpts$variables), names(stackOpts$lines)), colors = c(stackOpts$colors, stackOpts$lineColors), diff --git a/R/tsLegend.R b/R/tsLegend.R index 58c08c3..580a47d 100644 --- a/R/tsLegend.R +++ b/R/tsLegend.R @@ -71,7 +71,7 @@ tsLegend <- function(labels, colors, types = "line", legendItemsPerRow = 5, lege ) tags$div( - style=sprintf("position:relative;height:%spx", max(i * 20, 40)), + style=sprintf("position:relative;height:%spx", max(i * 20 + 20, 40)), tags$div( style = "position:absolute;top:0;bottom:0;width:100px; ", @@ -80,6 +80,7 @@ tsLegend <- function(labels, colors, types = "line", legendItemsPerRow = 5, lege id = paste0("date", legendId) ) ), + tags$br(), legendItems ) } @@ -150,21 +151,75 @@ tsLegend <- function(labels, colors, types = "line", legendItemsPerRow = 5, lege ) } -JS_updateLegend <- function(legendId, timeStep = "hourly") { +JS_updateLegend <- function(legendId, timeStep = "hourly", language = "en") { # Function that transform a timestamp ta a date label - timeToLab <- switch( - timeStep, - hourly = "var date = new Date(x); - var day = date.toUTCString().slice(0, 11); - var h = date.toUTCString().slice(17, 22); - return day + '
' + h;", - daily = "var date = new Date(x); return date.toUTCString().slice(0, 11)", - weekly = "var date = new Date(x); return date.toUTCString().slice(0, 11)", - monthly = "var date = new Date(x); return date.toUTCString().slice(7, 11)", - "return x" - ) - + timeToLab <- switch( + timeStep, + hourly = paste0("var date = new Date(x); + var res; + try { + res = date.toLocaleDateString('", language, "', { weekday: 'short', month: 'short', day: 'numeric', hour : '2-digit', minute:'2-digit', timeZone : 'UTC' }); + } catch (e) { + res = date.toLocaleDateString('en', { weekday: 'short', month: 'short', day: 'numeric', hour : '2-digit', minute:'2-digit', timeZone : 'UTC' }) + }; + // bug in Rstudio viewer / old browser + if(res == date.toLocaleDateString()){ + var day = date.toUTCString().slice(0, 11); + var h = date.toUTCString().slice(17, 22); + res = day + '
' + h; + } + return res"), + daily = paste0("var date = new Date(x); + var res; + try { + res = date.toLocaleDateString('", language, "', { weekday: 'short', month: 'short', day: 'numeric', timeZone : 'UTC' }); + } catch (e) { + res = date.toLocaleDateString('en', { weekday: 'short', month: 'short', day: 'numeric', timeZone : 'UTC' }) + }; + // bug in Rstudio viewer / old browser + if(res == date.toLocaleDateString()){ + res = date.toUTCString().slice(0, 11); + } + return res"), + weekly = paste0("var date = new Date(x); + var res; + try { + res = date.toLocaleDateString('", language, "', { weekday: 'short', month: 'short', day: 'numeric', timeZone : 'UTC' }); + } catch (e) { + res = date.toLocaleDateString('en', { weekday: 'short', month: 'short', day: 'numeric', timeZone : 'UTC' }) + }; + // bug in Rstudio viewer / old browser + if(res == date.toLocaleDateString()){ + res = date.toUTCString().slice(0, 11); + } + return res"), + monthly = paste0("var date = new Date(x); + var res; + try { + res = date.toLocaleDateString('", language, "', {month: 'long', year: 'numeric', timeZone : 'UTC' }); + } catch (e) { + res = date.toLocaleDateString('en', {month: 'long', year: 'numeric', timeZone : 'UTC' }) + }; + // bug in Rstudio viewer / old browser + if(res == date.toLocaleDateString()){ + res = return date.toUTCString().slice(7, 16); + } + return res"), + annual = paste0("var date = new Date(x); + var res; + try { + res = date.toLocaleDateString('", language, "', {year: 'numeric', timeZone : 'UTC' }); + } catch (e) { + res = date.toLocaleDateString('en', {year: 'numeric', timeZone : 'UTC' }) + }; + // bug in Rstudio viewer / old browser + if(res == date.toLocaleDateString()){ + res = date.toUTCString().slice(12, 16); + } + return res"), + "return x" + ) script <-" function(e, timestamp, data) { function timeToLab(x) {%s} @@ -183,7 +238,7 @@ function(e, timestamp, data) { if (!values.hasOwnProperty(k)) continue; var el = document.getElementById(k + '%s'); if (el) { - if (Math.abs(values[k]) > 100) { + if (Math.abs(values[k]) > 100 || values[k] === 0) { el.innerHTML = Math.round(values[k]); } else { el.innerHTML = values[k].toPrecision(3); diff --git a/R/zzz.R b/R/zzz.R index d41efcb..c4cd9c8 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -69,7 +69,8 @@ needed <- strsplit(needed, ",") variables = formulas[var], colors = unname(colors[var]), lines = formulas[lines], - lineColors = unname(colors[lines]) + lineColors = unname(colors[lines]), + lineWidth = 2 ) } @@ -117,10 +118,72 @@ pkgEnv$prodStackAliases <- list( rm(graphicalCharter, formulas, colors) +# message limit size +antaresVizSizeGraphError = "Too much data, please reduce selection. If you work with hourly data, you can reduce dateRange selection. +You can also use 'limitSizeGraph' function in R or 'Memory Controls' panel in shiny (if present) to update this." + +antaresVizSizeGraphError_fr = "Trop de données,veuillez réduire votre sélection. Si vous travaillez en données horaire, vous pouvez réduire la période de visualisation. +Il est également possible d'utiliser la fonction 'limitSizeGraph' en R ou l'onglet 'Memory Controls' dans shiny (si présent) pour changer la limite." + +# language for labels +language_labels <- fread(input=system.file("language_labels.csv", package = "antaresViz"), encoding = "UTF-8") + +availableLanguages_labels <- colnames(language_labels) + +.getLabelLanguage <- function(label, language = "en"){ + if(language %in% colnames(language_labels)){ + up_label <- language_labels[en %in% label, get(language)] + if(length(up_label) == 0){ + up_label <- label + } + } else { + up_label <- label + } + up_label +} + +# language for columns +language_columns <- fread(input=system.file("language_columns.csv", package = "antaresViz"), encoding = "UTF-8") + +language_columns$en <- as.character(language_columns$en) + +language_columns$fr <- as.character(language_columns$fr) +# Encoding(language_columns$fr) <- "latin1" + +expand_language_columns <- copy(language_columns) +#add _std _min _max +language_columns[, tmp_row := 1:nrow(language_columns)] + +language_columns <- language_columns[, list(en = c(en, paste0(en, c("_std", "_min", "_max"))), + fr = c(fr, paste0(fr, c("_std", "_min", "_max")))), by = tmp_row] + +language_columns[, tmp_row := NULL] + + +.getColumnsLanguage <- function(columns, language = "en"){ + if(language %in% colnames(language_columns)){ + ind_match <- match(columns, language_columns$en) + up_columns <- columns + if(any(!is.na(ind_match))){ + up_columns[which(!is.na(ind_match))] <- language_columns[[language]][ind_match[!is.na(ind_match)]] + } + } else { + up_columns <- columns + } + up_columns +} + +# map color colorsVars <- fread(input=system.file("color.csv", package = "antaresViz")) +colorsVars <- unique(colorsVars, by = "Column") colorsVars$colors <- rgb(colorsVars$red, colorsVars$green, colorsVars$blue, maxColorValue = 255) +# expand to fr name +expand_language_columns <- expand_language_columns[en %in% colorsVars$Column] + +ind_match <- match(expand_language_columns$en, colorsVars$Column) +rev_ind_match <- match(colorsVars$Column, expand_language_columns$en) + +col_fr <- colorsVars[Column %in% expand_language_columns$en][, Column := expand_language_columns$fr[rev_ind_match[!is.na(rev_ind_match)]]] +colorsVars <- unique(rbindlist(list(colorsVars, col_fr))) -# message limit size -antaresVizSizeGraphError = "Too much data, please reduce selection. If you work with hourly data, you can reduce dateRange selection. -You can also use 'limitSizeGraph' function in R or 'Memory Controls' panel in shiny to update this." \ No newline at end of file diff --git a/README.md b/README.md index 9c4dc7f..cccd3c0 100644 --- a/README.md +++ b/README.md @@ -12,10 +12,6 @@ This package has been published on CRAN, so you can install it easily: ```r install.packages("antaresViz") ``` -You can also install the last version from Github : -```r -devtools::install_github("rte-antares-rpackage/antaresViz") -``` To install the last development version: ```r diff --git a/inst/application/server.R b/inst/application/server.R index f3cca99..820de65 100644 --- a/inst/application/server.R +++ b/inst/application/server.R @@ -14,7 +14,9 @@ function(input, output, session) { # shared parameters #---------------- - modules <- reactiveValues(prodStack = NULL, exchangesStack = NULL, plotts = NULL, plotMap = NULL) + modules <- reactiveValues(prodStack = NULL, exchangesStack = NULL, plotts = NULL, plotMap = NULL, + id_prodStack = NULL, id_exchangesStack = NULL, id_plotts = NULL, id_plotMap = NULL, + init_prodStack = FALSE, init_exchangesStack = FALSE, init_plotts = FALSE, init_plotMap = FALSE) # all data loaded by user, with informations list_data_all <- reactiveValues(antaresDataList = list(), params = list(), diff --git a/inst/application/src/server/01_set_read_data.R b/inst/application/src/server/01_set_read_data.R index e15baca..4f6d770 100644 --- a/inst/application/src/server/01_set_read_data.R +++ b/inst/application/src/server/01_set_read_data.R @@ -153,15 +153,15 @@ observe({ # links links <- c("all", opts$linkList) - updateSelectInput(session, "read_links", "Links :", choices = links, selected = NULL) + updateSelectInput(session, "read_links", "Links :", choices = links, selected = links[1]) # clusters clusters <- c("all", opts$areasWithClusters) - updateSelectInput(session, "read_clusters", "Clusters :", choices = clusters, selected = NULL) + updateSelectInput(session, "read_clusters", "Clusters :", choices = clusters, selected = clusters[1]) # districts districts <- c("all", opts$districtList) - updateSelectInput(session, "read_districts", "Districts :", choices = districts, selected = NULL) + updateSelectInput(session, "read_districts", "Districts :", choices = districts, selected = districts[1]) # mcYears mcy <- c(opts$mcYears) diff --git a/inst/application/src/server/05_modules.R b/inst/application/src/server/05_modules.R index 0904045..0034636 100644 --- a/inst/application/src/server/05_modules.R +++ b/inst/application/src/server/05_modules.R @@ -19,14 +19,15 @@ observe({ input_data$data[grepl("^prodStack", input_id), input_id := paste0(id_prodStack, "-shared_", input)] output[["prodStack_ui"]] <- renderUI({ - mwModuleUI(id = id_prodStack, height = "800px", fluidRow = TRUE) + mwModuleUI(id = id_prodStack, height = "800px") }) .compare <- input$sel_compare_prodstack if(input$sel_compare_mcyear){ .compare <- unique(c(.compare, "mcYear")) } - if(!is.null(.compare)){ + + if(length(.compare) > 0){ list_compare <- vector("list", length(.compare)) names(list_compare) <- .compare # set main with study names @@ -35,18 +36,26 @@ observe({ } .compare <- list_compare } else { - .compare = NULL + if(length(ind_areas) > 1){ + .compare <- list(main = names(list_data_all$antaresDataList[ind_areas])) + } else { + .compare = NULL + } } + mod_prodStack <- prodStack(list_data_all$antaresDataList[ind_areas], xyCompare = "union", h5requestFiltering = list_data_all$params[ind_areas], unit = "GWh", interactive = TRUE, .updateBtn = TRUE, + language = "fr", .updateBtnInit = TRUE, compare = .compare, .runApp = FALSE) if("MWController" %in% class(modules$prodStack)){ modules$prodStack$clear() } - modules$prodStack <- mwModule(id = id_prodStack, mod_prodStack) + modules$prodStack <- mod_prodStack + modules$id_prodStack <- id_prodStack + modules$init_prodStack <- TRUE # init / re-init module plotts id_ts <- paste0("plotts_", round(runif(1, 1, 100000000))) @@ -55,14 +64,15 @@ observe({ input_data$data[grepl("^plotts", input_id), input_id := paste0(id_ts, "-shared_", input)] output[["plotts_ui"]] <- renderUI({ - mwModuleUI(id = id_ts, height = "800px", fluidRow = TRUE) + mwModuleUI(id = id_ts, height = "800px") }) .compare <- input$sel_compare_tsPlot if(input$sel_compare_mcyear){ .compare <- unique(c(.compare, "mcYear")) } - if(!is.null(.compare)){ + + if(length(.compare) > 0){ list_compare <- vector("list", length(.compare)) names(list_compare) <- .compare # set main with study names @@ -71,18 +81,25 @@ observe({ } .compare <- list_compare } else { - .compare = NULL + if(length(ind_areas) > 1){ + .compare <- list(main = names(list_data_all$antaresDataList[ind_areas])) + } else { + .compare = NULL + } } + mod_plotts <- plot(list_data_all$antaresDataList[ind_areas], xyCompare = "union", h5requestFiltering = list_data_all$params[ind_areas], - interactive = TRUE, .updateBtn = TRUE, + interactive = TRUE, .updateBtn = TRUE, language = "fr", .updateBtnInit = TRUE, compare = .compare, .runApp = FALSE) if("MWController" %in% class(modules$plotts)){ modules$plotts$clear() } - modules$plotts <- mwModule(id = id_ts, mod_plotts) + modules$plotts <- mod_plotts + modules$id_plotts <- id_ts + modules$init_plotts <- TRUE list_data_controls$n_areas <- length(ind_areas) list_data_controls$have_areas <- TRUE @@ -100,14 +117,15 @@ observe({ input_data$data[grepl("^exchangesStack", input_id), input_id := paste0(id_exchangesStack, "-shared_", input)] output[["exchangesStack_ui"]] <- renderUI({ - mwModuleUI(id = id_exchangesStack, height = "800px", fluidRow = TRUE) + mwModuleUI(id = id_exchangesStack, height = "800px") }) .compare <- input$sel_compare_exchangesStack if(input$sel_compare_mcyear){ .compare <- unique(c(.compare, "mcYear")) } - if(!is.null(.compare)){ + + if(length(.compare) > 0){ list_compare <- vector("list", length(.compare)) names(list_compare) <- .compare # set main with study names @@ -116,18 +134,24 @@ observe({ } .compare <- list_compare } else { - .compare = NULL + if(length(ind_links) > 1){ + .compare <- list(main = names(list_data_all$antaresDataList[ind_links])) + } else { + .compare = NULL + } } mod_exchangesStack <- exchangesStack(list_data_all$antaresDataList[ind_links], xyCompare = "union", h5requestFiltering = list_data_all$params[ind_links], - interactive = TRUE, .updateBtn = TRUE, + interactive = TRUE, .updateBtn = TRUE, language = "fr", .updateBtnInit = TRUE, compare = .compare, .runApp = FALSE) if("MWController" %in% class(modules$exchangesStack)){ modules$exchangesStack$clear() } - modules$exchangesStack <- mwModule(id = id_exchangesStack, mod_exchangesStack) + modules$exchangesStack <- mod_exchangesStack + modules$id_exchangesStack <- id_exchangesStack + modules$init_exchangesStack <- TRUE # save data and params list_data_controls$n_links <- length(ind_links) @@ -150,6 +174,41 @@ observe({ }) }) +# call module when click on tab if needed +observe({ + if(input[['nav-id']] == "prodStack" & modules$init_prodStack){ + isolate({ + if("MWController" %in% class(modules$prodStack) & modules$init_prodStack){ + modules$prodStack <- mwModule(id = modules$id_prodStack, modules$prodStack) + modules$init_prodStack <- FALSE + } + }) + } +}) + +observe({ + if(input[['nav-id']] == "tsPlot"){ + isolate({ + if("MWController" %in% class(modules$plotts) & modules$init_plotts){ + modules$plotts <- mwModule(id = modules$id_plotts, modules$plotts) + modules$init_plotts <- FALSE + } + }) + } +}) + +observe({ + if(input[['nav-id']] == "exchangesStack"){ + isolate({ + if("MWController" %in% class(modules$exchangesStack) & modules$init_exchangesStack){ + modules$exchangesStack <- mwModule(id = modules$id_exchangesStack, modules$exchangesStack) + modules$init_exchangesStack <- FALSE + } + }) + } +}) + + # control : have link in data output$have_data_links <- reactive({ list_data_controls$have_links diff --git a/inst/application/src/server/06_module_map.R b/inst/application/src/server/06_module_map.R index 21b61c5..6d3fc86 100644 --- a/inst/application/src/server/06_module_map.R +++ b/inst/application/src/server/06_module_map.R @@ -85,20 +85,21 @@ observe({ input_data$data[grepl("^plotMap", input_id), input_id := paste0(id_plotMap, "-shared_", input)] output[["plotMap_ui"]] <- renderUI({ - mwModuleUI(id = id_plotMap, height = "800px", fluidRow = TRUE) + mwModuleUI(id = id_plotMap, height = "800px") }) .compare <- input$sel_compare_plotMap if(input$sel_compare_mcyear){ .compare <- unique(c(.compare, "mcYear")) } - if(!is.null(.compare)){ + + if(length(.compare) > 0){ list_compare <- vector("list", length(.compare)) names(list_compare) <- .compare # set main with study names - if(length(ind_map) != 1){ - list_compare$main <- names(list_data_all$antaresDataList[ind_map]) - } + # if(length(ind_map) != 1){ + # list_compare$main <- names(list_data_all$antaresDataList[ind_map]) + # } .compare <- list_compare } else { .compare = NULL @@ -107,6 +108,7 @@ observe({ mod_plotMap <- plotMap(list_data_all$antaresDataList[ind_map], ml, interactive = TRUE, .updateBtn = TRUE, .updateBtnInit = TRUE, compare = .compare, + language = "fr", h5requestFiltering = list_data_all$params[ind_map], xyCompare = "union", .runApp = FALSE) @@ -114,7 +116,9 @@ observe({ modules$plotMap$clear() } - modules$plotMap <- mwModule(id = id_plotMap, mod_plotMap) + modules$plotMap <- mod_plotMap + modules$id_plotMap <- id_plotMap + modules$init_plotMap <- TRUE # save data and params list_data_controls$n_maps <- length(ind_map) } @@ -124,6 +128,18 @@ observe({ }) }) + +observe({ + if(input[['nav-id']] == "Map"){ + isolate({ + if("MWController" %in% class(modules$plotMap) & modules$init_plotMap){ + modules$plotMap <- mwModule(id = modules$id_plotMap, modules$plotMap) + modules$init_plotMap <- FALSE + } + }) + } +}) + # download layout output$download_layout <- downloadHandler( filename = function() { diff --git a/inst/application/ui.R b/inst/application/ui.R index 6bd73aa..ade3467 100644 --- a/inst/application/ui.R +++ b/inst/application/ui.R @@ -1,12 +1,12 @@ # Define UI for antaresViz app navbarPage(title = "antaresViz", id = "nav-id", inverse= TRUE, collapsible = TRUE, position = "fixed-top", - header = fluidRow( - column(12, + header = div( br(), br(), br(), singleton(tags$script(src = 'events.js')), + singleton(tags$script(src = 'is.min.js')), + tags$script(type="text/javascript", 'if(is.ie()){ alert("Ce site n\'est pas optimisé pour Internet Explorer");};'), div(id = "import_busy", tags$img(src= "spinner.gif", height = 100, style = "position: fixed;top: 50%;z-index:10;left: 48%;")) - ) ), windowTitle = "antaresViz", tabPanel("Data", fluidRow( diff --git a/inst/application/www/is.min.js b/inst/application/www/is.min.js new file mode 100644 index 0000000..5b701f0 --- /dev/null +++ b/inst/application/www/is.min.js @@ -0,0 +1,5 @@ +/*! + * is.js 0.9.0 + * Author: Aras Atasaygin + */ +(function(n,t){if(typeof define==="function"&&define.amd){define(function(){return n.is=t()})}else if(typeof exports==="object"){module.exports=t()}else{n.is=t()}})(this,function(){var n={};n.VERSION="0.8.0";n.not={};n.all={};n.any={};var t=Object.prototype.toString;var e=Array.prototype.slice;var r=Object.prototype.hasOwnProperty;function a(n){return function(){return!n.apply(null,e.call(arguments))}}function u(n){return function(){var t=c(arguments);var e=t.length;for(var r=0;r":function(n,t){return n>t},">=":function(n,t){return n>=t}};function f(n,t){var e=t+"";var r=+(e.match(/\d+/)||NaN);var a=e.match(/^[<>]=?|/)[0];return i[a]?i[a](n,r):n==r||r!==r}function c(t){var r=e.call(t);var a=r.length;if(a===1&&n.array(r[0])){r=r[0]}return r}n.arguments=function(n){return t.call(n)==="[object Arguments]"||n!=null&&typeof n==="object"&&"callee"in n};n.array=Array.isArray||function(n){return t.call(n)==="[object Array]"};n.boolean=function(n){return n===true||n===false||t.call(n)==="[object Boolean]"};n.char=function(t){return n.string(t)&&t.length===1};n.date=function(n){return t.call(n)==="[object Date]"};n.domNode=function(t){return n.object(t)&&t.nodeType>0};n.error=function(n){return t.call(n)==="[object Error]"};n["function"]=function(n){return t.call(n)==="[object Function]"||typeof n==="function"};n.json=function(n){return t.call(n)==="[object Object]"};n.nan=function(n){return n!==n};n["null"]=function(n){return n===null};n.number=function(e){return n.not.nan(e)&&t.call(e)==="[object Number]"};n.object=function(n){return Object(n)===n};n.regexp=function(n){return t.call(n)==="[object RegExp]"};n.sameType=function(e,r){var a=t.call(e);if(a!==t.call(r)){return false}if(a==="[object Number]"){return!n.any.nan(e,r)||n.all.nan(e,r)}return true};n.sameType.api=["not"];n.string=function(n){return t.call(n)==="[object String]"};n.undefined=function(n){return n===void 0};n.windowObject=function(n){return n!=null&&typeof n==="object"&&"setInterval"in n};n.empty=function(t){if(n.object(t)){var e=Object.getOwnPropertyNames(t).length;if(e===0||e===1&&n.array(t)||e===2&&n.arguments(t)){return true}return false}return t===""};n.existy=function(n){return n!=null};n.falsy=function(n){return!n};n.truthy=a(n.falsy);n.above=function(t,e){return n.all.number(t,e)&&t>e};n.above.api=["not"];n.decimal=function(t){return n.number(t)&&t%1!==0};n.equal=function(t,e){if(n.all.number(t,e)){return t===e&&1/t===1/e}if(n.all.string(t,e)||n.all.regexp(t,e)){return""+t===""+e}if(n.all.boolean(t,e)){return t===e}return false};n.equal.api=["not"];n.even=function(t){return n.number(t)&&t%2===0};n.finite=isFinite||function(t){return n.not.infinite(t)&&n.not.nan(t)};n.infinite=function(n){return n===Infinity||n===-Infinity};n.integer=function(t){return n.number(t)&&t%1===0};n.negative=function(t){return n.number(t)&&t<0};n.odd=function(t){return n.number(t)&&t%2===1};n.positive=function(t){return n.number(t)&&t>0};n.under=function(t,e){return n.all.number(t,e)&&te&&t=0&&t.indexOf(e,r)===r};n.endWith.api=["not"];n.include=function(n,t){return n.indexOf(t)>-1};n.include.api=["not"];n.lowerCase=function(t){return n.string(t)&&t===t.toLowerCase()};n.palindrome=function(t){if(n.not.string(t)){return false}t=t.replace(/[^a-zA-Z0-9]+/g,"").toLowerCase();var e=t.length-1;for(var r=0,a=Math.floor(e/2);r<=a;r++){if(t.charAt(r)!==t.charAt(e-r)){return false}}return true};n.space=function(t){if(n.not.char(t)){return false}var e=t.charCodeAt(0);return e>8&&e<14||e===32};n.startWith=function(t,e){return n.string(t)&&t.indexOf(e)===0};n.startWith.api=["not"];n.upperCase=function(t){return n.string(t)&&t===t.toUpperCase()};var F=["sunday","monday","tuesday","wednesday","thursday","friday","saturday"];var p=["january","february","march","april","may","june","july","august","september","october","november","december"];n.day=function(t,e){return n.date(t)&&e.toLowerCase()===F[t.getDay()]};n.day.api=["not"];n.dayLightSavingTime=function(n){var t=new Date(n.getFullYear(),0,1);var e=new Date(n.getFullYear(),6,1);var r=Math.max(t.getTimezoneOffset(),e.getTimezoneOffset());return n.getTimezoneOffset()e.getTime()};n.inDateRange=function(t,e,r){if(n.not.date(t)||n.not.date(e)||n.not.date(r)){return false}var a=t.getTime();return a>e.getTime()&&ae){return false}}return a===e};n.propertyCount.api=["not"];n.propertyDefined=function(t,e){return n.object(t)&&n.string(e)&&e in t};n.propertyDefined.api=["not"];n.inArray=function(t,e){if(n.not.array(e)){return false}for(var r=0;r="];for(var a=1;a\
\
\
\ \ \ '; - var btn = createEl("button", "btn btn-link btn-xs pull-right", container); - this._content = content; this._btn = btn; this._container = container; @@ -103,12 +111,16 @@ L.AntaresLegend = L.Control.extend({ }, showHide: function() { + var show_legend, hide_legend; + show_legend = this.options.show_legend; + hide_legend = this.options.hide_legend; + if (this.options.collapsed) { this._content.style.display = "none"; - this._btn.textContent = "Show legend"; + this._btn.textContent = show_legend; } else { this._content.style.display = "block"; - this._btn.textContent = "Hide legend"; + this._btn.textContent = hide_legend; } },