fixing particle filter and adding support for secchi and depth in run…

…_flare

NAMESPACE

@@ -4,6 +4,7 @@ export(check_noaa_present_arrow)
 export(create_glm_inflow_outflow_files)
 export(create_inflow_outflow_files_arrow)
 export(create_obs_matrix)
+export(create_obs_non_vertical)
 export(delete_restart)
 export(delete_sim)
 export(download_s3_objects)

R/create_obs_matrix.R

@@ -41,14 +41,21 @@ create_obs_matrix <- function(cleaned_observations_file_long,
     }
     if("time" %in% names(d)){
       d <- d |>
-        mutate(hour = lubridate::hour(time),
+        dplyr::mutate(hour = lubridate::hour(time),
                date = lubridate::as_date(time))
     }else if("datetime" %in% names(d)){
       d <- d |>
-        mutate(hour = lubridate::hour(datetime),
-               date = lubridate::as_date(datetime))
+        dplyr::mutate(hour = lubridate::hour(datetime),
+                      date = lubridate::as_date(datetime))
     }
 
+    if(!("multi_depth" %in% names(obs_config))){
+      obs_config <- obs_config |> dplyr::mutate(multi_depth = 1)
+    }
+
+    obs_config <- obs_config |>
+      dplyr::filter(multi_depth == 1)
+
     if(config$model_settings$ncore == 1){
       future::plan("future::sequential", workers = config$model_settings$ncore)
     }else{

R/create_obs_non_vertical.R

@@ -0,0 +1,76 @@
+#' Process observation for variables that don't have depth
+#'
+#' @param cleaned_observations_file_long
+#' @param obs_config description
+#' @param start_datetime
+#' @param end_datetime
+#' @param forecast_start_datetime
+#' @param forecast_horizon
+#' @param secchi_sd
+#' @param depth_sd
+#'
+#' @return
+#' @export
+#'
+#' @examples
+#'
+create_obs_non_vertical <- function(cleaned_observations_file_long,
+                                    obs_config,
+                                    start_datetime,
+                                    end_datetime,
+                                    forecast_start_datetime,
+                                    forecast_horizon){
+
+  start_datetime <- lubridate::as_datetime(start_datetime)
+  if(is.na(forecast_start_datetime)){
+    end_datetime <- lubridate::as_datetime(end_datetime)
+    forecast_start_datetime <- end_datetime
+  }else{
+    forecast_start_datetime <- lubridate::as_datetime(forecast_start_datetime)
+    end_datetime <- forecast_start_datetime + lubridate::days(forecast_horizon)
+  }
+
+  obs_config <- obs_config |>
+    dplyr::filter(multi_depth == 0)
+
+  full_time <- seq(start_datetime, end_datetime, by = "1 day")
+
+  if("secchi" %in% unique(obs_config$state_names_obs)){
+
+
+    obs_secchi <- readr::read_csv(cleaned_observations_file_long, show_col_types = FALSE) %>%
+      dplyr::filter(variable == "secchi") %>%
+      dplyr::mutate(date = lubridate::as_date(datetime)) %>%
+      dplyr::right_join(tibble::tibble(date = lubridate::as_datetime(full_time)), by = "date") %>%
+      dplyr::mutate(observation = ifelse(date > lubridate::as_date(forecast_start_datetime), NA, observation)) %>%
+      dplyr::arrange(date) %>%
+      dplyr::select(observation) %>%
+      as_vector()
+
+    obs_secchi <- list(obs = obs_secchi,
+                       secchi_sd = obs_config$obs_sd[which(obs_config$state_names_obs == "secchi")])
+  }else{
+    obs_secchi <- NULL
+  }
+
+  if("depth" %in% unique(obs_config$state_names_obs)){
+    obs_depth <- readr::read_csv(cleaned_observations_file_long, show_col_types = FALSE) %>%
+      dplyr::filter(variable == "depth") %>%
+      dplyr::mutate(date = lubridate::as_date(datetime),
+                    hour = hour(datetime)) %>%
+      dplyr::filter(hour == 0)  %>%
+      dplyr::right_join(tibble::tibble(date = lubridate::as_datetime(full_time)), by = "date") %>%
+      dplyr::mutate(observation = ifelse(date > lubridate::as_date(forecast_start_datetime), NA, observation)) %>%
+      dplyr::arrange(date) %>%
+      dplyr::select(observation) %>%
+      as_vector()
+
+    obs_depth <- list(obs = obs_depth,
+                      depth_sd = obs_config$obs_sd[which(obs_config$state_names_obs == "depth")])
+  }else{
+    obs_depth <- NULL
+
+  }
+
+  return(list(obs_secchi = obs_secchi, obs_depth = obs_depth))
+}