R et Shiny peuvent-ils faire de moi un meilleur pêcheur ? Partie 3

Dans cet article précédent, j’ai présenté l’application Shiny que j’ai développée pour enregistrer les données de mes sessions de pêche. Dans cet article, je vais présenter brièvement les modifications et les mises à jour que j’ai apportées pour améliorer l’application. Voici les principaux changements :

• API Météo : l’API que j’utilisais (Dark Sky) a arrêté de fournir des données gratuites. Je suis donc passé à Openweathermap et j’ai dû mettre à jour les fonctions pour récupérer les mêmes informations qu’avant.

• Débit de la rivière : la première version de l’application ne collectait pas de données sur le débit de la rivière dans laquelle je pêche. Cependant, je suis convaincu que le débit de la rivière avant la session de pêche peut avoir un impact sur la présence de bar. J’ai donc créé une fonction de web scraping qui collecte les débits de la Nive et de l’Adour (les principales rivières où je pêche).

• Collecte des données sur les leurres : dans la première version, les données sur les leurres utilisés n’étaient collectées que lorsqu’un poisson était capturé. Cependant, je n’avais pas de données sur le temps que je passais à utiliser un leurre avant de capturer un poisson. La nouvelle version de l’application collecte maintenant des données sur le leurre et la fréquence à laquelle je change de leurre.

API Météo

De petites modifications ont été apportées pour adapter la fonction météo précédente à la nouvelle API météo. Comme cette nouvelle API ne fournit pas de données sur la phase de la lune, j’ai décidé de calculer la phase de la lune avec le package oce :

library(httr)
library(jsonlite)
library(tidyverse)
library(rvest)
library(oce)

weather <- function(lat, lon, API_key){
  url <- paste0("api.openweathermap.org/data/2.5/weather?lat=", lat, "&lon=", lon, "&appid=", API_key, "&units=metric")
  
  rep <- GET(url)
  
  table <- fromJSON(content(rep, "text"))
  
  # The weather API don't provide moon phase so I compute it with Oce package
  moon_phase <- round(moonAngle(t = Sys.Date(),
                                longitude = as.numeric(lon),
                                latitude = as.numeric(lat))$illuminatedFraction,
                      3)
  
  
  current.weather.info <- data.frame(Air_temp = table$main$temp,
                                     Weather = table$weather$main,
                                     Atm_pres = table$main$pressure,
                                     Wind_str = table$wind$speed,
                                     Wind_dir = table$wind$deg,
                                     Cloud_cover = table$clouds$all,
                                     PrecipInt = ifelse(is.null(table$rains$`1h`), 0, table$rains$`1h`),  
                                     Moon = moon_phase)
  return(current.weather.info)
}

Débit de la rivière

J’ai écrit des fonctions pour scrapper des informations sur les débits des rivières dans lesquelles je pêche le plus, sur un site web :

# Get and prepare the flow data
get_Qdata <- function(link){
  table <- fromJSON(content(GET(link), "text"))
  table <- table$Serie$ObssHydro
  table <- as.data.frame(table)
  table$DtObsHydro <- sub("T", " ", table$DtObsHydro)
  table$DtObsHydro <- substr(table$DtObsHydro, start = 1, stop = 19)
  ts <- data.frame(Date = seq.POSIXt(as.POSIXct(range(table$DtObsHydro)[1],'%m/%d/%y %H:%M:%S'), 
                                     as.POSIXct(range(table$DtObsHydro)[2],'%m/%d/%y %H:%M:%S'), by="hour"))
  
  table$DtObsHydro <- as.POSIXct(table$DtObsHydro, format = "%Y-%m-%d %H:%M:%S")
  
  table <- full_join(table, ts, by = c("DtObsHydro" = "Date")) %>% arrange(DtObsHydro)
  return(table)
}

# Main function to collect river flow 

river_flow <- function(){
  # Url of website to scrap:
  url_index <- "https://www.vigicrues.gouv.fr/services/station.json/index.php"
  
  rep <- GET(url_index)
  
  table_index <- fromJSON(content(rep, "text"))$Stations%>% 
    na.omit()
  
  # I need to add the flow of several rivers to get the flow of the rivers I am interested in:
  stations <- table_index %>% 
    filter(LbStationHydro %in% c("Pontonx-sur-l'Adour", "St-Pandelon", "Artiguelouve", "Escos",
                                 "Aïcirits [St-Palais]", "Cambo-les-Bains"))
  
  base_url <- "http://www.vigicrues.gouv.fr/services/observations.json?CdStationHydro="
  height_url <- "&FormatDate=iso"
  Q_url <- "&GrdSerie=Q"
  
  stations <- stations %>% 
    mutate(WL_link = paste0(base_url, CdStationHydro, height_url),
           Q_link = paste0(WL_link, Q_url))
  
  data_Q <- lapply(stations$Q_link, 
                   function(x){get_Qdata(x)})
  
  data_Q <- suppressWarnings(Reduce(function(...) merge(..., all = TRUE, by = "DtObsHydro"),
                   data_Q))
  
  names(data_Q) <- c("Date", stations$LbStationHydro) 
  
  data_Q <- data_Q  %>% 
    mutate(hour_of_day = format(Date, "%Y-%m-%d %H"))
  
  
  data_Q <- aggregate(.~hour_of_day, data = data_Q, mean, na.rm = TRUE, na.action = na.pass)
  
  data_Q <- imputeTS::na_interpolation(data_Q, option = "linear")
  
  final_data <- data_Q %>% 
    mutate(Adour = `Pontonx-sur-l'Adour` +  `Aïcirits [St-Palais]` + Artiguelouve + Escos + `St-Pandelon`,
           Date = as.POSIXct(hour_of_day, tryFormats = "%Y-%m-%d %H")) %>% 
    select(Date, `Cambo-les-Bains`, Adour) %>% 
    rename(Nive = `Cambo-les-Bains`)
  
  Cur_flow <- data.frame("Nive_c" = final_data[nrow(final_data), 2],
                         "Adour_c" = final_data[nrow(final_data), 3])
  
  
  final_data <- cbind(Cur_flow, final_data) %>% 
    nest(Ts_flow = c(Date, Nive, Adour)) %>% 
    mutate(Ts_flow = paste(Ts_flow))

  return(final_data)
}

Application Shiny

Un graphique simplifié de la nouvelle application est montré ci-dessous :

Graphique simplifié de la nouvelle application

Côté UI

Le côté UI n’a pas beaucoup changé, j’ai seulement supprimé l’onglet qui affichait les données de pêche sur une carte car je n’utilisais pas beaucoup cette fonctionnalité :

# Load libraries 
library(shiny)
library(shinyWidgets)
library(googlesheets)
library(miniUI)
library(leaflet)
library(rdrop2)
Sys.setenv(TZ="Europe/Paris")

#Import the functions for weather API and webscrapping 
suppressMessages(source("api_functions.R"))


# Load the dropbox token : 
token <<- readRDS("token.rds")

# Minipage for small screens
ui <- miniPage(tags$script('$(document).ready(function () {
                           navigator.geolocation.getCurrentPosition(onSuccess, onError);

                           function onError (err) {
                           Shiny.onInputChange("geolocation", false);
                           }

                           function onSuccess (position) {
                           setTimeout(function () {
                           var coords = position.coords;
                           console.log(coords.latitude + ", " + coords.longitude);
                           Shiny.onInputChange("geolocation", true);
                           Shiny.onInputChange("lat", coords.latitude);
                           Shiny.onInputChange("long", coords.longitude);
                           }, 1100)
                           }
                           });'),
               
               gadgetTitleBar("Catch them all", left = NULL, right = NULL),
               
               miniTabstripPanel(
                 
                 miniTabPanel("Session", icon = icon("sliders"),
                              
                              miniContentPanel(uiOutput("UI_sess", align = "center"),
                                               uiOutput("UI", align = "center"))
                              
                 )
               )
               
)

Côté serveur

Plusieurs changements ont été apportés du côté serveur pour collecter des données sur les leurres que j’utilise. Désormais, chaque fois que je change de leurre, je remplis un petit formulaire pour collecter les caractéristiques du leurre et cela ajoute une ligne dans un troisième fichier csv :

server <- function(input, output, session){
  
  observeEvent(input$go ,{
    
  # Read the csv file containing information about fishing session. If a session is running,
  # display the UI that allows the user to input data about the fish caught. If a session is not started,
  # display a button to start the session and small survey on lure characteristics.
    
    dat <<- drop_read_csv("/app_peche/session1.csv", header = T, stringsAsFactors = F, dtoken = token)
    
    # Reactive UI
    
    output$UI <- renderUI({
      
      if(!is.na(rev(dat$End)[1])){
        # We now indicate what type of lure we use at the beginning of the session:
        tagList(
          selectInput("lure1", 
                      label = "Type de leurre",
                      choices = list("Shad" = "shad",
                                     "Slug" = "slug",
                                     "Jerkbait" = "jerkbait",
                                     "Casting jig" = "jig",
                                     "Topwater" = "topwater"),
                      selected = "shad",
                      selectize = FALSE),
          
          selectInput("color_lure1", 
                      label = "Couleur du leurre",
                      choices = list("Naturel" = "naturel",
                                     "Sombre" = "sombre",
                                     "Clair" = "clair",
                                     "Flashy" = "flashy" ),
                      selected = "naturel",
                      selectize = FALSE),
          
          selectInput("length_lure1",
                      label = "Taille du leurre",
                      choices = list("Petit" = "petit",
                                     "Moyen" = "moyen",
                                     "Grand" = "grand"),
                      selected = "petit",
                      selectize = FALSE),
          
          actionButton("go","Commencer session !"))
      }else{
        
        tagList(actionButton("go","End session"))
      }
      
    })
    
    output$UI_sess <- renderUI({
      
      if(!is.na(rev(dat$End)[1])){
        
        tagList(textInput("comments", label = "Commentaire avant le début?", value = "NA"))
        
      }else{
        input$catch
        input$lure
        tagList(
          
          selectInput("lure_type", 
                      label = "Type de leurre",
                      choices = list("Shad" = "shad",
                                     "Slug" = "slug",
                                     "Jerkbait" = "jerkbait",
                                     "Casting jig" = "jig",
                                     "Topwater" = "topwater"),
                      selected = "shad",
                      selectize = FALSE),
          
          selectInput("color_lure", 
                      label = "Couleur du leurre",
                      choices = list("Naturel" = "naturel",
                                     "Sombre" = "sombre",
                                     "Clair" = "clair",
                                     "Flashy" = "flashy" ),
                      selected = "naturel",
                      selectize = FALSE),
          
          selectInput("length_lure",
                      label = "Taille du leurre",
                      choices = list("Petit" = "petit",
                                     "Moyen" = "moyen",
                                     "Grand" = "grand"),
                      selected = "petit",
                      selectize = FALSE),
          
          actionButton("lure",
                       label = "Changer de leurre!"),
          
          br(), 
          br(), 
          
          h4("Ajouter une capture"),
          
          selectInput("species", 
                      label = "Espèces",
                      choices = list("Bar" = "bar",
                                     "Bar moucheté" = "bar_m",
                                     "Alose" = "alose",
                                     "Maquereau" = "maquereau",
                                     "Chinchard" = "chinchard"),
                      selected = "bar"),
          
          sliderInput("length",
                      label = "Taille du poisson",
                      value = 25, 
                      min = 0, 
                      max = 80, 
                      step = 1),
          
          actionButton("catch","Rajoutez cette capture aux stats!"),
          
          br(), 
          br(), 
          
          textInput("comments1", label = h4("Commentaire avant la fin ?"), value = "NA")
        )
      }
    })
  }, ignoreNULL = F)
  
  
  #If the button is pushed, create the line to be added in the csv file. 
  
  observeEvent(input$go,{
    
    # Two outcomes depending if the session starts or ends. This gives the possibility 
    # to the user to add a comment before starting the session or after ending the session
    
    if(!is.na(rev(dat$End)[1])){
      
      #Tide + geoloc + Weather
      c_tide <- tide()
      geoloc <- c(input$lat,input$long)
      current.weather.info <- weather(lat = geoloc[1], lon = geoloc[2])
      river.flow <- river_flow()
      
      n_ses <- c(rev(dat$Session)[1] + 1)
      time_beg <- as.character(as.POSIXct(Sys.time()))
      comment <- input$comments
      dat.f <<- cbind(data.frame(n_ses,
                                 time_beg,
                                 NA,
                                 geoloc[2],
                                 geoloc[1]),
                      current.weather.info,
                      c_tide,
                      river.flow,
                      comment)
      names(dat.f) <- names(dat)
      print(dat.f)
      final_dat <- rbind(dat, dat.f)
      
      lure <- drop_read_csv("/app_peche/lure.csv",
                            header = T,
                            stringsAsFactors = F,
                            dtoken = token)
      
      new_lure <- data.frame(n_ses = n_ses,
                             time = as.character(as.POSIXct(Sys.time())),
                             type_lure = input$lure1,
                             color_lure = input$color_lure1,
                             length_lure = input$length_lure1)
      
      new_df <- rbind(lure, 
                      new_lure)
      
      write_csv(as.data.frame(new_df), "lure.csv")
      drop_upload("lure.csv", path = "App_peche", mode = "overwrite", dtoken = token)
      

    }else{
      
      dat$End[nrow(dat)] <- as.character(as.POSIXct(Sys.time()))
      dat$Comments[nrow(dat)] <- paste(dat$Comments[nrow(dat)], "/", input$comments1)
      final_dat <- dat 
    }
    
    # Write csv in temporary files of shiny server 
    write_csv(as.data.frame(final_dat), "session1.csv")
    
    # Upload it to dropbox account 
    drop_upload("session1.csv", path = "App_peche", mode = "overwrite", dtoken = token)
  })
  
  # Add a line to the catch csv file whenever a fish is caught
  observeEvent(input$catch,{
    caugth <- drop_read_csv("/app_peche/catch1.csv", header = T, stringsAsFactors = F, dtoken = token)
    
    catch <- data.frame(n_ses = dat$Session[nrow(dat)],
                        time = as.character(as.POSIXct(Sys.time())),
                        species = input$species,
                        length = input$length)
    
    b <- rbind(caugth,catch)
    
    write_csv(as.data.frame(b), "catch1.csv")
    drop_upload("catch1.csv", path = "App_peche", mode = "overwrite", dtoken = token)
  })
  
  
  observeEvent(input$lure,{
    lure <- drop_read_csv("/app_peche/lure.csv",
                          header = T,
                          stringsAsFactors = F,
                          dtoken = token)
    
    new_lure <- data.frame(n_ses = dat$Session[nrow(dat)],
                        time = as.character(as.POSIXct(Sys.time())),
                        type_lure = input$lure_type,
                        color_lure = input$color_lure,
                        length_lure = input$length_lure)
    
    new_df <- rbind(lure, 
               new_lure)
    
    write_csv(as.data.frame(new_df), "lure.csv")
    drop_upload("lure.csv", path = "App_peche", mode = "overwrite", dtoken = token)
  })
}

Conclusion

J’ai testé cette nouvelle application lors de deux sessions de pêche et elle fonctionne à merveille. J’ai hâte de vous présenter mes résultats à la fin de cette saison de pêche !