/
SC-model.R
148 lines (132 loc) · 4.95 KB
/
SC-model.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
globalVariables("n")
#' The universal model
#'
#' The universal model `SC` is coordinates and binary relations between
#' pairs of coordinates. This is purely an edge (or segment) model, with all
#' higher level structures recorded as groupings of edges.
#' @param x input model
#' @param ... arguments passed to methods
#' @export
#' @return SC model with tables 'object', 'object_link_edge', 'edge', and 'vertex'
#' @examples
#' ## we can produce a high quality triangulation from a low quality one
#' ## see how the TRI edges are maintained (we can't yet filter out holes from DEL)
#' tri <- TRI(minimal_mesh)
#' plot(tri)
#' plot(SC(tri))
SC <- function(x, ...) {
UseMethod("SC")
}
#' #' @export
#' #' @name SC
#' SC.SC0 <- function(x, ...) {
#' v <- sc_vertex(x)
#' o <- sc_object(x)
#' index <- do.call(rbind, o$topology_)
#' o$topology_ <- NULL
#' structure(list(object = O,
#' object_link_edge = oXe,
#' edge = edge,
#' vertex = V,
#' meta = meta),
#' ## a special join_ramp, needs edge to split on vertex
#' join_ramp = c("object", "object_link_edge", "edge", "vertex"),
#' class = c("SC", "sc"))
#' }
#' @export
#' @name SC
SC.default <- function(x, ...) {
B <- SC0(x, ...)
O <- sc_object(B)
O$topology_ <- NULL
if (!"object_" %in% names(O)) O[["object_"]] <- sc_uid(O)
O1 <- O["object_"]
O1[["edge_"]] <- B$object[["topology_"]]
meta <- tibble::tibble(proj = get_projection(x), ctime = format(Sys.time(), tz = "UTC"))
for (i in seq_along(O1$edge_)) O1$edge_[[i]]$object_ <- O1$object_[i]
edge <- do.call(rbind, O1$edge_)
tst <- c(".vx0", ".vx1") %in% names(edge)
if (!all(tst)) {
if (sum(tst) == 1) stop("model has only 0-space vertices (is it point-topology? Try '?SC0'. )")
stop("unable to produce edge form of this data")
}
V <- sc_vertex(B)
if (!"vertex_" %in% names(V)) V[["vertex_"]] <- sc_uid(V)
## these are now the edges, but we need to classify which changed direction
v_0 <- pmin(edge$.vx0, edge$.vx1)
v_1 <- pmax(edge$.vx0, edge$.vx1)
edge$native_ <- v_0 == edge$.vx0 ## if TRUE the orientation is how it came in
## we now have ordered edges
edge[[".vx0"]] <- V[["vertex_"]][v_0]
edge[[".vx1"]] <- V[["vertex_"]][v_1]
edge[["u_edge"]] <- dplyr::group_indices(dplyr::group_by(edge, ".vx0", ".vx1"))
edge[["edge_"]] <- sc_uid(length(unique(edge$u_edge)))[edge$u_edge]
oXe <- edge[c("object_", "edge_", "native_")]
edge$native_ <- edge$object_ <- NULL
edge <- edge[!duplicated(edge$u_edge), ]
edge$object_ <- edge$u_edge <- NULL
structure(list(object = O,
object_link_edge = oXe,
edge = edge,
vertex = V,
meta = meta),
## a special join_ramp, needs edge to split on vertex
join_ramp = c("object", "object_link_edge", "edge", "vertex"),
class = c("SC", "sc"))
}
## triangle classification
#' @name SC
#' @export
SC.TRI <- function(x, ...) {
segment <- purrr::map_df(purrr::transpose(x$triangle[c(".vx0", ".vx1", ".vx2")]),
~to_tibble(tri_to_seg(unlist(.x))), .id = "triangle_")
edges <- as.integer(factor(apply(cbind(segment$.vx0, segment$.vx1), 1,
function(x) paste(sort(x), collapse = "-"))))
segment$edge_ <- sc_uid(length(unique(edges)))[edges]
segment$object_ <- x$triangle$object_[as.numeric(segment$triangle_)]
object_link_edge <- dplyr::distinct(segment, object_, edge_, object_)
object_link_edge[["native_"]] <- TRUE ## always native
segment <- segment[c(".vx0", ".vx1", "edge_")] %>% inner_join(object_link_edge, "edge_") %>%
dplyr::transmute(.vx0 = ".vx0", .vx1 = ".vx1", edge_ = "edge_")
structure(list(object = x$object, object_link_edge = object_link_edge,
edge = segment, vertex = x$vertex,
meta = rbind(dplyr::mutate(x$meta, ctime = Sys.time()), x$meta)), class = c("SC", "sc"))
}
#' @name SC
#' @export
SC.pslg <- function(x, ...) {
SC(SC0(x))
}
## need to identify segments that were input and are
## shared by two triangles, set to invisible
tri_to_seg <- function(x) {
x[c(1, 2, 2, 3, 3, 1)]
}
to_tibble <- function(x) {
mat <- matrix(x, ncol = 2, byrow = TRUE)
colnames(mat) <- c(".vx0", ".vx1")
tibble::as_tibble(mat)
}
##https://github.com/hypertidy/silicate/issues/46
ring_cycles <- function(aa) {
ii <- 1
set0 <- ii
visited <- logical(nrow(aa))
while(!all(visited)) {
i0 <- ii
repeat {
ii <- which(aa[,1] == aa[ii, 2])
if (length(ii) < 1 | ii[1] == i0) {
set0 <- c(set0, NA_integer_)
break;
}
set0 <- c(set0, ii)
}
visited <- seq(nrow(aa)) %in% stats::na.omit(set0)
ii <- which(!visited)[1L]
if (!is.na(ii)) set0 <- c(set0, ii)
}
l <- split(set0, c(0, cumsum(abs(diff(is.na(set0))))))
bind_rows(lapply(l[!unlist(lapply(l, function(x) all(is.na(x))))],
function(x) tibble(row = x)), .id = "cycle")
}