Skip to content
Snippets Groups Projects
Commit d5bb9093 authored by Ruben Heinrich's avatar Ruben Heinrich
Browse files

[base] Switched .gml class to R6

parent 7eb34eec
No related branches found
No related tags found
1 merge request!6Merge branch 7 fixed functionality into master
Hide whitespace changes
Inline Side-by-side
Showing
with 201 additions and 147 deletions
R/gml.R
+ 201
− 147
View file @ d5bb9093
#===== r2ogs6_gml ===== #===== OGS6_gml =====
#'r2ogs6_gml #'OGS6_gml
#'@description S3 class describing the .gml file #'@description Constructor for the OGS6_gml base class
#'@param name The name of the geometry
#'@param points A tibble of points
#'@param polylines Optional: A list of polylines
#'@param surfaces Optional: A list of surfaces
#'@export #'@export
r2ogs6_gml <- function(name, OGS6_gml <- R6::R6Class(
points, "OGS6_gml",
polylines = NULL, public = list(
surfaces = NULL){
#'@description
#Make this more user friendly #'Creates new OGS6_gml object
#... #'@param gml_path string: Optional: Path to .gml file
#'@param name string: Geometry name
validate_r2ogs6_gml(new_r2ogs6_gml(name, #'@param points tibble: Must have 3 vectors named 'x', 'y' and 'z', may
points, #' have optional 'name' vector
polylines, #'@param polylines list(list("foo", c(1, 2))):
surfaces)) #'@param surfaces list(list("foo", c(1, 2, 3), c(2, 3, 4))):
} initialize = function(gml_path = NULL,
name = NULL,
points = NULL,
polylines = NULL,
surfaces = NULL) {
if(is.null(gml_path)){
self$name <- name
self$points <- points
self$polylines <- polylines
self$surfaces <- surfaces
}else{
if(!is.null(name) ||
!is.null(points) ||
!is.null(polylines) ||
!is.null(surfaces)){
warning(paste("`gml_path` was specified for OGS6_gml",
"initialization, so all other parameters",
"will be ignored!"), call. = FALSE)
}
xml_doc <- validate_read_in_xml(gml_path)
self$name <- xml2::xml_text(xml2::xml_find_first(xml_doc,
"//name"))
self$points <- read_in_points(xml_doc)
self$polylines <- read_in_polylines(xml_doc)
self$surfaces <- read_in_surfaces(xml_doc)
}
#'new_r2ogs6_gml private$.gml_path <- gml_path
#'@description Constructor for S3 class new_r2ogs6_gml private$validate()
#'@param name The name of the geometry }
#'@param points A tibble of points ),
#'@param polylines Optional: A list of polylines
#'@param surfaces Optional: A list of surfaces active = list(
new_r2ogs6_gml <- function(name,
points, #'@field gml_path
polylines = NULL, #'Getter for private parameter '.gml_path'
surfaces = NULL) { gml_path = function(value) {
private$gml_path
},
#'@field name
#'Access to private parameter '.name'
name = function(value) {
if(missing(value)) {
private$.name
}else{
assertthat::assert_that(assertthat::is.string(value))
private$.name <- value
}
},
#'@field points
#'Access to private parameter '.points'
points = function(value) {
if(missing(value)) {
private$.points
}else{
private$.points <- validate_points(value)
}
},
#'@field polylines
#'Access to private parameter '.polylines'
polylines = function(value) {
if(missing(value)) {
private$.polylines
}else{
if(!is.null(value)){
value <- validate_polylines(value)
}
private$.polylines <- value
}
},
#'@field surfaces
#'Access to private parameter '.surfaces'
surfaces = function(value) {
if(missing(value)) {
private$.surfaces
}else{
if(!is.null(value)){
value <- validate_surfaces(value)
}
private$.surfaces <- value
}
},
#'@field is_subclass
#'Getter for private parameter '.is_subclass'
is_subclass = function(value) {
private$.is_subclass
},
#'@field attr_names
#'Getter for private parameter '.attr_names'
attr_names = function(value) {
private$.attr_names
},
#'@field flatten_on_exp
#'Getter for private parameter '.flatten_on_exp'
flatten_on_exp = function(value) {
private$.flatten_on_exp
}
),
assertthat::assert_that(assertthat::is.string(name)) private = list(
points <- validate_points(points) validate = function(){
maximal_point_id <- length(self$points[[1]]) - 1
if(!is.null(polylines)){ check_pnt <- function(pnt){
polylines <- validate_polylines(polylines) if(pnt > maximal_point_id ||
} pnt < 0){
stop(paste("Point with ID", pnt, "does not exist"),
call. = FALSE)
}
}
if(!is.null(surfaces)){ #Check if polylines reference existing points
surfaces <- validate_surfaces(surfaces) lapply(self$polylines, function(x){
} lapply(x[[2]], check_pnt)
})
structure(
list(name = name, #Check if surfaces reference existing points
points = points, lapply(self$surfaces, function(x){
polylines = polylines, lapply(x[[2]], check_pnt)
surfaces = surfaces, if(length(x) == 3){
is_subclass = TRUE, lapply(x[[3]], check_pnt)
attr_names = c("point", "name", "id", "element"), }
flatten_on_exp = character() })
), },
class = "r2ogs6_gml") .gml_path = NULL,
} .name = NULL,
.points = NULL,
.polylines = NULL,
.surfaces = NULL,
.is_subclass = TRUE,
.attr_names = c("point", "name", "id", "element"),
.flatten_on_exp = character()
)
)
#===== Validation utility ===== #===== Validation utility =====
#'validate_r2ogs6_gml
#'@description Validator for class r2ogs6_gml. Checks if the defined polylines
#' and surfaces reference existing points.
#'@param r2ogs6_gml r2ogs6_gml:
validate_r2ogs6_gml <- function(r2ogs6_gml) {
maximal_point_id <- length(r2ogs6_gml$points[[1]]) - 1
#Check if polylines reference existing points
for(i in seq_len(length(r2ogs6_gml$polylines))){
for(j in seq_len(length(r2ogs6_gml$polylines[[i]][[2]]))){
if(r2ogs6_gml$polylines[[i]][[2]][[j]] > maximal_point_id ||
r2ogs6_gml$polylines[[i]][[2]][[j]] < 0){
stop("Polyline references point ID which does not exist",
call. = FALSE)
}
}
}
#Check if surfaces reference existing points
for(i in seq_len(length(r2ogs6_gml$surfaces))){
for(j in seq_len(length(r2ogs6_gml$surfaces[[i]][[2]]))){
if(r2ogs6_gml$surfaces[[i]][[2]][[j]] > maximal_point_id ||
r2ogs6_gml$surfaces[[i]][[2]][[j]] < 0 ||
(length(r2ogs6_gml$surfaces[[i]]) == 3 &&
(r2ogs6_gml$surfaces[[i]][[3]][[j]] > maximal_point_id ||
r2ogs6_gml$surfaces[[i]][[3]][[j]] < 0))){
stop("Surface references point ID which does not exist",
call. = FALSE)
}
}
}
return(invisible(r2ogs6_gml))
}
#'validate_points #'validate_points
#'@description Checks if the input is a tibble, if this tibble has the right #'@description Checks if the input is a tibble, if this tibble has the right
#' number of elements, if those elements are named correctly and if there are #' number of elements, if those elements are named correctly and if there are
...@@ -159,21 +227,17 @@ validate_polylines <- function(polylines) { ...@@ -159,21 +227,17 @@ validate_polylines <- function(polylines) {
assertthat::assert_that(is.list(polylines)) assertthat::assert_that(is.list(polylines))
for(i in seq_len(length(polylines))){ polylines <- lapply(polylines, function(x){
assertthat::assert_that(is.list(x))
assertthat::assert_that(is.list(polylines[[i]])) assertthat::assert_that(length(x) == 2)
assertthat::assert_that(length(polylines[[i]]) == 2) assertthat::assert_that(assertthat::is.string(x[[1]]))
assertthat::assert_that(assertthat::is.string(polylines[[i]][[1]])) assertthat::assert_that(is.numeric(x[[2]]))
assertthat::assert_that(is.numeric(polylines[[i]][[2]])) names(x)[[1]] <- c("name")
names(polylines[[i]])[[1]] <- c("name") names(x[[2]]) <- rep("pnt", length(names(x[[2]])))
names(polylines[[i]][[2]]) <- rep("pnt", return(x)
length(names(polylines[[i]][[2]]))) })
#Check for duplicate points / polylines?
}
names(polylines) <- rep("polyline", length(polylines)) names(polylines) <- rep("polyline", length(polylines))
return(invisible(polylines)) return(invisible(polylines))
} }
...@@ -188,38 +252,29 @@ validate_surfaces <- function(surfaces) { ...@@ -188,38 +252,29 @@ validate_surfaces <- function(surfaces) {
assertthat::assert_that(is.list(surfaces)) assertthat::assert_that(is.list(surfaces))
for(i in seq_len(length(surfaces))){ validate_element <- function(element){
assertthat::assert_that(is.numeric(element))
assertthat::assert_that(is.list(surfaces[[i]])) assertthat::assert_that(length(element) == 3)
names(element) <- c("p1", "p2", "p3")
assertthat::assert_that(length(surfaces[[i]]) == 2 || return(invisible(element))
length(surfaces[[i]]) == 3) }
validate_surface <- function(surface){
names(surface)[[1]] <- c("name") surfaces <- lapply(surfaces, function(x){
assertthat::assert_that(is.numeric(surface[[2]]))
assertthat::assert_that(length(surface[[2]]) == 3)
names(surface)[[2]] <- c("element")
names(surface[[2]]) <- c("p1", "p2", "p3")
if(length(surface) == 3){ assertthat::assert_that(is.list(x))
assertthat::assert_that(is.numeric(surface[[3]])) assertthat::assert_that(length(x) == 2 ||
assertthat::assert_that(length(surface[[3]]) == 3) length(x) == 3)
names(surface)[[3]] <- c("element")
names(surface[[3]]) <- c("p1", "p2", "p3")
validate_surface_elements(surface[[2]], names(x) <- c("name", rep("element", (length(x)-1)))
surface[[3]]) x[[2]] <- validate_element(x[[2]])
}
return(invisible(surface)) if(length(x) == 3){
x[[3]] <- validate_element(x[[3]])
# validate_pnt_values(x[[2]], x[[3]])
} }
surfaces[[i]] <- validate_surface(surfaces[[i]]) return(x)
})
#Check for duplicate points / surfaces?
}
names(surfaces) <- rep("surface", length(surfaces)) names(surfaces) <- rep("surface", length(surfaces))
...@@ -227,31 +282,30 @@ validate_surfaces <- function(surfaces) { ...@@ -227,31 +282,30 @@ validate_surfaces <- function(surfaces) {
} }
#'validate_surface_elements #'validate_pnt_values
#'@description Helper function, checks if two numerical vectors of length 3 #'@description Checks if two numerical vectors of length 3
#' (two surface elements) each consist of 3 different elements and also have #' (two surface elements) each consist of 3 different elements and have
#' exactly 2 matching elements between them which means they describe a valid #' exactly 2 matching elements between them. Think of the two vectors as
#' surface. You can think of the two vectors as two triangles, and the two #' triangles, and the triangles together form a square which is our surface.
#' triangles together form a square which is our surface. #'@param element_1 numeric, length = 3
#'@param surface_element_1 numeric, length = 3 #'@param element_2 numeric, length = 3
#'@param surface_element_2 numeric, length = 3 validate_pnt_values = function (element_1, element_2) {
validate_surface_elements = function (surface_element_1, surface_element_2) {
if(element_1[[1]] == element_1[[2]] ||
if(surface_element_1[[1]] == surface_element_1[[2]] || element_1[[1]] == element_1[[3]] ||
surface_element_1[[1]] == surface_element_1[[3]] || element_1[[2]] == element_1[[3]] ||
surface_element_1[[2]] == surface_element_1[[3]] || element_2[[1]] == element_2[[2]] ||
surface_element_2[[1]] == surface_element_2[[2]] || element_2[[1]] == element_2[[3]] ||
surface_element_2[[1]] == surface_element_2[[3]] || element_2[[2]] == element_2[[3]]) {
surface_element_2[[2]] == surface_element_2[[3]]) {
stop("A surface element must consist of 3 different points", stop("A surface element must consist of 3 different points",
call. = FALSE) call. = FALSE)
} }
equal_count <- 0 equal_count <- 0
for(i in 1:length(surface_element_1)) { for(i in 1:length(element_1)) {
for(j in 1:length(surface_element_2)) { for(j in 1:length(element_2)) {
if(surface_element_1[[i]] == surface_element_2[[j]]) { if(element_1[[i]] == element_2[[j]]) {
equal_count <- equal_count + 1 equal_count <- equal_count + 1
break break
} }
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment