---
title: "lighthouse"
output:
flexdashboard::flex_dashboard:
logo: logo_AQUATEL_1.svg
theme: united
css: style2.css
source_code: embed
orientation: columns
vertical_layout: fill
---
```{r setup, include=FALSE}
library(dplyr)
library(tidyr)
library(DT)
library(stringr)
library(lubridate)
library(leaflet)
library(crosstalk)
library(plotly)
library(purrr)
library(leafem)
library(leaflet.extras)
library(htmltools)
library(leafpop)
knitr::opts_knit$set(root.dir = "~/R/lighthouse/R/")
knitr::opts_chunk$set(echo = F, cache = F, message = F, warning = F)
```
```{r load data,}
load("/mnt/D/Documents/Maitrise/Paper/Models/Data/models_db.RData")
if (!file.exists("/mnt/D/Documents/Maitrise/Paper/Models/DataLog.csv")) {
DataLog <- models_db %>% select(ID,PID) %>%
mutate(QC_SPM=1,
QC_Ag=1,
QC_Bbp=1,
Comment="")
write.csv(DataLog, "/mnt/D/Documents/Maitrise/Paper/Models/DataLog.csv", row.names=F)
} else {
DataLog <- readr::read_csv("/mnt/D/Documents/Maitrise/Paper/Models/DataLog.csv")
}
br_check <- function(Zsecchi,Zstation){
if (is.na(Zsecchi) | is.na(Zstation)) {
NA
} else if (Zsecchi > Zstation){
NA
} else if (Zsecchi == 999) {
T
} else if (Zsecchi*2 > Zstation) {
T
} else {
F
}
}
models_db <- models_db %>% left_join(DataLog %>% select(ID,QC_SPM,QC_Ag,QC_Bbp,Comment), by="ID") %>%
mutate(Region = ifelse(str_detect(Project,"CHONe|WISE|PMZA"),"EGSL","JB"),
OptShallow = br_check(Zsecchi,Zstation),
PIM_frac = ifelse((PIM/SPM)*100 <= 100,(PIM/SPM)*100,NA)) %>%
relocate(matches("QC|Comment|ROI|Region"), .after = "DateTime") %>%
relocate("OptShallow", .after = "Zsecchi")
wide_sensor <- models_db %>%
select(!c("data")) %>%
unnest(cols = c(OLI,S2A), names_sep="_")
wide_sensor <- wide_sensor %>% rename_with(~str_replace(.,"S2A","MSI"), starts_with("S2A")) %>%
mutate(across(matches("OLI|MSI"), ~na_if(., .<0)))
long_sensor <- wide_sensor %>%
pivot_longer(cols = all_of(str_subset(names(wide_sensor),"OLI|MSI")),
names_to = c("Sensor","Band","Cwl"),
values_to = "Rrs",
values_drop_na = T,
names_sep = "_") %>%
mutate(Cwl = as.numeric(Cwl))
possibleApprox <- purrr::possibly(approx, otherwise=NA)
approx_op <- models_db %>%
mutate(dataprox = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Rrs,c(380:800), na.rm = T)))) %>%
mutate(dataprox = purrr::map(dataprox, ~ dplyr::rename(.,Lambda = x, Rrs = y))) %>%
relocate(dataprox, .after=data)
long_insitu <- approx_op %>%
mutate(dataprox = (purrr::map(dataprox, ~ dplyr::filter(., Lambda %in% c(380,395,440,560,665,710,740,800))))) %>%
select(!c("OLI","S2A","data")) %>%
unnest(cols= c(dataprox))
wide_insitu <- long_insitu %>%
pivot_wider(names_from = Lambda,
values_from = Rrs,
names_prefix = "Rrs_") %>%
relocate(matches("Rrs"), .after = Region) %>%
ungroup()
```
```{r interpolation of iop to common wl 394-700 nm}
iop_long <- wide_insitu %>%
select(matches("^ID$|A_|Ap_|Aph_|Ag_|Anap_|Bbp_|Bb_")) %>%
pivot_longer(cols = all_of(str_subset(names(wide_insitu), "A_|Ap_|Aph_|Ag_|Anap_|Bbp_|Bb_")),
names_to = c(".value","Lambda"),
names_pattern = "(.+)_(.+)",
values_drop_na = T
) %>%
mutate(Lambda = as.numeric(Lambda))
iop_nest <- iop_long %>% arrange(ID,Lambda) %>%
group_by(ID) %>% nest()
possibleApprox <- purrr::possibly(approx, otherwise=NA)
Approxiop <- iop_nest %>%
mutate(
Lambda = purrr::map(.x = data, ~ data.frame(Lambda = .x$Lambda)),
A = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$A,.x$Lambda, na.rm = T))),
Ap = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Ap,.x$Lambda, na.rm = T))),
Aph = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Aph,.x$Lambda, na.rm = T))),
Anap = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Anap,.x$Lambda, na.rm = T))),
Ag = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Ag,.x$Lambda, na.rm = T))),
Bbp = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Bbp,.x$Lambda, na.rm = T))),
Bb = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Bb,.x$Lambda, na.rm = T))),
) %>%
select(ID,Lambda,A,Ap,Aph,Anap,Ag,Bbp,Bb)
Approxiop <- Approxiop %>%
dplyr::filter(purrr::map_lgl(A, ~ !is_empty(.)) | purrr::map_lgl(Ap, ~ !is_empty(.)) | purrr::map_lgl(Aph, ~ !is_empty(.)) | purrr::map_lgl(Anap, ~ !is_empty(.)) | purrr::map_lgl(Ag, ~ !is_empty(.)) | purrr::map_lgl(Bbp, ~ !is_empty(.)) | purrr::map_lgl(Bb, ~ !is_empty(.)))
Approxiop <- Approxiop %>% unnest(cols = c(Lambda, A, Ap, Aph, Anap, Ag, Bbp, Bb), names_sep="_")
Approxiop <- Approxiop %>% select(A_x,!contains("x")) %>% mutate(
Lambda = as.numeric(Lambda_Lambda),
A = A_y,
Ap = Ap_y,
Aph = Aph_y,
Anap = Anap_y,
Ag = Ag_y,
Bbp = Bbp_y,
Bb = Bb_y
) %>%
select(!contains(c("y","x","Lambda_Lambda"))) %>%
filter(Lambda %in%
c(305,320,330,340,380,394,395,412,420,443,465,470,490,510,532,555,560,589,620,625,665,683,694,700,710,740,780,875))
iopgate <- wide_insitu %>%
select(ID,PID,Project,Station,Zstation,DateTime,Comment,SPM,QC_SPM,QC_Ag) %>%
right_join(Approxiop, by="ID")
```
```{r sharedata objects}
sd_iops <- SharedData$new(iopgate %>% group_by(ID), key = ~str_pad(ID,3,pad = "0"), group = "iops")
submap <- wide_insitu %>% mutate(DateTime = as.POSIXct(DateTime, tz='UTC', format = "%Y-%m-%dT%H:%M:%S")) %>%
select(ID,PID,Project,Station,DateTime,SPM,Zstation,Zsecchi,Lat,Lon,Ag_440,SID) %>%
group_by(ID)
sd_map <- SharedData$new(submap, key = ~str_pad(ID,3,pad = "0"), group = "iops")
subrrs <- long_insitu %>%
select(ID,PID,Station,Zstation,Zsecchi,DateTime,Comment,Lambda,Rrs,SPM,Ag_440,QC_SPM,QC_Ag) %>%
group_by(ID)
sd_rrs <- SharedData$new(subrrs, key = ~str_pad(ID,3,pad = "0"), group = "iops")
subtab <- wide_insitu %>%
mutate(ID = str_pad(ID,3,pad = "0"),
DateTime = as.POSIXct(DateTime, tz='UTC', format = "%Y-%m-%dT%H:%M:%S")) %>%
select(ID,SID,PID,SPID,Station,Zstation,Zsecchi,DateTime,QC_SPM,QC_Ag,Comment) %>% group_by(ID)
sd_tab <- SharedData$new(subtab, key = ~str_pad(ID,3,pad = "0"), group = "iops")
```
Row {.sidebar}
-----------------------------------------------------------------------
### filters
```{r}
filter_checkbox(id = "Project",
label = "Project",
sharedData = sd_map,
group = ~Project,
inline = T
)
filter_select(id = "ID",
label = "ID",
sharedData = sd_map,
group = ~ID
)
filter_select(id = "PID",
label = "PID",
sharedData = sd_map,
group = ~PID
)
filter_select(id = "Station",
label = "Station",
sharedData = sd_map,
group = ~Station
)
filter_select(id = "DateTime",
label = "Date",
sharedData = sd_map,
group = ~lubridate::date(DateTime)
)
filter_slider(id = "Depth",
label = "Station Depth",
sharedData = sd_map,
column = ~Zstation
)
filter_slider(id = "SPM",
label = "SPM concentration",
sharedData = sd_map,
column = ~signif(SPM,2)
)
filter_slider(id = "Ag_440",
label = "CDOM concentration",
sharedData = sd_map,
column = ~signif(Ag_440,2)
)
```
Column {data-width=450}
-------------------------------------
### map
```{r map}
link <- "/mnt/D/Data/WISEMan/L2/066/COPS_Kildir/PDF/WISE_CAST_006_190821_143528_URC.csv.pdf"
map <- leaflet(sd_map) %>%
addScaleBar("bottomright") %>% leafem::addMouseCoordinates() %>%
addProviderTiles(provider = providers$CartoDB.Positron, group = 'Positron') %>%
addProviderTiles("Esri.WorldImagery", group = 'Aerial') %>%
addProviderTiles("OpenTopoMap", group = 'Terrain') %>%
addAwesomeMarkers(lat = ~Lat, lng = ~Lon,
group = "Stations",
label = ~paste0("PID: ", PID),
popup = ~paste0('Station Details',
'ID: ', ID, '',
'SID: ', str_c(SID, collapse = ", "), '',
'PID: ', PID, '',
'Station: ', Station, '',
'DateTime: ', DateTime, '',
'SPM: ', SPM, ' [mg.l-1]',
'Zstation: ', Zstation, ' [m-1]',
'Zsecchi: ', Zsecchi, ' [m-1]',
paste0('COPS Report:')
)
) %>%
addLayersControl(
baseGroups = c("Positron", "Aerial", "Terrain"),
overlayGroups = 'Stations',
options = layersControlOptions(collapsed = TRUE)
) %>%
addEasyButton(easyButton(
icon="fa-globe", title="Zoom to Level 1",
onClick=JS("function(btn, map){ map.setZoom(1); }"))) %>%
addEasyButton(easyButton(
icon="fa-crosshairs", title="Locate Me",
onClick=JS("function(btn, map){ map.locate({setView: true}); }"))) %>%
addSearchFeatures(targetGroups = c("Stations"))
map
```
### data table
```{r}
datatable(sd_tab,
extensions = c("Buttons", "Scroller", "Select"),
filter = "top",
escape = TRUE, rownames = FALSE,
style = "bootstrap",
class = "compact",
height = 100,
options = list(
dom = "Brtip",
select = list(style = 'os', items = 'row'),
buttons = list(I("colvis"),"selectNone","csv"),
columnDefs = list(
list(
visible = FALSE,
targets = c(1,3,5,6,8,9)
)),
deferRender = TRUE,
scrollY = 10,
pageLength = 10,
scroller = TRUE
),
selection = "none"
)
```
Column {.tabset}
-------------------------------------
### Rrs
```{r Rrs ,echo=FALSE, message=FALSE}
prrs <- plot_ly(sd_rrs, x = ~Lambda, y = ~Rrs,
text=~paste0(
'ID: ', ID, '',
'PID: ', PID, '',
'Station: ', Station, '',
'DateTime: ', DateTime, '',
'SPM: ', SPM, ' [mg.L-1]',
'ag(440): ', Ag_440, ' [m-1]',
'Zstation: ', Zstation, ' [m-1]',
'Zsecchi: ', Zsecchi, ' [m-1]',
'QC: ', QC_SPM, '',
'Comment: ', Comment, ''
)) %>%
add_lines(color = ~as.character(QC_SPM), colors = c("0" = "red", "1" = "steelblue3", "2"="orange"), showlegend= T) %>%
layout(
shapes = list(
type = "rect", fillcolor = "transparent", xref = "paper", yref = "paper", x0 = 0, x1 = 1, y0 = 0.01, y1 = 1),
xaxis = list(title = TeX("wavelength\\ [nm]"), type = ""),
yaxis = list(title = TeX("R_{rs}\\ [sr^{-1}]"), type = "")
) %>%
highlight(on = "plotly_click", off = "plotly_relayout", selectize = F, dynamic = F, persistent = F) %>%
config(mathjax = "cdn", displayModeBar = T)
prrs
```
### IOPs
```{r IOPs, echo=FALSE, message=FALSE}
piops <- plot_ly(sd_iops, x = ~Lambda, visible = "legendonly",
text=~paste0(
'PID: ', PID, '',
'Station: ', Station, '',
'DateTime: ', DateTime, '',
'SPM: ', SPM, ' [mg.l-1]',
'Zstation: ', Zstation, ' [m-1]',
'QC: ', QC_Ag, '',
'Comment: ', Comment, ''
)) %>%
add_lines(y = ~A , color="A", showlegend = T) %>%
add_lines(y = ~Ap , color="Ap", showlegend = T) %>%
add_lines(y = ~Aph , color="Aph", showlegend = T) %>%
add_lines(y = ~Anap , color="Anap", showlegend = T) %>%
add_lines(y = ~Ag , color="Ag", showlegend = T) %>%
add_lines(y = ~Bb , color="Bb", showlegend = T) %>%
add_lines(y = ~Bbp , color="Bbp", showlegend = T) %>%
layout(
shapes = list(
type = "rect", fillcolor = "transparent", xref = "paper", yref = "paper", x0 = 0, x1 = 1, y0 = 0.01, y1 = 1),
xaxis = list(title = TeX("wavelength\\ [nm]"), type = ""),
yaxis = list(title = TeX("IOP\\ coefficient\\ [m^{-1}]"), type = "")
) %>%
highlight(on = "plotly_click", off = "plotly_relayout", selectize = F, dynamic = F, persistent = F) %>%
config(mathjax = "cdn", displayModeBar = T)
piops
```
