adding volume coverage function

NAMESPACE

@@ -78,6 +78,7 @@ S3method(summary,vpts)
 export("rcs<-")
 export("sd_vvp_threshold<-")
 export(apply_mistnet)
+export(attribute_table)
 export(basemap)
 export(beam_distance)
 export(beam_height)

R/attribute_table.R

@@ -0,0 +1,66 @@
+#' Extract a volume coverage pattern table with all attributes
+#'
+#' @param x Either a pvol or scan for which the table should be created.
+#' @param add_params A logical whether a column with with the parameters present is to be added.
+#' @param select A character vector which the column names that should be returned when NULL all attributes are to be returned
+#' @param ... Currently not used
+#'
+#' This function tabulates the attributes of one scan or all scans of a pvol.
+#' Attributes that have a length longer then one are presented as a list column.
+#' By default the function returns a limited set of columns to keep the output clear.
+#' It is important to note that attributes of the full polar volume can contain additional information on processing that is not included in the resulting table.
+#' This function only tabulates attributes of the scans.
+#'
+#' @export
+#'
+#' @examples
+#' data(example_scan)
+#' attribute_table(example_scan)
+#'
+#' pvolfilepath <- system.file("extdata", "volume.h5", package = "bioRad")
+#' example_pvol <- read_pvolfile(pvolfilepath)
+#' attribute_table(example_pvol)
+attribute_table <-
+  function(x,
+           add_params = T,
+           select = c(
+             "how.lowprf",
+             "how.midprf",
+             "how.highprf",
+             "where.elangle",
+             "where.nbins",
+             "where.nrays",
+             "where.rscale",
+             "how.NI"
+           ),
+           ...) {
+    assert_that(inherits(x, "scan") | inherits(x, "pvol"))
+    assert_that(is.flag(add_params))
+    assert_that(is.character(select) | is.null(select))
+    if (inherits(x, "pvol")) {
+      df <-
+        do.call(
+          "rbind",
+          lapply(
+            x$scans,
+            attribute_table,
+            add_params = add_params,
+            select = select,
+            ...
+          )
+        )
+      return(df)
+    }
+    t <- unlist(x$attributes, F)
+    g <- lapply(t, function(x) {
+      ifelse(length(x) != 1, (list(x)), x)
+    })
+    df <- structure(g, class = "data.frame", row.names = "")
+    if (!is.null(select)) {
+      df <- df[, colnames(df) %in% select, drop = F]
+    }
+    if (add_params) {
+      df$params <- list(names(x$params))
+    }
+    return(df)
+  }

tests/testthat/test-attribute_table.R

@@ -0,0 +1,50 @@
+pvolfile <- system.file("extdata", "volume.h5", package = "bioRad")
+example_pvol <- read_pvolfile(pvolfile)
+data(example_scan)
+test_that("returns error on incorrect parameters", {
+  expect_error(attribute_table("not_a_vp"))
+  expect_error(attribute_table(example_pvol, add_param = "a"))
+  expect_error(attribute_table(example_pvol, select = 1L))
+})
+test_that("result is correct", {
+  expect_equal(nrow(attribute_table(example_pvol)), length(example_pvol$scans))
+  expect_equal(attribute_table(example_pvol)$params[[2]], names(example_pvol$scans[[2]]$params))
+  expect_equal(attribute_table(example_pvol)$where.elangle, get_elevation_angles(example_pvol))
+  expect_equal(attribute_table(example_pvol)$where.nbins[[3]], nrow(example_pvol$scans[[3]]$params[[1]]))
+  expect_equal(attribute_table(example_scan), attribute_table(example_pvol)[1, ])
+  expect_equal(attribute_table(example_pvol, select = "how.stopazT", F)[, 1], lapply(example_pvol$scans, function(x) x$attributes$how$stopazT))
+})
+test_that("add_params works", {
+  expect_false("params" %in% colnames(attribute_table(example_pvol, add_params = F)))
+  expect_true("params" %in% colnames(attribute_table(example_pvol, add_params = T)))
+  expect_true("params" %in% colnames(attribute_table(example_pvol)))
+  expect_type(attribute_table(example_pvol)$params, "list")
+  expect_type(attribute_table(example_pvol)$params[[2]], "character")
+})
+test_that("select argument works", {
+  expect_equal(setdiff(colnames(attribute_table(example_scan, add_params = F)), c(
+    "how.lowprf",
+    "how.midprf",
+    "how.highprf",
+    "where.elangle",
+    "where.nbins",
+    "where.nrays",
+    "where.rscale",
+    "how.NI"
+  )), character(0))
+  expect_equal(colnames(attribute_table(example_pvol, select = NULL, add_params = F)), names(unlist(example_pvol$scans[[1]]$attributes, recursive = F)))
+})
+
+test_that("silently isnores non existant colums", {
+  expect_equal(setdiff(colnames(attribute_table(example_scan, select = c(
+    "how.lowprf",
+    "how.NI", "asdf"
+  ), add_params = F)), c(
+    "how.lowprf",
+    "how.NI"
+  )), character(0))
+  expect_silent(attribute_table(example_scan, select = c(
+    "how.lowprf",
+    "how.NI", "asdf"
+  )))
+})