[base] Moved gml validation in here

R/gml.R

-#============================== GML CLASSES AND METHODS ================================
 
-#============================== GML ================================
+#===== r2ogs6_gml =====
 
 
 #'r2ogs6_gml
@@ -10,23 +9,31 @@
 #'@param polylines Optional: A list of polylines
 #'@param surfaces Optional: A list of surfaces
 #'@export
-r2ogs6_gml <- function(name, points, polylines = NULL, surfaces = NULL){
+r2ogs6_gml <- function(name,
+                       points,
+                       polylines = NULL,
+                       surfaces = NULL){
 
     #Make this more user friendly
     #...
 
-    validate_r2ogs6_gml(new_r2ogs6_gml(name, points, polylines, surfaces))
+    validate_r2ogs6_gml(new_r2ogs6_gml(name,
+                                       points,
+                                       polylines,
+                                       surfaces))
 }
 
 
-
 #'new_r2ogs6_gml
 #'@description Constructor for S3 class new_r2ogs6_gml
 #'@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
-new_r2ogs6_gml <- function(name, points, polylines = NULL, surfaces = NULL) {
+new_r2ogs6_gml <- function(name,
+                           points,
+                           polylines = NULL,
+                           surfaces = NULL) {
 
     assertthat::assert_that(assertthat::is.string(name))
 
@@ -44,17 +51,200 @@ new_r2ogs6_gml <- function(name, points, polylines = NULL, surfaces = NULL) {
         list(name = name,
              points = points,
              polylines = polylines,
-             surfaces = surfaces),
+             surfaces = surfaces,
+             is_subclass = TRUE,
+             attr_names = character(),
+             flatten_on_exp = character()
+             ),
 
         class = "r2ogs6_gml")
 }
 
 
-#'input_add.r2ogs6_gml
-#'@description Implementation of generic function input_add for S3 class r2ogs6_gml
-#'@param x A r2ogs6_gml class object
-#'@param ogs6_obj A OGS6 class object
-#'@export
-input_add.r2ogs6_gml <- function(x, ogs6_obj) {
-    ogs6_obj$add_gml(x)
-}
+#===== 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) {
\ No newline at end of file
+
+    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 ||
+               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
+#'@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
+#' any overlapping points or duplicate point names
+#'@param points tibble: Must have 3 vectors named 'x', 'y' and 'z', may have
+#' optional 'name' vector
+validate_points <- function(points) {
+
+    assertthat::assert_that(inherits(points, "tbl_df"))
+
+    names <- names(points)
+
+    if (!((length(points) == 4 && names[[1]] == "x" && names[[2]] == "y" &&
+           names[[3]] == "z" && names[[4]] == "name") ||
+          (length(points) == 3 && names[[1]] == "x" && names[[2]] == "y" &&
+           names[[3]] == "z"))){
+        stop(paste(points, " column names do not fit to 'x, y, z, (name)' "),
+             call. = FALSE)
+    }
+
+    assertthat::assert_that(is.numeric(points$x))
+    assertthat::assert_that(is.numeric(points$y))
+    assertthat::assert_that(is.numeric(points$z))
+
+    has_names <- (length(points) == 4)
+
+    #Find overlapping points and duplicate names
+    for(i in 1:(length(points[[1]])-1)){
+        for(j in (i+1):length(points[[1]])){
+            if(points[[1]][[i]] == points[[1]][[j]] &&
+               points[[2]][[i]] == points[[2]][[j]] &&
+               points[[3]][[i]] == points[[3]][[j]]){
+                stop("Overlapping .gml points detected", call. = FALSE)
+            }
+
+            if(has_names){
+                if(points[[4]][[i]] == points[[4]][[j]] &&
+                   points[[4]][[i]] != ""){
+                    warning("Duplicate .gml point names detected",
+                            call. = FALSE)
+                }
+            }
+        }
+    }
+
+    return(invisible(points))
+}
+
+
+#'validate_polylines
+#'@description Checks if the input is a list, if this list consists of other
+#' lists and if those lists have the correct structure (length of 2, first
+#' element is a string named 'name', second element is a numeric vector)
+#'@param polylines list(list("foo", c(1, 2))):
+validate_polylines <- function(polylines) {
+
+    assertthat::assert_that(is.list(polylines))
+
+    for(i in seq_len(length(polylines))){
+
+        assertthat::assert_that(is.list(polylines[[i]]))
+        assertthat::assert_that(length(polylines[[i]]) == 2)
+        assertthat::assert_that(assertthat::is.string(polylines[[i]][[1]]))
+        assertthat::assert_that(is.numeric(polylines[[i]][[2]]))
+        names(polylines[[i]])[[1]] <- c("name")
+        names(polylines[[i]])[[2]] <- rep("pnt",
+                                          length(names(polylines[[i]])[[2]]))
+
+        #Check for duplicate points / polylines?
+    }
+
+    names(polylines) <- rep("polyline", length(polylines))
+
+    return(invisible(polylines))
+}
+
+
+#'validate_surfaces
+#'@description Checks if the input is a list, if this list consists of other
+#' lists and if those lists have the correct structure (length of 3, first
+#' element is a string named 'name', second and third element are numeric
+#' vectors)
+#'@param surfaces list(list("foo", c(1, 2, 3), c(2, 3, 4))):
+validate_surfaces <- function(surfaces) {
+
+    assertthat::assert_that(is.list(surfaces))
+
+    for(i in 1:length(surfaces)){
+        surface <- surfaces[[i]]
+
+        assertthat::assert_that(is.list(surface))
+        assertthat::assert_that(length(surface) == 3)
+        names(surface)[[1]] <- c("name")
+
+        assertthat::assert_that(is.numeric(surface[[2]]))
+        assertthat::assert_that(length(surface[[2]]) == 3)
+        names(surface)[[2]] <- c("element")
+
+        assertthat::assert_that(is.numeric(surface[[3]]))
+        assertthat::assert_that(length(surface[[3]]) == 3)
+        names(surface)[[3]] <- c("element")
+
+        validate_surface_elements(surface[[2]], surface[[3]])
+
+        #Check for duplicate points / surfaces?
+    }
+
+    names(surfaces) <- rep("surface", length(surfaces))
+
+    return(invisible(surfaces))
+}
+
+
+#'validate_surface_elements
+#'@description Helper function, checks if two numerical vectors of length 3
+#' (two surface elements) each consist of 3 different elements and also have
+#' exactly 2 matching elements between them which means they describe a valid
+#' surface. You can think of the two vectors as two triangles, and the two
+#' triangles together form a square which is our surface.
+#'@param surface_element_1 numeric, length = 3
+#'@param surface_element_2 numeric, length = 3
+validate_surface_elements = function (surface_element_1, surface_element_2) {
+
+    if(surface_element_1[[1]] == surface_element_1[[2]] ||
+       surface_element_1[[1]] == surface_element_1[[3]] ||
+       surface_element_1[[2]] == surface_element_1[[3]] ||
+       surface_element_2[[1]] == surface_element_2[[2]] ||
+       surface_element_2[[1]] == surface_element_2[[3]] ||
+       surface_element_2[[2]] == surface_element_2[[3]]) {
+        stop("A surface element must consist of 3 different points",
+             call. = FALSE)
+    }
+
+    equal_count <- 0
+
+    for(i in 1:length(surface_element_1)) {
+        for(j in 1:length(surface_element_2)) {
+            if(surface_element_1[[i]] == surface_element_2[[j]]) {
+                equal_count <- equal_count + 1
+                break
+            }
+        }
+    }
+
+    if(equal_count != 2) {
+        stop("Invalid surface detected", call. = FALSE)
+    }
+}