cast0.R

st_cast0 <- function(x, to, ...) UseMethod("st_cast0")

# see this figure:
# https://cloud.githubusercontent.com/assets/520851/21387553/5f1edcaa-c778-11e6-92d0-2d735e4c8e40.png
# columns start counting at 0:

which_col = function(cls) {
	switch(cls,
		POINT = 0,
		LINESTRING = 1,
		MULTIPOINT = 1,
		MULTILINESTRING = 2,
		POLYGON = 2,
		MULTIPOLYGON = 3,
		GEOMETRYCOLLECTION = 4,
		GEOMETRY = 5,
		stop(paste("st_cast for", cls, "not supported"))
	)
}

need_close = function(cls) {
	switch(cls,
		POLYGON = TRUE,
		MULTIPOLYGON = TRUE,
		FALSE
	)
}

add_attributes = function(x,y) {
	attributes(x) = attributes(y)
	x
}

close = function(x, to) {
	to_col = which_col(to)
	close_mat = function(m) {
		if (any(m[1,] != m[nrow(m),]))
			rbind(m, m[1,])
		else
			m
	}
	ret = if (to_col == 2)
		lapply(x, function(y) add_attributes(lapply(y, close_mat), y))
	else if (to_col == 3)
		lapply(x, function(y) add_attributes(lapply(y, function(z) lapply(z, close_mat)), y))
	else
		stop("invalid to_col value")
	attributes(ret) = attributes(x)
	ret
}

reclass = function(x, to, must_close) {
	l = if (length(x)) {
		full_cls = c(class(x[[1]])[1], to, "sfg") 
		if (must_close)
			x = close(x, to)
		lapply(x, function(g) structure(g, class = full_cls))
	} else
		list()
	attributes(l) = attributes(x)
	structure(l, class = c(paste0("sfc_", to), "sfc"))
}

get_lengths = function(x) {
	switch(class(x)[1],
		sfc_POINT = rep(1, length(x)),
		sfc_MULTIPOINT = sapply(x, nrow),
		sfc_LINESTRING = sapply(x, nrow),
		sapply(x, length)
	)
}

st_cast0.sfc = function(x, to, ids = rep(1, length(x))) {
	from_cls = substr(class(x)[1], 5, 100)
	from_col = which_col(from_cls)
	to_col = which_col(to)
	if (from_cls == to)
		x # returns x: do nothing
	else if (from_cls == "GEOMETRY")
		st_sfc(lapply(x, st_cast, to = to))
	else if (from_col == to_col) # "vertical" conversion: only reclass, possibly close polygons
		reclass(x, to, need_close(to))
	else if (abs(from_col - to_col) > 1)
		stop("only one step at a time implemented")
	else if (from_col < to_col) { # "horizontal", to the right: group
		ret = if (from_col == 0)
			lapply(unname(split(x, ids)), function(y) structure(do.call(rbind, y), class = class(x[[1]])))
		else
			lapply(unname(split(x, ids)), function(y) structure(y, class = class(x[[1]])))
		attributes(ret) = attributes(x)
		reclass(ret, to, need_close(to))
	} else { # "horizontal", to the left: split
		ret = if (from_col == 1)
				unlist(lapply(x, function(m) lapply(seq_len(nrow(m)), 
						function(i) structure(m[i,], class = class(m)))),
					recursive = FALSE)
			else 
				lapply(do.call(c, x), function(y) structure(y, class = class(x[[1]])))
		attributes(ret) = attributes(x)
		structure(reclass(ret, to, need_close(to)), ids = get_lengths(x))
	}
}

# tests:
library(sf)
# "vertical" conversions:
# column 1:
mp = st_sfc(st_multipoint(matrix(0:3,,2)), st_multipoint(matrix(10:15,,2)))
(ls = st_cast0(mp, "LINESTRING"))
st_cast0(ls, "MULTIPOINT")

# column 2:
mls = st_sfc(st_multilinestring(list(rbind(c(0,0), c(10,0), c(10,10), c(0,10)), 
	rbind(c(5,5),c(5,6), c(6,6), c(6,5)))), 
	st_multilinestring(list(rbind(c(0,0), c(1,0), c(1,1), c(0,1)))))
(pol = st_cast0(mls, "POLYGON"))
st_cast0(pol, "MULTILINESTRING")

# "horizontal" conversions:

(pt = st_cast0(mp, "POINT"))
(i = attr(pt, "ids"))
(xx = st_cast0(pt, "MULTIPOINT", rep(seq_along(i), i)))
(yy = st_cast0(pt, "LINESTRING", rep(seq_along(i), i)))

(zz = st_cast0(yy, "MULTILINESTRING"))
(zz = st_cast0(yy, "POLYGON"))

st_cast0(mls, "LINESTRING")

(g = st_sfc(c(mls, ls)))
st_cast0(g, "MULTILINESTRING")
st_cast0(g, "LINESTRING")
st_cast0(st_cast0(g, "MULTILINESTRING"), "LINESTRING") # will not loose