Can R and Shiny make me a better fisherman? Part 3
[This article was first published on R on Aurélien Callens, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
In this previous post, I presented the shiny application I developed to record data about my fishing session. In today’s post, I will present briefly the changes and updates I made to improve the application. Here are the main changes:
Weather API: the API I was using (Dark Sky) stopped furnishing free data. I changed for Openweathermap and I needed to update the functions to gather the same information as before.
River flow: the first version of the application did not collect any data about the flow of the river in which I am fishing. However I am convinced that the river flow before the fishing session might have an impact on the presence of seabass. I therefore created a web scrapping function that collect the flow of the Nive and the Adour (main fishing rivers).
Collecting lure data: in the first version, data about fishing lures I used were only collected when a fish was caught. However I did not have data about how long I used the lure before catching a fish. The new version of the application now collects data about lure and how often I change lure.
Weather API
Small changes were made to adapt the former weather function to the new weather API. As this new API do not furnish moon phase data, I decided to compute the moon phase with the oce package:
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)
}
River flow
I wrote functions to scrap information about the flows of the rivers in which I fish the most on a french website:
# 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)
}
Shiny application
A simplified graph of the new application is showed below:
Simplified workflow of the new version of application
UI side
The UI side did not change that much, I only removed the tab that displayed fishing data on a map because I wasn’t using this feature too much:
# 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"))
)
)
)
Server side
Several changes were made in the server side to collect data about the lures I used. Now, each time I change my fishing lure, I fill a small form to collect the lure characteristics and it adds a line in a third csv file:
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
I have tested this new application during two fishing sessions and it has been working like a charm. I can’t wait to present you my findings at the end of this fishing season !
To leave a comment for the author, please follow the link and comment on their blog: R on Aurélien Callens.
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.