From 9a72322a8e530a2dead69ef85f54c3a994dd5a3e Mon Sep 17 00:00:00 2001
From: aheinri5 <Anna@netzkritzler.de>
Date: Sat, 16 Jan 2021 00:08:15 +0100
Subject: [PATCH] [feature] WIP Testing reading encoded data with own function
---
R/read_in_vtu.R | 214 +++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 212 insertions(+), 2 deletions(-)
diff --git a/R/read_in_vtu.R b/R/read_in_vtu.R
index 548acb8..b9ff1b8 100644
--- a/R/read_in_vtu.R
+++ b/R/read_in_vtu.R
@@ -1,9 +1,37 @@
+
+#===== read_in_pvd =====
+
+
+#'read_in_pvd
+#'@description Function to read in a .pvd file
+#'@param pvd_path string: Path to .pvd file that should be read in
+#'@return character: Vector containing .vtu paths
+#'@export
+read_in_pvd <- function(pvd_path) {
+
+ xml_doc <- validate_read_in_xml(pvd_path)
+ xpath_expr <- "/VTKFile"
+
+ root_node <- xml2::xml_find_first(xml_doc, xpath_expr)
+
+ dataset_nodes <- xml2::xml_find_all(root_node, "//Collection/DataSet")
+ vtu_refs <- character()
+
+ for(i in seq_len(length(dataset_nodes))){
+ vtu_refs <- c(vtu_refs, xml2::xml_attrs(dataset_nodes[[i]])[["file"]])
+ }
+
+ return(invisible(vtu_refs))
+}
+
+
#===== read_in_vtu =====
#'read_in_vtu
-#'@description Wrapper function to read in a whole .vtu file
+#'@description Wrapper function to read in a whole .vtu file as a OGS6_vtu
+#' class object
#'@param vtu_path string: Path to .vtu file that should be read in
#'@return OGS6_vtu: Mesh object
#'@export
@@ -19,5 +47,187 @@ read_in_vtu <- function(vtu_path) {
xpath_expr = xpath_expr,
subclasses_names =
get_subclass_names("OGS6_vtu"))
+
return(invisible(vtu_obj))
-}
\ No newline at end of file
+}
+
+
+#===== read_in_PointData_DataArray =====
+
+
+#'read_in_PointData_DataArray
+#'@description Wrapper function to read in a `PointData` `DataArray` element
+#' from a .vtu file
+#'@param vtu_path string: Path to .vtu file that should be read in
+#'@param Name string: `Name` attribute of `DataArray` element
+#'@export
+read_in_PointData_DataArray <- function(vtu_path,
+ Name) {
+
+ assertthat::assert_that(assertthat::is.string(vtu_path))
+ assertthat::assert_that(assertthat::is.string(Name))
+
+ # load vtu
+ vtk_xml_ugr <- vtk$vtkXMLUnstructuredGridReader()
+ vtk_xml_ugr$SetFileName(vtu_path)
+ vtk_xml_ugr$Update()
+
+ # extract data
+ wrapped_data <- vtk_dsa$WrapDataObject(vtk_xml_ugr$GetOutput())
+
+ wrapped_data_arr <- wrapped_data$PointData[[Name]]
+
+ return(invisible(wrapped_data_arr))
+}
+
+
+#===== Decoding and decompressing functionality =====
+
+
+#'decode_appended_data
+#'@description Decodes AppendedData
+#'@param appended_data character: `AppendedData` parameter of `OGS6_vtu`
+#'@param data_arrays list: Content of lists specified in
+#' `get_valid_vtu_categories()`
+#'@param compressor string: Optional: How the data was compressed, this is the
+#' `compressor` parameter of `OGS6_vtu`
+#'@return list: DataArrays with `data` element which is the decoded data
+decode_appended_data <- function(appended_data,
+ data_arrays,
+ compressor = "") {
+
+ assertthat::assert_that(is.character(appended_data))
+ assertthat::assert_that(length(appended_data) == 2)
+
+ assertthat::assert_that(assertthat::is.string(compressor))
+
+ encoding <- appended_data[["encoding"]]
+ appended_data <- substring(appended_data[["xml_text"]], 2)
+
+ for(i in seq_len(length(data_arrays))){
+ offset <- data_arrays[[i]][["offset"]]
+
+ next_offset <- ifelse(i < length(data_arrays),
+ data_arrays[[i+1]][["offset"]],
+ (nchar(appended_data) + 1))
+
+ encoded_data <- substring(appended_data, offset, (next_offset - 1))
+ data <- decode_data_array_data(encoded_data,
+ encoding = encoding,
+ compressor = compressor)
+
+ data_arrays[[i]] <- c(data_arrays[[i]], data = data)
+ }
+
+ return(invisible(data_arrays))
+}
+
+
+
+decode_data_array_data <- function(data_array_data,
+ encoding = "",
+ compressor = ""){
+
+ assertthat::assert_that(assertthat::is.string(data_array_data))
+ assertthat::assert_that(assertthat::is.string(encoding))
+ assertthat::assert_that(assertthat::is.string(compressor))
+
+ decoded_data <- data_array_data
+
+ # Decode
+ if(encoding == "base64"){
+ decoded_data <- base64enc::base64decode(decoded_data)
+ }else{
+ stop(paste("Encoding of AppendedData is not `base64`."), call. = FALSE)
+ }
+
+ switch(
+ compressor,
+
+ vtkZLibDataCompressor = {
+
+ py_env <- reticulate::py_run_string(
+ paste(
+ "import zlib",
+ "def decompress(x):",
+ "\t",
+ "\treturn zlib.decompress(x)",
+ sep = "\n"
+ ),
+ convert = TRUE
+ )
+
+ decoded_data <- py_env$decompress(decoded_data)
+ }
+ )
+
+ return(invisible(decoded_data))
+}
+
+
+#===== get_vtu_data_arrays_from_file =====
+
+
+#'get_vtu_data_arrays_from_file
+#'@description Reads DataArray elements from a .vtu file
+#'@param vtu_path string: .vtu file path
+#'@param Names character: Optional: Select `DataArray` elements by `Name`
+#' attribute
+#'@param categories character: Optional: One or more of `FieldData`, `PointData`,
+#' `CellData`, `Points` or `Cells`. If left empty, will get `DataArray`
+#' elements from whole XML document.
+get_vtu_data_arrays_from_file <- function(vtu_path,
+ Names = character(),
+ categories = character()){
+
+ assertthat::assert_that(assertthat::is.string(vtu_path))
+ assertthat::assert_that(is.character(Names))
+ assertthat::assert_that(is.character(categories))
+
+ valid_categories <- get_valid_vtu_categories()
+
+ lapply(categories, function(x){
+ assertthat::assert_that(x %in% valid_categories)
+ })
+
+ xml_doc <- validate_read_in_xml(vtu_path)
+ xpath_expr <- "/VTKFile/UnstructuredGrid"
+
+
+ data_array_nodes <- list()
+
+ if(length(categories) != 0){
+
+ for(i in seq_len(length(categories))){
+
+ categories_expr <- ifelse(categories[[i]] != "FieldData",
+ "/Piece",
+ "")
+
+ categories_expr <- paste0(xpath_expr,
+ categories_expr,
+ "/", categories[[i]], "/DataArray")
+
+ data_array_nodes <- c(data_array_nodes,
+ list(xml2::xml_find_all(xml_doc,
+ categories_expr)))
+ }
+
+ }else{
+ data_array_nodes <- xml2::xml_find_all(xml_doc, "//DataArray")
+ }
+
+ if(length(Names) != 0){
+ data_array_nodes <-
+ data_array_nodes[xml2::xml_attr(data_array_nodes,
+ "Name") %in% Names]
+ }
+
+ data_arrays <- lapply(data_array_nodes, function(x){
+ node_to_object(x)
+ })
+
+ return(invisible(data_arrays))
+}
+
+
--
GitLab