diff --git a/NAMESPACE b/NAMESPACE index 359b391ce..0f32f591f 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 03d355bbd..509934bc5 100644 --- a/NEWS.md +++ b/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) diff --git a/R/attribute_table.R b/R/attribute_table.R new file mode 100644 index 000000000..9899be36d --- /dev/null +++ b/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) + } diff --git a/man/attribute_table.Rd b/man/attribute_table.Rd new file mode 100644 index 000000000..4acadc2c9 --- /dev/null +++ b/man/attribute_table.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/attribute_table.R +\name{attribute_table} +\alias{attribute_table} +\title{Extract a volume coverage pattern table with all attributes} +\usage{ +attribute_table( + x, + select = c("how.lowprf", "how.midprf", "how.highprf", "where.elangle", "where.nbins", + "where.nrays", "where.rscale", "how.NI"), + ... +) +} +\arguments{ +\item{x}{Either a pvol or scan for which the table should be created.} + +\item{select}{A character vector which the column names that should be returned when NULL all attributes are to be returned} + +\item{...}{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.} +} +\description{ +Extract a volume coverage pattern table with all attributes +} +\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) +} diff --git a/tests/testthat/test-attribute_table.R b/tests/testthat/test-attribute_table.R new file mode 100644 index 000000000..07194f149 --- /dev/null +++ b/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" + ))) +})