Nothing
#' Add or remove links in the lattice
#'
#' editLattice is an interactive editor
#' based on the function edit.nb from the
#' package spdep. A formLatticeOutput object
#' includes an automatically generated
#' neighborhood structure. Occasionally
#' this will either leave two nodes disconnected
#' that should be connected or vice versa.
#' editLattice allows the user to directly edit
#' the plot of the lattice using mouseclicks to
#' add or remove neighbor links between nodes.
#' @param formLatticeOutput An object from formLattice or editLattice.
#' @return a formLatticeOutput object, which contains
#' \itemize{
#' \item EWlocs EW coordinates for use in contour.
#' \item NSlocs NS coordinates for use in contour.
#' \item nodes Matrix of node locations.
#' \item poly Matrix of vertices of the boundary polygon.
#' \item latt Lattice object as generated by dnearneigh of package spdep.
#' }
#' @author Ronald P. Barry
#' @seealso formLattice
#' @examples
#' \dontrun{
#' plot.new()
#' data(polygon1)
#' nodeFillingOutput = nodeFilling(poly=polygon1, node_spacing=0.03)
#' plot(nodeFillingOutput)
#' formLatticeOutput = formLattice(nodeFillingOutput)
#' plot(formLatticeOutput)
#' formLatticeOutput = editLattice(formLatticeOutput)
#' #
#' # Paste the code above into R, then do the editing before
#' # pasting the code below into R.
#' #
#' Pointdata = splancs::csr(polygon1,20)
#' densityOut = createDensity(formLatticeOutput,PointPattern=Pointdata,
#' k=150,intensity=FALSE, sparse = TRUE)
#' plot(densityOut)
#' }
#' @import utils
#' @import graphics
#' @import stats
#' @importFrom spdep card
#' @import grDevices
#' @export
editLattice <-
function (formLatticeOutput){
#
# This function is a highly modified version of 'edit.nb' in
# package 'spdep' originally by Roger Bivand.
#
latt <- formLatticeOutput$latt
nodes <- formLatticeOutput$nodes
polys <- formLatticeOutput$poly
hole_list <- formLatticeOutput$hole_list
nbr_numbers <- spdep::card(latt)
old_plt <- par()$plt
on.exit(par(plt=old_plt))
par(plt=c(0,1,0,1))
if (!inherits(latt, "nb"))
stop("not a neighbours list")
# inher_cl is a list of classes inherited by latt, not "nb"
cl <- class(latt)
if (length(cl) > 1)
inher_cl <- cl[-match("nb", cl)]
else inher_cl <- NULL
x <- nodes[, 1]
y <- nodes[, 2]
n <- length(latt)
row.names <- as.character(1:n)
xlim <- range(x)
ylim <- range(y)
plot.new()
plot.window(xlim = xlim, ylim = ylim, "", asp = 1)
lines(polys,col=6,lwd=0.5)
n_holes <- length(hole_list)
for(i in 1:n_holes){
lines(rbind(hole_list[[i]],hole_list[[i]][1,]),col=6,lwd=0.5)
}
# draw the neighbor links
for (i in 1:n) {
if (nbr_numbers[i] > 0)
segments(x[i], y[i], x[latt[[i]]], y[latt[[i]]])
}
if(min(spdep::card(latt))==0){
points(nodes[spdep::card(latt)==0,], col=2, cex=1,pch=19)}
finished <- "n"
erase.col <- par()$bg
while (finished == "n") {
cat("Identifying contiguity for deletion ...\n")
cand <- identify(x, y, n = 2,plot=FALSE)
lines(x[cand], y[cand], col = "red",lwd=2)
if (.Platform$OS.type == "windows")
bringToTop(-1)
if ((cand[2] %in% latt[[cand[1]]]) && (cand[1] %in%
latt[[cand[2]]])) {
delete <- readline("Delete this line (y/n) ")
if (delete != "y")
delete <- "n"
else {
latt[[cand[1]]] <- latt[[cand[1]]][latt[[cand[1]]] != cand[2]]
if (length(latt[[cand[1]]]) == 0) {
latt[[cand[1]]] <- as.integer(0)
cat(cand[1], "is now an island\n")
}
latt[[cand[2]]] <- latt[[cand[2]]][latt[[cand[2]]] !=
cand[1]]
if (length(latt[[cand[2]]]) == 0) {
latt[[cand[2]]] <- as.integer(0)
cat(cand[2], "is now an island\n")
}
lines(x[cand], y[cand], col = erase.col)
cat("deleted contiguity between point", cand[1],
"and", cand[2], "\n")
plot.new()
plot.window(xlim = xlim, ylim = ylim, "", asp = 1)
lines(polys,col=6,lwd=0.5)
for (i in 1:n) {
if (nbr_numbers[i] > 0)
segments(x[i], y[i], x[latt[[i]]], y[latt[[i]]])
}
if(min(spdep::card(latt))==0){
points(nodes[spdep::card(latt)==0,], col=2, cex=1,pch=19)}
}
}
else {
if (length(cand == 2)) {
cat("No contiguity between chosen points\n")
addcont <- readline("Add contiguity? (y/n) ")
if (addcont != "y")
addcont <- "n"
if (addcont == "y") {
latt[[cand[1]]] <- sort(unique(c(latt[[cand[1]]],
cand[2])))
latt[[cand[2]]] <- sort(unique(c(latt[[cand[2]]],
cand[1])))
cat("added contiguity between point", cand[1],
"and", cand[2], "\n")
lines(x[cand], y[cand], col = "black")
latt[[cand[2]]] <- latt[[cand[2]]][ latt[[cand[2]]]>0]
latt[[cand[1]]] <- latt[[cand[1]]][ latt[[cand[1]]]>0]
}
}
}
finished <- readline("Options: quit[q] continue[c] ")
if (finished != "q")
finished <- "n"
}
attr(latt, "region.id") <- row.names
if (is.null(inher_cl))
class(latt) <- "nb"
else class(latt) <- c("nb", inher_cl)
formLatticeOutput$latt <- latt
return(formLatticeOutput)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.