Nothing
R/sfc_curve.R
Defines functions sfc_3x3_meander sfc_3x3_peano .parse_code sfc_2x2
Documented in sfc_2x2 sfc_3x3_meander sfc_3x3_peano
#' Create space-filling curves
#'
#' @param seed The seed sequence. In most cases, the seed sequence is a single base pattern, which can be specified as a single letter, then `rot` controls
#' the initial rotation of the base pattern. It also supports a sequence with more than one base patterns as the seed sequence. In this case,
#' it can be specified as a string of more than one base letters, then `rot` can be set to a single rotation scalar which controls the rotation of the
#' first letter, or a vector with the same length as the number of base letters.
#' @param code A vector of the expansion code. The left side corresponds to the top levels of the curve and the right side corresponds to the bottom level of the curve.
#' The value can be set as a vector e.g. `c(1, 2, 1)`, or as a string e.g. `"121"`, or as a number e.g. `121`.
#' @param rot Rotation of the seed sequence, measured in the polar coordinate system, in degrees.
#'
#' @details
#' - `sfc_2x2()` generates the Hilbert curve from the seed sequence.
#' - `sfc_3x3_peano()` generates the Peano curve from the seed sequence.
#' - `sfc_3x3_meander()` generates the Meander curve from the seed sequence.
#'
#' @rdname spacefilling
#' @return
#'
#' - `sfc_hilbert()` returns an `sfc_2x2` object.
#' - `sfc_peano()` returns an `sfc_3x3_peano` object.
#' - `sfc_meander()` returns an `sfc_3x3_meander` object.
#'
#' These three classes are child classes of `sfc_nxn`.
#' @export
#' @import methods
#' @examples
#' sfc_2x2("I", "111") |> plot()
#' sfc_2x2("I", "111", rot = 90) |> plot()
#' sfc_2x2("IR", "111", rot = 90) |> plot()
sfc_2x2 = function(seed, code = integer(0), rot = 0L) {
code = .parse_code(code, 1:2)
if(inherits(seed, "character")) {
seed = sfc_seed(seed, rot = rot, universe = sfc_universe(SFC_RULES_2x2))
} else if(inherits(seed, "sfc_seed")) {
seed@seq = factor(as.vector(seed@seq), levels = sfc_universe(SFC_RULES_2x2))
} else {
seed = sfc_seed(seq = seed@seq, rot = seed@rot)
}
p = as(seed, "sfc_2x2")
p@seed = seed
p@level = 0L
p@mode = 2L
for(i in seq_along(code)) {
p = sfc_expand(p, code[i])
}
p@expansion = as.integer(code)
p@universe = sfc_universe(SFC_RULES_2x2)
p
}
.parse_code = function(code, full) {
if(length(code) == 1) {
if(is.numeric(code)) {
if(code > 2) {
code = as.character(code)
}
}
}
if(is.character(code)) {
code = as.integer(strsplit(code[1], "")[[1]])
}
if(any(!code %in% 1:2)) {
stop_wrap(paste0("`code` should only contain ", paste(1:2, collapse = ", "), "."))
}
code
}
#' @rdname spacefilling
#' @param flip Whether to use the "flipped" rules? For the Peano curve and the Meander curve, there is also a "fliiped" version
#' of curve expansion rules. On each level expansion in the Peano curve and the Meander curve, a point expands to nine points in
#' 3x3 grids. Thus the value of `flip` can be set as a logical vector of length of nine that controls whether to use the flipped expansion
#' for the corresponding unit. Besides such "1-to-9" mode, `flip` can also be set as a function which acccepts the number of current points in the curve and return
#' a logical vector with the same length, i.e. the "all-to-all*9" mode.
#' @param level Specifically for `sfc_3x3_peano()`, since there is only one expansion code 1, it can also be generated by `rep(1, level)`.
#' @export
#' @examples
#' sfc_3x3_peano("I", "111") |> plot()
#' sfc_3x3_peano("I", "111",
#' flip = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE)) |> plot()
#' sfc_3x3_peano("IJ", "111") |> plot()
#'
#' sfc_3x3_peano("I", level = 4, flip = function(p) {
#' p@rot %in% c(90, 270)
#' }) |> plot(lwd = 1)
#'
#' level = 4
#' sfc_3x3_peano("I", level = level, flip = function(p) {
#' if(length(p) == 9^(level-1)) {
#' l = rep(FALSE, length(p))
#' ind = 1:9^2 + 9^2*rep(c(0, 2, 4, 6, 8), each = 9^2)
#' l[ind] = p@rot[ind] %in% c(90, 270)
#'
#' ind = 1:9^2 + 9^2*rep(c(1, 3, 5, 7), each = 9^2)
#' l[ind] = p@rot[ind] %in% c(0, 180)
#'
#' l
#' } else {
#' rep(FALSE, length(p))
#' }
#' }) |> plot(lwd = 1)
#'
sfc_3x3_peano = function(seed, code = integer(0), rot = 0L, level = NULL, flip = FALSE) {
if(!is.null(level)) {
code = rep(1, level)
} else {
code = .parse_code(code, 1L)
}
if(inherits(seed, "character")) {
seed = sfc_seed(seed, rot = rot, universe = sfc_universe(SFC_RULES_3x3_PEANO))
} else if(inherits(seed, "sfc_seed")) {
levels(seed@seq) = sfc_universe(SFC_RULES_3x3_PEANO)
} else {
seed = sfc_seed(seq = seed@seq, rot = seed@rot)
}
p = as(seed, "sfc_3x3_peano")
p@seed = seed
p@level = 0L
p@mode = 3L
if(is.logical(flip)) {
if(!(length(flip) == length(seed) || length(flip) == 9 || length(flip) == 1)) {
stop_wrap("If `flip` is a logical vector, it should have a length the same as `seed` or 9\n")
}
}
if(is.function(flip)) {
for(i in seq_along(code)) {
p = sfc_expand(p, code[i], flip = flip(p))
}
} else {
for(i in seq_along(code)) {
if(i == 1) {
if(length(flip) == length(seed)) {
p = sfc_expand(p, code[i], flip = flip)
} else {
p = sfc_expand(p, code[i], flip = flip[1])
}
} else if (i == 2) {
if(length(flip) == 9) {
} else {
flip = rep(flip, each = 9)
}
p = sfc_expand(p, code[i], flip = flip)
} else {
flip = rep(flip, each = 9)
p = sfc_expand(p, code[i], flip = flip)
}
}
}
p@expansion = as.integer(code)
p@universe = sfc_universe(seed)
p
}
#' @rdname spacefilling
#' @export
#' @examples
#' sfc_3x3_meander("I", "111") |> plot()
#' sfc_3x3_meander("I", "111",
#' flip = c(TRUE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE)) |> plot()
#' sfc_3x3_meander("IR", "111") |> plot()
sfc_3x3_meander = function(seed, code = integer(0), rot = 0L, flip = FALSE) {
code = .parse_code(code, 1:2)
if(inherits(seed, "character")) {
seed = sfc_seed(seed, rot = rot, universe = sfc_universe(SFC_RULES_3x3_MEANDER))
} else if(inherits(seed, "sfc_seed")) {
levels(seed@seq) = sfc_universe(SFC_RULES_3x3_MEANDER)
} else {
seed = sfc_seed(seq = seed@seq, rot = seed@rot)
}
p = as(seed, "sfc_3x3_meander")
p@seed = seed
p@level = 0L
p@mode = 3L
if(is.logical(flip)) {
if(!(length(flip) == length(seed) || length(flip) == 9 || length(flip) == 1)) {
stop_wrap("If `flip` is a logical vector, it should have a length the same as `seed` or 9\n")
}
}
if(is.function(flip)) {
for(i in seq_along(code)) {
p = sfc_expand(p, code[i], flip = flip(p))
}
} else {
for(i in seq_along(code)) {
if(i == 1) {
if(length(flip) == length(seed)) {
p = sfc_expand(p, code[i], flip = flip)
} else {
p = sfc_expand(p, code[i], flip = flip[1])
}
} else if (i == 2) {
if(length(flip) == 9) {
} else {
flip = rep(flip, each = 9)
}
p = sfc_expand(p, code[i], flip = flip)
} else {
flip = rep(flip, each = 9)
p = sfc_expand(p, code[i], flip = flip)
}
}
}
p@expansion = as.integer(code)
p@universe = sfc_universe(seed)
p
}
#' The level of the curve
#' @aliases sfc_level
#' @rdname sfc_level
#' @param p An `sfc_nxn` object.
#'
#' @return An integer.
#' @export
#' @examples
#' p = sfc_2x2("I", "11")
#' sfc_level(p)
#'
#' p = sfc_2x2("I", "1111")
#' sfc_level(p)
setMethod("sfc_level",
signature = "sfc_nxn",
definition = function(p) {
p@level
})
#' @rdname sfc_mode
#' @export
#' @return An integer.
#' @examples
#' p = sfc_2x2("I", "1")
#' sfc_mode(p)
#' p = sfc_3x3_peano("I", "1")
#' sfc_mode(p)
setMethod("sfc_mode",
signature = "sfc_nxn",
definition = function(p) {
sfc_mode(p@rules)
})
setAs("sfc_seed", "sfc_2x2", function(from) {
p = new("sfc_2x2")
p@seq = from@seq
levels(p@seq) = sfc_universe(SFC_RULES_2x2)
if(any(is.na(p@seq))) {
stop_wrap("Base letters should all be in `sfc_universe(SFC_RULES_2x2)`.")
}
p@rot = from@rot
p@universe = sfc_universe(SFC_RULES_2x2)
p@level = 0L
p@mode = 2L
p@rules = SFC_RULES_2x2
p
})
setAs("sfc_sequence", "sfc_3x3_peano", function(from) {
p = new("sfc_3x3_peano")
p@seq = from@seq
levels(p@seq) = sfc_universe(SFC_RULES_3x3_PEANO)
if(any(is.na(p@seq))) {
stop_wrap("Base letters should all be in `sfc_universe(SFC_RULES_3x3_PEANO)`.")
}
p@rot = from@rot
p@universe = sfc_universe(SFC_RULES_3x3_PEANO)
p@level = 0L
p@mode = 3L
p@rules = SFC_RULES_3x3_PEANO
p
})
setAs("sfc_sequence", "sfc_3x3_meander", function(from) {
p = new("sfc_3x3_meander")
p@seq = from@seq
levels(p@seq) = sfc_universe(SFC_RULES_3x3_MEANDER)
if(any(is.na(p@seq))) {
stop_wrap("Base letters should all be in `sfc_universe(SFC_RULES_3x3_MEANDER)`.")
}
p@rot = from@rot
p@universe = sfc_universe(SFC_RULES_3x3_MEANDER)
p@level = 0L
p@mode = 3L
p@rules = SFC_RULES_3x3_MEANDER
p
})
setAs("sfc_sequence", "sfc_nxn", function(from) {
p = new("sfc_nxn")
p@seq = from@seq
p@rot = from@rot
p@universe = levels(from@seq)
p@level = 0L
p
})
#' @param object The corresponding object.
#' @rdname show
#' @export
setMethod("show",
signature = "sfc_nxn",
definition = function(object) {
cat("An", class(object)[1], "object.\n")
cat(" Increase mode: ", object@mode, " x ", object@mode, "\n", sep = "")
cat(" Level: ", object@level, "\n", sep = "")
cat(" Expansion rule:", object@rules@name, "\n")
if(length(object) < (object@mode^2)^object@level) {
cat(" A fragment from the original curve.\n")
}
cat("\n")
callNextMethod(object)
cat("\n")
cat("Seed: ")
callNextMethod(object@seed)
})
#' Level-1 unit in the Peano curve and Meander curve
#' @aliases level1_unit_orientation
#' @rdname level1_unit_orientation
#' @param p For `level1_unit_orientation()`, it is an `sfc_3x3_peano` or `sfc_3x3_meander` unit on level 1.
#' For `change_level1_unit_orientation()`, it is a normal `sfc_3x3_peano` or `sfc_3x3_meander` object.
#' @return `level1_unit_orientation()` returns "verticalhorizontal" (on the `sfc_3x3_peano` object) or "forward/backward" (on the `sfc_3x3_meander` object).
#' @details
#' "vertical" and "horizontal" correspond to the direction of the "long segments" in a Peano curve (see **Examples**).
#'
#' `level1_unit_orientation()` is normally used inside [`sfc_apply()`]. `change_level1_unit_orientation()`
#' changes all level-1 units of a Peano curve or a Meander curve simultaneously.
#' @export
setMethod("level1_unit_orientation",
signature = "sfc_3x3_peano",
definition = function(p) {
if(length(p) != 9) {
stop_wrap("`u` should be an sfc_3x3_peano unit with length of 9.")
}
loc = sfc_segments(p)
if(equal_to(loc[1, 1], loc[2, 1]) && equal_to(loc[2, 1], loc[3, 1])) {
"vertical"
} else {
"horizontal"
}
})
#' @aliases change_level1_unit_orientation
#' @param to A string of "vertical/horizontal" (on the `sfc_3x3_peano` object) or "forward/backward" (on the `sfc_3x3_meander` object).
#' @return `change_level1_unit_orientation()` returns an `sfc_3x3_peano` or `sfc_3x3_meander` object.
#' @export
#' @rdname level1_unit_orientation
#' @examples
#' p = sfc_3x3_peano("I", 111)
#' # the first level-1 unit
#' level1_unit_orientation(p[1:9, TRUE])
#' # the fourth level-1 unit
#' level1_unit_orientation(p[1:9 + 27, TRUE])
#' p2 = change_level1_unit_orientation(p, "horizontal")
#' p3 = change_level1_unit_orientation(p, "vertical")
#' draw_multiple_curves(p, p2, p3,
#' title = c("original", "all horizontal", "all vertical"), nrow = 1)
setMethod("change_level1_unit_orientation",
signature = "sfc_3x3_peano",
definition = function(p, to = c("horizontal", "vertical")) {
to = match.arg(to)
sfc_apply(p, log(length(p))/log(9) - 1, function(x) {
if(level1_unit_orientation(x) != to) {
sfc_flip_unit(x)
} else {
x
}
})
})
#' @rdname level1_unit_orientation
#' @export
setMethod("level1_unit_orientation",
signature = "sfc_3x3_meander",
definition = function(p) {
if(length(p) != 9) {
stop_wrap("`u` should be an sfc_3x3_meander unit with length of 9.")
}
loc = sfc_segments(p)
if( (loc[1, 1] == loc[2, 1] && loc[2, 1] == loc[3, 1]) || (loc[1, 2] == loc[2, 2] && loc[2, 2] == loc[3, 2])) {
"forward"
} else {
"backward"
}
})
#' @export
#' @rdname level1_unit_orientation
#' @examples
#' # by default, orientations of all level-1 units in Meander curve are forward
#' p = sfc_3x3_meander("I", 111)
#' level1_unit_orientation(p[1:9, TRUE])
#' p2 = change_level1_unit_orientation(p, "backward")
#' draw_multiple_curves(p, p2,
#' title = c("all forward", "all backward"), nrow = 1)
setMethod("change_level1_unit_orientation",
signature = "sfc_3x3_meander",
definition = function(p, to = c("forward", "backward")) {
to = match.arg(to)
sfc_apply(p, log(length(p))/log(9) - 1, function(x) {
if(level1_unit_orientation(x) != to) {
sfc_flip_unit(x)
} else {
x
}
})
})
Try the sfcurve package in your browser
Any scripts or data that you put into this service are public.
