adding volume coverage function

NAMESPACE

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

NEWS.md

@@ -1,5 +1,7 @@
 # bioRad 0.5.2.9XXX
 
+* adding `attribute_table()` to quickly tabulate scan attributes
+
 * `calculate_param()` now also works on ppi's (#316)
 
 * Speed up `integrate_to_ppi` and other functions by avoiding duplicate input argument checking (#358)

R/attribute_table.R

@@ -0,0 +1,61 @@
+#' Extract a volume coverage pattern table with all attributes
+#'
+#' @param x Either a pvol or scan for which the table should be created.
+#' @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)
+#'
+#' pvolfile <- system.file("extdata", "volume.h5", package = "bioRad")
+#' example_pvol <- read_pvolfile(pvolfile)
+#' attribute_table(example_pvol)
+attribute_table <-
+  function(x,
+           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.character(select) | is.null(select))
+    if (inherits(x, "pvol")) {
+      df <-
+        do.call(
+          "rbind",
+          lapply(
+            x$scans,
+            attribute_table,
+            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]
+    }
+    df$param <- list(names(x$params))
+
+    return(df)
+  }

tests/testthat/test-attribute_table.R

@@ -0,0 +1,49 @@
+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, select = 1L))
+})
+test_that("result is correct", {
+  expect_equal(nrow(attribute_table(example_pvol)), length(example_pvol$scans))
+  expect_equal(attribute_table(example_pvol)$param[[2]], names(example_pvol$scans[[2]]$param))
+  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]]$param[[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_true("param" %in% colnames(attribute_table(example_pvol)))
+  expect_type(attribute_table(example_pvol)$param, "list")
+  expect_type(attribute_table(example_pvol)$param[[2]], "character")
+})
+test_that("select argument works", {
+  expect_equal(setdiff(colnames(attribute_table(example_scan)), c(
+    "how.lowprf",
+    "how.midprf",
+    "how.highprf",
+    "where.elangle",
+    "where.nbins",
+    "where.nrays",
+    "where.rscale",
+    "how.NI",
+    "param"
+  )), character(0))
+  expect_equal(colnames(attribute_table(example_pvol, select = NULL)), c(names(unlist(example_pvol$scans[[1]]$attributes, recursive = F)), 'param'))
+})
+
+test_that("silently ignores non existant colums", {
+  expect_equal(setdiff(colnames(attribute_table(example_scan, select = c(
+    "how.lowprf",
+    "how.NI", "asdf"
+  ))), c(
+    "how.lowprf",
+    "how.NI",
+    "param"
+  )), character(0))
+  expect_silent(attribute_table(example_scan, select = c(
+    "how.lowprf",
+    "how.NI", "asdf"
+  )))
+})