Merge pull request #131 from Rafnuss/dev

v3.4.0

Author: Rafnuss

.github/workflows/lint.yaml

@@ -4,7 +4,6 @@ on:
   push:
     branches: [main, master]
   pull_request:
-    branches: [main, master]
 
 name: lint.yaml
 
@@ -24,7 +23,7 @@ jobs:
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::lintr, local::.
+          extra-packages: any::lintr, any::cyclocomp, local::.
           needs: lint
 
       - name: Lint

CITATION.cff

@@ -8,7 +8,7 @@ message: 'To cite package "GeoPressureR" in publications use:'
 type: software
 license: GPL-3.0-or-later
 title: 'GeoPressureR: Global Positioning by Atmospheric Pressure'
-version: 3.3.4
+version: 3.4.0
 doi: 10.5281/zenodo.7754457
 abstract: R package to determine the position and trajectory of a bird based on light-weight
   data-logger measuring at lease atmospheric pressure.
@@ -143,7 +143,7 @@ references:
   authors:
   - family-names: Csárdi
     given-names: Gábor
-    email: csardi.gabor@gmail.com
+    email: gabor@posit.co
   year: '2025'
   doi: 10.32614/CRAN.package.cli
 - type: software
@@ -354,7 +354,7 @@ references:
   title: Matrix
   abstract: 'Matrix: Sparse and Dense Matrix Classes and Methods'
   notes: Imports
-  url: https://R-forge.R-project.org/tracker/?atid=294&group_id=61
+  url: https://Matrix.R-forge.R-project.org
   repository: https://CRAN.R-project.org/package=Matrix
   authors:
   - family-names: Bates

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: GeoPressureR
 Title: Global Positioning by Atmospheric Pressure
-Version: 3.3.4
+Version: 3.4.0
 Authors@R: c(
     person("Raphaël", "Nussbaumer", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-8185-1020")),

R/geopressure_map_preprocess.R

@@ -188,7 +188,7 @@ geopressure_map_preprocess <- function(tag, compute_known = FALSE) {
 
     assertthat::assert_that(all(!is.na(pgi_reg$value)))
 
-    return(pgi_reg)
+    pgi_reg
   })
 
   # Combine into a single data.frame

R/geopressuretemplate_graph.R

@@ -85,7 +85,7 @@ geopressuretemplate_graph <- function(
         "i" = "Error while defining the movement model.{.var graph} is return.",
         ">" = "Debug line by line by opening {.code edit(geopressuretemplate_graph)}"
       ))
-      return(graph)
+      graph
     }
   )
 
@@ -137,7 +137,7 @@ geopressuretemplate_graph <- function(
         "x" = "Error while computing the outputs. {.var graph} is returned.",
         ">" = "Debug line by line by opening {.code edit(geopressuretemplate_graph)}"
       ))
-      return(graph)
+      graph
     }
   )
 

R/graph_add_wind.R

@@ -70,10 +70,31 @@ graph_add_wind <- function(
     ))
   }
 
+  # Filter node
   graph$s <- graph$s[id]
   graph$t <- graph$t[id]
   graph$gs <- graph$gs[id]
   graph$ws <- graph$ws[id]
+
+  # Prune the graph
+  # First, reconstruction the stap list graph for graph_create_prune to work
+  gr <- split(
+    data.frame(s = graph$s, t = graph$t, gs = graph$gs, ws = graph$ws),
+    arrayInd(graph$s, graph$sz)[, 3]
+  )
+  gr <- graph_create_prune(gr)
+  # Convert it back to a full list
+  tmp <- as.list(do.call("rbind", gr))
+  # Overwrite all edges vectors
+  graph$s <- tmp$s
+  graph$t <- tmp$t
+  graph$gs <- tmp$gs
+  graph$ws <- tmp$ws
+
+  # After pruning some retrieval nodes might not be present anymore.
+  graph$retrieval <- graph$retrieval[graph$retrieval %in% graph$t]
+
+  # Update param
   graph$param$graph_add_wind$thr_as <- thr_as
   attr(file, "srcref") <- NULL
   attr(file, "srcfile") <- NULL

R/graph_assert.R

@@ -51,5 +51,5 @@ graph_status <- function(graph) {
   if (length(graph$s) > 0) {
     status <- append(status, "full")
   }
-  return(status)
+  status
 }

R/graph_create.R

@@ -175,7 +175,7 @@ graph_create <- function(tag,
     thr_prob <- ls[id_prob_percentile + 1]
 
     # return matrix if the values are above the threshold
-    return(l >= thr_prob)
+    l >= thr_prob
   })
 
   # Check that there are still values
@@ -361,6 +361,8 @@ graph_create <- function(tag,
   graph$stap <- tag$stap
   graph$equipment <- which(nds[[1]] == TRUE)
   graph$retrieval <- as.integer(which(nds[[sz[3]]] == TRUE) + (sz[3] - 1) * nll)
+  # After pruning some retrieval nodes might not be present anymore.
+  graph$retrieval <- graph$retrieval[graph$retrieval %in% graph$t]
   graph$mask_water <- tag$map_pressure$mask_water
 
   # Create the param from tag
@@ -371,6 +373,11 @@ graph_create <- function(tag,
     likelihood = likelihood
   )
 
+  # Check graph validity
+  assertthat::assert_that(all(graph$s[!(graph$s  %in% graph$equipment)] %in% graph$t))
+  assertthat::assert_that(all(graph$equipment %in% graph$s))
+  assertthat::assert_that(all(graph$retrieval %in% graph$t))
+
   return(graph)
 }
 

R/graph_most_likely.R

@@ -58,24 +58,26 @@ graph_most_likely <- function(graph, quiet = FALSE) {
   # number of nodes in the 3d grid
   n <- prod(graph$sz)
 
-  # Compute the matrix TO
+  # Compute the matrix TO (transition * observation)
   if (!quiet) {
     cli::cli_progress_step("Compute movement model")
   }
   trans_obs <- graph_transition(graph) * graph$obs[graph$t]
 
-  # Initiate the matrix providing for each node of the graph, the source id (index of the node)
-  # with the most likely path to get there.
+  # Initiate the sparse 1D matrix providing for each node of the graph, the source id (index of the
+  # node in the 3D grid) with the cumulative max probability to get there.
+  # Start with prob=1 at the equipment site (log = 0)
   path_s <- Matrix::sparseMatrix(
     rep(1, length(graph$equipment)),
     graph$equipment,
-    x = 1, dims = c(1, n)
+    x = 0, dims = c(1, n)
   )
-  # Initiate the same matrix providing the total probability of the current path so far
+  # Initiate the same matrix providing the cumulative total probability of the current path so far
+  # Not sure why x is differently specify, should be the same value for both path_s and path_max
   path_max <- Matrix::sparseMatrix(
     rep(1, length(graph$equipment)),
     graph$equipment,
-    x = graph$obs[graph$equipment], dims = c(1, n)
+    x = log(graph$obs[graph$equipment]), dims = c(1, n)
   )
 
   # Create a data.frame of all edges information
@@ -85,13 +87,14 @@ graph_most_likely <- function(graph, quiet = FALSE) {
   node <- data.frame(
     s = graph$s,
     t = graph$t,
-    to = trans_obs,
+    to = log(trans_obs),
     stap = arrayInd(graph$s, graph$sz)[, 3]
   )
 
-  # Split this data.fram by stationary period (of the source)
+  # Split this data.frame by stationary period (of the source)
   node_stap <- split(node, node$stap)
 
+  # Compute number of nodes per stap
   n_edge <- sapply(node_stap, nrow)
 
   if (!quiet) {
@@ -109,12 +112,14 @@ graph_most_likely <- function(graph, quiet = FALSE) {
   }
 
   for (i_s in seq_len(length(node_stap))) {
+    # Select all nodes of the current stap
     node_i_s <- node_stap[[i_s]]
 
-    # compute the probability of all possible transition
-    node_i_s$p <- path_max[node_i_s$s] * node_i_s$to
+    # Compute the (cum) log probability of all possible transitions
+    node_i_s$p <- path_max[node_i_s$s] + node_i_s$to
 
-    # Find the value of the maximum possible transition for each target node
+    # Find the value of the maximum possible transition for each target node and store it into
+    # path_max
     max_v <- sapply(split(node_i_s$p, node_i_s$t), max)
     max_t <- as.numeric(names(max_v))
     path_max[max_t] <- max_v

R/graph_transition.R

@@ -43,5 +43,5 @@ graph_transition <- function(graph) {
     ))
   }
 
-  return(transition)
+  transition
 }

R/light2mat.R

@@ -58,9 +58,9 @@ light2mat <- function(light, twl_offset = 0) {
 
     if (length(candidates) > 0) {
       closest_idx <- candidates[which.min(abs(light_date_num[candidates] - t))]
-      return(light_value[closest_idx])
+      light_value[closest_idx]
     } else {
-      return(NA)
+      NA
     }
   }
 

R/map_create.R

@@ -139,13 +139,13 @@ dim.map <- function(x) {
   # Compute value
   z$data <- mapply(\(p, l) {
     if (is.null(p) && is.null(l)) {
-      return(NULL)
+      NULL
     } else if (is.null(p)) {
-      return(l)
+      l
     } else if (is.null(l)) {
-      return(p)
+      p
     } else {
-      return(p * l)
+      p * l
     }
   }, x$data, y$data, SIMPLIFY = FALSE)
 
@@ -157,5 +157,5 @@ dim.map <- function(x) {
 
   z$type <- glue::glue("{x$type} x {y$type}")
 
-  return(z)
+  z
 }

R/map_expand.R

@@ -77,5 +77,5 @@ map_expand <- function(extent, scale) {
     lon = lon,
     dim = dim
   )
-  return(grid)
+  grid
 }

R/path2edge.R

@@ -129,5 +129,5 @@ path2edge <- function(path, tag_graph) {
 
   attr(edge, "type") <- attr(path, "type")
 
-  return(edge)
+  edge
 }

R/plot.map.R

@@ -85,7 +85,7 @@ plot.map <- function(x,
       # Set to NA all value below this threshold
       m[m < thr_prob] <- NA
     }
-    return(m)
+    m
   })
 
   # Convert GeoPressureR map to terra rast object

R/pressurepath_create.R

@@ -235,9 +235,9 @@ pressurepath_create <- function(tag,
   # convert here as a NA
   out <- as.data.frame(lapply(resp_data, function(col) {
     if (length(col) == 0) {
-      return(NA)
+      NA
     } else {
-      return(col)
+      col
     }
   }))
 

R/print.bird.R

@@ -24,5 +24,5 @@ print.bird <- function(x, ...) {
     "*" = "Wing span: {round(bird$wing_span,1)} (m).",
     "*" = "Wing aspect: {round(bird$wing_aspect,1)} (-)."
   ))
-  return(invisible(bird))
+  invisible(bird)
 }

R/print.graph.R

@@ -82,5 +82,5 @@ print.graph <- function(x, ...) {
     cli::cli_bullets(c("x" = "No movement model defined. Use {.fun graph_set_movement}"))
   }
 
-  return(invisible(graph))
+  invisible(graph)
 }

R/print.map.R

@@ -43,5 +43,5 @@ print.map <- function(x, ...) {
   cli::cli_h3("Stationary periods {.field stap} (n={.val {nrow(map$stap)}})")
   cli::cli_text("Run {.code map$stap} to display full table")
 
-  return(invisible(x))
+  invisible(x)
 }

R/print.param.R

@@ -96,7 +96,7 @@ print.param <- function(x, ...) {
     bullets(param$geopressuretemplate, "pressurepath")
   }
 
-  return(invisible(param))
+  invisible(param)
 }
 
 bullets <- function(param, x) {

R/print.tag.R

@@ -137,5 +137,5 @@ print.tag <- function(x, ...) {
       }
     }
   }
-  return(invisible(tag))
+  invisible(tag)
 }

R/speed2prob.R

@@ -79,7 +79,7 @@ speed2prob <- function(speed, movement) {
 
   prob[speed_0] <- prob[speed_0] * movement$zero_speed_ratio
 
-  return(prob)
+  prob
 }
 
 
@@ -136,5 +136,5 @@ speed2power <- function(as, bird) {
   # Total Mechanical Power (eq 1 of Box 3.4)
   p_mech <- p_ind + p_par + p_pro
 
-  return(p_mech)
+  p_mech
 }

R/tag_assert.R

@@ -151,5 +151,5 @@ tag_status <- function(tag) {
     status <- append(status, "map_light")
   }
 
-  return(status)
+  status
 }

R/tag_create.R

@@ -1016,5 +1016,5 @@ tag_create_crop <- function(tag,
       }
     }
   }
-  return(tag)
+  tag
 }

R/tag_label_stap.R

@@ -185,7 +185,7 @@ pretty_dt <- function(tim) {
   }
 
   # Trim and return
-  return(trimws(duration_str))
+  trimws(duration_str)
 }
 
 #' Find the stationary period corresponding to a date
@@ -213,5 +213,5 @@ find_stap <- function(stap, date) {
 
   assertthat::assert_that(all(!is.na(stap_id)))
 
-  return(stap_id)
+  stap_id
 }