diff --git a/.github/workflows/deployment_uat.yml b/.github/workflows/deployment_uat.yml new file mode 100644 index 0000000..b17736e --- /dev/null +++ b/.github/workflows/deployment_uat.yml @@ -0,0 +1,29 @@ +on: [push, pull_request] +jobs: + build: + name: Build and upload Docker image + runs-on: [self-hosted] + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup AWS credentials + uses: aws-actions/configure-aws-credentials@v4 + with: + aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }} + aws-region: ${{ secrets.AWS_DEFAULT_REGION }} + role-to-assume: ${{ secrets.AWS_ROLE_TO_ASSUME }} + + - name: Login to Amazon ECR + id: login-ecr + uses: aws-actions/amazon-ecr-login@v2 + + - name: Build, tag, and push docker image to Amazon ECR + env: + REGISTRY: ${{ steps.login-ecr.outputs.registry }} + REPOSITORY: inbo-exotenportaal-portal + IMAGE_TAG: ${{ github.sha }} + run: | + docker build -t $REGISTRY/$REPOSITORY:$IMAGE_TAG . + docker push $REGISTRY/$REPOSITORY:$IMAGE_TAG diff --git a/.gitignore b/.gitignore index 200209b..bb2739e 100644 --- a/.gitignore +++ b/.gitignore @@ -58,3 +58,6 @@ alienSpecies/alienSpecies-tests/ # aws secret /script/ + +# temporary translations file +/alienSpecies/inst/extdata/translations.csv diff --git a/Dockerfile b/Dockerfile index ce01c46..f4f69fb 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,231 +1,55 @@ -# Generated by packamon: do not edit by hand -# Instead of modifying this file, you can modify a template. See ?init for details. +FROM rocker/r-ver:4.3.2 -FROM openanalytics/r-ver:4.2.2 +MAINTAINER Machteld Varewyck machteld.varewyck@openanalytics.eu -# System libraries (incl. system requirements for R packages) RUN apt-get update && apt-get install --no-install-recommends -y \ - libssl-dev \ - zlib1g-dev \ - pandoc \ - libgeos-dev \ - libgeos++-dev \ + libgdal-dev \ + libudunits2-dev \ libharfbuzz-dev \ - make \ - gdal-bin \ - libxml2-dev \ libfribidi-dev \ - libproj-dev \ - libgdal-dev \ - libicu-dev \ - imagemagick \ - libudunits2-dev \ + libproj22 \ + libgeos3.10.2 libgeos-c1v5 \ libcurl4-openssl-dev \ - libtiff-dev \ - libpng-dev \ + curl \ + imagemagick \ + lbzip2 \ + pandoc \ + libmagick++-dev \ + libssl-dev \ && rm -rf /var/lib/apt/lists/* -# Missing for tidyverse install +# Use the remotes package instead of devtools as it is much lighter +RUN R -q -e "install.packages('remotes')" -RUN apt-get update && apt-get install --no-install-recommends -y libfontconfig1-dev +RUN R -q -e "options(warn = 2); remotes::install_cran(c('shiny', 'data.table', 'dplyr', 'DT', 'ggplot2', 'ggspatial', 'htmlwidgets', 'httr', 'jsonlite', 'leaflet', 'leaflet.extras', 'plotly', 'reshape2', 'rgbif', 'sf', 'shinyjs', 'terra', 'testthat', 'tidyr', 'tidyverse', 'webshot', 'xtable'))" -RUN R -e "cat(\"local(options(repos = c(CRAN = 'https://cloud.r-project.org')))\n\", file = R.home('etc/Rprofile.site'), append = TRUE)" +# Specific data format + access to S3 on UAT +RUN R -q -e "options(warn = 2); remotes::install_cran(c('arrow', 'config', 'aws.ec2metadata', 'aws.s3', 'aws.signature'))" -# install dependencies -RUN R -q -e "install.packages('remotes')" && \ - R -q -e "remotes::install_version('backports', version = '1.4.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('base64enc', version = '0.1-3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('bit', version = '4.0.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('brew', version = '1.0-8', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('brio', version = '1.1.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('cli', version = '3.6.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('clipr', version = '0.8.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('colorspace', version = '2.1-0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('commonmark', version = '1.9.0', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('cpp11', version = '0.4.6', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('crayon', version = '1.5.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('curl', version = '5.1.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('data.table', version = '1.14.8', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('DBI', version = '1.1.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('digest', version = '0.6.33', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('evaluate', version = '0.22', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('fansi', version = '1.0.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('farver', version = '2.1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('fastmap', version = '1.1.1', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('fs', version = '1.6.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('generics', version = '0.1.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('glue', version = '1.6.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('httpcode', version = '0.3.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('isoband', version = '0.2.7', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('jsonlite', version = '1.8.7', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('KernSmooth', version = '2.23-22', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('labeling', version = '0.4.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('lattice', version = '0.21-9', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('lazyeval', version = '0.2.2', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('magrittr', version = '2.0.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('MASS', version = '7.3-60', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('mime', version = '0.12', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('pkgconfig', version = '2.0.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('png', version = '0.1-8', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('praise', version = '1.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('prettyunits', version = '1.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('proxy', version = '0.4-27', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('ps', version = '1.7.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('R6', version = '2.5.1', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('rappdirs', version = '0.3.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('RColorBrewer', version = '1.1-3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('Rcpp', version = '1.0.11', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rematch', version = '2.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rlang', version = '1.1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rprojroot', version = '2.0.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rstudioapi', version = '0.15.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('sourcetools', version = '0.1.7-1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('stringi', version = '1.7.12', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('sys', version = '3.4.2', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('utf8', version = '1.2.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('uuid', version = '1.1-1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('viridisLite', version = '0.4.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('whisker', version = '0.4.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('withr', version = '2.5.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('wk', version = '0.8.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('xfun', version = '0.40', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('xml2', version = '1.3.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('xtable', version = '1.8-4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('yaml', version = '2.3.7', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('askpass', version = '1.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('aws.ec2metadata', version = '0.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('aws.signature', version = '0.6.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('bit64', version = '4.0.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('cachem', version = '1.0.8', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('class', version = '7.3-22', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('config', version = '0.3.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('desc', version = '1.4.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('diffobj', version = '0.3.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('ellipsis', version = '0.3.2', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('highr', version = '0.10', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('later', version = '1.3.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('lifecycle', version = '1.0.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('Matrix', version = '1.6-1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('munsell', version = '0.5.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('nlme', version = '3.1-163', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('plyr', version = '1.8.9', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('processx', version = '3.8.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rex', version = '1.2.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('s2', version = '1.1.4', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('sp', version = '2.1-1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('systemfonts', version = '1.0.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('terra', version = '1.7-55', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('timechange', version = '0.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tinytex', version = '0.48', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('triebeard', version = '0.4.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tzdb', version = '0.4.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('units', version = '0.8-4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('callr', version = '3.7.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('e1071', version = '1.7-13', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('gtable', version = '0.3.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('htmltools', version = '0.5.6.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('knitr', version = '1.44', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('lubridate', version = '1.9.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('memoise', version = '2.0.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('mgcv', version = '1.9-0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('openssl', version = '2.1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('promises', version = '1.2.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('raster', version = '3.6-26', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('scales', version = '1.2.1', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('textshaping', version = '0.3.7', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('urltools', version = '1.7.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('vctrs', version = '0.6.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('blob', version = '1.2.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('classInt', version = '0.4-10', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('conflicted', version = '1.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('crosstalk', version = '1.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('crul', version = '1.4.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('fontawesome', version = '0.5.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('gridExtra', version = '2.3', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('hms', version = '1.1.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('httpuv', version = '1.6.11', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('httr', version = '1.4.7', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('ids', version = '1.0.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('jquerylib', version = '0.1.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('leaflet.providers', version = '2.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('pillar', version = '1.9.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('pkgbuild', version = '1.4.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('purrr', version = '1.0.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('ragg', version = '1.2.6', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('sass', version = '0.4.7', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('stringr', version = '1.5.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tidyselect', version = '1.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('webshot', version = '0.5.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('aws.s3', version = '0.3.21', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('bslib', version = '0.5.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('covr', version = '3.6.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('gargle', version = '1.5.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('pkgload', version = '1.3.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('progress', version = '1.2.2', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('reshape2', version = '1.4.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('selectr', version = '0.4-2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('sf', version = '1.0-14', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tibble', version = '3.2.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('cellranger', version = '1.1.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('dplyr', version = '1.1.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('forcats', version = '1.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('ggplot2', version = '3.4.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('googledrive', version = '2.1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('oai', version = '0.4.0', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('rematch2', version = '2.1.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rmarkdown', version = '2.25', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('roxygen2', version = '7.2.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rvest', version = '1.0.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('shiny', version = '1.7.5.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('vroom', version = '1.6.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('dtplyr', version = '1.3.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('googlesheets4', version = '1.1.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('htmlwidgets', version = '1.6.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('readr', version = '2.1.4', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('readxl', version = '1.4.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('reprex', version = '2.0.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('rgbif', version = '3.7.8', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('shinycssloaders', version = '1.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('shinyjs', version = '2.1.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tidyr', version = '1.3.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('viridis', version = '0.6.4', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('waldo', version = '0.5.1', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('broom', version = '1.0.5', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('dbplyr', version = '2.3.4', upgrade = FALSE)" -RUN R -q -e "remotes::install_version('DT', version = '0.30', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('haven', version = '2.5.3', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('leaflet', version = '2.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('plotly', version = '4.10.2', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('testthat', version = '3.2.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('leaflet.extras', version = '1.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('modelr', version = '0.1.11', upgrade = FALSE)" && \ - R -q -e "remotes::install_version('tidyverse', version = '2.0.0', upgrade = FALSE)" && \ - R -q -e "remotes::install_github('trias-project/trias')" +# INBO packages +RUN R -q -e "options(warn = 2); remotes::install_github(c('inbo/INBOtheme@v0.5.9', 'trias-project/trias', 'daattali/shinycssloaders'))" -# Specific version INBOtheme -RUN R -q -e "remotes::install_github('inbo/INBOtheme@v0.5.9')" +## For the rmarkdown pdf report +#RUN R -e "tinytex::install_tinytex()" +#ENV PATH="/root/bin:${PATH}" +#RUN R -e "tinytex::tlmgr_install(pkgs = c('fancyhdr', 'sectsty', 'titling', 'grffile'))" -# To prevent errors -## when opening ggplot via linux docker -## when installing phantomjs via webshot -RUN apt-get update && apt-get install --no-install-recommends -y \ - libxt-dev \ - wget \ - bzip2 - -# To download leaflet maps from within the app -## Attention: do not install phantomjs directly, will not work then! -RUN R -e "webshot::install_phantomjs()" +# For downloading the maps +# Attention: do not install phantomjs directly, will not work then! +RUN R -q -e "options(warn = 2); remotes::install_cran('webshot'); webshot::install_phantomjs()" + +# Git sha +ARG GIT_SHA +ENV GIT_SHA=$GIT_SHA + + +# Install the package without the source files ending up in the Docker image +COPY alienSpecies /tmp/package +RUN R -q -e "options(warn = 2); remotes::install_local('/tmp/package', dependencies=FALSE)" -# install local package(s) -RUN mkdir -p /tmp -WORKDIR /tmp -COPY alienSpecies /tmp/alienSpecies -#RUN R -q -e "roxygen2::roxygenize('alienSpecies'); #install.packages(pkgbuild::build('alienSpecies'), repos = NULL, dependencies = FALSE)" -RUN R -e "remotes::install_local('/tmp/alienSpecies')" +# set host +COPY Rprofile.site /usr/local/lib/R/etc/ -#packamon.run-shiny-start -RUN R -e "cat(\"local(options(shiny.port = 3838, shiny.host = '0.0.0.0'))\n\", file = R.home('etc/Rprofile.site'), append = TRUE)" EXPOSE 3838 -CMD ["R", "-e", "alienSpecies::runShiny()"] +CMD ["R", "-e alienSpecies::runShiny()"] \ No newline at end of file diff --git a/README.md b/README.md index 1337325..a6aad8a 100644 --- a/README.md +++ b/README.md @@ -18,22 +18,11 @@ Enkele relevante URLS: # Build/Run docker image The dockerfile needs to be updated only when some of the **dependencies** for `alienSpecies` changed. -This file is generated automatically by packamon: please do not edit by hand. -The following commands are run to update this dockerfile. - -``` -if (!require(packamon)) - install.packages("packamon", repos = c(rdepot = "https://repos.openanalytics.eu/repo/public", getOption("repos"))) -library(packamon) -writeDockerfile(sourceDir = ".", installSource = TRUE, -overwrite = TRUE, shinyFunction = "alienSpecies::runShiny()") -``` - -Then, to build the docker image with the latest dockerfile, run in bash +To build the docker image with the latest dockerfile, run in bash ``` cd git/alien-species-portal -docker build -t inbo/alienspecies . +docker build --build-arg GIT_SHA=$(git rev-parse HEAD) -t inbo/alienspecies . ``` Run the new docker image from bash. You need to point docker to the .aws folder on your local system to retrieve the credentials. diff --git a/alienSpecies/DESCRIPTION b/alienSpecies/DESCRIPTION index 9898944..39f8e1c 100644 --- a/alienSpecies/DESCRIPTION +++ b/alienSpecies/DESCRIPTION @@ -1,7 +1,7 @@ Package: alienSpecies Type: Package Title: Portal for alien and invasive species indicators -Version: 0.0.5 +Version: 1.0.0 Date: 2023-11-30 Author: Machteld Varewyck, Yingjie Zhang, Eva Adriaensen Maintainer: Machteld Varewyck @@ -9,6 +9,7 @@ Description: INBO shiny application based on the TRIAS package. Encoding: UTF-8 License: MIT + file LICENSE Imports: + arrow, aws.ec2metadata, aws.s3, aws.signature, @@ -17,28 +18,31 @@ Imports: dplyr, DT, ggplot2, + ggspatial, htmltools, htmlwidgets, + httr, INBOtheme (<= 0.5.9), jsonlite, - leaflet, + leaflet (>= 2.2.0), leaflet.extras, methods, plotly, reshape2, rgbif, - shiny, - shinycssloaders, - sf, - testthat (>= 3.0.0), + shiny, + shinycssloaders, + sf, + terra, + testthat (>= 3.0.0), tidyr, - tidyverse, - trias (>= 2.0.3), - webshot, - xtable + tidyverse, + trias (>= 2.0.8), + webshot, + xtable Suggests: shinyjs -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Remotes: inbo/INBOtheme@v0.5.9, trias-project/trias@v2.0.6 diff --git a/alienSpecies/NAMESPACE b/alienSpecies/NAMESPACE index df93c6c..7a27054 100644 --- a/alienSpecies/NAMESPACE +++ b/alienSpecies/NAMESPACE @@ -5,6 +5,7 @@ export(barplotLenteNesten) export(checkS3) export(combineActiveData) export(combineNestenData) +export(combineVespaData) export(comboTreeInput) export(countNestenServer) export(countNestenUI) @@ -24,8 +25,8 @@ export(createSummaryNesten) export(createSummaryRegions) export(createTabularData) export(createTaxaChoices) -export(createTaxaChoices2) export(createTimeseries) +export(decodeText) export(displayName) export(downloadS3) export(drawBullet) @@ -34,6 +35,7 @@ export(filterSelectServer) export(filterSelectUI) export(getDutchNames) export(getGbifOccurrence) +export(getPathLogo) export(loadGbif) export(loadMetaData) export(loadOccupancyData) @@ -47,7 +49,11 @@ export(mapHeatServer) export(mapHeatUI) export(mapOccurrence) export(mapPopup) +export(mapRaster) +export(mapRasterServer) +export(mapRasterUI) export(mapRegions) +export(mapRegionsFacet) export(mapRegionsServer) export(mapRegionsUI) export(matchCombo) @@ -59,12 +65,14 @@ export(plotModuleUI) export(plotTrias) export(plotTriasServer) export(plotTriasUI) +export(plotlyReport) export(readS3) export(replicateColors) export(runShiny) export(setupS3) export(simpleCap) export(summarizeTimeSeries) +export(summarizeYearGroupData) export(tableIndicators) export(tableIndicatorsServer) export(tableIndicatorsUI) @@ -76,6 +84,8 @@ export(titleModuleUI) export(translate) export(trendYearRegion) export(vectorToTitleString) +export(versionServer) +export(versionUI) export(welcomeSectionServer) export(welcomeSectionUI) export(writeS3) @@ -96,6 +106,9 @@ importFrom(INBOtheme,inbo_lichtgrijs) importFrom(INBOtheme,inbo_palette) importFrom(INBOtheme,inbo_steun_blauw) importFrom(INBOtheme,theme_inbo) +importFrom(arrow,open_dataset) +importFrom(arrow,read_parquet) +importFrom(arrow,write_parquet) importFrom(aws.ec2metadata,is_ec2) importFrom(aws.ec2metadata,metadata) importFrom(aws.s3,get_bucket_df) @@ -119,7 +132,10 @@ importFrom(data.table,setDT) importFrom(data.table,setkey) importFrom(data.table,setkeyv) importFrom(data.table,setnames) +importFrom(data.table,year) importFrom(dplyr,all_of) +importFrom(dplyr,case_when) +importFrom(dplyr,collect) importFrom(dplyr,filter) importFrom(dplyr,group_by) importFrom(dplyr,mutate) @@ -128,15 +144,21 @@ importFrom(dplyr,rename) importFrom(dplyr,select) importFrom(dplyr,summarise) importFrom(dplyr,ungroup) +importFrom(ggplot2,ggsave) +importFrom(ggspatial,annotation_map_tile) importFrom(htmltools,div) importFrom(htmlwidgets,saveWidget) +importFrom(httr,GET) +importFrom(httr,http_status) importFrom(jsonlite,toJSON) importFrom(leaflet,`%>%`) importFrom(leaflet,addCircleMarkers) importFrom(leaflet,addLegend) importFrom(leaflet,addMarkers) +importFrom(leaflet,addRasterImage) importFrom(leaflet,addScaleBar) importFrom(leaflet,addTiles) +importFrom(leaflet,colorNumeric) importFrom(leaflet,leaflet) importFrom(leaflet,leafletOutput) importFrom(leaflet,markerClusterOptions) @@ -163,9 +185,14 @@ importFrom(shiny,singleton) importFrom(shinycssloaders,withSpinner) importFrom(stats,aggregate) importFrom(stats,as.formula) +importFrom(stats,complete.cases) +importFrom(terra,rast) +importFrom(terra,values) importFrom(testthat,test_file) importFrom(tidyr,pivot_wider) importFrom(utils,capture.output) +importFrom(utils,download.file) +importFrom(utils,packageVersion) importFrom(utils,read.csv) importFrom(utils,read.table) importFrom(utils,tail) diff --git a/alienSpecies/R/app_modules.R b/alienSpecies/R/app_modules.R index ed85b89..f5d156b 100644 --- a/alienSpecies/R/app_modules.R +++ b/alienSpecies/R/app_modules.R @@ -10,7 +10,6 @@ #' User input for controlling specific plot (ui-side) #' @param id character, module id, unique name per plot -#' @param showGroup boolean, whether to show a select input field for group variable #' @param showSummary boolean, whether to show a select input field for summary choice #' @param showPeriod boolean, whether to show a slider input field for period (first_observed) #' @param showGewest boolean, whether to show filter for gewest @@ -20,7 +19,7 @@ #' @return ui object (tagList) #' @import shiny #' @export -optionsModuleUI <- function(id, showGroup = FALSE, showSummary = FALSE, +optionsModuleUI <- function(id, showSummary = FALSE, showPeriod = FALSE, showGewest = FALSE, exportData = TRUE, doWellPanel = TRUE) { @@ -31,8 +30,7 @@ optionsModuleUI <- function(id, showGroup = FALSE, showSummary = FALSE, fixedRow( if (showGewest) column(6, uiOutput(ns("gewest"))), - if (showGroup) - column(6, uiOutput(ns("group"))), + column(6, uiOutput(ns("group"))), if (showSummary) column(6, uiOutput(ns("summarizeBy"))), if (showPeriod) @@ -65,8 +63,11 @@ plotModuleUI <- function(id, height = "600px") { ns <- NS(id) - withSpinner(plotlyOutput(ns("plot"), height = height)) - + if (id == "management2_lente-plotTrias") + # dirty fix: this plot stays hidden when behind spinner + plotlyOutput(ns("plot"), height = height) else + withSpinner(plotlyOutput(ns("plot"), height = height)) + } @@ -103,6 +104,8 @@ tableModuleUI <- function(id, includeTotal = FALSE) { #' @param data reactive data.frame, data for chosen species #' @param period reactive numeric vector of length 2, selected period #' @param combine reactive boolean, see \code{\link{trendYearRegion}} +#' @param groupChoices reactive character, defines the choices for group variable; +#' if NULL no groupChoices available #' @return no return value; plot output object is created #' @author mvarewyck #' @import shiny @@ -111,7 +114,7 @@ tableModuleUI <- function(id, includeTotal = FALSE) { #' @importFrom plotly ggplotly layout #' @export plotModuleServer <- function(id, plotFunction, data, uiText = NULL, - outputType = NULL, triasFunction = NULL, triasArgs = NULL, + outputType = NULL, triasFunction = NULL, triasArgs = NULL, groupChoices = NULL, period = NULL, combine = NULL) { moduleServer(id, @@ -131,11 +134,9 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, output$group <- renderUI({ - choices <- c("", "lifeStage") - names(choices) <- c("", translate(uiText(), choices[-1])$title) - - selectInput(inputId = ns("group"), label = translate(uiText(), "group")$title, - choices = choices) + if (!is.null(groupChoices)) + selectInput(inputId = ns("group"), label = translate(uiText(), "group")$title, + choices = groupChoices()) }) @@ -145,7 +146,7 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, names(choices) <- translate(uiText(), choices)$title selectInput(inputId = ns("summarizeBy"), - label = translate(uiText(), "summary")$title, choices = choices) + label = translate(uiText(), "summarizeBy")$title, choices = choices) }) @@ -181,7 +182,7 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, argList <- reactive({ - req(nrow(subData()) > 0) + validate(need(nrow(subData()) > 0, translate(uiText(), "noData")$title)) argList <- c( list( @@ -214,8 +215,11 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, resultFct <- reactive({ - toReturn <- tryCatch( - do.call(plotFunction, args = argList()), + req(argList()) + + toReturn <- tryCatch({ + do.call(plotFunction, args = argList()) + }, error = function(err) validate(need(FALSE, err$message)) ) @@ -226,8 +230,9 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, }) - - output$plot <- renderPlotly({ + finalPlot <- reactive({ + + req(resultFct()) if (!is.null(triasFunction) && triasFunction == "apply_gam") { # remove title @@ -239,9 +244,12 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, } else resultFct()$plot }) - - if (!(plotFunction == "countOccupancy" | - (!is.null(triasFunction) && triasFunction %in% c("barplotLenteNesten", "countNesten")))) + + + output$plot <- renderPlotly(finalPlot()) + + + if (plotFunction != "countOccupancy" & plotFunction != "countOccurrence") outputOptions(output, "plot", suspendWhenHidden = FALSE) @@ -286,6 +294,15 @@ plotModuleServer <- function(id, plotFunction, data, uiText = NULL, }) + + reactive(c( + list(plot = if (!is.null(outputType) && outputType == "table") + req(resultFct()) else + req(finalPlot()) + ), + reactiveValuesToList(input) + )) + }) } diff --git a/alienSpecies/R/app_sections.R b/alienSpecies/R/app_sections.R index 8a7f294..33d5520 100644 --- a/alienSpecies/R/app_sections.R +++ b/alienSpecies/R/app_sections.R @@ -48,3 +48,76 @@ welcomeSectionUI <- function(id) { } + +#' Replace {{fields}} in title/description translations +#' @param text character, input from translation +#' @param params named list, all parameters that should be replaced with +#' their value +#' @return character, modified for the \code{params} mentioned in the text +#' +#' @author mvarewyck +#' @export +decodeText <- function(text, params) { + + newText <- text + + for (iParam in names(params)) { + + newText <- if (iParam == "period") + paste(newText, yearToTitleString(params[[iParam]])) else + gsub(paste0("\\{\\{", iParam, "\\}\\}"), params[[iParam]], newText) + + } + + newText + +} + +#' Link with version info - UI side +#' +#' @inherit welcomeSectionUI +#' @importFrom utils packageVersion +#' @export +versionUI <- function(id) { + + actionLink(inputId = NS(id, "version"), + label = paste0("v", packageVersion("alienSpecies")), + class = "version") + +} + + +#' Link with version info - server side +#' @inherit welcomeSectionServer +#' @importFrom utils packageVersion +#' @export +versionServer <- function(id, uiText) { + + moduleServer(id, + function(input, output, session) { + + observeEvent(input$version, { + +# # For internal use +# Sys.setenv("GIT_SHA" = system("git rev-parse HEAD", intern = TRUE)) + hashCode <- Sys.getenv("GIT_SHA") + + + showModal( + modalDialog( + fluidPage( + paste("R package:", packageVersion("alienSpecies")), + tags$br(), + "GIT:", if (hashCode == "") + translate(uiText(), "unknown")$title else + tags$a(id = "gitVersion", + href = paste0("https://github.com/inbo/alien-species-portal/commit/",hashCode), + target = "_blank", hashCode) + ), + title = translate(uiText(), "version")$title, + easyClose = TRUE + )) + + }) + }) +} diff --git a/alienSpecies/R/countYearGroup.R b/alienSpecies/R/countYearGroup.R index 91f06bc..b63e51b 100644 --- a/alienSpecies/R/countYearGroup.R +++ b/alienSpecies/R/countYearGroup.R @@ -1,3 +1,36 @@ +#' Summarize Vespa Velutina data for the plot \code{countYearGroup} +#' +#' @param df data.frame with nesten data +#' @param gewest character, which region(s) to filter on +#' @return data.table with summarized nesten data, as input for \code{codeYearGroup} +#' +#' @author mvarewyck +#' @importFrom dplyr mutate group_by summarise rename filter +#' @importFrom data.table as.data.table +#' @importFrom sf st_drop_geometry +#' @export +summarizeYearGroupData <- function(df, gewest) { + + # For R CMD check + result <- GEWEST <- observation_time <- NULL + + if (is.null(df)) + return(NULL) + + toReturn <- df %>% + st_drop_geometry() %>% + mutate(year = as.integer(format(observation_time, "%Y")), + result = ifelse(is.na(result), "onbekend", result)) %>% + filter(GEWEST %in% gewest) %>% + group_by(year, result, GEWEST) %>% + summarise(count = n()) %>% + rename(Behandeling = result) %>% + as.data.table() + + toReturn + +} + #' Create interactive plot for counts per group category and year #' @@ -68,8 +101,8 @@ countYearGroup <- function(df, groupVar = "", uiText = NULL, colors = colors, type = "bar") %>% layout( xaxis = list(title = translate(uiText, "year")$title), - yaxis = list(title = translate(uiText, "count")$title), - legend = list(title = list(translate(uiText, "group")$title)), + yaxis = list(title = translate(uiText, summarizeBy)$title), + legend = list(title = if (!is.null(groupVar)) list(text = translate(uiText, groupVar)$title)), barmode = if (is.null(groupVar) || length(groupLevels) == 1) "group" else "stack", annotations = list(x = totalCount$year, y = totalCount$count, @@ -90,24 +123,61 @@ countYearGroup <- function(df, groupVar = "", uiText = NULL, #' Shiny module for creating the plot \code{\link{countYearGroup}} - server side #' @inheritParams countOccupancyServer +#' @inheritParams plotModuleServer +#' @inheritParams mapCubeServer #' @return no return value #' #' @author mvarewyck #' @import shiny #' @export -countYearGroupServer <- function(id, uiText, data) { +countYearGroupServer <- function(id, uiText, data, groupChoices, dashReport = NULL) { moduleServer(id, function(input, output, session) { ns <- session$ns + tmpTranslation <- reactive(translate(uiText(), ns("countYearGroup"))) + + output$titleCountYearGroup <- renderUI(h3(HTML(tmpTranslation()$title))) + + output$descriptionCountYearGroup <- renderUI(HTML(tmpTranslation()$description)) + + # Plot - plotModuleServer(id = "countYearGroup", + plotResult <- plotModuleServer(id = "countYearGroup", plotFunction = "countYearGroup", - data = data, + data = reactive({ + req(data()) + validate(need(nrow(data()) > 0, translate(uiText(), "noData")$title)) + data() + }), + groupChoices = groupChoices, uiText = uiText - ) + ) + + + ## Report Objects ## + ## -------------- ## + + observe({ + + # Update when any of these change + req(plotResult()) + + # Return the static values + dashReport[[ns("countYearGroup")]] <- isolate({ + c(plotResult(), + list( + title = tmpTranslation()$title, + description = tmpTranslation()$description) + ) + }) + + }) + + + return(dashReport) }) @@ -117,20 +187,28 @@ countYearGroupServer <- function(id, uiText, data) { #' Shiny module for creating the plot \code{\link{countYearGroup}} - UI side #' @inheritParams plotModuleUI +#' @inheritParams plotTriasUI #' #' @author mvarewyck #' @export -countYearGroupUI <- function(id) { +countYearGroupUI <- function(id, showPlotDefault = FALSE) { ns <- NS(id) tagList( - - optionsModuleUI(id = ns("countYearGroup"), showGroup = TRUE, showSummary = TRUE, - showGewest = TRUE), + + actionLink(inputId = ns("linkCountYearGroup"), + label = uiOutput(ns("titleCountYearGroup"))), + conditionalPanel(paste("input.linkCountYearGroup % 2 ==",(as.numeric(showPlotDefault) + 1) %% 2), + ns = ns, + + uiOutput(ns("descriptionCountYearGroup")), + + optionsModuleUI(id = ns("countYearGroup"), showSummary = TRUE), plotModuleUI(id = ns("countYearGroup")), tags$hr() + ) ) } \ No newline at end of file diff --git a/alienSpecies/R/data_create.R b/alienSpecies/R/data_create.R index 4e60d93..1c82bce 100644 --- a/alienSpecies/R/data_create.R +++ b/alienSpecies/R/data_create.R @@ -94,7 +94,6 @@ createOccupancyCube <- function(dataDir = "~/git/alien-species-portal/data/trend #' @importFrom data.table fread setnames as.data.table #' @importFrom rgbif name_usage #' @export - createKeyData <- function( bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")), dataDir = "~/git/alien-species-portal/data"){ @@ -153,15 +152,15 @@ createKeyData <- function( #' @importFrom utils write.csv #' @importFrom data.table as.data.table #' @importFrom aws.s3 s3save s3load -#' @export -#' +#' @importFrom arrow write_parquet +#' @export createTimeseries <- function( bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")), shapeData = loadShapeData("grid.RData")$utm1_bel_with_regions) { # For R CMD check - df_ts <- NULL + df_ts <- taxonKey <- NULL # created from https://github.com/inbo/aspbo/blob/uat/src/05_occurrence_indicators_preprocessing.Rmd ## Data at 1km x 1km grid level @@ -177,10 +176,13 @@ createTimeseries <- function( timeseries <- merge(df_ts, sf::st_drop_geometry(shapeData)[, c("CELLCODE", paste0("is", simpleCap(regions)))], by.x = "eea_cell_code", by.y = "CELLCODE") - # put time series data RData to the bucket to speed up reading process timeseries <- as.data.table(timeseries) + setkey(timeseries, taxonKey) - s3save(timeseries, object = "full_timeseries.RData", bucket = bucket, + aws.s3::s3write_using(timeseries, + FUN = arrow::write_parquet, + bucket = bucket, + object = "full_timeseries.parquet", opts = list(show_progress = TRUE, multipart = TRUE, region = Sys.getenv("AWS_DEFAULT_REGION", unset = 'eu-west-1'))) @@ -196,8 +198,9 @@ createTimeseries <- function( #' @return character, file name of created object in S3 bucket #' #' @author mvarewyck +#' @importFrom aws.s3 s3save +#' @importFrom sf st_read #' @export -#' createShapeData <- function( dataDir = "~/git/alien-species-portal/data/occurrenceCube", bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")) @@ -235,10 +238,56 @@ createShapeData <- function( } + +#' Create taxa choices based on available exotenData +#' @param exotenData data.frame, as read from \code{\link{loadTabularData}} +#' @return data.frame all choices to be shown - for selectizeInput() +#' +#' @author mvarewyck +#' @export +createTaxaChoices <- function(exotenData) { + + # For R CMD check + kingdom <- kingdomKey <- NULL + phylum <- phylumKey <- NULL + classKey <- NULL + orderKey <- NULL + family <- familyKey <- NULL + species <- key <- NULL + + subData <- exotenData[, .(kingdom, phylum, class, order, family, species, + kingdomKey, phylumKey, classKey, orderKey, familyKey, key)] + subData <- subData[!duplicated(subData), ] + subData$speciesKey <- subData$key + + speciesLevels <- c("kingdom", "phylum", "class", "order", "family", "species") + + choices <- do.call(rbind, lapply(seq_along(speciesLevels), function(i) { + + iLevel <- speciesLevels[i] + keyVar <- paste0(iLevel, "Key") + do.call(rbind, lapply(split(subData, subData[[keyVar]]), function(iData) { + iData <- iData[!duplicated(iData[[keyVar]]), ] + longName <- paste(iData[, speciesLevels[1:i], with = FALSE], collapse = " > ") + data.frame( + value = iData[[keyVar]], + label = iData[[iLevel]], + long = longName, + html = paste0("", iData[[iLevel]], "", if (i != 1) paste0("
", longName)) + ) + })) + + })) + + choices <- choices[order(choices$label), ] + + choices + +} + + #' Create tabular data #' -#' For indicator data: -#' by default data for which \code{first_observed < 1950} is excluded. #' For unionlist data: #' only 'scientific name', 'english name' and 'kingdom' are retained #' @inheritParams readS3 @@ -252,8 +301,9 @@ createShapeData <- function( #' and attribute 'Date', the date that this data file was created #' @importFrom data.table fread := #' @importFrom utils tail +#' @importFrom stats complete.cases +#' @importFrom arrow write_parquet #' @export - createTabularData <- function( dataDir = "~/git/alien-species-portal/dataS3", bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")), @@ -264,6 +314,7 @@ createTabularData <- function( scientificName <- NULL i.scientificName <- NULL i.classKey <- NULL + taxonKey <- variable <- eea_cell_code <- NULL warningMessage <- NULL @@ -387,6 +438,32 @@ createTabularData <- function( oceania, tolower(oceania))) & !is.na(rawData$native_range)] <- "undefined" + ## update last_observed with info from timeseries + readS3(file = "full_timeseries.RData", bucket = bucket) + # exclude rows without observation + timeseries <- timeseries[timeseries$obs > 0, ] + # exclude unknown regions + timeseries <- timeseries[complete.cases(timeseries[, c("isFlanders", "isWallonia", "isBrussels")])] + # select last_year per cube + timeseries <- timeseries[timeseries[, .I[which.max(year)], by = .(eea_cell_code, taxonKey)]$V1] + timeseries$isBelgium <- apply(timeseries[, c("isFlanders", "isWallonia", "isBrussels")], 1, sum) > 0 + # wide to long format + setnames(timeseries, c("isFlanders", "isWallonia", "isBrussels", "isBelgium"), + c("Vlaanderen", "Wallonië", "Brussels Hoofdstedelijk Gewest", "België")) + timeseries <- melt.data.table(timeseries, id.vars = c("taxonKey", "year"), + measure.vars = c("Vlaanderen", "Wallonië", "Brussels Hoofdstedelijk Gewest", "België")) + # select last year per region + timeseries <- timeseries[timeseries[, .I[which.max(year)], by = .(variable, taxonKey)]$V1] + timeseries <- timeseries[timeseries$value, ] + timeseries$value <- NULL + +# head(rawData[, c("locality", "last_observed", "nubKey")]) + rawData <- merge(rawData, timeseries, by.x = c("locality", "nubKey"), + by.y = c("variable", "taxonKey"), all.x = TRUE) + rawData$last_observed <- apply(rawData[, c("last_observed", "year")], 1, + function(x) if (all(is.na(x))) NA else max(x, na.rm = TRUE)) + + ## replace missing "species" with "canonicalName" if available # then drop "canonicalName" ind <- which(is.na(rawData$species) & !is.na(rawData$canonicalName)) @@ -395,10 +472,19 @@ createTabularData <- function( warningMessage <- c(warningMessage, paste0(type, " data: Voor ", length(ind), " observaties is de 'species' onbekend. 'canonicalName' wordt gebruikt in de plaats.")) - attr(rawData, "habitats") <- currentHabitats + + # Create taxa choices + taxaChoices <- createTaxaChoices(exotenData = rawData) + aws.s3::s3write_using(taxaChoices, + FUN = arrow::write_parquet, + bucket = bucket, + object = "taxachoices_processed.parquet", + opts = list(multipart = TRUE, + region = Sys.getenv("AWS_DEFAULT_REGION", unset = 'eu-west-1'))) + } else if (type == "unionlist") { rawData <- fread(dataFiles, stringsAsFactors = FALSE, na.strings = "", @@ -435,11 +521,12 @@ createTabularData <- function( attr(rawData, "Date") <- file.mtime(dataFiles) attr(rawData, "warning") <- warningMessage - s3save(rawData, bucket = bucket, - object = paste0(basename(tools::file_path_sans_ext(dataFiles)), "_processed.RData"), - opts = list(multipart = TRUE, - region = Sys.getenv("AWS_DEFAULT_REGION", unset = 'eu-west-1'))) - + aws.s3::s3write_using(rawData, + FUN = arrow::write_parquet, + bucket = bucket, + object = paste0(basename(tools::file_path_sans_ext(dataFiles)), "_processed.parquet"), + opts = list(multipart = TRUE, + region = Sys.getenv("AWS_DEFAULT_REGION", unset = 'eu-west-1'))) return(TRUE) diff --git a/alienSpecies/R/data_filter.R b/alienSpecies/R/data_filter.R index 19cf703..6e7b056 100644 --- a/alienSpecies/R/data_filter.R +++ b/alienSpecies/R/data_filter.R @@ -1,88 +1,36 @@ +#createTaxaChoices <- function(exotenData) { +# +# # For R CMD check +# kingdom <- kingdomKey <- NULL +# phylum <- phylumKey <- NULL +# classKey <- NULL +# orderKey <- NULL +# family <- familyKey <- NULL +# species <- key <- NULL +# +# subData <- exotenData[, .(kingdom, phylum, class, order, family, species, +# kingdomKey, phylumKey, classKey, orderKey, familyKey, key)] +# subData <- subData[!duplicated(subData), ] +# +# lapply(unname(split(subData, subData$kingdom, drop = TRUE)), function(kingdom) +# list(id = kingdom[1, kingdomKey], title = kingdom[1, kingdom], +# subs = lapply(unname(split(kingdom, kingdom$phylum, drop = TRUE)), function(phylum) +# list(id = phylum[1, phylumKey], title = paste(phylum[1, .(kingdom, phylum)], collapse = " > "), +# subs = lapply(unname(split(phylum, phylum$class, drop = TRUE)), function(class) +# list(id = class[1, classKey], title = paste(class[1, .(kingdom, phylum, class)], collapse = " > "), +# subs = lapply(unname(split(class, class$order, drop = TRUE)), function(order) +# list(id = order[1, orderKey], title = paste(order[1, .(kingdom, phylum, class, order)], collapse = " > "), +# subs = lapply(unname(split(order, order$family, drop = TRUE)), function(family) +# list(id = family[1, familyKey], title = paste(family[1, .(kingdom, phylum, class, order, family)], collapse = " > "), +# subs = lapply(unname(split(family, family$species, drop = TRUE)), function(species) +# list(id = species[1, key], title = paste(species[1, .(kingdom, phylum, class, order, family, species)], collapse = " > "))))) +# )))))))) +# +#} -#' Create taxa choices based on available exotenData -#' @param exotenData data.frame, as read from \code{\link{loadTabularData}} -#' @return nested list with all choices to be shown - for comboTreeInput() -#' -#' @author mvarewyck -#' @export -createTaxaChoices <- function(exotenData) { - - # For R CMD check - kingdom <- kingdomKey <- NULL - phylum <- phylumKey <- NULL - classKey <- NULL - orderKey <- NULL - family <- familyKey <- NULL - species <- key <- NULL - - subData <- exotenData[, .(kingdom, phylum, class, order, family, species, - kingdomKey, phylumKey, classKey, orderKey, familyKey, key)] - subData <- subData[!duplicated(subData), ] - - lapply(unname(split(subData, subData$kingdom, drop = TRUE)), function(kingdom) - list(id = kingdom[1, kingdomKey], title = kingdom[1, kingdom], - subs = lapply(unname(split(kingdom, kingdom$phylum, drop = TRUE)), function(phylum) - list(id = phylum[1, phylumKey], title = paste(phylum[1, .(kingdom, phylum)], collapse = " > "), - subs = lapply(unname(split(phylum, phylum$class, drop = TRUE)), function(class) - list(id = class[1, classKey], title = paste(class[1, .(kingdom, phylum, class)], collapse = " > "), - subs = lapply(unname(split(class, class$order, drop = TRUE)), function(order) - list(id = order[1, orderKey], title = paste(order[1, .(kingdom, phylum, class, order)], collapse = " > "), - subs = lapply(unname(split(order, order$family, drop = TRUE)), function(family) - list(id = family[1, familyKey], title = paste(family[1, .(kingdom, phylum, class, order, family)], collapse = " > "), - subs = lapply(unname(split(family, family$species, drop = TRUE)), function(species) - list(id = species[1, key], title = paste(species[1, .(kingdom, phylum, class, order, family, species)], collapse = " > "))))) - )))))))) - -} -#' Create taxa choices based on available exotenData -#' @param exotenData data.frame, as read from \code{\link{loadTabularData}} -#' @return data.frame all choices to be shown - for selectizeInput() -#' -#' @author mvarewyck -#' @export -createTaxaChoices2 <- function(exotenData) { - - # For R CMD check - kingdom <- kingdomKey <- NULL - phylum <- phylumKey <- NULL - classKey <- NULL - orderKey <- NULL - family <- familyKey <- NULL - species <- key <- NULL - - subData <- exotenData[, .(kingdom, phylum, class, order, family, species, - kingdomKey, phylumKey, classKey, orderKey, familyKey, key)] - subData <- subData[!duplicated(subData), ] - subData$speciesKey <- subData$key - - speciesLevels <- c("kingdom", "phylum", "class", "order", "family", "species") - - choices <- do.call(rbind, lapply(seq_along(speciesLevels), function(i) { - - iLevel <- speciesLevels[i] - keyVar <- paste0(iLevel, "Key") - do.call(rbind, lapply(split(subData, subData[[keyVar]]), function(iData) { - iData <- iData[!duplicated(iData[[keyVar]]), ] - longName <- paste(iData[, speciesLevels[1:i], with = FALSE], collapse = " > ") - data.frame( - value = iData[[keyVar]], - label = iData[[iLevel]], - long = longName, - html = paste0("", iData[[iLevel]], "", if (i != 1) paste0("
", longName)) - ) - })) - - })) - - choices <- choices[order(choices$label), ] - - choices - -} - #' Create pathway choices based on available exotenData #' @inheritParams createTaxaChoices #' @param columns character vector, column names in \code{exotenData} for which diff --git a/alienSpecies/R/data_gbif.R b/alienSpecies/R/data_gbif.R index 83868f0..39c6d0f 100644 --- a/alienSpecies/R/data_gbif.R +++ b/alienSpecies/R/data_gbif.R @@ -154,7 +154,7 @@ loadGbif <- function(dataFile, ) { # For R CMD check - count <- NULL + count <- decimalLongitude <- decimalLatitude <- NULL rawData <- readS3(FUN = fread, stringsAsFactors = FALSE, na.strings = "", bucket = bucket, file = dataFile) @@ -164,6 +164,11 @@ loadGbif <- function(dataFile, data.table::setnames(rawData, "individualCount", "count") rawData[, count := as.numeric(count)] } + if ("decimalLongitude" %in% colnames(rawData)) + rawData[, decimalLongitude := as.numeric(decimalLongitude)] + if ("decimalLatitude" %in% colnames(rawData)) + rawData[, decimalLatitude := as.numeric(decimalLatitude)] + attr(rawData, "Date") <- file.mtime(dataFile) diff --git a/alienSpecies/R/data_load.R b/alienSpecies/R/data_load.R index bb96ec5..6dc5a73 100644 --- a/alienSpecies/R/data_load.R +++ b/alienSpecies/R/data_load.R @@ -23,27 +23,34 @@ loadShapeData <- function(file, #' #' Data is preprocessed by createTabularData() #' @inheritParams createTabularData -#' @return data.frame, loaded data +#' @return data.frame or data.table, loaded data; except for \code{code == 'timeseries'} +#' it loads pointer to the data of which a subset can be loaded using +#' \code{dplyr::collect()} #' @author mvarewyck +#' @importFrom arrow read_parquet open_dataset +#' @importFrom data.table as.data.table #' @export loadTabularData <- function( bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")), - type = c("indicators", "unionlist", "occurrence")) { + type = c("indicators", "unionlist", "occurrence", "timeseries", "taxachoices")) { type <- match.arg(type) - # For R CMD check - rawData <- NULL - dataFile <- switch(type, - "indicators" = "data_input_checklist_indicators_processed.RData", - "unionlist" = "eu_concern_species_processed.RData", - "occurrence" = "be_alientaxa_cube_processed.RData" + "indicators" = "data_input_checklist_indicators_processed.parquet", + "unionlist" = "eu_concern_species_processed.parquet", + "occurrence" = "be_alientaxa_cube_processed.parquet", + "timeseries" = "full_timeseries.parquet", + "taxachoices" = "taxachoices_processed.parquet" ) - readS3(file = dataFile, bucket = bucket, envir = environment()) + rawData <- if (type == "timeseries") + open_dataset(file.path("s3:/", bucket, dataFile)) else + read_parquet(file = file.path("s3:/", bucket, dataFile)) + if (type == "indicators") + attr(rawData, "habitats") <- c("marine", "freshwater", "terrestrial") return(rawData) @@ -58,6 +65,8 @@ loadTabularData <- function( #' should be one of \code{c("ui","keys")} #' @param language character, which language data sheet should be loaded; #' should be one of \code{c("nl", "fr", "en")} +#' @param local boolean, whether to use local translation file in +#' \code{system.file("extdata", "translations.csv", package = "alienSpecies")} #' @return data.frame #' #' @author mvarewyck @@ -67,7 +76,8 @@ loadTabularData <- function( loadMetaData <- function(type = c("ui", "keys"), #dataDir = system.file("extdata", package = "alienSpecies"), bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")), - language = c("nl", "fr", "en")) { + language = c("nl", "fr", "en"), + local = FALSE) { type <- match.arg(type) language <- match.arg(language) @@ -83,15 +93,20 @@ loadMetaData <- function(type = c("ui", "keys"), keys = "keys.csv" ) - allData <- readS3(FUN = read.csv, sep = if (type == "ui") ";" else ",",encoding = "UTF-8", - file = fileName) + allData <- if (local) + read.csv(system.file("extdata", fileName, package = "alienSpecies"), + sep = if (type == "ui") ";" else ",", encoding = "UTF-8") else + readS3(FUN = read.csv, sep = if (type == "ui") ";" else ",", encoding = "UTF-8", + file = fileName) + filterData <- switch(type, ui = { uiText <- allData[, c("title_id", paste0(c("title_", "description_"), language))] colnames(uiText) <- c("id", "title", "description") - uiText <- uiText[uiText$id != "", ] + uiText <- uiText[!uiText$id %in% c(NA, ""), ] + uiText[is.na(uiText)] <- "" if (any(duplicated(uiText$id))) stop("Following translations occur multiple times, please clean the file: ", @@ -199,11 +214,24 @@ translate <- function(data = loadMetaData(type = "ui"), id) { if (all(is.na(id))) return(data) + + # Composite translations e.g. habitats + compositeIds <- grepl("|", id, fixed = TRUE) + if (any(compositeIds)) { + + newIds <- unique(id[compositeIds]) + data <- rbind(data, + data.frame(id = newIds, t(as.data.frame(sapply(newIds, function(x) + apply(data[match(strsplit(x, split = "\\|")[[1]], data$id), c("title", "description")], 2, paste, collapse = "|"))))) + ) + + } + # Helpfull during development to see which are missing # can be turned of in production if (!is.null(data) & !all(id %in% data$id)) { if (!all(is.na(id[!id %in% data$id]))) - warning("Not in translation file: ", vectorToTitleString(id[!id %in% data$id])) + message("Not in translation file: ", vectorToTitleString(id[!id %in% data$id])) } data <- rbind( diff --git a/alienSpecies/R/mapHeat.R b/alienSpecies/R/mapHeat.R index a84fe6c..36a8215 100644 --- a/alienSpecies/R/mapHeat.R +++ b/alienSpecies/R/mapHeat.R @@ -3,28 +3,42 @@ #' Used on Management page for Vespa Velutina #' #' @param activeData sf, points data with actieve haarden -#' @param managedData sf, points data with beheerde nesten #' @param untreatedData sf, points data with onbehandelde nesten +#' @param managedData sf, points data with beheerde nesten; default is NULL #' @return sf data.frame, combining all data sources #' #' @author mvarewyck #' @importFrom dplyr select filter mutate group_by summarise #' @export -combineActiveData <- function(activeData, managedData, untreatedData) { +combineActiveData <- function(activeData, untreatedData, managedData = NULL) { - activeData$type <- "individual" - managedData$type <- "managed nest" - untreatedData$type <- "untreated nest" + if (nrow(activeData) != 0) { + + activeData$type <- "individual" + # for intermediate data (no radius yet) + if (is.null(activeData$radius)) + activeData$radius <- NA + + } + + untreatedData$type <- "untreated nest" # for intermediate data (no radius yet) - if(is.null(managedData$radius)) managedData$radius <- NA - if(is.null( activeData$radius)) activeData$radius <- NA - if(is.null( untreatedData$radius)) untreatedData$radius <- NA + if (is.null(untreatedData$radius)) + untreatedData$radius <- NA + + if (!is.null(managedData)) { + managedData$type <- "managed nest" + if (is.null(managedData$radius)) + managedData$radius <- NA + } toReturn <- rbind( - activeData[, c("type", "popup", "radius")], - managedData[, c("type", "popup", "radius")], + if (nrow(activeData) != 0) + activeData[, c("type", "popup", "radius")], + if (!is.null(managedData)) + managedData[, c("type", "popup", "radius")], untreatedData[, c("type", "popup", "radius")] ) @@ -41,31 +55,46 @@ combineActiveData <- function(activeData, managedData, untreatedData) { #' #' @param pointsData sf data.frame, points observations for individuals #' @param nestenData sf data.frame, points observations for nests +#' @param currentYear integer, current year for selecting nest data +#' @inheritParams mapHeat #' @return sf data.frame, combining both data sources #' #' @author mvarewyck -#' @importFrom dplyr select filter mutate group_by summarise rename +#' @importFrom dplyr select filter mutate group_by summarise rename case_when +#' @importFrom data.table year #' @export -combineNestenData <- function(pointsData, nestenData) { +combineNestenData <- function(pointsData, nestenData, + currentYear = data.table::year(Sys.Date()), + uiText = NULL) { # For R CMD check type <- eventDate <- popup <- institutionCode <- id <- observation_time <- NULL - geometry <- NULL + geometry <- nest_type <- result <- NULL points_redux <- pointsData %>% - dplyr::filter(year == year(Sys.Date())) %>% + dplyr::filter(year == currentYear) %>% + # Only retain individual data, see https://github.com/inbo/alien-species-portal/issues/63#issuecomment-1918810526 + dplyr::filter(dplyr::case_when(eventDate >= as.Date("31/12/2028", format = "%d/%m/%Y") ~ type == "Individu", TRUE ~ TRUE)) %>% dplyr::select(type, eventDate, popup, institutionCode, year) %>% - mutate(type = "individual") + mutate(type = ifelse(type == "Individu", "individual", "nest")) # punten laag van gemelde nesten nesten <- nestenData %>% - dplyr::filter(year == year(Sys.Date())) %>% + dplyr::filter(year == currentYear) + + if (nrow(nesten) == 0) + return(NULL) + + nesten <- nesten %>% mutate(type = "nest", - popup = paste0("Vespawatch rij ", id), + popup = paste( + translate(uiText, "nest")$title, ":", translate(uiText, nest_type)$title, + "
", translate(uiText, "management")$title, ":", translate(uiText, result)$title, + "
Vespawatch", translate(uiText, "row")$title, id), institutionCode = "Vespawatch") nesten_redux <- nesten %>% - dplyr::filter(year == year(Sys.Date())) %>% + dplyr::filter(year == currentYear) %>% dplyr::select(type, eventDate = observation_time, popup, institutionCode, year) # Recombine points @@ -104,8 +133,7 @@ mapHeat <- function(combinedData, baseMap = addBaseMap(), colors, blur = NULL, s # Base map - ah_map <- baseMap %>% - addScaleBar(position = "bottomleft") + ah_map <- baseMap if (addGlobe) ah_map <- addTiles(ah_map) @@ -126,7 +154,7 @@ mapHeat <- function(combinedData, baseMap = addBaseMap(), colors, blur = NULL, s # Filter data plotData <- combinedData[combinedData$filter %in% selected, ] - if (nrow(plotData) == 0) + if (is.null(plotData) || nrow(plotData) == 0) return(ah_map) @@ -163,7 +191,7 @@ mapHeat <- function(combinedData, baseMap = addBaseMap(), colors, blur = NULL, s #' #' @inheritParams welcomeSectionServer #' @inheritParams mapHeat -#' @param species reactive character, readable name of the selected species +#' @inheritParams mapCubeServer #' @param filter reactive list with filters to be shown in the app; #' names should match a plotFunction in \code{uiText}; #' values define the choices in \code{selectInput} @@ -177,8 +205,8 @@ mapHeat <- function(combinedData, baseMap = addBaseMap(), colors, blur = NULL, s #' @importFrom webshot webshot #' @importFrom sf st_drop_geometry #' @export -mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, - blur = NULL, maxDate +mapHeatServer <- function(id, uiText, species, gewest, combinedData, filter, colors, + blur = NULL, maxDate, dashReport = NULL ) { moduleServer(id, @@ -190,20 +218,39 @@ mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, noData <- reactive(translate(uiText(), "noData")$title) tmpTranslation <- reactive(translate(uiText(), ns("mapHeat"))) - output$descriptionMapHeat <- renderUI({ - - tmpDescription <- tmpTranslation()$description - tmpDescription <- gsub("\\{\\{maxDate\\}\\}", format(maxDate(), "%d/%m/%Y"), tmpDescription) - tmpDescription <- gsub("\\{\\{maxYear\\}\\}", format(maxDate(), "%Y"), tmpDescription) + tmpFile <- tempfile(fileext = ".html") + + description <- reactive({ - HTML(tmpDescription) + decodeText( + text = tmpTranslation()$description, + params = list( + maxDate = tryCatch(format(maxDate(), "%d/%m/%Y"), error = function(e) NA), + maxYear = format(Sys.Date(), "%Y") + ) + ) }) + output$descriptionMapHeat <- renderUI(HTML(description())) + output$titleMapHeat <- renderUI(h3(HTML(tmpTranslation()$title))) + # Hide output if no data + observe({ + + # Wait until output is created + req(input$legend) + + shinyjs::toggle(id = "mapHeatUI", + condition = (!is.null(combinedData()) && nrow(combinedData()) > 0)) + + }) + output$filters <- renderUI({ + req(nrow(combinedData())) + if (!is.null(filter())) lapply(names(filter()), function(filterName) { @@ -259,27 +306,33 @@ mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, input[["global"]] - temp <- combinedData() + tmpData <- combinedData() - for(iFilter in names(filter())[-1]){ + for (iFilter in names(filter())[-1]){ if (!is.null(input[[iFilter]]) && input[[iFilter]] != ""){ - index <- !is.na(temp[[iFilter]]) & (temp[[iFilter]] == input[[iFilter]]) - temp <- temp[index,] + index <- !is.na(tmpData[[iFilter]]) & (tmpData[[iFilter]] == input[[iFilter]]) + tmpData <- tmpData[index,] } } - temp + + tmpData + }) # Send map to the UI output$spacePlot <- renderLeaflet({ + validate(need(nrow(combinedDataPostFilter()) > 0, noData())) + myMap <- mapHeat( combinedData = combinedDataPostFilter(), + baseMap = addBaseMap(regions = gewest()), colors = colors(), selected = unique(combinedDataPostFilter()$filter), addGlobe = isolate(input$globe %% 2 == 1), - blur = blur + blur = blur, + uiText = uiText() ) myMap @@ -370,29 +423,31 @@ mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, # Create final map (for download) finalMap <- reactive({ + + req(nrow(combinedDataPostFilter()) > 0) + req(input[[names(filter())[1]]]) - input[[ names(filter())[2] ]] - newMap <- mapHeat( - combinedData =combinedDataPostFilter(), + combinedData = combinedDataPostFilter(), + baseMap = addBaseMap(regions = gewest()), colors = colors(), selected = input[[names(filter())[1]]], blur = blur, - legend = input$legend, - addGlobe = input$globe %% 2 == 1, + legend = if (is.null(input$legend)) "topright" else input$legend, + addGlobe = if (is.null(input$globe)) TRUE else input$globe %% 2 == 1, uiText = uiText() ) # save the zoom level and centering to the map object - newMap <- newMap %>% setView( - lng = input$spacePlot_center$lng, - lat = input$spacePlot_center$lat, - zoom = input$spacePlot_zoom - ) - - tmpFile <- tempfile(fileext = ".html") + if (!is.null(input$spacePlot_center)) + newMap <- newMap %>% setView( + lng = input$spacePlot_center$lng, + lat = input$spacePlot_center$lat, + zoom = input$spacePlot_zoom + ) # write map to temp .html file + req(newMap) htmlwidgets::saveWidget(newMap, file = tmpFile, selfcontained = FALSE) # output is path to temp .html file containing map @@ -435,6 +490,33 @@ mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, # # }) + ## Report Objects ## + ## -------------- ## + + observe({ + + req(dashReport) + + # Update when any of these change + finalMap() + maxDate() + input + + # Return the static values + dashReport[[ns("mapHeat")]] <- c( + list( + plot = isolate(finalMap()), + title = isolate(tmpTranslation()$title), + description = isolate(description()) + ), + isolate(reactiveValuesToList(input)) + ) + + }) + + + return(dashReport) + }) } @@ -444,6 +526,7 @@ mapHeatServer <- function(id, uiText, species, combinedData, filter, colors, #' Shiny module for creating the plot \code{\link{mapCube}} - UI side #' @inheritParams welcomeSectionServer #' @inheritParams mapCubeUI +#' #' @return UI object #' #' @author mvarewyck @@ -461,25 +544,27 @@ mapHeatUI <- function(id, showLegend = TRUE, showGlobe = TRUE) { uiOutput(ns("titleMapHeat")), uiOutput(ns("descriptionMapHeat")), - wellPanel( - fixedRow(uiOutput(ns("filters")), - if (showLegend) - column(4, - uiOutput(ns("legend")) - ), - if (showGlobe) - column(6, - actionLink(inputId = ns("globe"), label = "Show globe", - icon = icon("globe")) - ) - ) - ), - withSpinner(leafletOutput(ns("spacePlot"), height = "600px")), - - tags$br(), - - tags$div(uiOutput(ns("downloadMapButton")), style = "display:inline-block;"), + tags$div(id = ns("mapHeatUI"), + wellPanel( + fixedRow(uiOutput(ns("filters")), + if (showLegend) + column(4, + uiOutput(ns("legend")) + ), + if (showGlobe) + column(6, + actionLink(inputId = ns("globe"), label = "Show globe", + icon = icon("globe")) + ) + ) + ), + withSpinner(leafletOutput(ns("spacePlot"), height = "600px")), + + tags$br(), + + tags$div(uiOutput(ns("downloadMapButton")), style = "display:inline-block;"), # downloadButton(ns("downloadData"), label = "Download data", class = "downloadButton"), + ), tags$hr() diff --git a/alienSpecies/R/mapOccurrence.R b/alienSpecies/R/mapOccurrence.R index 1ff36c5..8ce6167 100644 --- a/alienSpecies/R/mapOccurrence.R +++ b/alienSpecies/R/mapOccurrence.R @@ -263,7 +263,7 @@ addBaseMap <- function(map = leaflet(), shape = c("Vlaams", "Brussels", "Waals")) gewestbel <- subset(gewestbel, GEWEST %in% matchingRegions$shape[match(regions, matchingRegions$name)]) - if (combine) + if (!is.null(combine) && combine) gewestbel <- sf::st_union(gewestbel) map %>% @@ -362,6 +362,9 @@ mapOccurrence <- function(occurrenceData, baseMap = addBaseMap(), # For R CMD check count <- decimalLongitude <- decimalLatitude <- NULL + if (!all(c("count", "decimalLongitude", "decimalLatitude") %in% colnames(occurrenceData))) + return(NULL) + ## Sum counts over ID occurrenceData <- occurrenceData[, .(count = sum(count)), by = .(decimalLongitude, decimalLatitude)] @@ -403,10 +406,12 @@ mapOccurrence <- function(occurrenceData, baseMap = addBaseMap(), #' values define the choices in \code{selectInput} #' @inheritParams welcomeSectionServer #' @inheritParams createCubeData -#' @inheritParams mapCubeServer #' @inheritParams mapCubeUI #' @param species reactive character, readable name of the selected species +#' @param gewest reactive character, name of the selected region(s) #' @param df reactive data.frame, data as loaded by \code{\link{loadGbif}} +#' @param dashReport reactive value, contains all objects for creating the report; +#' plot and parameters for current plot will be added with id \code{ns("mapOccurrence")} #' @return no return value #' #' @author mvarewyck @@ -416,8 +421,8 @@ mapOccurrence <- function(occurrenceData, baseMap = addBaseMap(), #' @importFrom webshot webshot #' @importFrom sf st_drop_geometry #' @export -mapCubeServer <- function(id, uiText, species, df, shapeData, - filter = reactive(NULL), groupVariable, showPeriod = FALSE +mapCubeServer <- function(id, uiText, species, gewest, df, shapeData, + filter = reactive(NULL), groupVariable, showPeriod = FALSE, dashReport = NULL ) { moduleServer(id, @@ -428,29 +433,29 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, currentYear <- as.numeric(format(Sys.Date(), "%Y")) ns <- session$ns - + tmpFile <- tempfile(fileext = ".html") + noData <- reactive(translate(uiText(), "noData")$title) tmpTranslation <- reactive(translate(uiText(), ns("mapOccurrence"))) output$descriptionMapOccurrence <- renderUI(tmpTranslation()$description) - output$titleMapOccurrence <- renderUI({ + title <- reactive({ req(species()) - tmpTitle <- tmpTranslation()$title - - myTitle <- if (showPeriod) { - req(input$period) - paste(tmpTitle, species(), yearToTitleString(req(input$period))) - } else { - paste(tmpTitle, species()) - } + decodeText(tmpTranslation()$title, + params = c( + list(species = species()), + if (showPeriod && !is.null(input$period)) + list(period = input$period) + ) + ) - h3(HTML(myTitle)) - }) + output$titleMapOccurrence <- renderUI(h3(HTML(title()))) + output$filters <- renderUI({ if (!is.null(filter())) @@ -469,16 +474,6 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, }) - output$region <- renderUI({ - - choices <- c("flanders", "wallonia", "brussels") - names(choices) <- translate(uiText(), choices)$title - - selectInput(inputId = ns("region"), label = translate(uiText(), "regions"), - choices = choices, multiple = TRUE, selected = choices) - - }) - output$period <- renderUI({ req(df()) @@ -519,8 +514,8 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, # Other filters if (!is.null(filter())) for (iFilter in names(filter())) { - req(input[[iFilter]]) - filterData <- filterData[filterData[[iFilter]] %in% input[[iFilter]], ] + if (!is.null(input[[iFilter]])) + filterData <- filterData[filterData[[iFilter]] %in% input[[iFilter]], ] } filterData @@ -531,9 +526,8 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, subData <- reactive({ # Filter on time - if (showPeriod) { + if (showPeriod && !is.null(input$period)) { - req(input$period) filterData()[year >= input$period[1] & year <= input$period[2], ] } else filterData() @@ -546,52 +540,62 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, cubeShape <- reactive({ validate(need(subData(), noData()), - need(nrow(subData()) > 0, noData()), - need(input$region, noData())) + need(nrow(subData()) > 0, noData())) createCubeData( df = subData(), shapeData = shapeData, groupVariable = groupVariable, - region = input$region + region = gewest() ) }) + mapOccurrenceLeaflet <- reactive({ + + req(is.null(shapeData)) + + validate(need(nrow(subData()) > 0, noData())) + + mapOccurrence(occurrenceData = subData(), + # when switching species, need to create correct basemap + baseMap = addBaseMap(regions = gewest(), combine = input$combine), + addGlobe = isolate(input$globe %% 2 == 0)) + + }) + + mapCubeLeaflet <- reactive({ + + req(!is.null(shapeData)) + if (showPeriod) + req(input$period) + + validate(need(cubeShape(), noData())) + + mapCube(cubeShape = cubeShape(), groupVariable = groupVariable, + # when switching species, need to create correct basemap + baseMap = addBaseMap(regions = isolate(gewest()), combine = isolate(input$combine)), + addGlobe = FALSE, legend = "topright") + + }) + # Send map to the UI output$spacePlot <- renderLeaflet({ - if (is.null(shapeData)) { - - validate(need(nrow(subData()) > 0, noData())) - - mapOccurrence(occurrenceData = subData(), - # when switching species, need to create correct basemap - baseMap = addBaseMap(regions = input$region, combine = input$combine), - addGlobe = isolate(input$globe %% 2 == 0)) - - } else { - - validate(need(cubeShape(), noData())) - - mapCube(cubeShape = cubeShape(), groupVariable = groupVariable, - # when switching species, need to create correct basemap - baseMap = addBaseMap(regions = isolate(input$region), combine = isolate(input$combine)), - addGlobe = FALSE, legend = "topright") - - } + if (is.null(shapeData)) + mapOccurrenceLeaflet() else + mapCubeLeaflet() }) # Add border region observe({ - validate(need(input$region, noData()), - need(!is.null(input$combine), noData())) + validate(need(!is.null(input$combine), noData())) proxy <- leafletProxy("spacePlot") - addBaseMap(map = proxy, regions = input$region, combine = input$combine) + addBaseMap(map = proxy, regions = gewest(), combine = input$combine) }) @@ -653,7 +657,7 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, } }) - + # Create final map (for download) finalMap <- reactive({ @@ -661,33 +665,33 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, if (is.null(shapeData)) { newMap <- mapOccurrence( - occurrenceData = subData(), - baseMap = addBaseMap(regions = req(input$region), combine = input$combine), - addGlobe = input$globe %% 2 == 0 + occurrenceData = req(subData()), + baseMap = addBaseMap(regions = req(gewest()), combine = input$combine), + addGlobe = if (is.null(input$globe)) TRUE else input$globe %% 2 == 0 ) } else { newMap <- mapCube( - cubeShape = cubeShape(), + cubeShape = req(cubeShape()), groupVariable = groupVariable, - baseMap = addBaseMap(regions = req(input$region), combine = input$combine), - legend = input$legend, - addGlobe = input$globe %% 2 == 0 + baseMap = addBaseMap(regions = req(gewest()), combine = input$combine), + legend = if (is.null(input$legend)) "topright" else input$legend, + addGlobe = if (is.null(input$globe)) TRUE else input$globe %% 2 == 0 ) } # save the zoom level and centering to the map object - newMap <- newMap %>% setView( - lng = input$spacePlot_center$lng, - lat = input$spacePlot_center$lat, - zoom = input$spacePlot_zoom - ) - - tmpFile <- tempfile(fileext = ".html") + if (!is.null(input$spacePlot_center)) + newMap <- newMap %>% setView( + lng = input$spacePlot_center$lng, + lat = input$spacePlot_center$lat, + zoom = input$spacePlot_zoom + ) # write map to temp .html file + req(newMap) htmlwidgets::saveWidget(newMap, file = tmpFile, selfcontained = FALSE) # output is path to temp .html file containing map @@ -746,11 +750,12 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, plotModuleServer(id = "countOccurrence", plotFunction = "countOccurrence", data = reactive({ - validate(need(input$region, noData())) + validate(need(gewest(), noData())) + req(filterData()) if (!is.null(shapeData)) merge(filterData(), # attach regions for coloring - sf::st_drop_geometry(shapeData$utm1_bel_with_regions)[, c("CELLCODE", paste0("is", simpleCap(input$region)))], + sf::st_drop_geometry(shapeData$utm1_bel_with_regions)[, c("CELLCODE", paste0("is", simpleCap(gewest())))], by.x = "cell_code1", by.y = "CELLCODE", all.x = TRUE) else filterData() }), @@ -759,6 +764,33 @@ mapCubeServer <- function(id, uiText, species, df, shapeData, uiText = uiText ) + + ## Report Objects ## + ## -------------- ## + + observe({ + + req(dashReport) + # Update when any of these change + req(finalMap()) + input + + # Return the static values + dashReport[[ns("mapOccurrence")]] <- c( + list( + plot = isolate(finalMap()), + title = isolate(title()), + description = isolate(tmpTranslation()$description), + showPeriod = (showPeriod && !is.null(input$period)) + ), + isolate(reactiveValuesToList(input)) + ) + + }) + + + return(dashReport) + }) } @@ -788,7 +820,6 @@ mapCubeUI <- function(id, showLegend = TRUE, showGlobe = TRUE, showPeriod = FALS wellPanel( fixedRow(uiOutput(ns("filters")), - column(6, uiOutput(ns("region"))), if (showLegend) column(6, uiOutput(ns("legend")) diff --git a/alienSpecies/R/mapRaster.R b/alienSpecies/R/mapRaster.R new file mode 100644 index 0000000..9ae7030 --- /dev/null +++ b/alienSpecies/R/mapRaster.R @@ -0,0 +1,363 @@ +# Functions for raster maps +# +# Used for +# - climate risk maps +# +# Author: mvarewyck +############################################################################### + + +#' Create leaflet raster map for the climate risk maps +#' +#' @param rasterInput SpatRaster object, as returned by \code{terra::rast} +#' @param legendScale character, scale to be mentioned in the legend +#' @inheritParams mapHeat +#' +#' @return leaflet map +#' +#' @author mvarewyck +#' @importFrom leaflet addScaleBar addTiles addLegend colorNumeric addRasterImage +#' @importFrom terra values +#' @export + +mapRaster <- function(rasterInput, baseMap = addBaseMap(), colors = "Spectral", + legend = "topright", legendScale = "risk", addGlobe = FALSE, uiText = NULL) { + + + # Base map + rasterMap <- baseMap %>% + addScaleBar(position = "bottomleft") + + if (addGlobe) + rasterMap <- addTiles(rasterMap) + + + if (is.null(rasterInput)) + return(rasterMap) + + rasterPal <- colorNumeric(palette = colors, domain = c(0, 1), + na.color = "transparent", reverse = TRUE) + + + if (legend != "none") + rasterMap <- addLegend( + map = rasterMap, + position = legend, + values = values(rasterInput), + opacity = 0.8, + colors = rasterPal(seq(0, 1, by = 0.2)), + labels = c( + paste("0 -", translate(uiText, paste0(legendScale, "Low"))$title), + rep("", 4), + paste("1 -", translate(uiText, paste0(legendScale, "High"))$title)), + title = translate(uiText, "legend")$title, + layerId = "legend" + ) + + rasterMap <- addRasterImage(rasterMap, + rasterInput, colors = rasterPal, + opacity = 0.8) + + + rasterMap + +} + + + + + +#' Shiny module for creating the plot \code{\link{mapCube}} - server side +#' +#' @inheritParams welcomeSectionServer +#' @inheritParams mapHeat +#' @inheritParams mapCubeServer +#' @param taxonKey reactive numeric, taxonkey of the species to select the correct tiff file +#' @return no return value +#' +#' @author mvarewyck +#' @import shiny +#' @import leaflet +#' @importFrom htmlwidgets saveWidget +#' @importFrom webshot webshot +#' @importFrom terra values rast +#' @importFrom httr http_status GET +#' @importFrom utils download.file +#' @export +mapRasterServer <- function(id, uiText, species, gewest, taxonKey) { + + colors <- "Spectral" + + moduleServer(id, + function(input, output, session) { + + ns <- session$ns + + + noData <- reactive(translate(uiText(), "noData")$title) + tmpTranslation <- reactive(translate(uiText(), ns("mapRaster"))) + + output$titleMapRaster <- renderUI(h3(HTML(tmpTranslation()$title))) + output$descriptionMapRaster <- renderUI(HTML(tmpTranslation()$description)) + + + output$filters <- renderUI({ + + # Filter choices + modelScenarios <- c("hist", "rcp26", "rcp45", "rcp85") + names(modelScenarios) <- translate(uiText(), modelScenarios)$title + + modelTypes <- c("riskMap", "confMap", "diffMap") + names(modelTypes) <- translate(uiText(), modelTypes)$title + + + filters <- list( + modelScenario = modelScenarios, + modelType = modelTypes + ) + + lapply(names(filters), function(iName) { + + column(4, + selectInput(inputId = ns(iName), + label = translate(uiText(), iName)$title, + choices = filters[[iName]], + multiple = FALSE)) + + }) + + }) + + + rasterFile <- reactive({ + + req(input$modelScenario) + req(!is.null(input$modelType)) + + tiffPath <- "https://raw.githubusercontent.com/trias-project/risk-maps/main/public/geotiffs" + tiffFile <- paste0( + paste("be", taxonKey(), input$modelScenario, sep = "_"), + if (input$modelType != "riskMap") + paste0("_", gsub("Map", "", input$modelType)), + ".4326.tif") + + toReturn <- file.path(tiffPath, tiffFile) + + if (httr::http_status(httr::GET(toReturn))$category == "Client error") + NULL else + toReturn + + }) + + output$warningFile <- renderUI({ + + if (is.null(rasterFile())) + tags$div(class = "alert alert-warning", noData()) + + }) + + + rasterInput <- reactive({ + + if (is.null(rasterFile())) + return(NULL) + + tempFile <- file.path(tempdir(), basename(rasterFile())) + download.file(rasterFile(), destfile = tempFile, method = "curl") + + terra::rast(x = tempFile) + + }) + + + output$legend <- renderUI({ + + legendChoices <- c("topright", "bottomright", "topleft", "bottomleft", "none") + names(legendChoices) <- sapply(legendChoices, function(x) translate(uiText(), x)$title) + + selectInput(inputId = ns("legend"), + label = translate(uiText(), "legend")$title, + choices = legendChoices) + + }) + + + # Send map to the UI + output$spacePlot <- renderLeaflet({ + + mapRaster( + rasterInput = rasterInput(), + baseMap = addBaseMap(regions = gewest()), + colors = colors, + legendScale = isolate(gsub("Map", "", input$modelType)), + addGlobe = isolate(input$globe %% 2 == 1), + uiText = uiText() + ) + + }) + + + # Add world map + observe({ + + proxy <- leafletProxy("spacePlot") + + if (!is.null(input$globe) & !is.null(proxy)){ + + if (input$globe %% 2 == 1){ + + updateActionLink(session, inputId = "globe", + label = translate(uiText(), "hideGlobe")$title) + + proxy %>% addTiles(options = tileOptions(zIndex = -10)) + + } else { + + updateActionLink(session, inputId = "globe", + label = translate(uiText(), "showGlobe")$title) + + proxy %>% clearTiles() + + } + + } + + }) + + + # Add legend + observe({ + + req(input$legend) + + proxy <- leafletProxy("spacePlot") + proxy %>% removeControl(layerId = "legend") + + if (input$legend != "none") { + + req(rasterInput()) + + rasterPal <- colorNumeric(palette = colors, domain = c(0, 1), + na.color = "transparent", reverse = TRUE) + + legendScale <- gsub("Map", "", input$modelType) + + proxy %>% addLegend( + position = input$legend, + values = terra::values(rasterInput()), + opacity = 0.8, + colors = rasterPal(seq(0, 1, by = 0.2)), + labels = c( + paste("0 -", translate(uiText(), paste0(legendScale, "Low"))$title), + rep("", 4), + paste("1 -", translate(uiText(), paste0(legendScale, "High"))$title)), + title = translate(uiText(), "legend")$title, + layerId = "legend" + ) + + } + + }) + + + # Create final map (for download) + finalMap <- reactive({ + + newMap <- mapRaster( + rasterInput = rasterInput(), + baseMap = addBaseMap(regions = gewest()), + colors = colors, + legend = input$legend, + legendScale = gsub("Map", "", input$modelType), + addGlobe = input$globe %% 2 == 1, + uiText = uiText() + ) + + # save the zoom level and centering to the map object + newMap <- newMap %>% setView( + lng = input$spacePlot_center$lng, + lat = input$spacePlot_center$lat, + zoom = input$spacePlot_zoom + ) + + tmpFile <- tempfile(fileext = ".html") + + # write map to temp .html file + req(newMap) + htmlwidgets::saveWidget(newMap, file = tmpFile, selfcontained = FALSE) + + # output is path to temp .html file containing map + tmpFile + + }) + + + # Download the map + output$downloadMapButton <- renderUI({ + downloadButton(ns("download"), + label = translate(uiText(), "downloadMap")$title, + class = "downloadButton") + }) + + output$download <- downloadHandler( + filename = function() + nameFile(species = species(), + content = id, fileExt = "png"), + content = function(file) { + + # convert temp .html file into .png for download + webshot::webshot(url = finalMap(), file = file, + vwidth = 1200, vheight = 600, cliprect = "viewport") + + } + ) + + }) +} + + + +#' Shiny module for creating the plot \code{\link{mapCube}} - UI side +#' @inheritParams welcomeSectionServer +#' @inheritParams mapCubeUI +#' @return UI object +#' +#' @author mvarewyck +#' @import shiny +#' @importFrom leaflet leafletOutput +#' @export +mapRasterUI <- function(id, uiText) { + + ns <- NS(id) + + + # Raster Map + tags$div(class = "container", style = "margin-top: 10px;", + + uiOutput(ns("titleMapRaster")), + uiOutput(ns("descriptionMapRaster")), + + wellPanel( + fixedRow( + uiOutput(ns("filters")), + column(4, + uiOutput(ns("legend")) + ), + column(6, + actionLink(inputId = ns("globe"), label = "Show globe", + icon = icon("globe")) + ) + ) + ), + uiOutput(ns("warningFile")), + withSpinner(leafletOutput(ns("spacePlot"), height = "600px")), + + tags$br(), + + tags$div(uiOutput(ns("downloadMapButton")), style = "display:inline-block;"), + + tags$hr() + + ) + +} diff --git a/alienSpecies/R/mapRegions.R b/alienSpecies/R/mapRegions.R index 0b2e278..4bb2dde 100644 --- a/alienSpecies/R/mapRegions.R +++ b/alienSpecies/R/mapRegions.R @@ -1,4 +1,49 @@ + +#' Combine all nesten data for regions summary +#' +#' Returned object can be used as `data` in \code{\link{createSummaryRegions}} +#' @inheritParams combineNestenData +#' @param nestenBeheerdData sf data.frame, beheerde nesten data +#' @return data.frame +#' +#' @author mvarewyck +#' @export +combineVespaData <- function(pointsData, nestenData, nestenBeheerdData) { + + ## Individual data + pointsData$type <- "individual" + # Columns + regionVariables <- list(level3Name = "NAAM", level2Name = "provincie", level1Name = "GEWEST") + for (iName in names(regionVariables)) + names(pointsData)[match(iName, names(pointsData))] <- regionVariables[[iName]] + # Gewest + pointsData$GEWEST <- ifelse(pointsData$GEWEST == "Vlaanderen", "flanders", + ifelse(pointsData$GEWEST == "Bruxelles", "brussels", + ifelse(pointsData$GEWEST == "Wallonie", "wallonia", ""))) + # Provincie + pointsData$provincie <- ifelse(pointsData$provincie == "Vlaams Brabant", "Vlaams-Brabant", + ifelse(pointsData$provincie == "Bruxelles", "HoofdstedelijkGewest", + ifelse(pointsData$provincie == "Liège", "Luik", + ifelse(pointsData$provincie == "Brabant Wallon", "Waals-Brabant", + ifelse(pointsData$provincie == "Hainaut", "Henegouwen", pointsData$provincie))))) + pointsData$nest_type <- "individual" + pointsData$isBeheerd <- FALSE + + ## Nest data + nestenData$type <- "nest" + nestenData$isBeheerd <- nestenData$geometry %in% nestenBeheerdData$geometry + + keepColumns <- c("year", "type", "nest_type", "NAAM", "provincie", "GEWEST", "isBeheerd", "geometry") + vespaBoth <- rbind(pointsData[, keepColumns], nestenData[, keepColumns]) + vespaBoth$nest_type[vespaBoth$nest_type %in% c("NA", "NULL")] <- NA + + vespaBoth + +} + + + #' Create summary data per region #' @param data data.table with management data #' @param shapeData list, each object is \code{SpatialPolygonsDataFrame}. @@ -30,12 +75,30 @@ createSummaryRegions <- function(data, shapeData, n <- NULL unit <- match.arg(unit) + regionLevel <- match.arg(regionLevel) data <- as.data.frame(data) - if (is.null(year)) - myYear <- unique(data$year) else + + if (is.null(year)) { + + myYear <- unique(data$year) + + } else if (is.list(year)) { + + # create periods + data$year <- cut(data$year, + breaks = c(year[[1]][1], sapply(year, function(x) tail(x, n = 1))), + include.lowest = TRUE, + labels = sapply(year, function(x) if (length(x) == 1) x else paste(x[1], "-", tail(x, n = 1))) + ) + myYear <- levels(data$year) + + } else { + myYear <- year # rename for tidyverse filtering + + } regionVariable <- switch(regionLevel, @@ -145,9 +208,11 @@ createSummaryRegions <- function(data, shapeData, #' Map with occurrence and management for single species -#' @param managementData data.frame, management data +#' @param managementData data.frame, management data; +#' as returned by \code{\link{createSummaryRegions}} #' @param occurrenceData data.frame, occurrence data #' @param shapeData list with spatial data (grid and regions) +#' @inheritParams mapHeat #' @param uiText data.frame, for translations #' @param regionLevel character, region level to color polygons #' @param palette character, color palette to be used, see also \code{\link[leaflet]{colorFactor}} @@ -158,7 +223,8 @@ createSummaryRegions <- function(data, shapeData, #' @author mvarewyck #' @import leaflet #' @export -mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText = NULL, +mapRegions <- function(managementData, occurrenceData = NULL, shapeData, + baseMap = addBaseMap(), uiText = NULL, regionLevel = c("communes", "provinces"), palette = "YlOrBr", legend = "topright", addGlobe = FALSE) { @@ -169,9 +235,29 @@ mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText reverse = (palette != "YlOrBr")) valuesPalette <- managementData$group[match(spatialData$NAAM, managementData$region)] + # Add borders + if (regionLevel == "communes") { + + # TODO include in addBaseMap() + myMap <- leaflet() %>% + addPolylines( + data = shapeData$provinces, + weight = 3, + color = "black", + opacity = 0.8, + group = "borderRegion" + ) + + } else if (regionLevel == "provinces") { + + myMap <- baseMap + + } + - myMap <- leaflet(spatialData) %>% + myMap <- myMap %>% addPolygons( + data = spatialData, weight = 1, color = "gray", fillColor = ~ paletteFunction(valuesPalette), @@ -192,23 +278,7 @@ mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText } - # Add borders - if (regionLevel == "communes") { - - myMap <- myMap %>% - addPolylines( - data = shapeData$provinces, - weight = 3, - color = "black", - opacity = 0.8, - group = "borderRegion" - ) - - } else if (regionLevel == "provinces") { - - myMap <- myMap %>% addBaseMap() - - } + # Add legend if (legend != "none") { @@ -247,6 +317,56 @@ mapRegions <- function(managementData, occurrenceData = NULL, shapeData, uiText } +#' Map with management for single species +#' @inheritParams mapRegions +#' @return ggplot object +#' +#' @author mvarewyck +#' @import ggplot2 +#' @importFrom ggspatial annotation_map_tile +#' @export +mapRegionsFacet <- function(managementData, shapeData, uiText = NULL, + regionLevel = c("communes", "provinces"), palette = "YlOrBr", + legend = "right", addGlobe = FALSE) { + + # For R CMD check + group <- NULL + + plotData <- merge(shapeData[[regionLevel]], managementData, + by.x = "NAAM", by.y = "region", all.x = TRUE) + + # Facet plot + myPlot <- ggplot() + + geom_sf(data = plotData, aes(fill = group), size = 0.5) + + facet_wrap(~ year, ncol = 3) + + scale_fill_brewer(palette = palette) + + theme_inbo(transparent = TRUE) + + theme( + legend.position = legend, + axis.text.x = element_blank(), + axis.text.y = element_blank(), + axis.ticks = element_blank()) + + guides(fill = guide_legend(title = translate(uiText, "legend")$title)) + + if (addGlobe) + # Add background globe + myPlot <- myPlot + ggspatial::annotation_map_tile( + zoom = 7, alpha = 0.5, forcedownload = FALSE, + cachedir = system.file("extdata", package = "alienSpecies")) + + # redraw polygons + geom_sf(data = plotData, aes(fill = group), size = 0.5) + + labs(caption = "\u00a9 OpenStreetMap contributors") + + if (regionLevel == "communes") + # Add province borders + myPlot <- myPlot + + geom_sf(data = shapeData$provinces, fill = NA, color = "black", size = 1) + + + myPlot + +} + #' Create popup text to display in \code{\link{mapRegions}} #' @param summaryData data.frame, as returned by \code{\link{createSummaryRegions}} @@ -303,11 +423,12 @@ mapPopup <- function(summaryData, uiText, year, unit, bronMap) { #' @inheritParams mapCubeServer #' @inheritParams mapCubeUI #' @inheritParams createSummaryRegions -#' @param species reactive character, readable name of the selected species #' @param df reactive data.frame, data as loaded by \code{\link{loadGbif}} #' @param occurrenceData data.table, as obtained by \code{loadTabularData(type = "occurrence")} #' @param sourceChoices character vector, choices for the data source; #' default value is NULL then no choices are shown +#' @param facet boolean, if TRUE a static facet plot is created; if FALSE an +#' interactive leaflet map is created #' #' @return no return value #' @@ -317,9 +438,10 @@ mapPopup <- function(summaryData, uiText, year, unit, bronMap) { #' @importFrom htmlwidgets saveWidget #' @importFrom webshot webshot #' @importFrom sf st_drop_geometry +#' @importFrom ggplot2 ggsave #' @export -mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, - sourceChoices = NULL) { +mapRegionsServer <- function(id, uiText, species, gewest, df, occurrenceData, shapeData, + sourceChoices = NULL, facet = FALSE, dashReport = NULL) { moduleServer(id, function(input, output, session) { @@ -329,22 +451,33 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, currentYear <- as.numeric(format(Sys.Date(), "%Y")) - 1 ns <- session$ns + htmlFile <- tempfile(fileext = ".html") + pngFile <- tempfile(fileext = ".png") results <- reactiveValues() noData <- reactive(translate(uiText(), "noData")) - tmpTranslation <- reactive(translate(uiText(), "management-mapOccurrence")) + tmpTranslation <- reactive(translate(uiText(), + if (!facet) + "management-mapOccurrence" else + "management-mapInvasion")) - output$titleMapRegions <- renderUI({ - - period <- if (!is.null(input$period)) - c(input$period, req(input$year)) else - req(input$year) - - h3(HTML(paste(tmpTranslation()$title, req(species()), yearToTitleString(period)))) - + title <- reactive({ + + decodeText(text = tmpTranslation()$title, + params = c( + list(species = species()), + if (!is.null(input$year)) + list(period = if (!is.null(input$period)) + c(input$period, input$year) else + input$year + )) + ) + }) + output$titleMapRegions <- renderUI(h3(HTML(title()))) + output$descriptionMapRegions <- renderUI(HTML(tmpTranslation()$description)) @@ -360,10 +493,11 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, inputId = ns("year"), label = paste0( translate(uiText(), "year")$title, - " (", translate(uiText(), "map")$title, ")"), + if (!facet) + paste0(" (", translate(uiText(), "map")$title, ")")), min = choices[1], max = choices[2], - value = 2018, + value = currentYear, step = 1, sep = "", width = "100%" @@ -424,30 +558,19 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, multiple = TRUE) }) - - # Filter on gewest - output$gewest <- renderUI({ - - choices <- c("flanders", "brussels", "wallonia") - names(choices) <- translate(uiText(), choices)$title - - selectInput(inputId = ns("gewestLevel"), label = translate(uiText(), "gewest")$title, - choices = choices, selected = choices, multiple = TRUE) - - }) - + subShape <- reactive({ - req(input$gewestLevel) + req(gewest()) # Subset for GEWEST lapply(shapeData, function(iData) { if ("GEWEST" %in% colnames(iData)){ iData$GEWEST <- dplyr::recode(iData$GEWEST, "Brussels" = "brussels", "Vlaams"="flanders", "Waals" = "wallonia") - iData[iData$GEWEST %in% input$gewestLevel, ]}else{ - iData[apply(sf::st_drop_geometry(iData[, paste0("is", simpleCap(input$gewestLevel)), drop = FALSE]), 1, sum) > 0, ] - } - }) - + iData[iData$GEWEST %in% gewest(), ] + }else{ + iData[apply(sf::st_drop_geometry(iData[, paste0("is", simpleCap(gewest())), drop = FALSE]), 1, sum) > 0, ] + } + }) }) @@ -475,7 +598,9 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, # Map attributes output$legend <- renderUI({ - legendChoices <- c("topright", "bottomright", "topleft", "bottomleft", "none") + legendChoices <- if (facet) + c("bottom", "top", "right", "left", "none") else + c("topright", "bottomright", "topleft", "bottomleft", "none") names(legendChoices) <- sapply(legendChoices, function(x) translate(uiText(), x)$title) selectInput(inputId = ns("legend"), @@ -492,10 +617,8 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, subData <- df() - if (!is.null(sourceChoices)) { - req(input$bronMap) + if (!is.null(sourceChoices) && !is.null(input$bronMap)) subData <- subData[subData$type %in% input$bronMap, ] - } subData @@ -506,11 +629,20 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, req(nrow(subData()) > 0) + selectedYear <- if (is.null(input$year)) + currentYear else + input$year + createSummaryRegions(data = subData(), shapeData = shapeData, - regionLevel = req(input$regionLevel), - year = req(input$year), - unit = input$unit, + regionLevel = if (is.null(input$regionLevel)) "communes" else input$regionLevel, + year = if (facet) + list( + c(selectedYear-8, selectedYear-5), + c(selectedYear-4, selectedYear-1), + selectedYear) else + selectedYear, + unit = if (is.null(input$unit)) "absolute" else input$unit, groupingVariable = if (!is.null(sourceChoices)) c("nest_type", "isBeheerd") ) @@ -520,8 +652,14 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, # Filter Occurrence data subOccurrence <- reactive({ + selectedYear <- if (is.null(input$year)) + currentYear else + input$year + # Filter on taxonKey and year - occurrenceData <- occurrenceData[occurrenceData$scientificName == species() & occurrenceData$year == req(input$year), ] + occurrenceData[ + occurrenceData$scientificName == species() & + occurrenceData$year == selectedYear, ] }) @@ -529,12 +667,36 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, # Send map to the UI output$regionsPlot <- renderLeaflet({ + req(!facet) validate(need(nrow(req(summaryData())) > 0, noData())) - mapRegions(managementData = summaryData(), occurrenceData = subOccurrence(), - shapeData = subShape(), uiText = uiText(), regionLevel = input$regionLevel, + mapRegions( + managementData = summaryData(), + occurrenceData = subOccurrence(), + shapeData = subShape(), + uiText = uiText(), + regionLevel = input$regionLevel, + baseMap = addBaseMap(regions = gewest()), addGlobe = isolate(input$globe %% 2 == 1), - palette = if (!is.null(input$unit) && input$unit == "difference") "RdYlGn" else "YlOrBr") + palette = if (!is.null(input$unit) && input$unit == "difference") "RdYlGn" else "YlOrBr" + ) + + }) + + output$regionsPlotFacet <- renderPlot({ + + req(facet) + validate(need(nrow(req(summaryData())) > 0, noData())) + + mapRegionsFacet( + managementData = summaryData(), + shapeData = subShape(), + uiText = uiText(), + regionLevel = req(input$regionLevel), + legend = input$legend, + addGlobe = input$globe, + palette = if (!is.null(input$unit) && input$unit == "difference") "RdYlGn" else "YlOrBr" + ) }) @@ -620,6 +782,7 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, observe({ req(input$legend) + req(!facet) req(summaryData()) proxy <- leafletProxy("regionsPlot") @@ -713,27 +876,54 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, # Create final map (for download) finalMap <- reactive({ - newMap <- mapRegions(managementData = summaryData(), occurrenceData = subOccurrence(), - shapeData = subShape(), uiText = uiText(), regionLevel = input$regionLevel, - legend = input$legend, addGlobe = input$globe %% 2 == 1, - palette = if (input$unit == "difference") "RdYlGn" else "YlOrBr") + req(nrow(summaryData()) > 0) + if (facet) { + + myPlot <- mapRegionsFacet( + managementData = summaryData(), + shapeData = subShape(), + uiText = uiText(), + regionLevel = if (is.null(input$regionLevel)) "communes" else input$regionLevel, + legend = if (is.null(input$legend)) "bottom" else input$legend, + addGlobe = if (is.null(input$globe)) FALSE else input$globe %% 2 == 1, + palette = if (!is.null(input$unit) && input$unit == "difference") "RdYlGn" else "YlOrBr" + ) + + ggplot2::ggsave(pngFile, plot = myPlot, width = 8, height = 4, dpi = 150) + pngFile + + } else { - # save the zoom level and centering to the map object - newMap <- newMap %>% setView( - lng = input$regionsPlot_center$lng, - lat = input$regionsPlot_center$lat, - zoom = input$regionsPlot_zoom - ) + newMap <- mapRegions( + managementData = summaryData(), + occurrenceData = subOccurrence(), + shapeData = subShape(), + baseMap = addBaseMap(regions = gewest()), + uiText = uiText(), + regionLevel = if (is.null(input$regionLevel)) "communes" else input$regionLevel, + legend = if (is.null(input$legend)) "topright" else input$legend, + addGlobe = if (is.null(input$globe)) FALSE else input$globe %% 2 == 1, + palette = if (is.null(input$unit) || input$unit != "difference") "YlOrBr" else "RdYlGn") - tmpFile <- tempfile(fileext = ".html") + + # save the zoom level and centering to the map object + if (!is.null(input$regionsPlot_center)) + newMap <- newMap %>% setView( + lng = input$regionsPlot_center$lng, + lat = input$regionsPlot_center$lat, + zoom = input$regionsPlot_zoom + ) # write map to temp .html file - htmlwidgets::saveWidget(newMap, file = tmpFile, selfcontained = FALSE) + req(newMap) + htmlwidgets::saveWidget(newMap, file = htmlFile, selfcontained = FALSE) # output is path to temp .html file containing map - tmpFile + htmlFile + } + }) @@ -751,10 +941,18 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, content = "management", fileExt = "png"), content = function(file) { - # convert temp .html file into .png for download - webshot::webshot(url = finalMap(), file = file, - vwidth = 1000, vheight = 500, cliprect = "viewport") - + if (facet) { + + file.copy(from = pngFile, to = file, overwrite = TRUE) + + } else { + + # convert temp .html file into .png for download + webshot::webshot(url = finalMap(), file = file, + vwidth = 1000, vheight = 500, cliprect = "viewport") + + } + } ) @@ -762,7 +960,8 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, filename = function() nameFile(species = species(), period = input$year, - content = "management_data", fileExt = "csv"), + content = if (!facet) "management_data" else "invasion_data", + fileExt = "csv"), content = function(file) { ## write data to exported file @@ -790,10 +989,10 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, }) - plotModuleServer(id = "timePlotFlanders", + plotFlanders <- plotModuleServer(id = "timePlotFlanders", plotFunction = "trendYearRegion", data = reactive({ - timeDataFlanders()[timeDataFlanders()$region %in% req(input$gewestLevel), ] + timeDataFlanders()[timeDataFlanders()$region %in% req(gewest()), ] }), uiText = uiText, period = reactive(input$period) @@ -827,7 +1026,7 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, }) - plotModuleServer(id = "timePlot", + plotRegion <- plotModuleServer(id = "timePlot", plotFunction = "trendYearRegion", data = reactive({ timeData()[timeData()$region %in% req(input$region), ] @@ -838,6 +1037,42 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, ) + ## Report Objects ## + ## -------------- ## + + observe({ + + req(dashReport) + + # Update when any of these change + req(finalMap()) + input + + # Return the static values + dashReport[[if (!facet) + ns("mapOccurrence") else + ns("mapInvasion")]] <- c( + list( + plot = isolate(finalMap()), + title = isolate(title()), + description = isolate(tmpTranslation()$description) + ), + if (!inherits(try(plotFlanders(), silent = TRUE), "try-error")) + list( + plotFlanders = isolate(plotFlanders()$plot) + ), + if (!inherits(try(plotRegion(), silent = TRUE), "try-error")) + list( + plotRegion = isolate(plotRegion()$plot) + ), + isolate(reactiveValuesToList(input)) + ) + + }) + + + return(dashReport) + }) } @@ -848,13 +1083,14 @@ mapRegionsServer <- function(id, uiText, species, df, occurrenceData, shapeData, #' @param plotDetails character vector, which plots to be shown below the map #' @param showUnit boolean, whether to show the option to choose unit; #' default is TRUE +#' @inheritParams mapRegionsServer #' @return UI object #' #' @author mvarewyck #' @import shiny #' @importFrom leaflet leafletOutput #' @export -mapRegionsUI <- function(id, plotDetails = NULL, showUnit = TRUE) { +mapRegionsUI <- function(id, plotDetails = NULL, showUnit = TRUE, facet = FALSE) { ns <- NS(id) @@ -868,13 +1104,12 @@ mapRegionsUI <- function(id, plotDetails = NULL, showUnit = TRUE) { wellPanel( fixedRow( - column(4, uiOutput(ns("gewest"))), - column(4, uiOutput(ns("regionLevel"))), - column(4, uiOutput(ns("region"))) - ), - fixedRow( + column(6, uiOutput(ns("regionLevel"))), + if (!facet) + column(6, uiOutput(ns("region"))), column(6, uiOutput(ns("year"))), - column(6, uiOutput(ns("period"))) + if (!facet) + column(6, uiOutput(ns("period"))) ), fixedRow( column(6, uiOutput(ns("legend"))), @@ -887,7 +1122,11 @@ mapRegionsUI <- function(id, plotDetails = NULL, showUnit = TRUE) { label = "Combine all selected regions"), actionLink(inputId = ns("globe"), label = "Show globe", icon = icon("globe")) ), - withSpinner(leafletOutput(ns("regionsPlot"))), + + if (!facet) + withSpinner(leafletOutput(ns("regionsPlot"), height = "600px")) else + withSpinner(plotOutput(ns("regionsPlotFacet"))), + tags$br(), diff --git a/alienSpecies/R/plot_nesten.R b/alienSpecies/R/plot_nesten.R index 5b3e608..8ba9468 100644 --- a/alienSpecies/R/plot_nesten.R +++ b/alienSpecies/R/plot_nesten.R @@ -59,7 +59,8 @@ createSummaryNesten <- function(data, #' @author mvarewyck #' @import shiny #' @export -countNestenServer <- function(id, uiText, maxDate = reactive(NULL), data) { +countNestenServer <- function(id, uiText, maxDate = reactive(NULL), data, + dashReport = NULL) { moduleServer(id, function(input, output, session) { @@ -72,15 +73,15 @@ countNestenServer <- function(id, uiText, maxDate = reactive(NULL), data) { output$titleCountNesten <- renderUI(h3(HTML(tmpTranslation()$title))) - output$descriptionCountNesten <- renderUI({ + description <- reactive({ - tmpDescription <- tmpTranslation()$description - tmpDescription <- gsub("\\{\\{maxDate\\}\\}", format(maxDate(), "%d/%m/%Y"), tmpDescription) - - HTML(tmpDescription) + decodeText(text = tmpTranslation()$description, + params = list(maxDate = format(maxDate(), "%d/%m/%Y"))) }) + output$descriptionCountNesten <- renderUI(HTML(description())) + ## Periode (grafiek) output$period <- renderUI({ @@ -148,6 +149,7 @@ countNestenServer <- function(id, uiText, maxDate = reactive(NULL), data) { # Temporary fix # https://github.com/inbo/alien-species-portal/issues/27#issuecomment-1801937223 nestChoices <- nestChoices[!nestChoices %in% c('NA', 'NULL')] + req(length(nestChoices) > 0) names(nestChoices) <- sapply(nestChoices, function(x) translate(uiText(), x)$title) @@ -164,13 +166,37 @@ countNestenServer <- function(id, uiText, maxDate = reactive(NULL), data) { }) - plotModuleServer(id = "countNesten", + plotResult <- plotModuleServer(id = "countNesten", plotFunction = "trendYearRegion", data = reactive(plotData()[plotData()$region %in% req(input$region), ]), uiText = uiText, combine = reactive(input$combine) ) + ## Report Objects ## + ## -------------- ## + + observe({ + + # Update when any of these change + plotResult() + input + + # Return the static values + dashReport[[ns("countNesten")]] <- c( + list( + plot = isolate(plotResult()$plot), + title = isolate(tmpTranslation()$title), + description = isolate(description()) + ), + isolate(reactiveValuesToList(input)) + ) + + }) + + + return(dashReport) + }) } diff --git a/alienSpecies/R/plot_trias.R b/alienSpecies/R/plot_trias.R index c87e0bf..a878c43 100644 --- a/alienSpecies/R/plot_trias.R +++ b/alienSpecies/R/plot_trias.R @@ -79,12 +79,14 @@ plotTrias <- function(triasFunction, df, triasArgs = NULL, #' Shiny module for creating the plot \code{\link{plotTrias}} - server side #' @inheritParams welcomeSectionServer #' @inheritParams plotTrias +#' @inheritParams mapCubeServer #' @param data reactive object, data for \code{\link{plotTrias}} +#' @param translationId character, identifier for the translation file provided +#' in \code{uiText}; by default this is same as \code{triasFunction} #' @param triasArgs reactive object, extra plot arguments to be passed to the #' trias package #' @param filters character vector, additional filters for the TRIAS plot to #' be dipslayed -#' @param filterRegion boolean, whether to show filter for region #' @param maxDate reactive date, maximum observation date for printing in description #' @return no return value #' @@ -92,8 +94,10 @@ plotTrias <- function(triasFunction, df, triasArgs = NULL, #' @import shiny #' @import trias #' @export -plotTriasServer <- function(id, uiText, data, triasFunction, triasArgs = NULL, - filters = NULL, filterRegion = FALSE, maxDate = reactive(NULL), outputType = c("plot", "table")) { +plotTriasServer <- function(id, uiText, data, triasFunction, + translationId = triasFunction, triasArgs = NULL, + filters = NULL, maxDate = reactive(NULL), outputType = c("plot", "table"), + dashReport = NULL) { # For R CMD check protected <- NULL @@ -105,81 +109,68 @@ plotTriasServer <- function(id, uiText, data, triasFunction, triasArgs = NULL, ns <- session$ns - tmpTranslation <- reactive(translate(uiText(), triasFunction)) + tmpTranslation <- reactive(translate(uiText(), translationId)) output$titlePlotTrias <- renderUI(h3(HTML(tmpTranslation()$title))) - output$descriptionPlotTrias <- renderUI({ + description <- reactive({ - tmpDescription <- tmpTranslation()$description - tmpDescription <- gsub("\\{\\{maxDate\\}\\}", format(maxDate(), "%d/%m/%Y"), tmpDescription) - - HTML(tmpDescription) + decodeText(text = tmpTranslation()$description, + params = list(maxDate = format(maxDate(), "%d/%m/%Y"))) }) + output$descriptionPlotTrias <- renderUI(HTML(description())) + output$filters <- renderUI({ if (!is.null(filters)) - lapply(filters, function(iFilter) { - checkboxInput(inputId = ns(iFilter), label = switch(iFilter, - bias = translate(uiText(), "correctBias")$title, - protected = translate(uiText(), "protectAreas")$title) - ) - }) - }) - - output$regionFilter <- renderUI({ - - choices <- c("flanders", "wallonia", "brussels") - names(choices) <- translate(uiText(), choices)$title - - selectInput(inputId = ns("region"), label = translate(uiText(), "regions"), - choices = choices, multiple = TRUE, selected = choices) - - }) - - output$filterPanel <- renderUI({ - - if (!is.null(filters) | filterRegion) wellPanel( - fluidRow( - column(6, uiOutput(ns("filters"))), - if (filterRegion) - column(6, uiOutput(ns("regionFilter"))) - ) + lapply(names(filters), function(iFilter) { + if (all(filters[[iFilter]] == "checkbox")) { + checkboxInput(inputId = ns(iFilter), + label = translate(uiText(), iFilter)$title) + } else { + choices <- filters[[iFilter]] + names(choices) <- translate(uiText(), choices)$title + fluidRow(column(4, selectInput(inputId = ns(iFilter), + label = translate(uiText(), iFilter)$title, + choices = choices))) + } + }) ) - + }) + plotData <- reactive({ subData <- data() - if (!is.null(input$region)) - # only for GAM - subData <- summarizeTimeSeries(rawData = subData, region = input$region) - - if (!is.null(input$protected)) - subData <- subData[protected == input$protected, ] + if (!is.null(input$protectAreas)) + subData <- subData[protected == input$protectAreas, ] subData }) - plotModuleServer(id = "plotTrias", + plotResult <- plotModuleServer(id = "plotTrias", plotFunction = "plotTrias", triasFunction = triasFunction, data = plotData, triasArgs = reactive({ if (!is.null(triasArgs)) { initArgs <- triasArgs() - if (!is.null(input$bias)) { - initArgs$eval_years <- min(plotData()$year):max(plotData()$year) - if (input$bias) - initArgs$baseline_var <- "cobs" + if (!is.null(input$correctBias)) { + initArgs$eval_years <- min(plotData()$year, na.rm = TRUE):max(plotData()$year, na.rm = TRUE) + if (input$correctBias) + if (initArgs$y_var == "obs") + initArgs$baseline_var <- "cobs" else + initArgs$baseline_var <- "c_ncells" } + if (!is.null(input$regionLevel)) + initArgs$type <- input$regionLevel initArgs } else NULL }), @@ -187,6 +178,31 @@ plotTriasServer <- function(id, uiText, data, triasFunction, triasArgs = NULL, uiText = uiText ) + + ## Report Objects ## + ## -------------- ## + + observe({ + + # Update when any of these change + req(plotResult()) + input + + # Return the static values + dashReport[[ns(triasFunction)]] <- c( + list( + plot = isolate(plotResult()$plot), + title = isolate(tmpTranslation()$title), + description = isolate(description()) + ), + isolate(reactiveValuesToList(input)) + ) + + }) + + + return(dashReport) + }) } @@ -194,12 +210,14 @@ plotTriasServer <- function(id, uiText, data, triasFunction, triasArgs = NULL, #' Shiny module for creating the plot \code{\link{plotTrias}} - UI side +#' @param showPlotDefault boolean, whether to show the plot by default; +#' default value is FALSE, i.e. plot hidden in conditionalPanel() #' @inheritParams plotModuleUI #' @inheritParams plotTrias #' @author mvarewyck #' @import shiny #' @export -plotTriasUI <- function(id, outputType = c("plot", "table")) { +plotTriasUI <- function(id, outputType = c("plot", "table"), showPlotDefault = FALSE) { ns <- NS(id) outputType <- match.arg(outputType) @@ -208,10 +226,11 @@ plotTriasUI <- function(id, outputType = c("plot", "table")) { actionLink(inputId = ns("linkPlotTrias"), label = uiOutput(ns("titlePlotTrias"))), - conditionalPanel("input.linkPlotTrias % 2 == 1", ns = ns, + conditionalPanel(paste("input.linkPlotTrias % 2 ==", (as.numeric(showPlotDefault) + 1) %% 2), + ns = ns, uiOutput(ns("descriptionPlotTrias")), - uiOutput(ns("filterPanel")), + uiOutput(ns("filters")), if (outputType == "plot") plotModuleUI(id = ns("plotTrias")) else diff --git a/alienSpecies/R/tableIndicators.R b/alienSpecies/R/tableIndicators.R index 9565c5f..8e1d4dc 100644 --- a/alienSpecies/R/tableIndicators.R +++ b/alienSpecies/R/tableIndicators.R @@ -50,10 +50,12 @@ tableIndicators <- function(exotenData, unionlistData, occurrenceData) { tableData <- merge(tableData, combinedData[[iName]], by = "key", all.x = TRUE) } - managementSpecies <- sapply(strsplit(list.files(system.file("extdata/management", package = "alienSpecies")), split = "\\."), - function(x) x[1]) - managementSpecies <- gsub("_", " ", managementSpecies) - colorCode <- ifelse(tableData$species %in% managementSpecies, "green", "black") + expectedFiles <- gsub(" ", "_", tableData$species) + availableFiles <- aws.s3::get_bucket_df( + bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")))$Key + + colorCode <- sapply(expectedFiles, function(iSpecies) if (any(grepl(iSpecies, availableFiles))) + "green" else "black") # Add unionlist info tableData$unionColor <- ifelse(tableData$nubKey %in% unionlistData$taxonKey, colorCode, NA) # Add occurrence info @@ -107,7 +109,7 @@ tableIndicatorsServer <- function(id, exotenData, unionlistData, occurrenceData, # More column tableData$more <- paste0(' -
+
', # Button to union ifelse(!is.na(tableData$unionColor), diff --git a/alienSpecies/R/timeseries.R b/alienSpecies/R/timeseries.R index 8a69284..6c95d5e 100644 --- a/alienSpecies/R/timeseries.R +++ b/alienSpecies/R/timeseries.R @@ -6,19 +6,23 @@ #' Summarize time series data over the 1kmx1km grids for selected regions #' -#' @param rawData data.table, as created by \code{\link{createTimeseries}} +#' @param timeseries connection to data.table, as created by \code{loadTabularData(type = "timeseries")} +#' @param species numeric, taxonKey for the species select #' @inheritParams createCubeData #' @return data.table #' #' @author mvarewyck +#' @importFrom dplyr filter collect #' @export -summarizeTimeSeries <- function(rawData, region = c("flanders", "wallonia", "brussels")) { +summarizeTimeSeries <- function(timeseries, species, region = c("flanders", "wallonia", "brussels")) { # For R CMD check obs <- cobs <- pa_obs <- pa_cobs <- classKey <- taxonKey <- year <- protected <- NULL natura2000 <- NULL - # Filter on region + # Filter data and collect + rawData <- dplyr::filter(timeseries, taxonKey == species) %>% dplyr::collect() + regionCols <- paste0("is", simpleCap(region)) rawData <- rawData[rowSums(rawData[, regionCols, with = FALSE]) > 0, ] diff --git a/alienSpecies/R/tools.R b/alienSpecies/R/tools.R index 98803df..b3a0eb1 100644 --- a/alienSpecies/R/tools.R +++ b/alienSpecies/R/tools.R @@ -181,3 +181,53 @@ simpleCap <- function(names, keepNames = TRUE) { }, USE.NAMES = keepNames) } + + +#' get path of INBO logo file +#' +#' @return character, path of logo file +#' @param type character, defines which logo is returned; should be one of +#' \code{c("inbo", "trias")} +#' @author mvarewyck +#' @export +getPathLogo <- function(type = c("inbo", "trias", "combined")) { + + type <- match.arg(type) + + system.file("app/www", switch(type, + inbo = "logo.png", + trias = "logoTrias.png", + combined = "logoCombined.png" + ), package = "alienSpecies") + +} + + + +#' Style plotly object for Rmd report +#' +#' @param myPlot plotly object +#' @return plotly object +#' +#' @author mvarewyck +#' @import plotly +#' @export +plotlyReport <- function(myPlot) { + + myPlot <- myPlot %>% config(displayModeBar = FALSE) + + # remove gridlines + if (is.null(myPlot$x$layoutAttrs[[1]]$xaxis)) + myPlot$x$layoutAttrs[[1]]$xaxis <- list(showgrid = FALSE) else + myPlot$x$layoutAttrs[[1]]$xaxis$showgrid <- FALSE +# myPlot$x$layoutAttrs[[1]]$xaxis$ticks <- "outside" + + if (is.null(myPlot$x$layoutAttrs[[1]]$yaxis)) + myPlot$x$layoutAttrs[[1]]$yaxis <- list(showgrid = FALSE) else + myPlot$x$layoutAttrs[[1]]$yaxis$showgrid <- FALSE +# myPlot$x$layoutAttrs[[1]]$yaxis$ticks <- "outside" + + myPlot %>% layout(autosize = FALSE, width = 1000, height = 400) + +} + diff --git a/alienSpecies/R/trendYearRegion.R b/alienSpecies/R/trendYearRegion.R index ebc59e8..1243edb 100644 --- a/alienSpecies/R/trendYearRegion.R +++ b/alienSpecies/R/trendYearRegion.R @@ -54,7 +54,8 @@ trendYearRegion <- function(df, uiText = NULL, # Create plot pl <- plot_ly(data = plotData, x = ~year, y = ~outcome, - color = ~region, colors = colorList$colors, + color = ~region, colors = colorList$colors, +# line = list(dash = ~group), hoverinfo = "x+y+name", type = "scatter", mode = "lines+markers") %>% layout(title = title, diff --git a/alienSpecies/inst/NEWS b/alienSpecies/inst/NEWS index 4031a4c..1e4862d 100644 --- a/alienSpecies/inst/NEWS +++ b/alienSpecies/inst/NEWS @@ -1,3 +1,6 @@ +1.0.0 + o first version of app on UAT + o overwrite last_observed of indicators by timeseries 0.0.5 o fix for timeseries aspbo: read unprocessed from S3 bucket 0.0.4 diff --git a/alienSpecies/inst/app/global.R b/alienSpecies/inst/app/global.R index 9e3dd53..2633cca 100644 --- a/alienSpecies/inst/app/global.R +++ b/alienSpecies/inst/app/global.R @@ -8,6 +8,8 @@ library(shiny) `%<>%` <- magrittr::`%<>%` +# overwrite config::get as default +get <- base::get if (!exists("doDebug")) doDebug <- FALSE @@ -25,19 +27,19 @@ if (!doDebug | !exists("unionlistData")) unionlistData <- loadTabularData(type = "unionlist") if (!doDebug | !exists("occurrenceData")) occurrenceData <- loadTabularData(type = "occurrence") -if (!doDebug | !exists("timeseries")) - readS3(file = "full_timeseries.RData") +if (!doDebug | !exists("taxaChoices")) + taxaChoices <- loadTabularData(type = "taxachoices") + +# Load occupancy data from createOccupancyCube() - also loads `dfCube` +if (!doDebug | !exists("occupancy")) + occupancy <- loadOccupancyData() # Specify default year to show (and default max to show in time ranges) defaultYear <- max(exotenData$first_observed, na.rm = TRUE) defaultTimeNA <- TRUE defaultTime <- c(min(exotenData$first_observed, na.rm = TRUE), defaultYear) -# Load occupancy data from createOccupancyCube() -if (!doDebug | !exists("occupancy")){ -occupancy <- loadOccupancyData() -} # Load cube data if (!doDebug | !exists("allShapes")) @@ -59,13 +61,14 @@ dictionary <- loadMetaData(type = "keys") # Initial exoten filter choices # e.g. search for Stylommatophora taxaLevels <- c("kingdom", "phylum", "class", "order", "family", "species") -#taxaChoices <- createTaxaChoices(exotenData = exotenData) -#longTaxaChoices <- unlist(taxaChoices) # for matching id and title in search query -taxaChoices <- createTaxaChoices2(exotenData = exotenData) - habitatChoices <- attr(exotenData, "habitats") doeChoices <- sort(unique(exotenData$degree_of_establishment)) regionChoices <- sort(unique(exotenData$locality)) bronChoices <- sort(levels(exotenData$source)) +# Available species for risk maps (Species > More > Risk maps) +request <- httr::GET("https://api.github.com/repos/trias-project/risk-maps/contents/public/geotiffs") +keysRiskMap <- unique(sapply(httr::content(request), function(x) + strsplit(gsub("public/geotiffs/be_", "", x$path), split = "_")[[1]][1])) + diff --git a/alienSpecies/inst/app/server.R b/alienSpecies/inst/app/server.R index ebe954e..47814ad 100644 --- a/alienSpecies/inst/app/server.R +++ b/alienSpecies/inst/app/server.R @@ -35,31 +35,39 @@ function(input, output, session) { results <- reactiveValues( # Default language is dutch - translations = loadMetaData(language = "en"), + translations = loadMetaData(language = "en", local = doDebug), searchId = "", + renderedTabs = c("start", "checklist_taxa"), exoten_timeNA = defaultTimeNA, exoten_time = defaultTime, - species_choice = if (doDebug) c("Alopochen aegyptiaca", "Muntiacus reevesi", - "Lithobates catesbeianus", "Vespa velutina")[4] else NULL + species_choice = "" ) # Select language - observeEvent(input$translate_nl, results$translations <- loadMetaData(language = "nl")) - observeEvent(input$translate_fr, results$translations <- loadMetaData(language = "fr")) - observeEvent(input$translate_en, results$translations <- loadMetaData(language = "en")) + observeEvent(input$translate_nl, results$translations <- loadMetaData(language = "nl", local = doDebug)) + observeEvent(input$translate_fr, results$translations <- loadMetaData(language = "fr", local = doDebug)) + observeEvent(input$translate_en, results$translations <- loadMetaData(language = "en", local = doDebug)) results$switchTranslation <- reactive( input$translate_nl + input$translate_fr + input$translate_en ) + # Version + # ------- + + versionServer(id = "main", uiText = reactive(results$translations)) + + # URL Query # ---------- + + # Create URL for current session observeEvent(input$showShare, { - searchId <- if (input$tabs %in% c("global_indicators")) + searchId <- if (input$tabs != "start") results$searchId else "" languageId <- paste0("&language=", attr(results$translations, "language")) @@ -102,12 +110,14 @@ function(input, output, session) { }) + # Resulting URL from previous session + urlSearch <- reactive(parseQueryString(session$clientData$url_search)) + + # Update page observe({ - # The url will be sth like: http://awsabiirl1118.jnj.com/?step=qc&id=16608 - url <- parseQueryString(session$clientData$url_search) - results$urlPage <- url$page + results$urlPage <- urlSearch()$page }) @@ -115,17 +125,18 @@ function(input, output, session) { updateNavbarPage(session = session, inputId = "tabs", selected = results$urlPage) - url <- parseQueryString(session$clientData$url_search) - if (!is.null(url$habitat)) - results$urlHabitat <- strsplit(url$habitat, split = ", ")[[1]] + # TODO necessary here? + if (!is.null(urlSearch()$habitat)) + results$urlHabitat <- strsplit(urlSearch()$habitat, split = ", ")[[1]] }) + + # Update language observe({ - url <- parseQueryString(session$clientData$url_search) - results$urlLanguage <- url$language + results$urlLanguage <- urlSearch()$language }) @@ -142,29 +153,41 @@ function(input, output, session) { output$shareLink <- renderUI( actionLink(inputId = "showShare", label = translate(results$translations, "shareLink")) ) - - # Load code for all tabpages - for (serverFile in list.files("serverFiles", full.names = TRUE)) - source(serverFile, local = TRUE) - - - # Tabpanels + # Landing page + source(file.path("serverFiles", "serverStart.R"), local = TRUE) output$start_page <- renderUI({ source(file.path("uiFiles", "uiStart.R"), local = TRUE)$value }) - output$indicators_content <- renderUI({ + # Render tabpanel upon need + observeEvent(input$tabs, { - source(file.path("uiFiles", "uiChecklist.R"), local = TRUE)$value + # render only once + req(!input$tabs %in% results$renderedTabs) - }) - - output$species_content <- renderUI({ - - source(file.path("uiFiles", "uiSpecies.R"), local = TRUE)$value + switch(input$tabs, + global_indicators = { + + output$indicators_content <- renderUI({ + source(file.path("uiFiles", "uiChecklist.R"), local = TRUE)$value + }) + source(file.path("serverFiles", "serverChecklist.R"), local = TRUE) + results$renderedTabs <- c(results$renderedTabs, "global_indicators") + + }, + species_information = { + + output$species_content <- renderUI({ + source(file.path("uiFiles", "uiSpecies.R"), local = TRUE)$value + }) + source(file.path("serverFiles", "serverSpecies.R"), local = TRUE) + results$renderedTabs <- c(results$renderedTabs, "species_information") + + } + ) }) diff --git a/alienSpecies/inst/app/serverFiles/serverChecklist.R b/alienSpecies/inst/app/serverFiles/serverChecklist.R index 8f95b7a..1003105 100644 --- a/alienSpecies/inst/app/serverFiles/serverChecklist.R +++ b/alienSpecies/inst/app/serverFiles/serverChecklist.R @@ -4,11 +4,6 @@ ############################################################################### -output$checklist_title <- renderUI({ - - translate(results$translations, id = tabChoices[2])$title - - }) # Create titles lapply(c("taxa", "trend", "pathways", "origin"), function(iName) @@ -25,15 +20,13 @@ results$filter_exotenDataTranslated <- reactive({ exotenData[, pathway_level2_translate := translate(results$translations, do.call(paste, c(.SD, sep = "_")))$title, .SDcols = c("pathway_level1", "pathway_level2")] - exotenData$habitat_translate <- sapply(exotenData$habitat, function(x) - paste(translate(results$translations, strsplit(x, split = "\\|")[[1]])$title, collapse = "|")) exotenData[, ':=' ( - pathway_level1_translate = translate(results$translations, pathway_level1)$title, - native_continent_translate = translate(results$translations, native_continent)$title, - native_range_translate = translate(results$translations, native_range)$title, - degree_of_establishment_translate = translate(results$translations, degree_of_establishment)$title - )] - + pathway_level1_translate = translate(results$translations, pathway_level1)$title, + native_continent_translate = translate(results$translations, native_continent)$title, + native_range_translate = translate(results$translations, native_range)$title, + degree_of_establishment_translate = translate(results$translations, degree_of_establishment)$title, + habitat_translate = translate(results$translations, habitat)$title + )] }) @@ -55,10 +48,10 @@ observeEvent(exoten_triggerMore(), { if (input$exoten_more %% 2 == 1) updateActionLink(session = session, inputId = "exoten_more", label = translate(results$translations, "less")$title, - icon = icon("angle-double-up")) else + icon = icon("angle-double-up", class = "green-icon")) else updateActionLink(session = session, inputId = "exoten_more", label = translate(results$translations, "more")$title, - icon = icon("angle-double-down")) + icon = icon("angle-double-down", class = "green-icon")) }) @@ -67,7 +60,6 @@ observeEvent(exoten_triggerMore(), { ### Filters for Data ### ----------------- -urlSearch <- reactive(parseQueryString(session$clientData$url_search)) observeEvent(input$tabs, { @@ -78,10 +70,10 @@ observeEvent(input$tabs, { options = list( placeholder = translate(results$translations, "allTaxa")$title, render = I( - '{ + "{ option: function(item, escape) { - return "
" + item.html + "
"; } - }' + return '
' + item.html + '
'; } + }" )) ) @@ -332,7 +324,7 @@ output$exoten_legendLink <- renderUI({ actionLink(inputId = "exoten_legend", label = translate(results$translations, "tableLegend")$title, - icon = icon("angle-double-down")) + icon = icon("angle-double-down", class = "green-icon")) }) @@ -373,13 +365,10 @@ observeEvent(tmpKey(), { gbifKey <- strsplit(tmpKey(), "_")[[1]][2] tabPage <- strsplit(tmpKey(), "_")[[1]][1] - # Lookup key for occurrence data - newSpecies <- dictionary$scientificName[match(gbifKey, dictionary$gbifKey)] - updateNavbarPage(session = session, inputId = "tabs", selected = "species_information") # 2nd update only works if the tabs already exist updateTabsetPanel(session = session, inputId = "species_tabs", selected = paste0("species_", tabPage)) - results$species_choice <- newSpecies + results$species_choice <- dictionary$taxonKey[match(gbifKey, dictionary$gbifKey)] }) @@ -389,143 +378,174 @@ observeEvent(tmpKey(), { ### ----------------- -## Plot number of species per year -plotTriasServer(id = "checklist-count", - data = results$exoten_data, - uiText = reactive(results$translations), - triasFunction = "indicator_introduction_year", - triasArgs = reactive({ - list( - start_year_plot = min(results$exoten_data()$first_observed, na.rm = TRUE) - 1, - x_lab = translate(results$translations, "year")$title, - y_lab = translate(results$translations, "indicator_introduction_year")$title - ) - }) -) - - -## Plot cumulative number of species per year -plotTriasServer(id = "checklist-cum", - data = results$exoten_data, - uiText = reactive(results$translations), - triasFunction = "indicator_total_year", - triasArgs = reactive({ - list( - start_year_plot = min(results$exoten_data()$first_observed, na.rm = TRUE) - 1, - x_lab = translate(results$translations, "year")$title, - y_lab = translate(results$translations, "indicator_total_year")$title - ) - }) -) - -## Plot trend occupancy -countOccupancyServer(id = "checklist", - data = reactive(occupancy), - uiText = reactive(results$translations) -) - - -## Plot number of species per year by native region -plotTriasServer(id = "checklist_yearNativeRange", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "indicator_native_range_year", - triasArgs = reactive({ - list( - x_lab = translate(results$translations, "year")$title, - y_lab = translate(results$translations, "number")$title - ) - }) -) +# Checklist tab +observeEvent(input$exoten_tabs, { + + req(input$exoten_tabs == "checklist_trend") + req(!"checklist_trend" %in% results$renderedTabs) + results$renderedTabs <- c(results$renderedTabs, "checklist_trend") + + ## Plot number of species per year + plotTriasServer(id = "checklist-count", + data = results$exoten_data, + uiText = reactive(results$translations), + triasFunction = "indicator_introduction_year", + triasArgs = reactive({ + list( + start_year_plot = min(results$exoten_data()$first_observed, na.rm = TRUE) - 1, + x_lab = translate(results$translations, "year")$title, + y_lab = translate(results$translations, "indicator_introduction_year")$title + ) + }) + ) + + + ## Plot cumulative number of species per year + plotTriasServer(id = "checklist-cum", + data = results$exoten_data, + uiText = reactive(results$translations), + triasFunction = "indicator_total_year", + triasArgs = reactive({ + list( + start_year_plot = min(results$exoten_data()$first_observed, na.rm = TRUE) - 1, + x_lab = translate(results$translations, "year")$title, + y_lab = translate(results$translations, "indicator_total_year")$title + ) + }) + ) + + ## Plot trend occupancy + countOccupancyServer(id = "checklist", + data = reactive(occupancy), + uiText = reactive(results$translations) + ) + + }) -plotTriasServer(id = "checklist_tablePathway", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "get_table_pathways", - triasArgs = reactive(list(species_names = "species")), - outputType = "table" -) -results$checklist_levelsP1 <- reactive({ +# Pathways tab +observeEvent(input$exoten_tabs, { + + req(input$exoten_tabs == "checklist_pathways") + req(!"checklist_pathways" %in% results$renderedTabs) + results$renderedTabs <- c(results$renderedTabs, "checklist_pathways") + + plotTriasServer(id = "checklist_tablePathway", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "get_table_pathways", + triasArgs = reactive(list(species_names = "species")), + outputType = "table" + ) + + + results$checklist_levelsP1 <- reactive({ + + levelsP1 <- sort(unique(results$exoten_data()$pathway_level1)) + c(grep(unknownValue(), levelsP1, value = TRUE, invert = TRUE), + grep(unknownValue(), levelsP1, value = TRUE) + ) + + }) - levelsP1 <- sort(unique(results$exoten_data()$pathway_level1)) - c(grep(unknownValue(), levelsP1, value = TRUE, invert = TRUE), - grep(unknownValue(), levelsP1, value = TRUE) - ) + plotTriasServer(id = "checklist_pathway1", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "visualize_pathways_level1", + triasArgs = reactive({ + list( + x_lab = translate(results$translations, "numberTaxa")$title, + y_lab = translate(results$translations, "pathways")$title, + cbd_standard = FALSE, + pathways = results$checklist_levelsP1() + ) + }) + ) + + plotTriasServer(id = "checklist_pathway1Trend", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "visualize_pathways_year_level1", + triasArgs = reactive({ + list( + x_lab = translate(results$translations, "period")$title, + y_lab = translate(results$translations, "numberTaxa")$title, + cbd_standard = FALSE, + pathways = results$checklist_levelsP1() + ) + }) + ) + + plotTriasServer(id = "checklist_pathway2", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "visualize_pathways_level2", + triasArgs = reactive({ + validate(need(length(unique(results$exoten_data()$pathway_level1)) == 1, + translate(results$translations, "singlePathway")$title)) + list( + chosen_pathway_level1 = unique(results$exoten_data()$pathway_level1), + x_lab = translate(results$translations, "numberTaxa")$title, + y_lab = translate(results$translations, "pathways")$title, + cbd_standard = FALSE, + pathways = { + levelsP2 <- sort(unique(results$exoten_data()$pathway_level2)) + c(grep(unknownValue(), levelsP2, value = TRUE, invert = TRUE), + grep(unknownValue(), levelsP2, value = TRUE) + ) + } + ) + }) + ) + + plotTriasServer(id = "checklist_pathway2Trend", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "visualize_pathways_year_level2", + triasArgs = reactive({ + validate(need(length(unique(results$exoten_data()$pathway_level1)) == 1, + translate(results$translations, "singlePathway")$title)) + list( + chosen_pathway_level1 = unique(results$exoten_data()$pathway_level1), + x_lab = translate(results$translations, "period")$title, + y_lab = translate(results$translations, "numberTaxa")$title, + cbd_standard = FALSE, + pathways = { + levelsP2 <- sort(unique(results$exoten_data()$pathway_level2)) + c(grep(unknownValue(), levelsP2, value = TRUE, invert = TRUE), + grep(unknownValue(), levelsP2, value = TRUE) + ) + } + ) + }) + ) }) -plotTriasServer(id = "checklist_pathway1", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "visualize_pathways_level1", - triasArgs = reactive({ - list( - x_lab = translate(results$translations, "numberTaxa")$title, - y_lab = translate(results$translations, "pathways")$title, - cbd_standard = FALSE, - pathways = results$checklist_levelsP1() - ) - }) -) - -plotTriasServer(id = "checklist_pathway1Trend", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "visualize_pathways_year_level1", - triasArgs = reactive({ - list( - x_lab = translate(results$translations, "period")$title, - y_lab = translate(results$translations, "numberTaxa")$title, - cbd_standard = FALSE, - pathways = results$checklist_levelsP1() - ) - }) -) - -plotTriasServer(id = "checklist_pathway2", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "visualize_pathways_level2", - triasArgs = reactive({ - validate(need(length(unique(results$exoten_data()$pathway_level1)) == 1, - translate(results$translations, "singlePathway")$title)) - list( - chosen_pathway_level1 = unique(results$exoten_data()$pathway_level1), - x_lab = translate(results$translations, "numberTaxa")$title, - y_lab = translate(results$translations, "pathways")$title, - cbd_standard = FALSE, - pathways = { - levelsP2 <- sort(unique(results$exoten_data()$pathway_level2)) - c(grep(unknownValue(), levelsP2, value = TRUE, invert = TRUE), - grep(unknownValue(), levelsP2, value = TRUE) - ) - } - ) - }) -) -plotTriasServer(id = "checklist_pathway2Trend", - uiText = reactive(results$translations), - data = results$exoten_data, - triasFunction = "visualize_pathways_year_level2", - triasArgs = reactive({ - validate(need(length(unique(results$exoten_data()$pathway_level1)) == 1, - translate(results$translations, "singlePathway")$title)) - list( - chosen_pathway_level1 = unique(results$exoten_data()$pathway_level1), - x_lab = translate(results$translations, "period")$title, - y_lab = translate(results$translations, "numberTaxa")$title, - cbd_standard = FALSE, - pathways = { - levelsP2 <- sort(unique(results$exoten_data()$pathway_level2)) - c(grep(unknownValue(), levelsP2, value = TRUE, invert = TRUE), - grep(unknownValue(), levelsP2, value = TRUE) - ) - } - ) - }) -) \ No newline at end of file +# Origin tab +observeEvent(input$exoten_tabs, { + + req(input$exoten_tabs == "checklist_origin") + req(!"checklist_origin" %in% results$renderedTabs) + results$renderedTabs <- c(results$renderedTabs, "checklist_origin") + + ## Plot number of species per year by native region + plotTriasServer(id = "checklist_yearNativeRange", + uiText = reactive(results$translations), + data = results$exoten_data, + triasFunction = "indicator_native_range_year", + triasArgs = reactive({ + list( + x_lab = translate(results$translations, "year")$title, + y_lab = translate(results$translations, "number")$title + ) + }), + filters = list( + regionLevel = c("native_continent", "native_range")) + ) + + }) \ No newline at end of file diff --git a/alienSpecies/inst/app/serverFiles/serverSpecies.R b/alienSpecies/inst/app/serverFiles/serverSpecies.R index cfdb50a..83795e1 100644 --- a/alienSpecies/inst/app/serverFiles/serverSpecies.R +++ b/alienSpecies/inst/app/serverFiles/serverSpecies.R @@ -10,11 +10,9 @@ -output$species_title <- renderUI({ - - translate(data = results$translations, id = tabChoices[3])$title - - }) + +# Collect all results for the report +dashReport <- reactiveValues() lapply(c("observations", "indicators", "reporting", "management", "more", "habitats", "risk_maps", "links", "risk_assessment", "images"), function(iName) @@ -24,6 +22,8 @@ lapply(c("observations", "indicators", "reporting", "management", "more", plotFunction = iName )) +welcomeSectionServer(id = "species", uiText = reactive(results$translations)) + # Species selection results$species_choices <- reactive({ @@ -33,21 +33,60 @@ results$species_choices <- reactive({ # Reporting reportChoices <- dfCube[!duplicated(species) & !species %in% taxChoices, species] - sort(c(taxChoices, reportChoices)) - + choiceNames <- sort(c(taxChoices, reportChoices)) + choices <- dictionary$taxonKey[match(choiceNames, dictionary$scientificName)] + + names(choices) <- choiceNames + choices + }) observe({ # Trigger update when changing tab - input$tabs + if (input$tabs == "species_information") + updateSelectizeInput(session = session, inputId = "species_choice", + choices = results$species_choices(), + selected = if (results$species_choice == "" & !is.null(urlSearch()$taxonkey)) + urlSearch()$taxonkey else + results$species_choice, + server = TRUE) + + }) + +# Save choice when leaving this tab +observeEvent(input$tabs, { + + req(input$tabs != "species_information") + results$species_choice <- input$species_choice + + }) + + +# Gewest selection +observe({ - updateSelectizeInput(session = session, inputId = "species_choice", - choices = results$species_choices(), - selected = as.character(results$species_choice), - server = TRUE) + choices <- c("flanders", "wallonia", "brussels") + names(choices) <- translate(results$translations, choices)$title + # Trigger update when changing tab + if (input$tabs == "species_information") + updateSelectInput(session = session, inputId = "species_gewest", + choices = choices, + selected = if (!is.null(urlSearch()$gewest)) + strsplit(urlSearch()$gewest, split = ",")[[1]] else + choices) + +}) + + +# Update search ID +observe({ + + results$searchId <- paste0("&taxonkey=", input$species_choice, + "&gewest=", paste(input$species_gewest, collapse = ",")) + }) @@ -55,23 +94,26 @@ observe({ ### Observations ### ----------------- -# Taxonkey of selected species -taxonKey <- reactive({ +# Name corresponding with the selected taxonkey +taxonName <- reactive({ - dictionary$taxonKey[match(req(input$species_choice), dictionary$scientificName)] + req(input$species_choice) + dictionary$scientificName[match(input$species_choice, dictionary$taxonKey)] }) # Disable tab if no info observe({ + req(!is.null(input$species_choice)) + # https://stackoverflow.com/a/64324799 shinyjs::toggleState( selector = '#species_tabs a[data-value="species_observations"', - condition = !is.na(taxonKey()) + condition = !is.na(input$species_choice) ) - if (is.na(taxonKey()) & input$species_tabs == "species_observations") + if (is.na(input$species_choice) & input$species_tabs == "species_observations") updateTabsetPanel(session = session, inputId = "species_tabs", selected = "species_reporting") @@ -79,16 +121,18 @@ observe({ ## Map + barplot -mapCubeServer(id = "observations", +dashReport <- mapCubeServer(id = "observations", uiText = reactive(results$translations), - species = reactive(input$species_choice), + species = taxonName, + gewest = reactive(req(input$species_gewest)), df = reactive({ - req(taxonKey()) - occurrenceData[taxonKey %in% taxonKey(), ] + req(input$species_choice) + occurrenceData[taxonKey %in% input$species_choice, ] }), groupVariable = "cell_code", shapeData = allShapes, - showPeriod = TRUE + showPeriod = TRUE, + dashReport = dashReport ) @@ -101,38 +145,75 @@ mapCubeServer(id = "observations", # Disable tab if no info observe({ + req(!is.null(input$species_choice)) + # https://stackoverflow.com/a/64324799 shinyjs::toggleState( selector = '#species_tabs a[data-value="species_indicators"', - condition = !is.na(taxonKey()) + condition = !is.na(input$species_choice) ) - if (is.na(taxonKey()) & input$species_tabs == "species_indicators") + if (is.na(input$species_choice) & input$species_tabs == "species_indicators") updateTabsetPanel(session = session, inputId = "species_tabs", selected = "species_reporting") }) +timeseries <- loadTabularData(type = "timeseries") + +results$species_gamData <- reactive({ + + req(input$species_choice) + summarizeTimeSeries( + timeseries = timeseries, + species = as.numeric(input$species_choice), + region = input$species_gewest) + + }) ## Emergence status GAM - Observations -plotTriasServer(id = "species_gam", +dashReport <- plotTriasServer(id = "indicators_gamObservations", uiText = reactive(results$translations), - data = reactive({ - req(taxonKey()) - timeseries[taxonKey %in% taxonKey(), ] - }), + data = results$species_gamData, triasFunction = "apply_gam", + translationId = "apply_gamObservations", triasArgs = reactive({ list( y_var = "obs", - taxon_key = taxonKey(), - name = input$species_choice, + taxon_key = input$species_choice, + name = taxonName(), x_label = translate(results$translations, "year")$title, y_label = translate(results$translations, "observations")$title ) }), - filters = c("bias", "protected"), - filterRegion = TRUE + filters = list( + correctBias = "checkbox", + protectAreas = "checkbox" + ), + dashReport = dashReport +) + + +## Emergence status GAM - Occupancy +dashReport <- plotTriasServer(id = "indicators_gamOccupancy", + uiText = reactive(results$translations), + data = results$species_gamData, + triasFunction = "apply_gam", + translationId = "apply_gamOccupancy", + triasArgs = reactive({ + list( + y_var = "ncells", + taxon_key = input$species_choice, + name = taxonName(), + x_label = translate(results$translations, "year")$title, + y_label = translate(results$translations, "occupancy")$title + ) + }), + filters = list( + correctBias = "checkbox", + protectAreas = "checkbox" + ), + dashReport = dashReport ) @@ -148,10 +229,10 @@ observe({ # https://stackoverflow.com/a/64324799 shinyjs::toggleState( selector = '#species_tabs a[data-value="species_reporting"', - condition = input$species_choice %in% dfCube$species + condition = taxonName() %in% dfCube$species ) - if (!(input$species_choice %in% dfCube$species) & input$species_tabs == "species_reporting") + if (!(taxonName() %in% dfCube$species) & input$species_tabs == "species_reporting") updateTabsetPanel(session = session, inputId = "species_tabs", selected = "species_observations") @@ -159,13 +240,15 @@ observe({ # t0 and t1 -mapCubeServer(id = "reporting_t01", +dashReport <- mapCubeServer(id = "reporting_t01", uiText = reactive(results$translations), - species = reactive(input$species_choice), - df = reactive(dfCube[species %in% input$species_choice, ]), - filter = reactive(list(source = unique(dfCube$source[dfCube$species %in% input$species_choice]))), + species = taxonName, + gewest = reactive(req(input$species_gewest)), + df = reactive(dfCube[species %in% taxonName(), ]), + filter = reactive(list(source = unique(dfCube$source[dfCube$species %in% taxonName()]))), groupVariable = "source", - shapeData = allShapes + shapeData = allShapes, + dashReport = dashReport ) @@ -178,13 +261,14 @@ cubeSpecies <- c("Oxyura jamaicensis") # Species for which to show heatMap output heatSpecies <- c("Vespa velutina") # Other species will have mapRegions output +# e.g. Ondatra zibethicus results$species_managementFile <- reactive({ - req(input$species_choice) - expectFile <- if (input$species_choice %in% heatSpecies) - paste0(gsub(" ", "_", input$species_choice), "_shape.RData") else - gsub(" ", "_", paste0(input$species_choice, ".csv")) + req(taxonName()) + expectFile <- if (taxonName() %in% heatSpecies) + paste0(gsub(" ", "_", taxonName()), "_shape.RData") else + gsub(" ", "_", paste0(taxonName(), ".csv")) availableFiles <- aws.s3::get_bucket_df( bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")))$Key @@ -197,7 +281,7 @@ results$species_managementFile <- reactive({ # Disable tab if no info observe({ - req(input$species_choice) + req(taxonName()) # https://stackoverflow.com/a/64324799 shinyjs::toggleState( @@ -213,11 +297,11 @@ observe({ results$species_managementData <- reactive({ - req(input$species_choice) + req(taxonName()) validate(need(results$species_managementFile(), translate(results$translations, "noData")$title)) - if (input$species_choice %in% heatSpecies) { + if (taxonName() %in% heatSpecies) { readS3(file = results$species_managementFile()) @@ -226,10 +310,13 @@ results$species_managementData <- reactive({ } else { tmpData <- loadGbif(dataFile = results$species_managementFile()) - if( ! "GEWEST" %in% colnames(tmpData) ){ - tmpData$GEWEST <- allShapes$communes$GEWEST[ - match(tmpData$NISCODE, allShapes$communes$NISCODE)] + + if (!"GEWEST" %in% colnames(tmpData) && "NISCODE" %in% colnames(tmpData)){ + tmpData$GEWEST <- allShapes$communes$GEWEST[ + match(tmpData$NISCODE, allShapes$communes$NISCODE)] + tmpData <- tmpData[tmpData$GEWEST %in% input$species_gewest, ] } + tmpData } @@ -237,16 +324,20 @@ results$species_managementData <- reactive({ }) +# TODO rmd per management type? +# https://stackoverflow.com/a/33500524 +# https://bookdown.org/yihui/rmarkdown/shiny-args.html observe({ req(results$species_managementData()) - if (input$species_choice %in% cubeSpecies) { - ## Map + slider barplot + if (taxonName() %in% cubeSpecies) { + ## Map + slider barplot: Oxyura jamaicensis - mapCubeServer(id = "management", + dashReport <- mapCubeServer(id = "management", uiText = reactive(results$translations), - species = reactive(input$species_choice), + species = taxonName, + gewest = reactive(req(input$species_gewest)), df = results$species_managementData, filter = reactive({ filterCandidates <- c("gender", "samplingProtocol", "lifeStage") @@ -257,96 +348,96 @@ observe({ }), groupVariable = NULL, shapeData = NULL, - showPeriod = TRUE + showPeriod = TRUE, + dashReport = dashReport ) - } else if (input$species_choice %in% heatSpecies) { - ## heatmap + } else if (taxonName() %in% heatSpecies) { + ## heatmap: Vespa velutina ## Actieve haarden combinedActive <- combineActiveData( activeData = results$species_managementData()$actieve_haarden, - managedData = results$species_managementData()$beheerde_nesten, untreatedData = results$species_managementData()$onbehandelde_nesten ) - colorsActive <- c("blue", "black", "red") - names(colorsActive) <- c("individual", "managed nest", "untreated nest") + colorsActive <- c("blue", "black") + names(colorsActive) <- c("individual", "untreated nest") - mapHeatServer(id = "management2_active", + dashReport <- mapHeatServer(id = "management2_active", uiText = reactive(results$translations), - species = reactive(input$species_choice), + species = taxonName, + gewest = reactive(req(input$species_gewest)), combinedData = reactive(combinedActive), - filter = reactive(list(nest = unique(combinedActive$filter), radius = na.omit(unique(combinedActive$radius)))), + filter = reactive(list( + nest = unique(combinedActive$filter), + radius = na.omit(unique(combinedActive$radius)) + )), colors = reactive(colorsActive), blur = "individual", - maxDate = reactive(max(results$species_managementData()$actieve_haarden$eventDate, na.rm = TRUE)) + maxDate = reactive({ + req(results$species_managementData()) + max(results$species_managementData()$actieve_haarden$eventDate, na.rm = TRUE) + }) , + dashReport = dashReport ) ## Alle observaties combinedObserved <- combineNestenData( pointsData = results$species_managementData()$points, - nestenData = results$species_managementData()$nesten + nestenData = results$species_managementData()$nesten, + uiText = results$translations + # For testing only: when no observations yet, use latest available year +# currentYear = format(max(results$species_managementData()$points$eventDate, na.rm = TRUE), "%Y") ) colorsObserved <- c("blue", "red") names(colorsObserved) <- c("individual", "nest") - mapHeatServer(id = "management2_observed", + dashReport <- mapHeatServer(id = "management2_observed", uiText = reactive(results$translations), - species = reactive(input$species_choice), + species = taxonName, + gewest = reactive(req(input$species_gewest)), combinedData = reactive(combinedObserved), filter = reactive(list(source = unique(combinedObserved$filter))), colors = reactive(colorsObserved), - maxDate = reactive(max(results$species_managementData()$points$eventDate, na.rm = TRUE)) + maxDate = reactive({ + req(results$species_managementData()$points$eventDate) + max(results$species_managementData()$points$eventDate, na.rm = TRUE) + }), + dashReport = dashReport ) # Trend region - mapRegionsServer( + combinedManaged <- combineVespaData( + pointsData = req(results$species_managementData()$points), + nestenData = req(results$species_managementData()$nesten), + nestenBeheerdData = results$species_managementData()$beheerde_nesten + ) + dashReport <- mapRegionsServer( id = "management2", uiText = reactive(results$translations), - species = reactive(input$species_choice), - df = reactive({ - - # TODO this should be done in a createVespaData() function before uploading on S3 - ## Individual data - vespaPoints <- results$species_managementData()$points - req(vespaPoints) - vespaPoints$type <- "individual" - # Columns - regionVariables <- list(level3Name = "NAAM", level2Name = "provincie", level1Name = "GEWEST") - for (iName in names(regionVariables)) - names(vespaPoints)[match(iName, names(vespaPoints))] <- regionVariables[[iName]] - # Gewest - vespaPoints$GEWEST <- ifelse(vespaPoints$GEWEST == "Vlaanderen", "flanders", - ifelse(vespaPoints$GEWEST == "Bruxelles", "brussels", - ifelse(vespaPoints$GEWEST == "Wallonie", "wallonia", ""))) - # Provincie - vespaPoints$provincie <- ifelse(vespaPoints$provincie == "Vlaams Brabant", "Vlaams-Brabant", - ifelse(vespaPoints$provincie == "Bruxelles", "HoofdstedelijkGewest", - ifelse(vespaPoints$provincie == "Liège", "Luik", - ifelse(vespaPoints$provincie == "Brabant Wallon", "Waals-Brabant", - ifelse(vespaPoints$provincie == "Hainaut", "Henegouwen", vespaPoints$provincie))))) - vespaPoints$nest_type <- "individual" - vespaPoints$isBeheerd <- FALSE - - ## Nest data - vespaNesten <- results$species_managementData()$nesten - vespaNesten$type <- "nest" - vespaNesten$isBeheerd <- vespaNesten$geometry %in% results$species_managementData()$beheerde_nesten$geometry - - keepColumns <- c("year", "type", "nest_type", "NAAM", "provincie", "GEWEST", "isBeheerd", "geometry") - vespaBoth <- rbind(vespaPoints[, keepColumns], vespaNesten[, keepColumns]) - vespaBoth$nest_type[vespaBoth$nest_type %in% c("NA", "NULL")] <- NA - - vespaBoth - - }), + species = taxonName, + gewest = reactive(req(input$species_gewest)), + df = reactive(combinedManaged), + occurrenceData = NULL, + shapeData = allShapes, + sourceChoices = c("individual", "nest"), + dashReport = dashReport + ) + + # Facet invasion + dashReport <- mapRegionsServer(id = "management2_facet", + uiText = reactive(results$translations), + species = taxonName, + gewest = reactive(req(input$species_gewest)), + df = reactive(combinedManaged), occurrenceData = NULL, shapeData = allShapes, - sourceChoices = c("individual", "nest") + facet = TRUE, + dashReport = dashReport ) # Aantal lente nesten - plotTriasServer( + dashReport <- plotTriasServer( id = "management2_lente", triasFunction = "barplotLenteNesten", data = reactive(aws.s3::s3read_using(FUN = read.csv, @@ -354,44 +445,87 @@ observe({ bucket = config::get("bucket", file = system.file("config.yml", package = "alienSpecies")) )), #read.csv(system.file("extdata", "management", "Vespa_velutina", "aantal_lente_nesten.csv", package = "alienSpecies")) - uiText = reactive(results$translations) + uiText = reactive(results$translations), + dashReport = dashReport ) # Aantal nesten per provincie - figuur - countNestenServer( + dashReport <- countNestenServer( id = "management2_province", data = reactive(results$species_managementData()$nesten), uiText = reactive(results$translations), - maxDate = reactive(max(results$species_managementData()$nesten$observation_time, na.rm = TRUE)) + maxDate = reactive({ + req(results$species_managementData()) + max(results$species_managementData()$nesten$observation_time, na.rm = TRUE) + }), + dashReport = dashReport ) # Aantal nesten per provincie - tabel - plotTriasServer( + dashReport <- plotTriasServer( id = "management2_provinceTable", triasFunction = "tableNesten", data = reactive(results$species_managementData()$nesten), uiText = reactive(results$translations), maxDate = reactive(max(results$species_managementData()$nesten$observation_time, na.rm = TRUE)), - outputType = "table" + outputType = "table", + dashReport = dashReport ) + dashReport <- countYearGroupServer( + id = "management2", + uiText = reactive(results$translations), + data = reactive({ + req(results$species_managementData()) + summarizeYearGroupData( + df = results$species_managementData()$nesten, + gewest = input$species_gewest) + }), + groupChoices = reactive({ + choices <- c("", "Behandeling") + names(choices) <- c("", translate(results$translations, choices[-1])$title) + choices + }), + dashReport = dashReport + ) } else { - ## Map + choices barplot + ## Map + choices barplot: Lithobates catesbeianus - mapRegionsServer( + dashReport <- mapRegionsServer( id = "management3", uiText = reactive(results$translations), - species = reactive(input$species_choice), + species = taxonName, + gewest = reactive(req(input$species_gewest)), df = results$species_managementData, occurrenceData = occurrenceData, - shapeData = allShapes + shapeData = allShapes, + dashReport = dashReport + ) + + # Facet invasion + dashReport <- mapRegionsServer(id = "management3_facet", + uiText = reactive(results$translations), + species = taxonName, + gewest = reactive(req(input$species_gewest)), + df = results$species_managementData, + occurrenceData = NULL, + shapeData = allShapes, + facet = TRUE, + dashReport = dashReport ) - countYearGroupServer( + + dashReport <- countYearGroupServer( id = "management3", uiText = reactive(results$translations), - data = results$species_managementData + data = results$species_managementData, + groupChoices = reactive({ + choices <- c("", "lifeStage") + names(choices) <- c("", translate(results$translations, choices[-1])$title) + choices + }), + dashReport = dashReport ) } @@ -403,11 +537,11 @@ output$species_managementContent <- renderUI({ # Important: different ids needed, otherwise there is communication between both cases # e.g. input$legend exists for both - if (input$species_choice %in% cubeSpecies) { + if (taxonName() %in% cubeSpecies) { mapCubeUI(id = "management", showPeriod = TRUE, showLegend = FALSE) - } else if (input$species_choice %in% heatSpecies) { + } else if (taxonName() %in% heatSpecies) { isSeason <- Sys.Date() >= as.Date(paste0("01-04-", format(Sys.Date(), "%Y")), format = "%d-%m-%Y") & Sys.Date() < as.Date(paste0("01-12-", format(Sys.Date(), "%Y")), format = "%d-%m-%Y") @@ -423,16 +557,19 @@ output$species_managementContent <- renderUI({ ), mapHeatUI(id = "management2_observed"), mapRegionsUI(id = "management2", plotDetails = c("flanders", "region"), showUnit = FALSE), + mapRegionsUI(id = "management2_facet", showUnit = FALSE, facet = TRUE), plotTriasUI(id = "management2_lente"), countNestenUI(id = "management2_province"), - plotTriasUI(id = "management2_provinceTable", outputType = "table") + plotTriasUI(id = "management2_provinceTable", outputType = "table"), + countYearGroupUI(id = "management2", showPlotDefault = TRUE) ) } else { tagList( mapRegionsUI(id = "management3", plotDetails = c("flanders", "region")), - countYearGroupUI(id = "management3") + mapRegionsUI(id = "management3_facet", showUnit = FALSE, facet = TRUE), + countYearGroupUI(id = "management3", showPlotDefault = TRUE) ) } @@ -448,10 +585,107 @@ observe({ req(input$species_choice) # https://stackoverflow.com/a/64324799 + + # Conditionally enable 'More' shinyjs::toggleState( selector = '#species_tabs a[data-value="species_more"', + condition = input$species_choice %in% keysRiskMap + ) + # Risk maps + shinyjs::toggleState( + selector = '#species_more a[data-value="species_risk_maps"', + condition = input$species_choice %in% keysRiskMap + ) + # All other subpanels + shinyjs::toggleState( + selector = '#species_more a[data-value="species_habitats"', condition = FALSE ) + shinyjs::toggleState( + selector = '#species_more a[data-value="species_links"', + condition = FALSE + ) + shinyjs::toggleState( + selector = '#species_more a[data-value="species_risk_management"', + condition = FALSE + ) + shinyjs::toggleState( + selector = '#species_more a[data-value="species_images"', + condition = FALSE + ) + + }) + + +observe({ + + req(input$species_choice) + + mapRasterServer( + id = "risk", + uiText = reactive(results$translations), + species = taxonName, + taxonKey = reactive(input$species_choice) + ) }) + + +## SUBMIT & DOWNLOAD report ## + +species_reportFile <- reactiveVal() + +observe({ + + updateActionButton(inputId = "species_createReport", + label = translate(data = results$translations, id = "createReport")$title) + + }) + +observeEvent(input$species_createReport, { + + species_reportFile(NULL) # reset on each button press + + withProgress(message = paste(translate(data = results$translations, id = "createReport")$title, '...\n'), value = 0, { + + oldDir <- getwd() + setwd(tempdir()) + on.exit(setwd(oldDir)) + + fromFiles <- system.file("app/www", c( + "reportSpecies.Rmd", + "plotSpecies.Rmd", + "plotLandscape.Rmd" + ), package = "alienSpecies") + file.copy(from = fromFiles, to = file.path(tempdir(), basename(fromFiles)), overwrite = TRUE) + + species_reportFile( + rmarkdown::render( + input = file.path(tempdir(), basename(fromFiles[1])), + output_file = tempfile(fileext = ".pdf"), + intermediates_dir = tempdir(), + output_options = list( + bigLogo = getPathLogo(type = "combined") + ) + ) + ) + + # report is ready, trigger download + setProgress(1) + + session$sendCustomMessage(type = "imageReady", + message = list(id = "species_downloadReport")) + + }) + + }) + + +output$species_downloadReport <- downloadHandler( + filename = function() + nameFile(species = taxonName(), content = "report", fileExt = "pdf"), + content = function(file) + file.copy(species_reportFile(), file, overwrite = TRUE) +) + diff --git a/alienSpecies/inst/app/serverFiles/serverStart.R b/alienSpecies/inst/app/serverFiles/serverStart.R index a40aa05..3a3af4e 100644 --- a/alienSpecies/inst/app/serverFiles/serverStart.R +++ b/alienSpecies/inst/app/serverFiles/serverStart.R @@ -23,22 +23,6 @@ output$start_tiles <- renderUI({ }) -output$start_disclaimer <- renderUI({ - - if (doDebug) - tagList( - tags$b("Disclaimer"), - tags$ul( - lapply(c(attr(exotenData, "warning"), attr(occurrenceData, "warning")), function(iText) - tags$li(iText) - ) - ), - helpText("Only shown in debug mode") - ) - - }) - - observeEvent(input$start_navigate, { if (input$start_navigate == "early_warning") @@ -51,4 +35,18 @@ observeEvent(input$tabs, { updateRadioButtons(session = session, inputId = "start_navigate", selected = input$tabs) + }) + + +# Titles for pages in navbar +output$checklist_title <- renderUI({ + + translate(results$translations, id = tabChoices[2])$title + + }) + +output$species_title <- renderUI({ + + translate(data = results$translations, id = tabChoices[3])$title + }) \ No newline at end of file diff --git a/alienSpecies/inst/app/ui.R b/alienSpecies/inst/app/ui.R index d1f8080..6757e7a 100644 --- a/alienSpecies/inst/app/ui.R +++ b/alienSpecies/inst/app/ui.R @@ -42,8 +42,8 @@ shinyUI( img(src = "logo.png", float = "top", height = "45px"), style = "margin-top: -13px; margin-bottom: -13px; margin-left: -150px; margin-right: 50px;", tags$script(HTML(paste("var header = $('.navbar > .container');", - "header.append('
", - paste0("v", packageVersion("alienSpecies")),"
')")) + "header.append('
", + versionUI(id = "main"),"
')")) )), windowTitle = "Alien Species Portal", fluid = FALSE, @@ -63,7 +63,7 @@ shinyUI( tags$p( tags$div(uiOutput("shareLink"), style = "display: inline-block;"), "-", - tags$a(id = "contact", href="mailto:faunabeheer@inbo.be?SUBJECT=Alien species web applicatie", target="_blank", "Contact") + tags$a(id = "contact", href="mailto:mailto:faunabeheer@inbo.be?subject=Alien%20species%20web%20applicatie&body=**Describe%20the%20bug**%0AA%20clear%20and%20concise%20description%20of%20what%20the%20bug%20is.%0A%0A**To%20Reproduce**%0ASteps%20to%20reproduce%20the%20behavior%3A%0A1.%20Go%20to%20%27...%27%0A2.%20Click%20on%20%27....%27%0A3.%20Scroll%20down%20to%20%27....%27%0A4.%20See%20error%0A%0A**Expected%20behavior**%0AA%20clear%20and%20concise%20description%20of%20what%20you%20expected%20to%20happen.%0A%0A**Screenshots**%0AIf%20applicable%2C%20add%20screenshots%20to%20help%20explain%20your%20problem.%0A%0A**Desktop%20%28please%20complete%20the%20following%20information%29%3A**%0A%20-%20OS%3A%20%5Be.g.%20iOS%5D%0A%20-%20Browser%20%5Be.g.%20chrome%2C%20safari%5D%0A%20-%20Version%20%5Be.g.%2022%5D%0A%0A**Smartphone%20%28please%20complete%20the%20following%20information%29%3A**%0A%20-%20Device%3A%20%5Be.g.%20iPhone6%5D%0A%20-%20OS%3A%20%5Be.g.%20iOS8.1%5D%0A%20-%20Browser%20%5Be.g.%20stock%20browser%2C%20safari%5D%0A%20-%20Version%20%5Be.g.%2022%5D%0A%0A**Additional%20context**%0AAdd%20any%20other%20context%20about%20the%20problem%20here.", target="_blank", "Contact") ) ) ) diff --git a/alienSpecies/inst/app/uiFiles/uiChecklist.R b/alienSpecies/inst/app/uiFiles/uiChecklist.R index a2c0c6b..2044c43 100644 --- a/alienSpecies/inst/app/uiFiles/uiChecklist.R +++ b/alienSpecies/inst/app/uiFiles/uiChecklist.R @@ -6,14 +6,14 @@ tagList( tags$div(class = "container", - - welcomeSectionUI(id = "checklist"), - - wellPanel( + tags$div(class = "jumbotron", + + welcomeSectionUI(id = "checklist"), # https://stackoverflow.com/a/60315446 # uiOutput("filter_taxa"), - selectizeInput(inputId = "exoten_taxa", label = NULL, choices = NULL, multiple = TRUE), + selectizeInput(inputId = "exoten_taxa", label = NULL, choices = NULL, multiple = TRUE, + width = "100%"), fixedRow( # Select habitat @@ -29,7 +29,8 @@ tagList( ), - actionLink("exoten_more", label = "More", icon = icon("angle-double-down")), + actionLink("exoten_more", label = "More", + icon = icon("angle-double-down", class = "green-icon")), conditionalPanel("input.exoten_more % 2 == 1", @@ -62,9 +63,9 @@ tagList( tags$div(class = "container", style = "margin-bottom: 10px;", - tabsetPanel( + tabsetPanel(id = "exoten_tabs", - tabPanel(titleModuleUI(id = "checklist_taxa"), + tabPanel(value = "checklist_taxa", titleModuleUI(id = "checklist_taxa"), tags$div(style = "margin-top: 10px;", @@ -80,13 +81,13 @@ tagList( ), - tabPanel(titleModuleUI(id = "checklist_trend"), + tabPanel(value = "checklist_trend", titleModuleUI(id = "checklist_trend"), plotTriasUI(id = "checklist-count"), plotTriasUI(id = "checklist-cum"), countOccupancyUI(id = "checklist") ), - tabPanel(titleModuleUI(id = "checklist_pathways"), + tabPanel(value = "checklist_pathways", titleModuleUI(id = "checklist_pathways"), plotTriasUI(id = "checklist_tablePathway", outputType = "table"), plotTriasUI(id = "checklist_pathway1"), @@ -96,7 +97,7 @@ tagList( ), - tabPanel(titleModuleUI(id = "checklist_origin"), + tabPanel(value = "checklist_origin", titleModuleUI(id = "checklist_origin"), plotTriasUI(id = "checklist_yearNativeRange") ) ) diff --git a/alienSpecies/inst/app/uiFiles/uiSpecies.R b/alienSpecies/inst/app/uiFiles/uiSpecies.R index 46c1605..73ef92f 100644 --- a/alienSpecies/inst/app/uiFiles/uiSpecies.R +++ b/alienSpecies/inst/app/uiFiles/uiSpecies.R @@ -5,12 +5,24 @@ tagList( + + tags$div(class = "container", + tags$div(class = "jumbotron", + + welcomeSectionUI(id = "species"), + fixedRow( + column(6, + selectInput(inputId = "species_choice", label = NULL, choices = NULL, + width = "100%")), + column(6, + selectInput(inputId = "species_gewest", label = NULL, + choices = NULL, multiple = TRUE, width = "100%")) + ) + ) + ), tags$div(class = "container", - - selectInput(inputId = "species_choice", label = NULL, - choices = NULL, width = "100%"), - + tabsetPanel(id = "species_tabs", tabPanel(titleModuleUI(id = "species_observations"), @@ -23,7 +35,8 @@ tagList( tabPanel(titleModuleUI(id = "species_indicators"), value = "species_indicators", tags$div(style = "margin-top: 10px;", - plotTriasUI(id = "species_gam"), + plotTriasUI(id = "indicators_gamObservations", showPlotDefault = TRUE), + plotTriasUI(id = "indicators_gamOccupancy", showPlotDefault = TRUE) ) ), @@ -43,14 +56,29 @@ tagList( tabPanel(titleModuleUI(id = "species_more"), value = "species_more", - tabsetPanel( + tabsetPanel(id = "species_more", tabPanel(titleModuleUI(id = "species_habitats"), value = "species_habitats"), - tabPanel(titleModuleUI(id = "species_risk_maps"), value = "species_risk_maps"), + tabPanel(titleModuleUI(id = "species_risk_maps"), value = "species_risk_maps", + mapRasterUI("risk") + ), tabPanel(titleModuleUI(id = "species_links"), value = "species_links"), tabPanel(titleModuleUI(id = "species_risk_assessment"), value = "species_risk_management"), tabPanel(titleModuleUI(id = "species_images"), value = "species_images") ) ) + ), + + tags$div(style = "margin-bottom: 70px;"), + + tags$div(class = "footer", + tags$div(class = "footer-content", + singleton( + tags$head(tags$script(src = "triggerDownload.js")) + ), + actionButton(inputId = "species_createReport", label = "Create report", + icon = icon("file-pdf")), + downloadLink("species_downloadReport", " ", class = "invisible") + ) ) ) ) \ No newline at end of file diff --git a/alienSpecies/inst/app/uiFiles/uiStart.R b/alienSpecies/inst/app/uiFiles/uiStart.R index bf3c04c..0834806 100644 --- a/alienSpecies/inst/app/uiFiles/uiStart.R +++ b/alienSpecies/inst/app/uiFiles/uiStart.R @@ -1,12 +1,14 @@ tagList( - tags$div(align = "right", - tags$p( - actionLink(inputId = "translate_en", label = "EN"), - "-", - actionLink(inputId = "translate_fr", label = "FR"), - "-", - actionLink(inputId = "translate_nl", label = "NL") + tags$div(class = "container", + tags$div(align = "right", + tags$p( + actionLink(inputId = "translate_en", label = "EN"), + "-", + actionLink(inputId = "translate_fr", label = "FR"), + "-", + actionLink(inputId = "translate_nl", label = "NL") + ) ) ), tags$div(class = "container", @@ -14,6 +16,5 @@ tagList( tags$div(class = "noButton", uiOutput("start_tiles") ) - ), - uiOutput("start_disclaimer") + ) ) \ No newline at end of file diff --git a/alienSpecies/inst/app/www/buttonPopup.css b/alienSpecies/inst/app/www/buttonPopup.css index b25e103..abf22aa 100644 --- a/alienSpecies/inst/app/www/buttonPopup.css +++ b/alienSpecies/inst/app/www/buttonPopup.css @@ -1,18 +1,23 @@ /* =============== select button with popup window =============== */ /* caret on the right of the button*/ -button#exoten_timeButton .fa.fa-caret-down::before { +button#exoten_timeButton .fa.fa-angle-down::after { float: right; } button#exoten_timeButton .fa { - display: inline; + display: inline; } /*button*/ button#exoten_timeButton { -margin-bottom: 15px; -margin-left: 25px; -margin-right: 25px; + margin-bottom: 15px; + margin-left: 25px; + margin-right: 25px; + color: #757575; + font-family: FlandersArtSans, sans-serif; + font-size: 16px; + text-align: left; + height: 34px; } div.selection-button { diff --git a/alienSpecies/inst/app/www/comboTree.css b/alienSpecies/inst/app/www/comboTree.css index 8d40213..3fd81a5 100644 --- a/alienSpecies/inst/app/www/comboTree.css +++ b/alienSpecies/inst/app/www/comboTree.css @@ -11,12 +11,12 @@ --ct-bg: #fff; --ct-btn-hover: #e8e8e8; --ct-btn-active: #ddd; - --ct-btn-color: #555; - --ct-border-color: #e1e1e1; - --ct-border-radius: 5px; + --ct-btn-color: #ccc; + --ct-border-color: #ccc; + --ct-border-radius: 4px; --ct-tree-hover: #efefef; --ct-selection: #418EFF; - --ct-padding: 8px; + --ct-padding: 12px; } @@ -133,6 +133,7 @@ span.comboTreeItemTitle{ width: 100%; box-sizing: border-box; padding-right: 24px; + height: 34px; } .comboTreeInputBox:focus { border: 1px solid var(--ct-selection); diff --git a/alienSpecies/inst/app/www/logoCombined.png b/alienSpecies/inst/app/www/logoCombined.png new file mode 100644 index 0000000..4d286f4 Binary files /dev/null and b/alienSpecies/inst/app/www/logoCombined.png differ diff --git a/alienSpecies/inst/app/www/navbar.css b/alienSpecies/inst/app/www/navbar.css index ce58ea6..13a75f0 100644 --- a/alienSpecies/inst/app/www/navbar.css +++ b/alienSpecies/inst/app/www/navbar.css @@ -17,3 +17,18 @@ color: #ccc !important; cursor: not-allowed !important; } + +.footer { + position: fixed; + bottom: 0pt; + background-color: white; + width: 100%; + z-index: 10000; +} + +.footer-content { + margin-left: 10px; + margin-top: 10px; + margin-bottom: 10px; +} + diff --git a/alienSpecies/inst/app/www/plotLandscape.Rmd b/alienSpecies/inst/app/www/plotLandscape.Rmd new file mode 100644 index 0000000..2ab5e3f --- /dev/null +++ b/alienSpecies/inst/app/www/plotLandscape.Rmd @@ -0,0 +1,9 @@ +```{r eval = (tools::file_ext(params$plot) == "html")} +webshot::webshot(url = params$plot, vwidth = 1200, vheight = 600, cliprect = "viewport") +``` + +```{r eval = (tools::file_ext(params$plot) == "png"), results = "asis"} +knitr::include_graphics(params$plot) +``` + + diff --git a/alienSpecies/inst/app/www/plotSpecies.Rmd b/alienSpecies/inst/app/www/plotSpecies.Rmd new file mode 100644 index 0000000..fcc338c --- /dev/null +++ b/alienSpecies/inst/app/www/plotSpecies.Rmd @@ -0,0 +1,95 @@ +```{r, echo = FALSE, results = "asis"} + +# Printed in this order in report +allParams <- c("regionLevel", "region", "period", "year", + "correctBias", "protectAreas", "source", "group", "summarizeBy", + "gender", "samplingProtocol", "lifeStage") +currentLandscape <- FALSE + +tryCatch({ + + params <- dashReport[[id]] + currentParams <- names(params) + + if (is.character(params$plot) && file.exists(params$plot)) { + # expects path to map + currentLandscape <- TRUE + cat("\n\n\\blandscape\n") + } + + cat("##", params$title, "\n\n") + + # Description + cat(params$description, "\n\n") + + + # Parameters + if (any(allParams %in% currentParams)) { + + cat(paste0("**", translate(results$translations, "parameters")$title, "**\n\n")) + + for (iParam in currentParams[currentParams %in% allParams]) { + cat(paste0("- ", translate(results$translations, iParam)$title, ": ")) + if (is.character(params[[iParam]])) + cat(toString(translate(results$translations, params[[iParam]])$title), "\n\n") + else if (is.numeric(params[[iParam]])) + cat(paste(params[[iParam]], collapse = " - "), "\n\n") + else if (is.logical(params[[iParam]])) + cat(if (params[[iParam]]) + translate(results$translations, "yes")$title else + translate(results$translations, "no")$title, "\n\n") + + } + } else { + + cat(paste0("*", translate(results$translations, "noParameters")$title, "*\n\n")) + + } + + # Plot + if (is(params$plot, "plotly")) { + + # plotly + plotlyReport(params$plot) + + } else if (is.character(params$plot)) { + + # leaflet & landscape: not working directly + cat(knitr::knit_child("plotLandscape.Rmd", quiet = TRUE, envir = environment())) + cat("\n\n\\elandscape\n") + + } else { + + # DT table + DT::datatable(params$plot$data, rownames = FALSE, + colnames = params$plot$columnNames, + selection = "single", + options = list(dom = 'ftp', pageLength = -1)) + + } + + }, error = function(err) { + if (currentLandscape) + cat("\n\n\\elandscape\n") + + cat("No results for", + decodeText(translate(results$translations, id)$title, + params = c( + list(species = taxonName()) + ) + ), "\n\n") + + }) +``` + +```{r, echo = FALSE, results = "asis"} +if (is(params$plotFlanders, "plotly")) + plotlyReport(params$plotFlanders) +``` + +```{r, echo = FALSE, results = "asis"} +if (is(params$plotRegion, "plotly")) + plotlyReport(params$plotRegion) +``` + +\newpage diff --git a/alienSpecies/inst/app/www/reportSpecies.Rmd b/alienSpecies/inst/app/www/reportSpecies.Rmd new file mode 100644 index 0000000..d7d8fc9 --- /dev/null +++ b/alienSpecies/inst/app/www/reportSpecies.Rmd @@ -0,0 +1,104 @@ +--- +title: "`r paste0(translate(data = results$translations, id = 'species_information')$title, ': ', taxonName())`" +author: "`r paste0('v', packageVersion('alienSpecies'))`" +date: "`r format(Sys.Date(), '%d-%m-%Y')`" +toc-title: "r paste(translate(data = results$translations, id = 'contents')$title" +output: + oaStyle::pdf_report: + logo: NULL + bigLogoSize: 15cm + always_allow_html: yes + latex_engine: pdflatex +header-includes: +- \usepackage{pdflscape} +- \newcommand{\blandscape}{\begin{landscape}} +- \newcommand{\elandscape}{\end{landscape}} +editor_options: + chunk_output_type: console +--- + +```{r knitr, echo = FALSE, results = 'hide', warning = FALSE} +library(knitr) +knitr::opts_chunk$set( + echo = FALSE, + warning = FALSE, + message = FALSE, + fig.align = 'center', + fig.width = 10, + fig.height = 8 +) + +gewestNames <- sapply(input$species_gewest, function(x) + translate(data = results$translations, id = x)$title) +``` + +--- +subtitle: "`r toString(gewestNames)`" +--- + + +```{r intro, results = "asis"} +cat("*", translate(data = results$translations, id = 'species')$title, ":", taxonName(), "\n") +cat("*", translate(data = results$translations, id = 'region')$title, ":", toString(gewestNames), "\n") +``` + + + +```{r sectionObservations, results = "asis"} +myTitle <- translate(results$translations, "observations")$title +cat("#", toupper(myTitle), "\n\n") +incProgress(amount = 0.2, detail = myTitle) + +childOutput <- lapply(grep("observations", names(dashReport), value = TRUE), function(id) + knitr::knit_child("plotSpecies.Rmd", quiet = TRUE, envir = environment()) +) +cat(unlist(childOutput), sep = '\n') +``` + + +```{r sectionIndicators, results = "asis"} +myTitle <- translate(results$translations, "indicators")$title +cat("#", toupper(myTitle), "\n\n") +incProgress(amount = 0.2, detail = myTitle) + +childOutput <- lapply(grep("indicators", names(dashReport), value = TRUE), function(id) + knitr::knit_child("plotSpecies.Rmd", quiet = TRUE, envir = environment()) +) +cat(unlist(childOutput), sep = '\n') +``` + + +```{r sectionReporting, results = "asis"} +myTitle <- translate(results$translations, "reporting")$title +cat("#", toupper(myTitle), "\n\n") +incProgress(amount = 0.2, detail = myTitle) + +childOutput <- lapply(grep("reporting", names(dashReport), value = TRUE), function(id) + knitr::knit_child("plotSpecies.Rmd", quiet = TRUE, envir = environment()) +) +cat(unlist(childOutput), sep = '\n') +``` + + +```{r sectionManagement, results = "asis"} +myTitle <- translate(results$translations, "management")$title +cat("#", toupper(myTitle), "\n\n") +incProgress(amount = 0.2, detail = myTitle) + +mgtKey <- if (taxonName() %in% cubeSpecies) + "management" else if (taxonName() %in% heatSpecies) + "management2" else + "management3" +# Define order to be the same as in the app +managementIds <- paste0(mgtKey, c("-mapOccurrence", "_facet-mapInvasion", +"_lente-barplotLenteNesten", "_province-countNesten", "_provinceTable-tableNesten", +"-countYearGroup")) +managementIds <- managementIds[managementIds %in% names(dashReport)] + +childOutput <- lapply(managementIds, function(id) + knitr::knit_child("plotSpecies.Rmd", quiet = TRUE, envir = environment()) +) +cat(unlist(childOutput), sep = '\n') +``` + + diff --git a/alienSpecies/inst/app/www/style.css b/alienSpecies/inst/app/www/style.css index 7c765ba..156b886 100644 --- a/alienSpecies/inst/app/www/style.css +++ b/alienSpecies/inst/app/www/style.css @@ -36,6 +36,9 @@ footer { margin-top: 20px; } +.loader { + min-height: 40px !important; +} /*** For the fancy noButton but tiles - radiobuttons ***/ @@ -70,7 +73,7 @@ a, a:visited, a:hover, a:active, a:focus { } -#showShare, #contact, #translate_en, #translate_fr, #translate_nl { +#showShare, #contact, #translate_en, #translate_fr, #translate_nl, .version { font-size: 14px; line-height: 20px; color: #595959 @@ -135,10 +138,22 @@ a, a:visited, a:hover, a:active, a:focus { color: #fff; } +.shiny-download-link .invisible { + background-color: white; +} + +.shiny-download-link:hover .invisible { + background-color: white; +} + .fa-download { color: #fff; } +.green-icon { + color: #c1c443; +} + p, li, label { font-size: 16px } @@ -156,3 +171,19 @@ p, li, label { } + +/*** Customize Global Indicators page ***/ + +.jumbotron h1 { + font-size: 36px; +} + +.long-selectize { + padding: 5px; + padding-left: 10px; +} + +.form-control { + font-size: 16px; +} + diff --git a/alienSpecies/inst/extdata/osm/7_64_42.png b/alienSpecies/inst/extdata/osm/7_64_42.png new file mode 100644 index 0000000..8ee3865 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_64_42.png differ diff --git a/alienSpecies/inst/extdata/osm/7_64_43.png b/alienSpecies/inst/extdata/osm/7_64_43.png new file mode 100644 index 0000000..01f4077 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_64_43.png differ diff --git a/alienSpecies/inst/extdata/osm/7_65_42.png b/alienSpecies/inst/extdata/osm/7_65_42.png new file mode 100644 index 0000000..d2a8135 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_65_42.png differ diff --git a/alienSpecies/inst/extdata/osm/7_65_43.png b/alienSpecies/inst/extdata/osm/7_65_43.png new file mode 100644 index 0000000..696c603 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_65_43.png differ diff --git a/alienSpecies/inst/extdata/osm/7_66_42.png b/alienSpecies/inst/extdata/osm/7_66_42.png new file mode 100644 index 0000000..1a88415 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_66_42.png differ diff --git a/alienSpecies/inst/extdata/osm/7_66_43.png b/alienSpecies/inst/extdata/osm/7_66_43.png new file mode 100644 index 0000000..9466e72 Binary files /dev/null and b/alienSpecies/inst/extdata/osm/7_66_43.png differ diff --git a/alienSpecies/inst/tests/testthat/testData.R b/alienSpecies/inst/tests/testthat/testData.R index 05bc67f..26f23a4 100644 --- a/alienSpecies/inst/tests/testthat/testData.R +++ b/alienSpecies/inst/tests/testthat/testData.R @@ -182,34 +182,26 @@ test_that("Load shape data", { test_that("Load exotenData", { exotenData <- loadTabularData(type = "indicators") - expect_s3_class( exotenData, "data.table") + expect_s3_class(exotenData, "data.table") }) - test_that("Load unionlistData", { unionlistData <- loadTabularData(type = "unionlist") - - expect_s3_class( unionlistData, "data.table") - + expect_s3_class(unionlistData, "data.table") }) test_that("Load occurrenceData", { occurrenceData <- loadTabularData(type = "occurrence") - expect_s3_class( occurrenceData, "data.table") - + expect_s3_class(occurrenceData, "data.table") }) - - test_that("Load full_timeseries", { - readS3(file = "full_timeseries.RData") - expect_true(exists("timeseries")) + timeseries <- loadTabularData(type = "timeseries") expect_s3_class(timeseries, "data.table") }) test_that("Load cube data", { - occupancy <- loadOccupancyData() expect_true(exists("dfCube")) expect_s3_class(occupancy, "data.table") diff --git a/alienSpecies/tests/testthat/testChecklist.R b/alienSpecies/tests/testthat/testChecklist.R index bc8ffeb..d6a8f96 100644 --- a/alienSpecies/tests/testthat/testChecklist.R +++ b/alienSpecies/tests/testthat/testChecklist.R @@ -51,6 +51,31 @@ test_that("Trigger errors data filtering" , { inputLevels = NULL)) }) +test_that("Translate exoten data", { + +# exotenData <- loadTabularData(type = "indicators") + translations <- loadMetaData(language = "nl") + + time1 <- Sys.time() + exotenData[, pathway_level2_translate := translate(translations, do.call(paste, c(.SD, sep = "_")))$title, + .SDcols = c("pathway_level1", "pathway_level2")] + print(Sys.time() - time1) +# exotenData$habitat_translate <- sapply(exotenData$habitat, function(x) +# paste(translate(translations, strsplit(x, split = "\\|")[[1]])$title, collapse = "|")) +# print(Sys.time() - time1) + exotenData[, ':=' ( + pathway_level1_translate = translate(translations, pathway_level1)$title, + native_continent_translate = translate(translations, native_continent)$title, + native_range_translate = translate(translations, native_range)$title, + degree_of_establishment_translate = translate(translations, degree_of_establishment)$title, + habitat_translate = translate(translations, habitat)$title + )] + print(Sys.time() - time1) + + expect_is(exotenData, "data.table") + + }) + test_that("Define user choices and filter data", { # choices @@ -159,7 +184,12 @@ test_that("Grafiek: Mate van verspreiding van de Unielijstsoorten", { ## PLOT 4 test_that("Grafiek: Aantal geïntroduceerde uitheemse soorten per jaar per regio van oorsprong", { - tmpResult <- trias::indicator_native_range_year(df = exotenData) + # Data for single species + speciesData <- exotenData[exotenData$degree_of_establishment == "invasive", ] + + tmpResult <- trias::indicator_native_range_year(df = speciesData, + type = "native_continent", # native_continent or native_range + taxon_key_col = "key") expect_type(tmpResult, "list") expect_s3_class(tmpResult$interactive_plot, "plotly") diff --git a/alienSpecies/tests/testthat/testClimateRisk.R b/alienSpecies/tests/testthat/testClimateRisk.R new file mode 100644 index 0000000..e2273e9 --- /dev/null +++ b/alienSpecies/tests/testthat/testClimateRisk.R @@ -0,0 +1,63 @@ +# Climate risk maps +# +# Code: https://github.com/trias-project/risk-maps/tree/main +# Live: https://trias-project.github.io/risk-maps/ +# +# Author: mvarewyck +############################################################################### + + +taxData <- loadTabularData(type = "occurrence") +allSpecies <- c("Psittacula krameri") + +test_that("Create climate risk map", { + + # Specify trias risk map file + + keyChoice <- unique(taxData$taxonKey[taxData$scientificName %in% allSpecies]) + keyChoice <- 2479226 + + climateChoice <- c("hist", "rcp26", "rcp45", "rcp85")[1] + mapChoice <- c("", "conf", "diff")[1] + + tiffPath <- "https://raw.githubusercontent.com/trias-project/risk-maps/main/public/geotiffs" + tiffFile <- paste0(paste("be", keyChoice, climateChoice, sep = "_"), + if (mapChoice != "") paste0("_", mapChoice), ".4326.tif") + + # List files from GIT -> if any files for the species, show tab 'More' + library(httr) + request <- GET("https://api.github.com/repos/trias-project/risk-maps/contents/public/geotiffs") + stop_for_status(request) + filelist <- sapply(content(request), function(x) x$path) + keyFiles <- grep(keyChoice, filelist, value = TRUE, fixed = TRUE) + + keyChoices <- unique(sapply(content(request), function(x) strsplit(gsub("public/geotiffs/be_", "", x$path), split = "_")[[1]][1])) + + # Given user specification + download.file(file.path(tiffPath, tiffFile), + destfile = file.path(tempdir(), tiffFile), method = "curl") + + library(terra) + rasterInput <- terra::rast(x = file.path(tempdir(), tiffFile)) + #plot(r) + # Error: external pointer is not valid + # Ignore, doesn't limit plotting and only in Eclipse + # See also: https://www.eclipse.org/lists/statet-users/msg00142.html + + # Need leaflet >= 2.2.0 (https://github.com/rstudio/leaflet/issues/865) + myPlot <- mapRaster(rasterInput = rasterInput, addGlobe = FALSE) + + myPlot %>% addTiles(options = tileOptions(zIndex = -10)) + + }) + +## CODE from trias project - which tif files are used + +#if (this.mapTypeId === "") { +# return `${this.publicPath}geotiffs/be_${this.speciesId}_${this.climateScenarioId}.4326.tif`; +#} else { +# return `${this.publicPath}geotiffs/be_${this.speciesId}_${this.climateScenarioId}_${this.mapTypeId}.4326.tif`; +#} + + + diff --git a/alienSpecies/tests/testthat/testManagement.R b/alienSpecies/tests/testthat/testManagement.R index e48be44..5275b69 100644 --- a/alienSpecies/tests/testthat/testManagement.R +++ b/alienSpecies/tests/testthat/testManagement.R @@ -154,7 +154,26 @@ test_that("Trend for Bullfrogs", { }) - +test_that("Map invasion", { + + currentYear <- 2023 + + summaryData <- createSummaryRegions( + data = managementData, + shapeData = allShapes, + regionLevel = "provinces", + year = list( + c(currentYear-8, currentYear-5), + c(currentYear-4, currentYear-1), + currentYear) + ) + + myPlot <- mapRegionsFacet(managementData = summaryData, + shapeData = allShapes, regionLevel = "provinces") + + expect_s3_class(myPlot, "ggplot") + + }) ## Aziatische hoornaar ## @@ -167,14 +186,14 @@ test_that("Actieve haarden", { combinedData <- combineActiveData( activeData = Vespa_velutina_shape$actieve_haarden, - managedData = Vespa_velutina_shape$beheerde_nesten, +# managedData = Vespa_velutina_shape$beheerde_nesten, untreatedData = Vespa_velutina_shape$onbehandelde_nesten ) myPlot <- mapHeat( combinedData = combinedData, colors = { - myColors <- c("blue", "black", "red") - names(myColors) <- c("individual", "managed nest", "untreated nest") + myColors <- c("blue", "black") + names(myColors) <- c("individual", "untreated nest") myColors }, selected = unique(combinedData$filter), @@ -190,7 +209,11 @@ test_that("Actieve haarden", { test_that("Alle observaties", { - combinedData <- combineNestenData(pointsData = Vespa_velutina_shape$points, nestenData = Vespa_velutina_shape$nesten) + combinedData <- combineNestenData( + pointsData = Vespa_velutina_shape$points, + nestenData = Vespa_velutina_shape$nesten, + currentYear = 2024 + ) myPlot <- mapHeat( combinedData = combinedData, colors = { @@ -217,7 +240,8 @@ test_that("Voorjaarsnesten", { test_that("Provincie nesten", { - df <- createSummaryNesten(data = Vespa_velutina_shape$nesten, regionLevel = "gewest", + df <- createSummaryNesten(data = Vespa_velutina_shape$nesten, + regionLevel = "provinces", typeNesten = c("AE", "AP")) myPlot <- trendYearRegion(df = df) expect_s3_class(myPlot$plot, "plotly") @@ -230,57 +254,32 @@ test_that("Provincie nesten", { test_that("Map Trend", { - ## Points data - vespaPoints <- Vespa_velutina_shape$points - vespaPoints$type <- "individual" - - ## Refactor data - # Columns - regionVariables <- list(level3Name = "NAAM", level2Name = "provincie", level1Name = "GEWEST") - for (iName in names(regionVariables)) - names(vespaPoints)[match(iName, names(vespaPoints))] <- regionVariables[[iName]] - # Gewest - vespaPoints$GEWEST <- ifelse(vespaPoints$GEWEST == "Vlaanderen", "flanders", - ifelse(vespaPoints$GEWEST == "Bruxelles", "brussels", - ifelse(vespaPoints$GEWEST == "Wallonie", "wallonia", ""))) - # Provincie - vespaPoints$provincie <- ifelse(vespaPoints$provincie == "Vlaams Brabant", "Vlaams-Brabant", - ifelse(vespaPoints$provincie == "Bruxelles", "HoofdstedelijkGewest", - ifelse(vespaPoints$provincie == "Liège", "Luik", - ifelse(vespaPoints$provincie == "Brabant Wallon", "Waals-Brabant", - ifelse(vespaPoints$provincie == "Hainaut", "Henegouwen", vespaPoints$provincie))))) - - summaryData <- createSummaryRegions(data = vespaPoints, shapeData = allShapes, + # Combine all data + vespaBoth <- combineVespaData( + pointsData = Vespa_velutina_shape$points, + nestenData = Vespa_velutina_shape$nesten, + nestenBeheerdData = Vespa_velutina_shape$beheerde_nesten) + + ## POINTS data + # Per municipality + summaryData <- createSummaryRegions( + data = vespaBoth[vespaBoth$type %in% "individual", ], + shapeData = allShapes, regionLevel = "communes", - year = 2022, - unit = "absolute") + year = 2022) mapRegions(managementData = summaryData, shapeData = allShapes, regionLevel = "communes") - - summaryData <- createSummaryRegions(data = vespaPoints, shapeData = allShapes, + # Per province + summaryData <- createSummaryRegions( + data = vespaBoth[vespaBoth$type %in% "individual", ], + shapeData = allShapes, regionLevel = "provinces", - year = 2022, - unit = "absolute") + year = 2022) mapRegions(managementData = summaryData, shapeData = allShapes, regionLevel = "provinces") - ## Nesten data - vespaNesten <- Vespa_velutina_shape$nesten - vespaNesten$type <- "nest" - -# Vespa_velutina_shape$beheerde_nesten[!(Vespa_velutina_shape$beheerde_nesten$geometry %in% Vespa_velutina_shape$nesten$geometry), c("id", "comments", "NAAM", "geometry")] - vespaNesten$isBeheerd <- vespaNesten$geometry %in% Vespa_velutina_shape$beheerde_nesten$geometry - - - # Nesten and Points combined on 1 map - test from here - vespaPoints$nest_type <- "individual" - vespaPoints$isBeheerd <- FALSE - keepColumns <- c("year", "type", "nest_type", "NAAM", - "provincie", "GEWEST", "isBeheerd", - "geometry") - vespaBoth <- rbind(vespaPoints[, keepColumns], vespaNesten[, keepColumns]) - vespaBoth$nest_type[vespaBoth$nest_type %in% c("NA", "NULL")] <- NA + ## POINTS and NESTEN data summaryData <- createSummaryRegions( data = vespaBoth, shapeData = allShapes, regionLevel = "provinces", @@ -290,10 +289,66 @@ test_that("Map Trend", { mapRegions(managementData = summaryData, shapeData = allShapes, regionLevel = "provinces") + summaryData <- createSummaryRegions( + data = vespaBoth, shapeData = allShapes, + regionLevel = "provinces", + groupingVariable = c("nest_type", "isBeheerd"), + year = 2018:2023, + unit = NULL) + + trendYearRegion(df = summaryData)$plot + # create popup with summary table in it - mapPopup(summaryData = summaryData, uiText = uiText, year = 2023, unit = "absolute", bronMap = "nesten") + tmpText <- mapPopup(summaryData = summaryData, uiText = uiText, year = 2023, + unit = NULL, bronMap = "individual") }) + +test_that("Management succes", { + + plotData <- summarizeYearGroupData(df = Vespa_velutina_shape$nesten, + gewest = "flanders") + + countYearGroup(df = plotData, groupVar = "Behandeling") + + }) + +test_that("Map invasion", { + + # Combine all data + vespaBoth <- combineVespaData( + pointsData = Vespa_velutina_shape$points, + nestenData = Vespa_velutina_shape$nesten, + nestenBeheerdData = Vespa_velutina_shape$beheerde_nesten) + + # User selection + regionLevel <- c("provinces", "communes")[2] + addGlobe <- c(FALSE, TRUE)[2] + legend <- c("none", "left", "right", "bottom", "top")[4] + currentYear <- 2023 + + ## POINTS data + # Per province + summaryData <- createSummaryRegions( +# data = vespaBoth[vespaBoth$type %in% "nest", ], + data = vespaBoth, + shapeData = allShapes, + regionLevel = regionLevel, + year = list( + c(currentYear-8, currentYear-5), + c(currentYear-4, currentYear-1), + currentYear) + ) + + myPlot <- mapRegionsFacet(managementData = summaryData, + shapeData = allShapes, regionLevel = regionLevel, uiText = uiText, + legend = legend, addGlobe = addGlobe) + # TODO globe layer slows down the graph + # Alternative: https://yutani.rbind.io/post/2018-06-09-plot-osm-tiles/ + + expect_s3_class(myPlot, "ggplot") + + }) @@ -381,4 +436,28 @@ test_that("Trend for Muskrat", { }) +test_that("Map invasion", { + + currentYear <- 2023 + + summaryData <- createSummaryRegions( + data = managementData, + shapeData = allShapes, + regionLevel = "provinces", + year = list( + c(currentYear-8, currentYear-5), + c(currentYear-4, currentYear-1), + currentYear) + ) + + myPlot <- mapRegionsFacet(managementData = summaryData, + shapeData = allShapes, regionLevel = "provinces") + + expect_s3_class(myPlot, "ggplot") + + }) + + + + diff --git a/alienSpecies/tests/testthat/testShiny.R b/alienSpecies/tests/testthat/testShiny.R index 34aeb7f..c336f30 100644 --- a/alienSpecies/tests/testthat/testShiny.R +++ b/alienSpecies/tests/testthat/testShiny.R @@ -77,8 +77,6 @@ test_that("Module mapCube", { mySpecies <- "Oxyura jamaicensis" - - dictionary <- loadMetaData(type = "keys") myKey <- dictionary$taxonKey[match(mySpecies, dictionary$scientificName)] @@ -86,14 +84,16 @@ test_that("Module mapCube", { args = list( uiText = reactive(translations), species = reactive(mySpecies), + gewest = reactive("flanders"), df = reactive(occurrenceData[taxonKey %in% myKey, ]), groupVariable = "cell_code", shapeData = allShapes, showPeriod = TRUE ), { session$setInputs(period = c(2002, 2020)) - expect_true(!is.null(output$region)) + expect_true(!is.null(output$legend)) }) + }) @@ -139,6 +139,7 @@ test_that("Module plotModule", { plotFunction = "plotTrias", triasFunction = "indicator_introduction_year", data = reactive(exotenData), + uiText = reactive(translations), triasArgs = reactive(list( start_year_plot = 2002, x_lab = "Jaar", @@ -206,7 +207,6 @@ test_that("Module mapHeat",{ combinedActive <- combineActiveData( activeData = Vespa_velutina_shape$actieve_haarden, - managedData = Vespa_velutina_shape$beheerde_nesten, untreatedData = Vespa_velutina_shape$onbehandelde_nesten ) colorsActive <- c("blue", "black", "red") @@ -216,11 +216,12 @@ test_that("Module mapHeat",{ args = list( uiText = reactive(translationsEn), species = reactive( "Vespa velutina"), + gewest = reactive("flanders"), combinedData = reactive(combinedActive), filter = reactive(list(nest = unique(combinedActive$filter), radius = na.omit(unique(combinedActive$radius)))), colors = reactive(colorsActive), blur = "individual", - maxDate = reactive(max( Vespa_velutina_shape$actieve_haarden$eventDate, na.rm = TRUE)) + maxDate = reactive(max(Vespa_velutina_shape$actieve_haarden$eventDate, na.rm = TRUE)) ), { session$setInputs(globe = 2) @@ -303,7 +304,7 @@ test_that("Module countNesten",{ ), { session$setInputs(linkCountNesten = 1) #session$setInputs(linkPlotTrias = 1) - session$setInputs(period = c(2017,2023)) + session$setInputs(period = c(2020,2023)) session$setInputs(regionLevel = "communes") session$setInputs( typeNesten = "individual") expect_true(!is.null(output$descriptionCountNesten )) diff --git a/alienSpecies/tests/testthat/testSpecies.R b/alienSpecies/tests/testthat/testSpecies.R index 54f5a0f..f2675ee 100644 --- a/alienSpecies/tests/testthat/testSpecies.R +++ b/alienSpecies/tests/testthat/testSpecies.R @@ -88,28 +88,39 @@ test_that("Occurrence plots", { test_that("Emergence status GAM - Observations", { + + ## Note: fitting GAM model only works when loading the R-package using library(alienSpecies) + ## When loading via devtools::load_all() there is a conflict with config::get() + ## which can be resolved by + ## library(config) + ## conflicted::conflict_prefer("get", "base", "config") - readS3(file = "full_timeseries.RData") + myKey <- unique(taxData$taxonKey[taxData$scientificName %in% allSpecies[2]]) + + timeseries <- loadTabularData(type = "timeseries") - timeseries <- summarizeTimeSeries( - rawData = timeseries, + subData <- summarizeTimeSeries( + timeseries = timeseries, + species = myKey, region = c("flanders", "brussels") ) - myKey <- unique(taxData$taxonKey[taxData$scientificName %in% allSpecies[2]]) - correctBias <- c(TRUE, FALSE)[1] isProtected <- c(TRUE, FALSE)[2] - subData <- timeseries[taxonKey %in% myKey, ] subData <- subData[protected == isProtected, ] tmpResult <- plotTrias(triasFunction = "apply_gam", df = subData, triasArgs = list( y_var = "obs", - eval_years = min(subData$year):max(subData$year), - taxon_key = myKey, name = allSpecies[2], + # not restricting the data? + eval_years = 2008, +# eval_years = min(subData$year):max(subData$year), + taxon_key = myKey, + name = allSpecies[2], + type_indicator = "observations", + baseline_var = if (correctBias) "cobs", verbose = TRUE) ) @@ -121,6 +132,40 @@ test_that("Emergence status GAM - Observations", { }) +test_that("Emergence status GAM - Occupancy", { + + myKey <- unique(taxData$taxonKey[taxData$scientificName %in% allSpecies[2]]) + + timeseries <- loadTabularData(type = "timeseries") + + subData <- summarizeTimeSeries( + timeseries = timeseries, + species = myKey, + region = c("flanders", "brussels") + ) + + correctBias <- c(TRUE, FALSE)[2] + isProtected <- c(TRUE, FALSE)[2] + + subData <- subData[protected == isProtected, ] + + tmpResult <- plotTrias(triasFunction = "apply_gam", + df = subData, + triasArgs = list( + y_var = "ncells", + eval_years = min(subData$year):max(subData$year), + taxon_key = myKey, name = allSpecies[2], + baseline_var = if (correctBias) "c_ncells", + verbose = TRUE) + ) + + expect_type(tmpResult, "list") + expect_s3_class(tmpResult$plot, "plotly") + expect_s3_class(tmpResult$data, "data.frame") + + }) + + test_that("Reporting t0 and t1", {