From b3e59982294fe4eba12a6d18fe7ac90b384a164c Mon Sep 17 00:00:00 2001 From: Simon Date: Sat, 11 Apr 2026 12:30:00 +0100 Subject: [PATCH] fix bacfill problem, add more grouping option --- app.R | 140 +++++++++++++++++++++++++++++++++- getCloseStat.R | 40 ++++------ meteofranceapi.R | 54 +++++++++++-- scripts/backfill_two_years.R | 2 +- tests/testthat/test-rain-db.R | 51 ++++++++++++- 5 files changed, 250 insertions(+), 37 deletions(-) diff --git a/app.R b/app.R index abdb0ab..72f54cc 100644 --- a/app.R +++ b/app.R @@ -84,6 +84,99 @@ format_window_label <- function(amount, unit) { sprintf("last %s %s", amount, unit_label) } + +get_rain_view_choices <- function(window_unit = "days") { + switch( + window_unit, + days = c( + "6-minute rain" = "raw", + "Daily total" = "daily" + ), + months = c( + "Daily total" = "daily", + "Weekly total" = "weekly" + ), + years = c( + "Weekly total" = "weekly", + "Monthly total" = "monthly" + ), + c( + "6-minute rain" = "raw", + "Daily total" = "daily" + ) + ) +} + + +get_metric_view_choices <- function(window_unit = "days") { + switch( + window_unit, + days = c( + "Raw observations" = "raw", + "Daily aggregate" = "daily" + ), + months = c( + "Daily aggregate" = "daily", + "Weekly aggregate" = "weekly" + ), + years = c( + "Weekly aggregate" = "weekly", + "Monthly aggregate" = "monthly" + ), + c( + "Raw observations" = "raw", + "Daily aggregate" = "daily" + ) + ) +} + + +get_preferred_window_view <- function(window_unit = "days") { + switch( + window_unit, + days = "raw", + months = "weekly", + years = "monthly", + "raw" + ) +} + + +get_summary_aggregate <- function(window_unit = "days") { + switch( + window_unit, + days = "daily", + months = "weekly", + years = "monthly", + "daily" + ) +} + + +format_aggregate_label <- function(aggregate = c("raw", "daily", "weekly", "monthly")) { + aggregate <- match.arg(aggregate) + + switch( + aggregate, + raw = "Raw", + daily = "Daily", + weekly = "Weekly", + monthly = "Monthly" + ) +} + + +format_aggregate_period_label <- function(aggregate = c("daily", "weekly", "monthly")) { + aggregate <- match.arg(aggregate) + + switch( + aggregate, + daily = "Day", + weekly = "Week", + monthly = "Month" + ) +} + ui <- fluidPage( tags$head( tags$style(HTML(" @@ -188,7 +281,7 @@ ui <- fluidPage( class = "panel-card", h3(class = "panel-title", "Rain"), withSpinner(plotOutput("rainPlot", height = "420px")), - h4("Daily rain totals"), + h4(textOutput("summaryTitle", container = span)), tableOutput("dailySummary") ) ), @@ -223,11 +316,24 @@ server <- function(input, output, session) { observeEvent(input$window_unit, { settings <- get_window_slider_config(input$window_unit) + preferred_view <- get_preferred_window_view(input$window_unit) + rain_choices <- get_rain_view_choices(input$window_unit) + metric_choices <- get_metric_view_choices(input$window_unit) current_value <- if (is.null(input$window_amount)) { settings$value } else { as.integer(input$window_amount) } + current_rain_view <- if (!is.null(input$rain_view_mode) && input$rain_view_mode %in% rain_choices) { + input$rain_view_mode + } else { + preferred_view + } + current_metric_view <- if (!is.null(input$metric_view_mode) && input$metric_view_mode %in% metric_choices) { + input$metric_view_mode + } else { + preferred_view + } updateSliderInput( session = session, @@ -238,6 +344,20 @@ server <- function(input, output, session) { value = min(max(current_value, 1L), settings$max), step = 1 ) + + updateRadioButtons( + session = session, + inputId = "rain_view_mode", + choices = rain_choices, + selected = current_rain_view + ) + + updateRadioButtons( + session = session, + inputId = "metric_view_mode", + choices = metric_choices, + selected = current_metric_view + ) }, ignoreInit = TRUE) selected_start_date <- reactive({ @@ -259,6 +379,10 @@ server <- function(input, output, session) { as.integer(Sys.Date() - selected_start_date()) + 1L }) + selected_summary_aggregate <- reactive({ + get_summary_aggregate(input$window_unit) + }) + cached_rain <- reactive({ data_version() @@ -291,7 +415,7 @@ server <- function(input, output, session) { location_id = input$location_id, start_date = selected_start_date(), end_date = Sys.Date(), - aggregate = "daily", + aggregate = selected_summary_aggregate(), db_path = db_path ) }) @@ -310,6 +434,13 @@ server <- function(input, output, session) { selected_metric()$label }) + output$summaryTitle <- renderText({ + sprintf( + "%s rain totals", + format_aggregate_label(selected_summary_aggregate()) + ) + }) + output$syncControls <- renderUI({ if (is.null(api_headers)) { return( @@ -474,8 +605,9 @@ server <- function(input, output, session) { return(NULL) } - names(summary_data) <- c("Station ID", "Station", "Day", "Metric", "Label", "Unit", "Rain") - summary_data[, c("Station", "Day", "Rain")] + period_label <- format_aggregate_period_label(selected_summary_aggregate()) + names(summary_data) <- c("Station ID", "Station", period_label, "Metric", "Label", "Unit", "Rain") + summary_data[, c("Station", period_label, "Rain")] }, striped = TRUE, spacing = "s", digits = 2) output$metricLatest <- renderTable({ diff --git a/getCloseStat.R b/getCloseStat.R index deca9b4..9215f08 100644 --- a/getCloseStat.R +++ b/getCloseStat.R @@ -9,40 +9,32 @@ headers.default <- add_headers( apikey = token4 ) -getAllFromCoord <- function(coord,start_date,end_date,allstations,N=3,headers,base="https://public-api.meteofrance.fr"){ - three_station=getIdFromCoords(coord,allstations,N=N) - alldata=lapply(three_station$Id_station,function(statid){ - print(paste("recuperer station",statid)) - allstat=tryCatch(getStationData(start_date=start_date,end_date=end_date,station_id=statid,headers=headers,base=base), - error=function(e){print(e);NULL}) - print(paste("done, sleep 5 sec")) - print(dim(allstat)) - Sys.sleep(5) - return(allstat) - }) - alldata= do.call("rbind.data.frame",alldata) - ids=three_station$Nom_usuel - names(ids)=three_station$Id_station - cbind.data.frame(alldata,Nom_usuel=ids[as.character(alldata[,1])]) -} - allstations=read.csv("allstations.csv") #get all station lacouch.coor <- c(45.3722971,5.6387118) -lamure.coor <- c(44.9167, 5.8000) vignass.coor=c(44.8550665,5.8441789) foreve=list() -for(y in 0:3){ - enddate=format(Sys.Date()-y*365, "%Y-%m-%d") - startdate=format(Sys.Date()-(y*365+364), "%Y-%m-%d") - foreve=tryCatch(getAllFromCoord(vignass.coor,startdate,enddate,allstations,headers=headers.default,base="https://public-api.meteofrance.fr"),error=function(e)e) +n_periods = 10 +for (i in 0:(n_periods-1)) { + enddate = format(Sys.Date() - i * 182, "%Y-%m-%d") # Approximately 6 months, adjust if you need more precision + # Calculate start date for the period, 182 days before the end date + startdate = format(Sys.Date() - (i * 182 + 181), "%Y-%m-%d") # Approximately 6 months + foreve[[paste0("per",i)]]=tryCatch(getAllFromCoord(lacouch.coor,startdate,enddate,allstations,headers=headers.default,base="https://public-api.meteofrance.fr"),error=function(e)e) } -test1=getAllFromCoord(vignass.coor,start_date=startdate,end_date=enddate,allstations,headers=headers.default) +startdate = format(Sys.Date() - 5, "%Y-%m-%d") +test1=getAllFromCoord(vignass.coor,start_date=startdate,end_date= format(Sys.Date() , "%Y-%m-%d"),allstations,headers=headers.default) +#test1=do.call("rbind.data.frame",foreve) +#test1=read.csv("allvignass.csv")[,-1] cols=palette.colors()[1:length(unique(test1$Nom_usuel))] names(cols)=unique(test1$Nom_usuel) -plot(getDate(test1[,2]),test1[,3],pch=20,col=cols[test1$Nom_usuel],cex=2) +testsep=test1#[test1[,3]>0,] +testsep[testsep[,3]==0,c(3,4)]=NA +testsep=testsep[getDate(testsep[,2])>a,] +plot(getDate(testsep[,2]),testsep[,3],pch=20,col=adjustcolor(cols[testsep$Nom_usuel],.4),cex=1.3,ylim=c(0,8)) legend("topleft",col=cols,legend=names(cols),pch=20,cex=2) + abline(v=as.numeric(as.POSIXlt("2024-08-07",format="%Y-%m-%d")),lwd=3,col="red") +#write.csv(file="allvignass.csv",test1) diff --git a/meteofranceapi.R b/meteofranceapi.R index e2baaa4..2eca944 100644 --- a/meteofranceapi.R +++ b/meteofranceapi.R @@ -8,6 +8,10 @@ headersLIM <- add_headers( accept = "*/*", apikey = token2 ) +headersLIM2 <- add_headers( + accept = "*/*", + apikey = token +) headersPaquet <- add_headers( accept = "*/*", apikey = yearTokenPaquer @@ -21,19 +25,55 @@ start_date <- as.Date("2024-03-24") end_date <- as.Date("2024-08-14") station_id <- "38269004" -allstations=getStations(headersLIM) +#allstations=getStations(headersLIM) allstations=read.csv("allstations.csv") #write.csv(file="allstations.csv",allstation,row.names=F) -lacouch=c(45.3722971,5.6387118) +lacouch.coor <- c(45.3722971,5.6387118) +lamure.coor <- c(44.9167, 5.8000) -alldist=dist(rbind(lacouch,cbind(allstations$Latitude,allstations$Longitude))) -staupre=allstation$Id_station[which.min(as.matrix(alldist)[1,-1])] -lamure=38269004 +vignass.coor=c(44.8550665,5.8441789) -allmure=getStationData(start_date="2024-06-24",end_date="2024-08-14",station_id=lamure,headers=headersLIM) +lamure.id=38269004 +lavaldens.id=38269004 +lacouch.id=38269004 +lacouch.stats=getIdFromCoords(lacouch.coor,allstations,N=3) +lamure.stats=getIdFromCoords(lamure.coor,allstations,N=3) +vignass.stats=getIdFromCoords(vignass.coor,allstations,N=3) + +allvignass=getStationData(start_date="2024-06-24",end_date="2024-08-14",station_id=lamure.id,headers=headersLIM) alllavaldens=getStationData(start_date="2024-06-24",end_date="2024-08-14",station_id=38207001,headers=headersLIM) +allcouch=getStationData(start_date="2024-06-24",end_date="2024-08-16",station_id=lacouch.id,headers=headersLIM) + +today=format(Sys.Date(), "%Y-%m-%d") +monthan=format(Sys.Date()-45, "%Y-%m-%d") + +allvignass=lapply(vignass.stats$Id_station,function(statid){print(paste("recuperer station",statid));Sys.sleep(5);getStationData(start_date=monthan,end_date=today,station_id=statid,headers=headersLIM);paste("done, sleep 5 sec");Sys.sleep(5)}) + +alllacouch=lapply(lacouch.stats$Id_station,function(statid){print(paste("recuperer station",statid));statdat=tryCatch(getStationData(start_date=monthan,end_date=today,station_id=statid,headers=headersLIM),error=function(e)NULL);paste("done, sleep 5 sec");Sys.sleep(5);statdat}) + +getStationData(start_date="2024-07-04",end_date="2024-08-16",station_id=vignass.stats$Id_station[3],headers=headersLIM) + +allvignass.df=do.call("rbind.data.frame",allvignass) +allvignass.df=allvignass.df[allvignass.df[,3]>0,] +ids=vignass.stats$Nom_usuel +names(ids)=vignass.stats$Id_station +cols=palette.colors()[1:nrow(vignass.stats)] +names(cols)=vignass.stats$Id_station +plot(getDate(allvignass.df[,2]),allvignass.df[,3],pch=20,col=cols[as.character(allvignass.df[,1])],cex=2) +legend("topleft",col=cols,legend=ids[names(cols)],pch=20,cex=2) + +abline(v=as.numeric(as.POSIXlt("2024-08-07",format="%Y-%m-%d")),lwd=3,col="red") + +alllacouch=do.call("rbind.data.frame",alllacouch) +alllacouch=alllacouch[alllacouch[,3]>0,] +ids=lacouch.stats$Nom_usuel +names(ids)=lacouch.stats$Id_station +cols=palette.colors()[1:nrow(lacouch.stats)] +names(cols)=lacouch.stats$Id_station +plot(getDate(alllacouch[,2]),alllacouch[,3],pch=20,col=cols[as.character(alllacouch[,1])],cex=2) +legend("topleft",col=cols,legend=ids[names(cols)],pch=20,cex=2) + paquetLamure=getStationPaquet(id_station=lamure) -allcouch=getStationData(start_date="2024-06-24",end_date="2024-08-14",station_id=staupre,headers=headersLIM) allal=getStationData(start_date="2024-01-24",end_date="2024-08-13",station_id=staupre,headers=headersLIM) plot(getDate(alllavaldens[,2]),alllavaldens[,3],lwd=3,type="l",col="red") diff --git a/scripts/backfill_two_years.R b/scripts/backfill_two_years.R index 5a92807..a9fe477 100644 --- a/scripts/backfill_two_years.R +++ b/scripts/backfill_two_years.R @@ -158,7 +158,7 @@ for (location_index in seq_along(location_ids)) { status <- get_location_cache_status(location_id, db_path = db_path) results[[location_index]] <- data.frame( location_id = location_id, - start_date = as.character(location_start_date), + start_date = "", end_date = as.character(end_date), chunk_days = chunk_days, rows_fetched = 0L, diff --git a/tests/testthat/test-rain-db.R b/tests/testthat/test-rain-db.R index 9f5e890..1ab5422 100644 --- a/tests/testthat/test-rain-db.R +++ b/tests/testthat/test-rain-db.R @@ -162,7 +162,11 @@ test_that("SQLite cache upserts and queries multiple metrics from one dataset", expect_equal(latest_temperature$value_num[1], 22) expect_equal( as.character(get_sync_start_date("vignasses", db_path, end_date = as.Date("2024-01-10"))), - "2024-01-01" + "2023-12-21" + ) + expect_equal( + as.character(get_sync_start_date("vignasses", db_path, end_date = as.Date("2024-01-01"))), + "2023-12-12" ) }) @@ -178,3 +182,48 @@ test_that("sync ranges are chunked predictably", { expect_equal(as.character(ranges$start_date[1]), "2024-01-01") expect_equal(as.character(ranges$end_date[3]), "2024-05-15") }) + + +test_that("weekly and monthly rainfall aggregates collapse long windows", { + skip_if_not(nzchar(Sys.which("sqlite3")), "sqlite3 is required for cache tests.") + + db_path <- tempfile(fileext = ".sqlite") + on.exit(unlink(c(db_path, paste0(db_path, c("-shm", "-wal")))), add = TRUE) + + ensure_weather_db(db_path) + + rain_rows <- normalise_rainfall_data( + raw_data = data.frame( + POSTE = c("1001", "1001", "1001"), + DATE = c(202401020000, 202401090000, 202402010000), + RR6 = c(1, 2, 3), + Nom_usuel = c("Station A", "Station A", "Station A"), + stringsAsFactors = FALSE + ), + location_id = "vignasses", + fetched_at = as.POSIXct("2026-04-08 09:00:00", tz = "UTC") + ) + + expect_equal(upsert_weather_measurements(rain_rows, db_path), 3) + + weekly_rain <- query_cached_rainfall( + location_id = "vignasses", + start_date = "2024-01-01", + end_date = "2024-02-01", + aggregate = "weekly", + db_path = db_path + ) + + monthly_rain <- query_cached_rainfall( + location_id = "vignasses", + start_date = "2024-01-01", + end_date = "2024-02-01", + aggregate = "monthly", + db_path = db_path + ) + + expect_equal(as.character(weekly_rain$observed_day), c("2024-01-01", "2024-01-08", "2024-01-29")) + expect_equal(weekly_rain$rain_mm, c(1, 2, 3)) + expect_equal(as.character(monthly_rain$observed_day), c("2024-01-01", "2024-02-01")) + expect_equal(monthly_rain$rain_mm, c(3, 3)) +})