Nothing
# Author: Oscar Perpinan Lamigueiro oscar.perpinan@gmail.com
# Date : October 2012
# Version 0.10
# Licence GPL v3
lineLabel <- function(line, label,
spar=.6, position = c('above', 'below'),
textloc = 'constantSlope',
col = add.text$col,
alpha = add.text$alpha,
cex = add.text$cex,
lineheight = add.text$lineheight,
font = add.text$font,
fontfamily = add.text$fontfamily,
fontface = add.text$fontface,
lty = add.line$lty,
lwd = add.line$lwd,
col.line = add.line$col,
identifier = 'lineLabel',
...){
.Deprecated("", package="maptools", old="lineLabel",
msg="Function moved to https://github.com/oscarperpinan/label")
## line is a list of Line objects
## label and line must be of equal length
stopifnot(is.numeric(textloc) | is.character(textloc))
stopifnot(length(line) == length(label))
if (is.numeric(textloc)) stopifnot(length(line) == length(textloc))
add.text <- trellis.par.get("add.text")
add.line <- trellis.par.get("add.line")
position <- match.arg(position)
for (i in seq_along(line)) {
subline <- line[[i]]
lbl <- label[i]
coords <- xy.coords(coordinates(subline))
llines(coords,
col = col.line, lty=lty, lwd=lwd,
identifier = paste(identifier, "line", ## add ID?
sep = "."))
if (lbl !='') { ## Only execute if label is not empty
## Where the label is to be placed?
## Method "mixed" from lattice::panel.levelplot
coords <- with(coords, data.frame(x, y))
slopes <- diff(coords$y) / diff(coords$x)
slopes[is.infinite(slopes)] <- NA
rx <- range(coords$x)
ry <- range(coords$y)
stopifnot(is.character(textloc) | is.numeric(textloc))
if (is.character(textloc)){
textloc <- match.arg(textloc, c('minSlope', 'maxDepth', 'constantSlope'))
idxLoc <- switch(textloc,
minSlope = which.min(abs(slopes)),
maxDepth = {
depth <- pmin(pmin(coords$x - rx[1], rx[2] - coords$x) / diff(rx),
pmin(coords$y - ry[1], ry[2] - coords$y) / diff(ry))
min(which.max(depth), length(slopes))
},
constantSlope = {
slopeSign <- sign(slopes)
zeros <- which(slopes==0)
for (i in zeros) {
i1 <- max(1, i-1)
i2 <- min(length(slopes), i + 1)
slopeSign[i] <- sign(sum(slopes[c(i1, i2)], na.rm=1))
}
rleSlopes <- rle(slopeSign)
idxCS <- max(which.max(rleSlopes$lengths) - 1, 1)
cumLengths <- cumsum(rleSlopes$lengths)
idxLim <- c(cumLengths[idxCS] +1, cumLengths[idxCS + 1])
idxLim[1]
## idx1 <- cumsum(rleSlopes$lengths)[idxCS] + 1
## idx2 <- idx1 + rleSlopes$lengths[idxCS + 1] - 1
## which(coords[,1] == min(coords[c(idx1, idx2), 1]))
}
)
} else {idxLoc <- textloc[i]}
## Label: number of characters, width and height
gp <- gpar(col = col,
alpha = alpha,
cex = cex,
lineheight = lineheight,
fontfamily = fontfamily,
fontface = fontface)
chars <- strsplit(lbl, '')[[1]]
nchars <- length(chars)
chWidth <- sapply(chars, function(ch){
chGrob <- textGrob(ch, gp=gp)
gWidth <- grobWidth(chGrob)
convertWidth(gWidth, 'native', valueOnly=TRUE)
})
labLength <- sum(chWidth)
chHeight <- sapply(chars, function(ch){
chGrob <- textGrob(ch, gp=gp)
gHeight <- grobHeight(chGrob)
convertHeight(gHeight, 'native', valueOnly=TRUE)
})
labHeight <- max(chHeight)
##------------------------------------------------------------------##
## Starting at idxLoc, extract the segment of the line to be
## followed. It must be long enough for the text
##------------------------------------------------------------------##
lengths <- LineLength(subline, sum=FALSE, longlat=FALSE)
nParts <- length(lengths)
lengthsLoc <- cumsum(lengths[idxLoc:nParts])
if (labLength > lengthsLoc[nParts - idxLoc +1]) { ##The segment is not long enough for the label
idxLoc <- 1
segCoords <- apply(coords, 2, mean)
slopes <- mean(slopes, na.rm=TRUE)
} else {
idxLength <- min(which(lengthsLoc >= labLength))
segCoords <- coords[idxLoc:(idxLoc+idxLength),]
segment <- Line(segCoords)
lengthSeg <- LineLength(segment)
}
nX <- nrow(segCoords)
if (!is.null(nX) && nX >= 4) { ## smooth.spline needs at least four distinct x values
##------------------------------------------------------------------##
## Resample the segment to obtain a collection of short segments.
##------------------------------------------------------------------##
n <- floor(lengthSeg/min(chWidth)) * 1e3
segSplineFun <- smooth.spline(segCoords, spar = spar) ## change spar to adjust the smooth level
rxSeg <- range(segCoords$x)
xsp <- seq(rxSeg[1], rxSeg[2], length=n) ## new x values to resample the segment
segSpline <- data.frame(predict(segSplineFun, xsp))
## Each letter will be placed above a midpoint of this resampled segment
midPoints <- 1/2 * (segSpline[1:(n-1), ] + segSpline[2:n, ])
slopes <- diff(segSpline$y) / diff(segSpline$x)
##------------------------------------------------------------------##
## Parallel translation of the resampled segment. The distant is fixed
## by the height of the label.
##------------------------------------------------------------------##
## Distance between segments
D <- labHeight
## Unitary perpendicular vector
perp <- data.frame(x=-diff(segSpline$y), y=diff(segSpline$x))
len <- apply(perp, 1, FUN=function(v)sqrt(sum(v^2)))
perp <- perp/len
## Points above (+) or below (-) line
if (position =='below') D <- abs(D) else D <- -abs(D)
segOffset <- sweep(midPoints, 2, D * colMeans(perp))
##segOffset <- midPoints + D*perp
segSplineLine <- Line(segOffset) ##Line(segSpline)
lengthSegSpline <- LineLength(segSplineLine, sum=FALSE)
## sp.lines(segSplineLine, col='blue')
##------------------------------------------------------------------##
## A character is placed above a collection of segments whose total
## length is higher than the character width. IDs is a vector of
## indices to subset the parallel segment.
##------------------------------------------------------------------##
id <- IDs <- 1
lengths <- lengthSegSpline
nSegs <- length(lengths)
for (i in 2:nchars){
D <- cumsum(lengths)
L <- 1/2*(chWidth[i-1] + chWidth[i])
id <- min(which(D>=L))
lengths <- lengths[(id+1):nSegs]
IDs <- c(IDs, id)
}
IDs <- cumsum(IDs)
pts <- SpatialPoints(segOffset)[IDs,]
coordLabs <- coordinates(pts)
slopeLabs <- 180/pi * atan(slopes[IDs])
tg <- textGrob(chars, coordLabs[,1], coordLabs[,2],
default.units='native',
rot=slopeLabs,
gp=gp)
grid.draw(tg)
} else { ## without 4 distinct x values
coordLabs <- coords[idxLoc,]
slopeLabs <- 180/pi * atan(slopes[idxLoc])
just <- if (position=='below') 'top' else 'bottom'
tg <- textGrob(lbl, coordLabs[,1], coordLabs[,2],
just=just,
default.units='native',
rot=slopeLabs,
gp=gp)
grid.draw(tg)
}
## lapply(1:nchars, FUN=function(i){
## pg <- circleGrob(coordLabs[i,1], coordLabs[i,2], r=chWidth[i]/2,
## default.units='native', gp=gpar(col='red'))
## grid.draw(pg)
## })
}}
}
setGeneric('sp.lineLabel', function(object, labels, byid=TRUE,...){standardGeneric('sp.lineLabel')})
setMethod('sp.lineLabel',
signature=(object='Lines'),
definition=function(object, labels, byid=TRUE, ...){
.Deprecated("", package="maptools", old="sp.lineLabel",
msg="Function moved to https://github.com/oscarperpinan/label")
if (missing(labels)) labels=object@ID
if (isTRUE(byid)){
lengths <- sapply(object@Lines, LineLength)
idxMax <- which.max(lengths)
labs <- rep('', length(object@Lines))
labs[idxMax] <- labels
} else {
labs <- rep(labels, length(object@Lines))
}
lineLabel(object@Lines, label=labs, ...)
}
)
setMethod('sp.lineLabel',
signature=(object='SpatialLines'),
definition=function(object, labels, byid=TRUE,...){
.Deprecated("", package="maptools", old="sp.lineLabel",
msg="Function moved to https://github.com/oscarperpinan/label")
if (missing(labels)) labels=object@ID
if (isTRUE(byid)){
lengths <- sapply(object@Lines, LineLength)
idxMax <- which.max(lengths)
labs <- rep('', length(object@Lines))
labs[idxMax] <- labels
} else {
labs <- rep(labels, length(object@Lines))
}
if (missing(labels)){
ids <- sapply(object@lines, function(l)l@ID)
labels <- ids
names(labels) <- ids
}
for (i in seq_along(object)){
line <- object@lines[[i]]
idLabel <- match(line@ID, names(labels))
lbl <- if (is.na(idLabel)) '' else as.graphicsAnnot(labels[idLabel])
sp.lineLabel(line, lbl, byid=byid,...)
}
}
)
setGeneric('label', function(object, text,...){standardGeneric('label')})
setMethod('label', signature=(object='SpatialLines'),
definition=function(object, text,...){
.Deprecated("", package="maptools", old="label",
msg="Function moved to https://github.com/oscarperpinan/label")
text <- as.character(text)
nfeatures <- length(object)
if (!identical(nfeatures, length(text))){
stop('Number of labels must equal number of features.')
}
ids <- sapply(object@lines, function(l)l@ID)
names(text) <- ids
text
})
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.