geosphere/ 0000755 0001762 0000144 00000000000 15164563437 012251 5 ustar ligges users geosphere/MD5 0000644 0001762 0000144 00000016704 15164563437 012571 0 ustar ligges users 7f22976807c2cc107c3f2f88362a3e96 *ChangeLog
ba5cdaf082e3533c7474d24f44851ef3 *DESCRIPTION
4bb73096ca67ec7d2fd66cd11338f0e0 *NAMESPACE
ea5fcc0276d17d2012801761b5c911b8 *R/RcppExports.R
f765cc60d33c319f122215070b9e5cca *R/alongTrack.R
c603e867d2d36b565c0223b52c1c769e *R/antipodal.R
237feea5ae914ff3b1750efcad930a60 *R/areaPolygon.R
b32846602a0f755c189e48bae7d59a06 *R/bearing.R
495cb8e6ca1422490b1c6058f9450a46 *R/bearingRhumb.R
02fa33c037a5533db977a7d8e264909b *R/centroid.R
1743d120f033b849e8e77ca463d7c815 *R/daylength.R
1e9e4acd9a27238f46135af46902db60 *R/destPoint.R
19e711a9e49bbc7200d3d6a92af583c5 *R/destPointRhumb.R
68e1394e399cf2cbd41133f482dab2f4 *R/dist2Line.R
7f333bbd90b64c3aa7f9d34b39ed539d *R/dist2gc.R
ef4a2cf12c3ed6b1f6c685ad3c9640d6 *R/distCosines.R
30118ba1a360d8679c7f8885f76a2f32 *R/distGeo.R
6b8bc545e94f6bb859ced4267b7b7a73 *R/distHaversine.R
0fc2aa7858bca0fcde0168aecafc3582 *R/distMeeus.R
b76298022a9e7e04a41bed4963e4f31d *R/distRhumb.R
d86e0dbc3e707a4e765afa6d4ecc7b76 *R/distVincentyEllipsoid.R
c91231d7fd536e01af2bcebf5266f40c *R/distVincentySphere.R
e5d8a111f45a8958d3c1550365ac8be1 *R/distm.R
a8fd9e76e34b8ba76855fb68e0268c5b *R/finalBearing.R
e2ec6c0673f26d1674123059b83b8270 *R/gcIntermediate.R
7907332e1c86fd152dba4944eeac4c5e *R/gcIntersect.R
df3e5ff050196f694dcb830909576d54 *R/gcIntersectBearing.R
4983e28ab7a610326903f3f8c968e346 *R/gcLat.R
9ee61a5e62351c7c8693abbf7a25b103 *R/gcLon.R
3195f1d7d786a931e8f07307bab61d62 *R/gcMaxLat.R
ed6f29123a6c6eb832574e97e4fb9ec7 *R/geocode.R
d0057355a3a1dfd076e94db19a958e77 *R/geodesic.R
2081dca1de87b02dd38dee2d21857e58 *R/geomean.R
37f5bc81ce752f6b153e70ba2eb233fd *R/geomedian.R
62c5857e4eccadd74f486bda66f01121 *R/greatCircle.R
2818b0933c09267f0c05b1ae07bec869 *R/greatCircleBearing.R
088fe0172bbf3794e16cecc29e17a3ee *R/helper.R
ea4c7189b67965e4517e648f27e062b2 *R/horizon.R
8e8deca391daef336db38ed3789eba98 *R/lengthLine.R
5909511eb4bb49f486fda5bbaeda913c *R/makePoly.R
323eadc05c03f5d11b51558ec412640d *R/mercator.R
430c0a96d811acc0eb31638a108ef44b *R/midPoint.R
13f88662ae5bcb6f0584facd6bd57e29 *R/old_destPoint.R
caba5729f0e9429c56c9e6dd6c0d4b3c *R/onGreatCircle.R
70aa176635f101570c71808e71c4353a *R/perimeter.R
dbb5582cf39016edd8981e7c332fcc5c *R/plotPoly.R
3cd75796774d047493dc8242023af7e4 *R/pointsToMatrix.R
63372c1d29b6fd85bc82e2695ef831cf *R/randomCoordinates.R
ad94d2fb3c7bab9fcc660132ae3534bb *R/refEllipsoids.R
a0903ff2b54c613bedcd723a0b3784f7 *R/regularCoordinates.R
c6b3b408ca7a076e2de11c1db8a76ae5 *R/sampleAlong.R
d11b49142cde7f8bdd857796a4d2d53a *R/span.R
ba582b375e5afde780e991c9b7711c6a *build/partial.rdb
f9ea47bc9654de64083dea7bab544d0e *build/vignette.rds
990871f1c55db0d5b160d786c86e6850 *data/merc.RData
464a29b93751536caa7f2cf583124960 *data/wrld.RData
62bcb6dd4e344c6e21a4d75c29e6888d *inst/doc/geosphere.R
ccb6235f7e1009cfab76508d2848344e *inst/doc/geosphere.Rnw
385f05501fe8e5dd663cd530571f5315 *inst/doc/geosphere.pdf
81ce1c4eb1d5bd1302cd0e07987e9186 *man/OSGB.Rd
6d96299e3d47a6bc59572c331080d5c6 *man/alongTrackDistance.Rd
e3149675013c8042a7e4b1d189ebb502 *man/antipode.Rd
2bcdc62b4d51146bd94aefad61c3b47b *man/area.Rd
3c1e67195e91c173dab816fa1ef556a5 *man/bearing.Rd
759fd642d8d30a6e4df829f4ad83e96d *man/bearingRhumb.Rd
9f635d7f7c92d5a35ca58634f9d4aca0 *man/centroid.Rd
5313bdcb42b9f847a3cfe5a6662122f1 *man/data.Rd
919193497deae5b71e7b2ce8586aa695 *man/daylength.Rd
bb669fa8d574e4635055b22f1d50f4c6 *man/destPoint.Rd
8c9abb053076948c843bb6aee5bc8255 *man/destPointRhumb.Rd
308ded364b826af6300a8fdd4ef87ef9 *man/dist2gc.Rd
01a22370f20c44a9caaa72f910c6e514 *man/dist2line.Rd
c5f5fb73bb34f9a26752da3e52111dba *man/distCosine.Rd
dd141627647789d50a684905fcc436a0 *man/distGeo.Rd
fe4749f348de0dfc5e40628e2e0d3359 *man/distHaversine.Rd
18bf5b4b4721eaa101e44787e6c3cb0e *man/distMeeus.Rd
6b58e5faa130ae3e37cfe14ca51c94b0 *man/distRhumb.Rd
e885d31e77b4c95b3fc5f38b1ffc2524 *man/distVincentyEllipsoid.Rd
e4e1780d70108de0d7bd8e9fc864490b *man/distVincentySphere.Rd
afa1c56dd3db517d3d1605943a1c1826 *man/distm.Rd
4b6f1d4603bc1b515b02b5e00f33b356 *man/finalDirection.Rd
3c4b544ec73c1fe20b6071539c427a0a *man/gcIntersect.Rd
45cb5bd7816f9245b501a0cc194185e4 *man/gcIntersectBearing.Rd
6cb89752de06fa903cd398aeff8f7eba *man/gcLat.Rd
4765b6196ab47333898170efd8dfccb2 *man/gcLon.Rd
ac3f7fabfe8b312bb0a432305d2d4d15 *man/gcMaxLat.Rd
6fa655576b9ef5b129e1f4d840772857 *man/geodesic.Rd
48cb8c3ad419c5c376828521bcae65c2 *man/geomean.Rd
10e81cd9f8a6e505dd79e4583749bf99 *man/geosphere-package.Rd
4e7069024be6c2df3c285532b4a09a3f *man/greatCircle.Rd
1fb55c4fcc4dc6832a62ed972ed21e72 *man/greatCircleBearing.Rd
2fe4ad438c887c4afa1b6ab8ec397c8e *man/horizon.Rd
a2a12c427a2df1ada5e71a01db049204 *man/intermediate.Rd
f4041cf233eff9ff59f433466b12c72b *man/lengthLine.Rd
f914ee7fb7d8814771cc6b9030d80874 *man/makepoly.Rd
bb5594fa360f7bd43ce0e5a3e7669765 *man/mercator.Rd
1f4501ca3c843ed15e7fad9ede71fbd7 *man/midPoint.Rd
59e5771608c5cd49199e43247d7322c5 *man/onGreatCircle.Rd
d6584b12201babdd088d975b602765a3 *man/perimeter.Rd
9c6d6bf5d20a721a18e2ecc43b93b53c *man/plotArrows.Rd
a62b2968097c05ee51730cf47c42bd02 *man/randomCoordinates.Rd
03ee9e2645c0d185463b1b7d39096280 *man/refEllipsoids.Rd
8ff83d99b122d13079310a49f7ec0ce0 *man/span.Rd
39591eb218c065d7e125f248c79e8d37 *src/Accumulator.cpp
a8a4a49937fa1635e2ce60efbd47c1c4 *src/Accumulator.h
7df17490cd97669418e4edf79717c74b *src/AuxAngle.cpp
e686b6989192f3d03e7128bf57cbc761 *src/AuxAngle.h
358255deaa10d857e5cc5e907590f6e1 *src/AuxLatitude.cpp
375e0b493048b714dc3346c41ffe5ba7 *src/AuxLatitude.h
36d77345f6a87b7d68e5ac4ac41e1b14 *src/Config.h
57fb3421da601baee7a53b23dc580bc6 *src/Constants.h
977f2859fb02e7d107964dc3a2581328 *src/DAuxLatitude.cpp
6063e9de7269708f445536347fe90589 *src/DAuxLatitude.h
623e9d420c8746611ac773f54c682720 *src/DST.cpp
1997c248dfdbfab5d2e4c81dc2f808c9 *src/DST.h
eb14bc987c9ceaf0f933a63fc37f5438 *src/EllipticFunction.cpp
291246bbb8492257c651bb416452cf1f *src/EllipticFunction.h
4c9454105a2a592501d9cf8451508166 *src/Geodesic.cpp
30f7b21cba2e1e30272f74bb0e5812d4 *src/Geodesic.h
04aaaf9810be4ba3668e6ee229f0e0ef *src/GeodesicExact.cpp
cee2b16efbe43315d39b7894830fbbc9 *src/GeodesicExact.h
34df130bb0a42756c88356e3f8f66d16 *src/GeodesicLine.cpp
a590c2bc01c87bfb0f91be3b8555862e *src/GeodesicLine.h
357217d4be46e98b5a886fe615abf538 *src/GeodesicLineExact.cpp
ab2cc1df0bd160eeecadce0fbc36b57c *src/GeodesicLineExact.h
35bf34f043e882c2221fbb4c78c92f9d *src/Intersect.cpp
3d88a5905cf41301ca54ffe829ad3e71 *src/Intersect.h
d62f7b5944ce65812625aecd52dbf26a *src/Math.cpp
3861dddb4835bd414d47ea6c7451ee8f *src/Math.h
a429ad13aba5b14d307ec3dae32cf058 *src/OSGB.cpp
5a2cc4fbc9774ca372197a9bea983aa7 *src/OSGB.h
66f32acfc8866c70ff68365f63911593 *src/PolygonArea.cpp
40ac8d3474ea86594044b85ad1b470ab *src/PolygonArea.h
76a3ffc6ea694b29cbde3bc8db11a5b8 *src/RcppExports.cpp
d63e2378df2584eb4168cb00afc4b273 *src/Rhumb.cpp
3ba5f15aa5dc8a216a2e82973e657d9b *src/Rhumb.h
84d5acfd85193f0b3c5a7c12395a9448 *src/TransverseMercator.cpp
d888ce0a86c3a5b80744faa1fc378e18 *src/TransverseMercator.h
32d1f89a83a9eeb7a8d8ebb0749bc64f *src/TransverseMercatorExact.cpp
45c8975a619d558444a2dd0fce98283d *src/TransverseMercatorExact.h
b3ea65f0d651f0a4dd0cbb4b4705c79f *src/Utility.cpp
30a695ad88cbda1d4e24bc7af625ca28 *src/Utility.h
c92e9a174ac3b5529402c9795b612356 *src/a_dist.c
be6f63b3c81cd6fd1ea61be6d2ee9883 *src/a_geodesic.cpp
f0f94c31254b48429601bbbf75c0790a *src/a_geolib.cpp
e7ed3cfd2ceb132ccd9e7c342ba7f0a0 *src/a_util.c
02b3ab8677d52f791681845435a5252a *src/a_util.h
b64faa17284258c98812d2f21e67a8b7 *src/kissfft.h
ccb6235f7e1009cfab76508d2848344e *vignettes/geosphere.Rnw
geosphere/R/ 0000755 0001762 0000144 00000000000 15147425256 012447 5 ustar ligges users geosphere/R/gcIntermediate.R 0000644 0001762 0000144 00000010317 15153103722 015504 0 ustar ligges users # author Robert Hijmans
# October 2009
# version 0.1
# license GPL
.interm <- function(p1, p2, n) {
toRad <- pi / 180
if (antipodal(p1, p2)) {
return(rep(Inf, nrow(p1)))
}
if (isTRUE(all.equal(p1, p2))) {
return(cbind(rep(p1[,1], nrow(p1)), rep(p1[,2], nrow(p1)) ))
}
d <- distCosine(p1, p2, r=1)
lon1 <- p1[,1] * toRad
lat1 <- p1[,2] * toRad
lon2 <- p2[,1] * toRad
lat2 <- p2[,2] * toRad
n <- max(round(n), 1)
f <- 1:n / (n+1)
A <- sin((1-f)*d) / sin(d)
B <- sin(f*d) / sin(d)
x <- A*cos(lat1)*cos(lon1) + B*cos(lat2)*cos(lon2)
y <- A*cos(lat1)*sin(lon1) + B*cos(lat2)*sin(lon2)
z <- A*sin(lat1) + B*sin(lat2)
lat <- atan2(z,sqrt(x^2+y^2))
lon <- atan2(y,x)
cbind(lon,lat)/toRad
}
.breakAtDateLine <- function(x) {
r <- range(x[,1])
r <- r[2] - r[1]
if (r > 200) {
dif <- abs(x[-nrow(x),1] - x[-1,1])
tr <- which(dif==max(dif))
x1 <- x[1:tr, ,drop=FALSE]
x2 <- x[(tr+1):nrow(x), ,drop=FALSE]
if (x1[tr,1] < 0) {
x1[tr,1] <- -180
x2[1,1] <- 180
} else {
x1[tr,1] <- 180
x2[1,1] <- -180
}
if (nrow(x1) <= 1) {
res <- x2
} else if (nrow(x2) <= 1) {
res <- x1
} else {
res <- list(x1, x2)
}
return(res)
}
return(x)
}
gcIntermediate <- function( p1, p2, n=50, breakAtDateLine=FALSE, addStartEnd=FALSE, output=NULL, sepNA=FALSE, ...) {
# Intermediate points on a great circle
# source: http://www.edwilliams.org/avform.htm
# backwards compat
sp <- isTRUE(list(...)$sp)
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(n))
res <- list()
for (i in 1:nrow(p)) {
x <- .interm(p[i,1:2,drop=FALSE], p[i,3:4,drop=FALSE], p[i,5])
if (addStartEnd) {
x <- rbind(p[i,1:2,drop=FALSE], x, p[i,3:4,drop=FALSE])
}
if (breakAtDateLine) {
res[[i]] <- .breakAtDateLine(x)
} else {
res[[i]] <- x
}
}
if (is.null(output)) {
if (sp) {
for (i in 1:length(res)) {
if (! is.list(res[[i]])) {
res[[i]] <- sp::Lines( list( sp::Line (res[[i]])), ID=as.character(i))
} else {
res[[i]] <- sp::Lines( list( sp::Line (res[[i]][[1]]), sp::Line(res[[i]][[2]])), ID=as.character(i))
}
}
res <- sp::SpatialLines(res, sp::CRS("+proj=longlat +ellps=WGS84"))
} else if (nrow(p) == 1 ) {
res <- res[[1]]
} else if (sepNA) {
r <- res[[1]]
for (i in 2:length(res)) {
r <- rbind(r, c(NA,NA), res[[i]])
}
return(r)
}
return(res)
} else if (output == "list") {
return(res)
} else if (output == "matrix") {
if (sepNA) {
r <- do.call(rbind, lapply(res, function(x) rbind(c(NA, NA), x)))
return(r[-1,])
} else {
return(do.call(rbind, res))
}
} else if (output == "sf") {
r <- lapply(res, function(x) sf::st_linestring(x))
r <- sf::st_sf(geometry = sf::st_sfc(r, crs = 4326))
} else if (output == "sv") {
r <- terra::vect(lapply(res, function(x) terra::vect(x, type="lines")))
terra::crs(r) <- "lonlat"
} else if (output=="sp") {
for (i in 1:length(res)) {
if (! is.list(res[[i]])) {
res[[i]] <- sp::Lines( list( sp::Line (res[[i]])), ID=as.character(i))
} else {
res[[i]] <- sp::Lines( list( sp::Line (res[[i]][[1]]), sp::Line(res[[i]][[2]])), ID=as.character(i))
}
}
res <- sp::SpatialLines(res, sp::CRS("+proj=longlat +ellps=WGS84"))
}
}
.geodIntermediate <- function(p1, p2, n=50, breakAtDateLine=FALSE, addStartEnd=TRUE, sepNA=FALSE) {
a=6378137
f=1/298.257223563
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(n))
res <- list()
for (i in 1:nrow(p)) {
x <- .geod_intermediate(p[i,1], p[i,2], p[i,3], p[i,4], p[i,5], -1, TRUE, a, f)
x <- .interm(p[i,1:2,drop=FALSE], p[i,3:4,drop=FALSE], p[i,5])
if (!addStartEnd) {
x <- x[-c(1, nrow(x)), ,drop=FALSE]
}
if (breakAtDateLine) {
res[[i]] <- .breakAtDateLine(x)
} else {
res[[i]] <- x
}
}
if (nrow(p) == 1 ) {
res <- res[[1]]
} else if (sepNA) {
r <- res[[1]]
for (i in 2:length(res)) {
r <- rbind(r, c(NA,NA), res[[i]])
}
return(r)
}
return(res)
}
geosphere/R/old_destPoint.R 0000644 0001762 0000144 00000002313 15147425256 015400 0 ustar ligges users # author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# Based on formulae by Ed Williams
# http://www.edwilliams.org/avform.htm
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# License GPL3
.old_destPoint <- function(p, b, d, r=6378137) {
# calculate destination point given start point, initial bearing (deg) and distance (km)
# see http:#//www.edwilliams.org/avform.htm#LL
# source http://www.movable-type.co.uk/scripts/latlong.html
# (c) 2002-2009 Chris Veness
toRad <- pi / 180
b = as.vector(b)
d = as.vector(d)
r = as.vector(r)
p <- .pointsToMatrix(p)
p = cbind(p[,1], p[,2], b, d, r)
lon1 <- p[,1] * toRad
lat1 <- p[,2] * toRad
b <- p[,3] * toRad
d = p[,4]
r = p[,5]
lat2 <- asin( sin(lat1)*cos(d/r) + cos(lat1)*sin(d/r)*cos(b) )
lon2 <- lon1 + atan2(sin(b)*sin(d/r)*cos(lat1), cos(d/r)-sin(lat1)*sin(lat2))
lon2 <- (lon2+pi)%%(2*pi) - pi #// normalise to -180...+180
lon2[is.nan(lon2)] <- NA
lat2[is.nan(lat2)] <- NA
res <- cbind(lon2, lat2) / toRad
colnames(res) <- c('lon', 'lat')
return(res)
}
geosphere/R/distCosines.R 0000644 0001762 0000144 00000002423 15147425256 015062 0 ustar ligges users # Author: Robert J. Hijmans
# Date : June 2008
# Licence GPL v3
# distance based on law of cosines
# http://en.wikipedia.org/wiki/Great_circle_distance
distCosine <- function(p1, p2, r=6378137) {
p1 <- .pointsToMatrix(p1)
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2)
}
pp <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
# remove identical points to avoid errors due to floating point math
# problem reported by Bill Monahan
i <- rowSums(abs(pp[, 1:2, drop=FALSE] - pp[, 3:4, drop=FALSE]) < .Machine$double.eps ^ 0.5) < 2
p <- pp[i, ,drop=FALSE]
r <- rep(0, nrow(pp))
if (nrow(p) > 0) {
p[,1:4] <- p[,1:4] * pi / 180
r[i] <- acos( sin(p[,2]) * sin(p[,4]) + cos(p[,2]) * cos(p[,4]) * cos(p[,1]-p[,3]) ) * p[,5]
}
r
}
# m = matrix(c(-58.65222,-19.65154,-52.985550,-1.484869, -69.652220, 7.348464, -69.652220,7.348464, -1,1 ,-1,1, -1,1.1,-1,1.1, -1,1.2,-1,1.2, -116.65220,72.01513,-121.48560,53.34847), ncol=4, byrow=T)
# distCosine(m[,1:2], m[,3:4])
# n <- nrow(p)
# d <- vector("double", n)
# d <- .C('distance', as.integer(n), as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(p[,5]), as.integer(1), d)[[8]]
# return(d)
geosphere/R/geomedian.R 0000644 0001762 0000144 00000003067 15147425256 014530 0 ustar ligges users # Author: Robert J. Hijmans
# March 2012
# version 1
# license GPL3
.geomedian <- function(xy, w=NULL) {
xy <- .pointsToMatrix(xy)
if (is.null(w)) {
w <- 1
} else if (length(w) != nrow(xy)) {
stop('length of weights not correct. It should be: ', nrow(xy))
}
w <- w / sum(w)
xyw <- cbind(xy, w)
xy <- stats::na.omit(xyw)
xy <- xyw[,1:2]
w <- xyw[,3]
est <- geomean(xy, w)
fun <- function(p) {
if (p[2] > 90 | p[2] < -90) {
return(Inf)
} else {
p[1] = (p[1] + 180) %% 360 - 180
sum( distCosine(xy, p) * w)
}
}
opt <- stats::optim(geomean(xy), fun)
if (!is.null(opt$message)) {
warning(opt$message)
}
return(opt$par)
}
..geomedian_ndcor <- function(xy, w=NULL, threshold=100, maxiter=100) {
if (inherits(xy, 'SpatialPolygons') | inherits(xy, 'SpatialPoints')) {
stopifnot(terra::is.lonlat(terra::vect(xy)))
xy <- sp::coordinates(xy)
}
if (is.null(w)) {
w <- 1
} else if (length(w) != nrow(xy)) {
stop('length of weights not correct. It should be: ', nrow(xy))
}
w <- w / sum(w)
xyw <- cbind(xy, w)
xy <- stats::na.omit(xyw)
xy <- xyw[,1:2]
w <- xyw[,3]
est <- geomean(xy, w)
estold <- est
iter = 1
while (TRUE) {
d <- distCosine(xy, est)
x <- sum(w*xy[,1] / d) / sum(w/d)
y <- sum(w*xy[,2] / d) / sum(w/d)
est <- cbind(x,y)
dif <- distCosine(est, estold)
if (dif < threshold) {
return(est)
} else if (iter > maxiter) {
warning('maxiter reached')
return(est)
}
estold <- est
iter <- iter + 1
}
}
geosphere/R/geodesic.R 0000644 0001762 0000144 00000002717 15147425256 014363 0 ustar ligges users # R implementation of
# /*
# * This is a C implementation of the geodesic algorithms described in
# *
# * C. F. F. Karney,
# * Algorithms for geodesics,
# * J. Geodesy 87, 43--55 (2013);
# * https://dx.doi.org/10.1007/s00190-012-0578-z
# * Addenda: http://geographiclib.sf.net/geod-addenda.html
# *
# * See the comments in geodesic.h for documentation.
# *
# * Copyright (c) Charles Karney (2012-2014) and licensed
# * under the MIT/X11 License. For more information, see
# * http://geographiclib.sourceforge.net/
# */
#
# Robert Hijmans
# May 2015
# version 1
# license GPL3
# Solve the direct geodesic problem.
geodesic <- function(p, azi, d, a=6378137, f=1/298.257223563, ...) {
p <- .pointsToMatrix(p)
p <- cbind(p[,1], p[,2], azi, d)
r <- .geodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f))
r <- matrix(r, ncol=3, byrow=TRUE)
colnames(r) <- c('longitude', 'latitude', 'azimuth')
r
}
# Solve the inverse geodesic problem.
geodesic_inverse <- function(p1, p2, a=6378137, f=1/298.257223563, ...) {
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
r <- .inversegeodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f))
r <- matrix(r, ncol=3, byrow=TRUE)
colnames(r) <- c('distance', 'azimuth1', 'azimuth2')
r
}
geosphere/R/RcppExports.R 0000644 0001762 0000144 00000001522 15147425256 015063 0 ustar ligges users # Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
.geodesic <- function(lon1, lat1, azi1, s12, a, f) {
.Call(`_geosphere_geodesic`, lon1, lat1, azi1, s12, a, f)
}
.inversegeodesic <- function(lon1, lat1, lon2, lat2, a, f) {
.Call(`_geosphere_inversegeodesic`, lon1, lat1, lon2, lat2, a, f)
}
.polygonarea <- function(lon, lat, a, f) {
.Call(`_geosphere_polygonarea`, lon, lat, a, f)
}
.geod_intermediate <- function(lon1, lat1, lon2, lat2, n, distance, arc, a, f) {
.Call(`_geosphere_geodesic_nodes`, lon1, lat1, lon2, lat2, n, distance, arc, a, f)
}
.OSGB <- function(x, y, p, geo) {
.Call(`_geosphere_osgb`, x, y, p, geo)
}
.OSGBinv <- function(g, prec, centerp) {
.Call(`_geosphere_osgb_rev`, g, prec, centerp)
}
geosphere/R/destPoint.R 0000644 0001762 0000144 00000001270 15147425256 014543 0 ustar ligges users # Author: Robert J. Hijmans
# Date : May 2015
# Licence GPL v3
destPoint <- function(p, b, d, a=6378137, f=1/298.257223563, ...) {
# calculate destination point given start point, initial bearing (deg) and distance (m)
r <- list(...)$r
if (!is.null(r)) {
# for backwards compatibility
return( .old_destPoint(p, b, d, r=r) )
}
b <- as.vector(b)
d <- as.vector(d)
p <- .pointsToMatrix(p)
p <- cbind(p[,1], p[,2], b, d)
r <- .geodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f))
r <- matrix(r, ncol=3, byrow=TRUE)
colnames(r) <- c('lon', 'lat', 'finalbearing')
return(r[, 1:2, drop=FALSE])
}
geosphere/R/gcLon.R 0000644 0001762 0000144 00000002626 15147425256 013642 0 ustar ligges users # author Robert Hijmans
# October 2009
# version 0.1
# license GPL3
# based on
#http://www.edwilliams.org/avform.htm#Par
gcLon <- function(p1, p2, lat) {
# longitudes at which a given great circle crosses a given parallel
# source: http://www.edwilliams.org/avform.htm
toRad <- pi / 180
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], lat)
p1 <- p[,1:2,drop=FALSE]
p2 <- p[,3:4,drop=FALSE]
lat <- p[,5]
res <- matrix(NA, nrow=nrow(p1), ncol=2)
colnames(res) <- c('lon1', 'lon2')
anti <- ! antipodal(p1, p2)
if (sum(anti) == 0) {
return(res)
}
p1 <- p1[anti, ,drop=FALSE] * toRad
p2 <- p2[anti, ,drop=FALSE] * toRad
lon1 <- p1[,1] * -1
lat1 <- p1[,2]
lon2 <- p2[,1] * -1
lat2 <- p2[,2]
lat3 <- lat * toRad
l12 <- lon1-lon2
A <- sin(lat1)*cos(lat2)*cos(lat3)*sin(l12)
B <- sin(lat1)*cos(lat2)*cos(lat3)*cos(l12) - cos(lat1)*sin(lat2)*cos(lat3)
C <- cos(lat1)*cos(lat2)*sin(lat3)*sin(l12)
lon <- atan2(B,A)
lon3 <- matrix(NA, nrow=length(lon1), ncol=2)
i <- (abs(C) > sqrt(A^2 + B^2)) | (sqrt(A^2 + B^2) == 0)
lon3[i,] <- NA
i <- !i
dlon <- rep(NA, length(A))
dlon[i] <- acos(C[i]/sqrt(A[i]^2+B[i]^2))
lon3[i,1] <- .normalizeLonRad(lon1[i]+dlon[i]+lon[i])
lon3[i,2] <- .normalizeLonRad(lon1[i]-dlon[i]+lon[i])
res[anti,] <- -1 * lon3 / toRad
return(res)
}
geosphere/R/daylength.R 0000644 0001762 0000144 00000003265 15147425256 014557 0 ustar ligges users # Author: Robert J. Hijmans, r.hijmans@gmail.com
# License GPL3
# Version 0.1 January 2009
daylength <- function(lat, doy) {
if (inherits(doy, "Date") || inherits(doy, "character")) {
doy <- as.character(doy)
doy <- as.numeric(format(as.Date(doy), "%j"))
} else {
doy <- (doy-1) %% 365 + 1
}
lat[lat > 90 | lat < -90] <- NA
#Forsythe, William C., Edward J. Rykiel Jr., Randal S. Stahl, Hsin-i Wu and Robert M. Schoolfield, 1995.
#A model comparison for daylength as a function of latitude and day of the year. Ecological Modeling 80:87-95.
P <- asin(0.39795 * cos(0.2163108 + 2 * atan(0.9671396 * tan(0.00860*(doy-186)))))
a <- (sin(0.8333 * pi/180) + sin(lat * pi/180) * sin(P)) / (cos(lat * pi/180) * cos(P))
a <- pmin(pmax(a, -1), 1)
DL <- 24 - (24/pi) * acos(a)
return(DL)
}
.daylength2 <- function(lat, doy) {
if (inherits(doy, "Date") || inherits(doy, "character")) {
doy <- as.character(doy)
doy <- as.numeric(format(as.Date(doy), "%j"))
} else {
doy <- (doy-1) %% 365 + 1
}
lat[lat > 90 | lat < -90] <- NA
doy <- (doy-1) %% 365 + 1
# after Goudriaan and Van Laar
RAD <- pi/180
# Sine and cosine of latitude (LAT)
SINLAT <- sin(RAD * lat);
COSLAT <- cos(RAD * lat);
# Maximal sine of declination;}
SINDCM <- sin(RAD * 23.45)
#{Sine and cosine of declination (Eqns 3.4, 3.5);}
SINDEC <- -SINDCM * cos(2*pi*(doy+10)/365)
COSDEC <- sqrt(1-SINDEC*SINDEC);
#The terms A and B according to Eqn 3.3;}
A <- SINLAT*SINDEC;
B <- COSLAT*COSDEC;
C <- A/B;
#Daylength according to Eqn 3.6; arcsin(c) = arctan(c/sqrt(c*c+1))}
DAYL <- 12* (1+(2/pi)* atan(C/sqrt(C*C+1)))
return(DAYL)
}
geosphere/R/dist2gc.R 0000644 0001762 0000144 00000001306 15147425256 014131 0 ustar ligges users # based on code by Ed Williams
# Licence: GPL
# http://www.edwilliams.org/avform.htm#XTE
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
dist2gc <- function(p1, p2, p3, r=6378137, sign=FALSE) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p3 <- .pointsToMatrix(p3)
r <- as.vector(r)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], p3[,1], p3[,2], r)
p1 <- p[,1:2]
p2 <- p[,3:4]
p3 <- p[,5:6]
r <- p[,7]
tc <- bearing(p1, p2, a=r, f=0) * toRad
tcp <- bearing(p1, p3, a=r, f=0) * toRad
dp <- distCosine(p1, p3, r=1)
xtr <- (asin(sin(tcp-tc) * sin(dp)) * r)
xtr <- as.vector(xtr)
if (!sign) xtr <- abs(xtr)
xtr
}
geosphere/R/plotPoly.R 0000644 0001762 0000144 00000003567 15147425256 014427 0 ustar ligges users # Author: Robert Hijmans
# April 2010
# version 0.1
# license GPL
# inspired by an example in Software for Data Analysis by John Chambers (pp 250-1)
# but adjusted to follow great circles, rather than straight (2D) lines.
.doArrows <- function(p, line, fraction, length, interval, ...) {
if (fraction >= 1) {
graphics::lines(line, ...)
} else {
dist <- distGeo(p[-nrow(p),], p[-1,]) * (1 - fraction)
bearing <- bearing(p[-nrow(p),], p[-1,])
p0 <- destPoint(p[-nrow(p),], bearing, dist)
for (i in 1:nrow(p0)) {
line = .makeSinglePoly(rbind(p0[i,], p[i+1,]), interval=interval)
graphics::lines(line)
}
}
bearing = finalBearing(p[-nrow(p),], p[-1,])
bearing = (bearing + 180) %% 360
pp = destPoint(p[-1,], bearing, interval)
x0 <- pp[,1]
y0 <- pp[,2]
x1 <- p[,1][-1]
y1 <- p[,2][-1]
# delta = sqrt(mean((x1-x0)^2 + (y1-y0)^2, na.rm=TRUE))
# delta = delta * (par("pin")[1] / diff(range(x, na.rm=TRUE)))
graphics::arrows(x0, y0, x1, y1, code=2, length=length, ...)
}
plotArrows <- function(p, fraction=0.9, length=0.15, first='', add=FALSE, ...) {
asp=1
if (inherits(p, 'Spatial')) {
bb = t(sp::bbox(p))
interval = distm(bb)[2][1] / 1000
if (! add) { plot(bb, asp=asp, type='n') }
p = p@polygons
n = length(p)
for (i in 1:n) {
parts = length(p[[i]]@Polygons )
sumarea = 0
for (j in 1:parts) {
pp = p[[i]]@Polygons[[j]]@coords
line = .makeSinglePoly(pp, interval=interval)
.doArrows(pp, line, fraction, length, interval=interval, ...)
}
graphics::points(pp[1,1], pp[1,2], pch=first, cex=2)
}
} else {
interval = max(distm(p), na.rm=TRUE) / 1000
line = .makeSinglePoly(p, interval=interval)
if (! add) { plot(line, asp=asp, type='n') }
.doArrows(p, line=line, fraction, length, interval=interval, ...)
graphics::points(p[1,1], p[1,2], pch=first, cex=2)
}
}
geosphere/R/distVincentyEllipsoid.R 0000644 0001762 0000144 00000005735 15147425256 017134 0 ustar ligges users # author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
distVincentyEllipsoid <- function(p1, p2, a=6378137, b=6356752.3142, f=1/298.257223563) {
#/* Vincenty Inverse Solution of Geodesics on the Ellipsoid (c) Chris Veness 2002-2009 #*/
#* Calculate geodesic distance (in m) between two points specified by latitude/longitude
#* (in numeric degrees) using Vincenty inverse formula for ellipsoids
# source http://www.movable-type.co.uk/scripts/latlong-vincenty.html
# (c) 2002-2009 Chris Veness
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p = cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(a), as.vector(b), as.vector(f))
p1 = p[,1:2,drop=FALSE]
p2 = p[,3:4,drop=FALSE]
res <- vector(length=nrow(p1))
for (i in 1:dim(p1)[1]) {
if ( any( is.na( c(p1[i,], p2[i,])))) { #improvement by George Wang and Sebastian P. Luque
res[i] <- NA
} else if (isTRUE(all.equal(p1[i,], p2[i,]))) {
res[i] <- 0
} else {
lon1 <- p1[i,1]
lat1 <- p1[i,2]
lon2 <- p2[i,1]
lat2 <- p2[i,2]
a = p[i,5]
b = p[i,6]
f = p[i,7]
L <- (lon2-lon1)
U1 <- atan((1-f) * tan(lat1))
U2 <- atan((1-f) * tan(lat2))
sinU1 <- sin(U1)
cosU1 <- cos(U1)
sinU2 <- sin(U2)
cosU2 <- cos(U2)
lambda <- L
iterLimit <- 100
continue <- TRUE
while (continue) {
sinLambda <- sin(lambda)
cosLambda <- cos(lambda)
sinSigma <- sqrt((cosU2*sinLambda) * (cosU2*sinLambda) + (cosU1*sinU2-sinU1*cosU2*cosLambda) * (cosU1*sinU2-sinU1*cosU2*cosLambda))
cosSigma <- sinU1*sinU2 + cosU1*cosU2*cosLambda
sigma <- atan2(sinSigma, cosSigma)
sinAlpha <- cosU1 * cosU2 * sinLambda / sinSigma
cosSqAlpha <- 1 - sinAlpha*sinAlpha
cos2SigmaM <- cosSigma - 2*sinU1*sinU2/cosSqAlpha
if (is.nan(cos2SigmaM)) cos2SigmaM <- 0 # equatorial line: cosSqAlpha=0 (par. 6)
C <- f/16*cosSqAlpha*(4+f*(4-3*cosSqAlpha))
lambdaP <- lambda
lambda <- L + (1-C) * f * sinAlpha * (sigma + C*sinSigma*(cos2SigmaM+C*cosSigma*(-1+2*cos2SigmaM*cos2SigmaM)))
iterLimit <- iterLimit - 1
continue <- (abs(lambda-lambdaP) > 1e-12 && iterLimit > 0)
}
if (iterLimit==0) {
res[i] <- NA # failed to converge
} else {
uSq <- cosSqAlpha * (a*a - b*b) / (b*b)
A <- 1 + uSq/16384*(4096+uSq*(-768+uSq*(320-175*uSq)))
B <- uSq/1024 * (256+uSq*(-128+uSq*(74-47*uSq)))
deltaSigma <- B*sinSigma*(cos2SigmaM+B/4*(cosSigma*(-1+2*cos2SigmaM*cos2SigmaM)- B/6*cos2SigmaM*(-3+4*sinSigma*sinSigma)*(-3+4*cos2SigmaM*cos2SigmaM)))
res[i] <- b*A*(sigma-deltaSigma)
}
}
}
return(as.vector(res))
}
geosphere/R/sampleAlong.R 0000644 0001762 0000144 00000004771 15147425256 015045 0 ustar ligges users # Based on code by Barry Rowlingson
#http://r-sig-geo.2731867.n2.nabble.com/how-to-generate-perpendicular-transects-along-a-line-feature-td7583710.html
# Some adaptations by Robert Hijmans
# January 2016
# version 0.1
# License GPL3
.evenspace <- function(xy, sep, start=0, size, direction=FALSE){
dx <- c(0,diff(xy[,1]))
dy <- c(0,diff(xy[,2]))
dseg <- sqrt(dx^2+dy^2)
dtotal <- cumsum(dseg)
linelength <- sum(dseg)
pos <- seq(start,linelength, by=sep)
whichseg <- unlist(lapply(pos, function(x){sum(dtotal<=x)}))
x0 <- xy[whichseg,1]
y0 <- xy[whichseg,2]
x1 <- xy[whichseg+1,1]
y1 <- xy[whichseg+1,2]
dtotal <- dtotal[whichseg]
further <- pos - dtotal
dseg <- dseg[whichseg+1]
f <- further/dseg
x <- x0 + f * (x1-x0)
y <- y0 + f * (y1-y0)
r <- data.frame(x, y)
# if (direction) {
# r$direction <- atan2(y0-y1,x0-x1)
# }
r
}
.transect <- function(pts, len){
pts$thetaT = pts$theta+pi/2
dx <- len*cos(pts$thetaT)
dy <- len*sin(pts$thetaT)
data.frame(x0 = pts$x + dx,
y0 = pts$y + dy,
x1 = pts$x - dx,
y1 = pts$y -dy)
}
.sampleAlong <- function(x, interval) {
if (inherits(x, 'SpatialPolygons')) {
x <- terra::as.lines(terra::vect(x))
} else if (inherits(x, 'SpatialLines')) {
x <- terra::vect(x)
} else if (inherits(x, 'sf')) {
x <- terra::as.lines(terra::vect(x))
}
if (inherits(x, "SpatVector")) {
x <- terra::densify(x, interval)
terra::crds(x)
} else {
x <- .pointsToMatrix(x)
.evenspace(x, interval, direction=FALSE)
}
}
.sampleAlongPerpendicular <- function(x, interval, pdist, np=1 ) {
if (inherits(x, 'SpatialPolygons')) {
line <- terra::as.lines(terra::vect(line))
} else if (inherits(x, 'SpatialLines')) {
line <- terra::vect(line)
} else if (inherits(x, "sf")) {
line <- terra::vect(line)
}
if (inherits(line, "SpatVector")) {
x <- data.frame(terra::geom(x))
allpts <- NULL
cump <- as.integer(interaction(x$geom, x$part))
for (p in unique(cump)) {
y <- x[cump==p, c('x', 'y')]
tspts <- .evenspace(y, interval)
pts <- NULL
for (i in 1:np) {
pts1 <- .transect(tspts, i * pdist)
pts <- cbind(pts, pts1)
}
allpts <- rbind(allpts, pts)
}
return(allpts)
} else {
x <- .pointsToMatrix(x)
y <- .evenspace(x, interval)
pts <- NULL
for (i in 1:np) {
pts1 <- .transect(y, i * pdist)
pts <- cbind(pts, pts1)
}
return(pts)
}
}
geosphere/R/gcIntersect.R 0000644 0001762 0000144 00000004576 15147425256 015060 0 ustar ligges users # author Robert Hijmans
# October 2009
# version 0.1
# license GPL3
# based on an alogrithm described by Ed Williams
# http://www.edwilliams.org/intersect.htm
# Not used
#gete <- function(lon, lat) {
# ex <- cos(lat)*cos(lon)
# ey <- -cos(lat)*sin(lon)
# ez <- sin(lat)
# return(cbind(ex, ey, ez))
#}
gcIntersect <- function(p1, p2, p3, p4) {
#intersection of two great circles defined by pt1 to pt2 and pt3 to pt4.
einv <- function(e) {
lat <- atan2(e[,3], sqrt(e[,1]^2 + e[,2]^2))
lon <- atan2(-e[,2], e[,1])
return(cbind(lon, lat))
}
eXe5 <- function(lon1, lat1, lon2, lat2) {
ex <- sin(lat1-lat2) *sin((lon1+lon2)/2) *cos((lon1-lon2)/2) - sin(lat1+lat2) *cos((lon1+lon2)/2) *sin((lon1-lon2)/2)
ey <- sin(lat1-lat2) *cos((lon1+lon2)/2) *cos((lon1-lon2)/2) + sin(lat1+lat2) *sin((lon1+lon2)/2) *sin((lon1-lon2)/2)
ez <- cos(lat1)*cos(lat2)*sin(lon1-lon2)
return( cbind(ex, ey, ez) )
}
eXe3 <- function(e1, e2) {
x <- e1[,2] * e2[,3] -e2[,2] *e1[,3]
y <- e1[,3] *e2[,1] -e2[,3] *e1[,1]
z <- e1[,1] *e2[,2] -e1[,2] *e2[,1]
return(cbind(x,y,z))
}
eSQRT <- function(e) {
return(sqrt(e[,1]^2 + e[,2]^2 + e[,3]^2))
}
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p3 <- .pointsToMatrix(p3)
p4 <- .pointsToMatrix(p4)
p1 <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
p3 <- cbind(p3[,1], p3[,2], p4[,1], p4[,2])
p <- cbind(p1[,1], p1[,2], p1[,3], p1[,4], p3[,1], p3[,2], p3[,3], p3[,4])
p1 <- p[,1:2,drop=FALSE]
p2 <- p[,3:4,drop=FALSE]
p3 <- p[,5:6,drop=FALSE]
p4 <- p[,7:8,drop=FALSE]
res <- matrix(NA, nrow=nrow(p1), ncol=4)
colnames(res) <- c('lon1', 'lat1', 'lon2', 'lat2')
keep <- ! antipodal(p1, p2) | antipodal(p3, p4)
keep <- keep & ! apply(p1 == p2, 1, sum) == 2
if (sum(keep) == 0) { return(res) }
toRad <- pi / 180
p1 <- p1[keep, , drop=FALSE] * toRad
p2 <- p2[keep, , drop=FALSE] * toRad
p3 <- p3[keep, , drop=FALSE] * toRad
p4 <- p4[keep, , drop=FALSE] * toRad
e1Xe2 <- eXe5(p1[,1], p1[,2], p2[,1], p2[,2])
e3Xe4 <- eXe5(p3[,1], p3[,2], p4[,1], p4[,2])
ea <- e1Xe2 / eSQRT(e1Xe2)
eb <- e3Xe4 / eSQRT(e3Xe4)
eaXeb <- eXe3(ea, eb)
ll <- einv(eaXeb)
ll2 <- cbind(ll[,1] + pi, -ll[,2])
pts <- cbind(ll, ll2)
pts[,1] <- .normalizeLonRad(pts[,1])
pts[,3] <- .normalizeLonRad(pts[,3])
res[keep,] <- pts / toRad
return(res)
}
geosphere/R/greatCircle.R 0000644 0001762 0000144 00000002244 15147425256 015020 0 ustar ligges users # author Robert Hijmans
# October 2009
# version 0.1
# license GPL
greatCircle <- function(p1, p2, n=360, sp=FALSE) {
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], n)
p1 <- p[,1:2]
p2 <- p[,3:4]
n <- pmax(round(p[,5]), 1)
if (nrow(p) == 1) {
lon <- (1:n * 360 / n) - 180
lat <- gcLat(p1, p2, lon)
res <- cbind(lon,lat)
if (sp) {
lat <- gcLat(p1, p2, 180)
res <- list(rbind(cbind(-180, lat), res))
res <- sp::SpatialLines( list( sp::Lines( list( sp::Line (res)), ID=as.character(1)) ), sp::CRS("+proj=longlat +ellps=WGS84"))
}
} else {
res <- list()
for (i in 1:nrow(p1)) {
lon <- (1:n[i] * 360 / n[i]) - 180
lat <- gcLat(p1[i,], p2[i,], lon)
res[[i]] <- cbind(lon, lat)
}
if (sp) {
for (i in 1:length(res)) {
lat <- gcLat(p1[i,], p2[i,], 180)
res[[i]] <- rbind(cbind(-180, lat), res[[i]])
res[[i]] <- sp::Lines( list( sp::Line (res[[i]])), ID=as.character(i))
}
res <- sp::SpatialLines(res, sp::CRS("+proj=longlat +ellps=WGS84"))
}
}
return(res)
}
#greatCircle(rbind(cbind(5,52), cbind(5,15)), c(-120,37), n=12)
geosphere/R/regularCoordinates.R 0000644 0001762 0000144 00000001731 15147425256 016430 0 ustar ligges users # author Robert Hijmans
# July 2010
# version 0.1
# license GPL
# Based on pascal code by Nils Haeck, simdesign.nl
# http://mathforum.org/kb/message.jspa?messageID=3985660&tstart=0
regularCoordinates <- function(N) {
N <- round(N)
if (N < 1) {stop('N should be >= 1')}
# subdivision angle
beta <- 0.5 * pi / N
# line segment length
A <- 2 * sin(beta/2);
# endcap
points <- rbind(c(0, 0, 1), c(0, 0, -1))
# rings
R <- sin(1:N * beta)
Z <- cos(1:N * beta)
M <- round(R * 2 * pi / A)
for (i in 1:N) {
j <- 0:(M[i]-1)
Alpha <- j/M[i] * 2 * pi
X <- cos(Alpha) * R[i]
Y <- sin(Alpha) * R[i]
points <- rbind(points, cbind(X, Y, Z[i]))
if (i != N) {
points <- rbind(points, cbind(X, Y, -Z[i]))
}
}
r <- sqrt(points[,1]^2 + points[,2]^2 + points[,3]^2)
theta <- acos(points[,3] / r)
phi <- atan2(points[,2], points[,1])
lat <- theta * 180 / pi - 90
lon <- phi * 180 / pi
return(cbind(lon,lat))
}
geosphere/R/dist2Line.R 0000644 0001762 0000144 00000005421 15147425256 014431 0 ustar ligges users # Author: George Wang & Robert J. Hijmans
# August 2010
# version 1
# license GPL3
.spDistPoint2Line <- function(p, line, distfun) {
test <- !sp::is.projected(line)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of sp::SpatialPolygons object is not set. Assuming it is degrees (longitude/latitude)!')
} else {
stop('Points are projected. They should be in degrees (longitude/latitude)')
}
# or rather transform them ....?
}
x <- line@lines
n <- length(x)
res <- matrix(nrow=nrow(p), ncol=4)
colnames(res) <- c("distance","lon","lat","ID")
res[] <- Inf
for (i in 1:n) {
parts <- length(x[[i]]@Lines )
for (j in 1:parts) {
crd <- x[[i]]@Lines[[j]]@coords
r <- cbind(dist2Line(p, crd, distfun), i)
k <- r[,1] < res[,1]
res[k, ] <- r[k, ]
}
}
return(res)
}
dist2Line <- function(p, line, distfun=distGeo) {
p <- .pointsToMatrix(p)
if (inherits(line, 'SpatialPolygons')) {
line <- methods::as(line, 'sp::SpatialLines')
}
if (inherits(line, 'SpatialLines')) {
return( .spDistPoint2Line(p, line, distfun) )
}
line <- .pointsToMatrix(line)
line1 <- line[-nrow(line), ,drop=FALSE]
line2 <- line[-1, ,drop=FALSE]
seglength <- distfun(line1, line2)
res <- matrix(nrow=nrow(p), ncol=3)
colnames(res) <- c("distance","lon","lat")
for (i in 1:nrow(p)) {
xy <- p[i,]
# the shortest distance of a point to a great circle
crossdist <- abs(dist2gc(line1, line2, xy))
# the alongTrackDistance is the length of the path along the great circle to the point of intersection
# there are two, depending on which node you start
# we want to use the min, but the max needs to be < segment length
trackdist1 <- alongTrackDistance(line1, line2, xy)
trackdist2 <- alongTrackDistance(line2, line1, xy)
mintrackdist <- pmin(trackdist1, trackdist2)
maxtrackdist <- pmax(trackdist1, trackdist2)
crossdist[maxtrackdist >= seglength] <- NA
# if the crossdist is NA, we use the distance to the nodes
nodedist <- distfun(xy, line)
warnopt = getOption('warn')
options('warn'=-1)
distmin1 <- min(nodedist, na.rm=TRUE)
distmin2 <- min(crossdist, na.rm=TRUE)
options('warn'= warnopt)
if (distmin1 <= distmin2) {
j <- which.min(nodedist)
res[i,] <- c(distmin1, line[j,])
} else {
j <- which.min(crossdist)
# if else to determine from which node to start
if (trackdist1[j] < trackdist2[j]) {
bear <- bearing(line1[j,], line2[j,])
pt <- destPoint(line1[j,], bear, mintrackdist[j])
res[i,] <- c(crossdist[j], pt)
} else {
bear <- bearing(line2[j,], line1[j,])
pt <- destPoint(line2[j,], bear, mintrackdist[j])
res[i,] <- c(crossdist[j], pt)
}
}
}
return(res)
}
geosphere/R/geocode.R 0000644 0001762 0000144 00000000704 15147425256 014200 0 ustar ligges users # Robert Hijmans
# May 2023
# version 1
# license GPL3
OSGB <- function(xy, precision, geo=FALSE, inverse=FALSE) {
if (inverse) {
xy <- .OSGBinv(xy, 1, TRUE)
matrix(xy, ncol=2, dimnames=list(NULL, c("x", "y")))
} else {
stopifnot(precision %in% c('1m', '10m', '100m', '1km', '10km', '100km', '5m', '50m', '500m', '5km', '50km', '500km'))
xy <- .pointsToMatrix(xy, FALSE)
.OSGB(xy[,1], xy[,2], precision[1], geo[1])
}
}
geosphere/R/mercator.R 0000644 0001762 0000144 00000000771 15147425256 014413 0 ustar ligges users # Author: Robert J. Hijmans
# April 2010
# version 0.1
# license GPL3
mercator <- function(p, inverse=FALSE, r=6378137) {
toRad <- pi / 180
if (inverse) {
p <- .pointsToMatrix(p, checkLonLat=FALSE)
p[ ,2] <- pi/2 - 2 * atan(exp(-p[,2] / r))
p[ ,1] <- p[,1] / r
colnames(p) <- c('lon', 'lat')
return( p / toRad )
} else {
p <- .pointsToMatrix(p) * toRad
p[,2] <- log( tan(p[,2]) + (1 / cos(p[,2])))
p <- p * r
colnames(p) <- c('x', 'y')
return( p )
}
}
geosphere/R/distMeeus.R 0000644 0001762 0000144 00000002142 15147425256 014533 0 ustar ligges users # R code by Robert Hijmans
# based on Java script code by
# Stephen R. Schmitt (copyright, 2004)
# http://web.archive.org/web/20070108024032/http://home.att.net/~srschmitt/script_greatcircle.html
# algorithm taken from "Astronomical Algorithms" by Jean Meeus
distMeeus <- function(p1, p2, a=6378137, f=1/298.257223563) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
F <- ( p1[,2] + p2[,2] ) / 2
G <- ( p1[,2] - p2[,2] ) / 2
L <- ( p1[,1] - p2[,1] ) / 2
sinG2 <- ( sin( G ) )^2
cosG2 <- ( cos( G ) )^2
sinF2 <- ( sin( F ) )^2
cosF2 <- ( cos( F ) )^2
sinL2 <- ( sin( L ) )^2
cosL2 <- ( cos( L ) )^2
S <- sinG2 * cosL2 + cosF2 * sinL2
C <- cosG2 * cosL2 + sinF2 * sinL2
w <- atan( sqrt( S/C ) )
R <- sqrt( S*C )/w
D <- 2 * w * a
H1 <- (3*R - 1)/(2*C)
H2 <- (3*R + 1)/(2*S)
dst <- D*( 1 + f*H1*sinF2*cosG2 - f*H2*cosF2*sinG2 )
# remove NaN for when p1[i,]==p2[i,]
dst[which(w==0)] <- 0
return ( as.vector(dst) )
}
geosphere/R/distm.R 0000644 0001762 0000144 00000001067 15147425256 013716 0 ustar ligges users # Robert Hijmans
# April 2010
# version 1
# License GPL3
.distm1 <- function(x, fun) {
n = nrow(x)
dm = matrix(0, ncol=n, nrow=n)
if (n == 1) {
return(dm)
}
for (i in 2:n) {
j = 1:(i-1)
dm[i,j] = fun(x[i,], x[j,])
}
dm <- dm+t(dm)
return(dm)
}
distm <- function(x, y, fun=distGeo) {
x <- .pointsToMatrix(x)
if (missing(y)) {
return( .distm1(x, fun) )
}
y <- .pointsToMatrix(y)
n = nrow(x)
m = nrow(y)
dm = matrix(ncol=m, nrow=n)
for (i in 1:n) {
dm[i,] = fun(x[i,], y)
}
return(dm)
}
geosphere/R/gcLat.R 0000644 0001762 0000144 00000002014 15147425256 013621 0 ustar ligges users # author Robert Hijmans
# October 2009
# version 0.1
# license GPL
gcLat <- function(p1, p2, lon) {
# Intermediate points on a great circle
# source: http://www.edwilliams.org/avform.htm
toRad <- pi / 180
d <- distCosine(p1, p2)
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(lon))
p1 <- p[,1:2,drop=FALSE]
p2 <- p[,3:4,drop=FALSE]
lon <- p[,5]
res <- rep(NA, nrow(p))
notanti <- ! antipodal(p1, p2)
lon1 <- p1[,1] * toRad
lat1 <- p1[,2] * toRad
lon2 <- p2[,1] * toRad
lat2 <- p2[,2] * toRad
lon <- lon * toRad
# cannot compute this for a meridian
notmeridians <- ! sin(lon1-lon2)==0
keep <- notanti & notmeridians
if (sum(keep) == 0) { return(res) }
lon1 <- lon1[keep]
lat1 <- lat1[keep]
lon2 <- lon2[keep]
lat2 <- lat2[keep]
lon <- lon[keep]
res[keep] <- atan((sin(lat1)*cos(lat2)*sin(lon-lon2) -sin(lat2)*cos(lat1)*sin(lon-lon1))/(cos(lat1)*cos(lat2)*sin(lon1-lon2)))
return(res / toRad)
}
geosphere/R/helper.R 0000644 0001762 0000144 00000001421 15147425256 014047 0 ustar ligges users # Author: Robert J. Hijmans
# April 2010
# version 1
# license GPL3
.normalizeLonDeg <- function(x) {
(x + 180) %% 360 - 180
}
.normalizeLonRad <- function(x) {
(x + pi) %% (2*pi) - pi
}
.isPolygon <- function(x, fix=FALSE) {
x <- stats::na.omit(x)
if (nrow(x) < 4) {
stop('this is not a polygon (insufficent number of vertices)')
}
if (length(unique(x[,1]))==1) {
stop('All longitudes are the same (not a polygon)')
}
if (length(unique(x[,2]))==1) {
stop('All latitudes are the same (not a polygon)')
}
if (! all(!(is.na(x))) ) {
stop('polygon has NA values)')
}
if (! isTRUE(all.equal(x[1,], x[nrow(x),]))) {
stop('this is not a valid (closed) polygon. The first vertex is not equal to the last vertex')
}
return(x)
}
geosphere/R/geomean.R 0000644 0001762 0000144 00000001235 15147425256 014206 0 ustar ligges users # Author: Robert J. Hijmans
# February 2012
# version 1
# license GPL3
geomean <- function(xy, w=NULL) {
xy <- .pointsToMatrix(xy)
if (is.null(w)) {
w <- 1
} else if (length(w) != nrow(xy)) {
stop('length of weights not correct. It should be: ', nrow(xy))
}
w <- w / sum(w)
xyw <- cbind(xy, w)
xy <- stats::na.omit(xyw)
xy <- xyw[,1:2]
w <- xyw[,3]
xy[,1] <- xy[,1] + 180
xy <- xy * pi / 180
Sx <- mean(sin(xy[,1]) * w)
Cx <- mean(cos(xy[,1]) * w)
x <- atan2(Sx, Cx)
x <- x %% (2 * pi) - pi
Sy <- mean(sin(xy[,2]) * w)
Cy <- mean(cos(xy[,2]) * w)
y <- atan2(Sy, Cy)
cbind(x,y) * 180 / pi
}
geosphere/R/antipodal.R 0000644 0001762 0000144 00000001263 15147425256 014547 0 ustar ligges users # Author: Robert J. Hijmans
# October 2009
# version 1.0
# license GPL3
antipodal <- function(p1, p2, tol=1e-9) {
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
p[,c(1,3)] <- .normalizeLonDeg(p[,c(1,3)])
diflon <- abs(p[,1] - p[,3])
diflat <- abs(p[,2] + p[,4])
## FIX by Gareth Davies
# (diflat < tol) & (diflon > (180 - tol))
## FIX by Jonathan Rynd
# (diflat < tol) & (abs(diflon%%360 - 180) < tol)
(diflat < tol) & ((cos(p[,2] * pi/180) * abs(diflon%%360 - 180)) < tol)
}
antipode <- function(p) {
p <- .pointsToMatrix(p)
p[,1] <- .normalizeLonDeg(p[,1] + 180)
p[,2] <- -p[,2]
return( p )
}
geosphere/R/greatCircleBearing.R 0000644 0001762 0000144 00000000544 15147425256 016311 0 ustar ligges users # author Robert Hijmans
# April 2010
# version 0.1
# license GPL
greatCircleBearing <- function(p, brng, n=360) {
p <- .pointsToMatrix(p)
p <- cbind(p[,1], p[,2], as.vector(brng), n)
p2 <- destPoint(p[,1:2], p[,3], 10000000)
return(greatCircle(p[,1:2], p2, n=p[,4]))
}
#greatCircleBearing(rbind(cbind(5,52), cbind(5,15)), 60, n=12)
geosphere/R/gcMaxLat.R 0000644 0001762 0000144 00000002554 15147425256 014300 0 ustar ligges users # Based on formulae by Ed Williams
# http://www.edwilliams.org/avform.htm
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# License GPL3
gcMaxLat <- function(p1, p2) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
p1 <- p[,1:2,drop=FALSE]
p2 <- p[,3:4,drop=FALSE]
anti <- antipodal(p1, p2)
same <- apply(p1 == p2, 1, sum) == 2
use <- !(anti | same)
res <- matrix(rep(NA, nrow(p1)*2), ncol=2)
colnames(res) <- c('lon', 'lat')
if (length(use)==0) {
return(res)
}
pp1 <- p1[use, , drop=FALSE]
pp2 <- p2[use, , drop=FALSE]
b <- .old_bearing(pp1, pp2) * toRad
lat <- pp1[,2] * toRad
# Clairaut's formula : the maximum latitude of a great circle path, given a bearing and latitude on the great circle
maxlat <- acos(abs(sin(b) * cos(lat))) / toRad
ml <- maxlat - 0.000000000001
maxlon <- mean(gcLon(pp1, pp2, ml))
res[use,] <- cbind(maxlon, maxlat)
# lon <- pp1[,1] * toRad
# maxlon <- rep(NA, length(maxlat))
# i <- maxlat==0
# j <- b < pi & !i
# k <- !j & !i
# maxlon[j] <- lon[j] - atan2(cos(b[j]), sin(b[j]) * sin(lat[j]))
# maxlon[k] <- lon[k] + pi - atan2(cos(b[k]), sin(b[k]) * sin(lat[k]))
# maxlon <- -1 * ((maxlon+pi)%%(2*pi) - pi)
# res[use,] <- cbind(maxlon, maxlat)/ toRad
return(res)
}
geosphere/R/midPoint.R 0000644 0001762 0000144 00000002627 15147425256 014364 0 ustar ligges users # Robert Hijmans
# October 2009
# version 0.1
# License GPL3
midPoint <- function(p1, p2, a=6378137, f = 1/298.257223563) {
# by Elias Pipping
gi <- geodesic_inverse(p1, p2, a=a, f=f);
destPoint(p1, gi[,'azimuth1'], gi[,'distance']/2, a = a, f = f)
}
.old_midPoint <- function(p1, p2) {
# author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# Much of the above based on formulae by Ed Williams
# http://www.edwilliams.org/avform.htm
# Port to R by Robert Hijmans
# calculate midpoint of great circle line between p1 & p2.
# see http:#//mathforum.org/library/drmath/view/51822.html for derivation
# based on http://www.movable-type.co.uk/scripts/latlong.html
# (c) 2002-2009 Chris Veness
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
p2 <- .pointsToMatrix(p2) * toRad
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
lon1 <- p[,1]
lat1 <- p[,2]
lon2 <- p[,3]
lat2 <- p[,4]
dLon <- (lon2-lon1)
Bx <- cos(lat2) * cos(dLon)
By <- cos(lat2) * sin(dLon)
lat <- atan2(sin(lat1) + sin(lat2), sqrt((cos(lat1) + Bx)*(cos(lat1) + Bx) + By*By ) )
lon <- lon1 + atan2(By, cos(lat1) + Bx)
lon[is.nan(lon)] <- NA
lat[is.nan(lat)] <- NA
lon <- (lon+pi)%%(2*pi) - pi
res <- cbind(lon, lat) / toRad
return(res)
}
geosphere/R/distVincentySphere.R 0000644 0001762 0000144 00000001502 15147425256 016422 0 ustar ligges users # Author: Robert J. Hijmans
# Date : June 2008
# Version 0.8 (taken from Raster package)
# Licence GPL v3
# Vincenty formula for a sphere
# http://en.wikipedia.org/wiki/Great_circle_distance
distVincentySphere <- function(p1, p2, r=6378137) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
lon1 <- p[,1]
lat1 <- p[,2]
lon2 <- p[,3]
lat2 <- p[,4]
x <- sqrt((cos(lat2) * sin(lon1-lon2))^2 + (cos(lat1) * sin(lat2) - sin(lat1) * cos(lat2) * cos(lon1-lon2))^2)
y <- sin(lat1) * sin(lat2) + cos(lat1) * cos(lat2) * cos(lon1-lon2)
dist <- p[,5] * atan2(x, y)
return ( as.vector(dist ))
}
geosphere/R/randomCoordinates.R 0000644 0001762 0000144 00000001017 15147425256 016244 0 ustar ligges users # author Robert Hijmans
# July 2010
# version 0.1
# license GPL
# based on suggstions by Michael Orion
# http://sci.tech-archive.net/Archive/sci.math/2005-09/msg04691.html
randomCoordinates <- function(n) {
z <- stats::runif(n) * 2 - 1
t <- stats::runif(n) * 2 * pi
r <- sqrt(1-z^2)
x <- r * cos(t)
y <- r * sin(t)
r <- sqrt(x^2 + y^2 + z^2)
theta <- acos(z / r)
phi <- atan2(y,x)
lat <- theta * 180 / pi - 90
lon <- phi * 180 / pi
return(cbind(lon,lat))
}
geosphere/R/alongTrack.R 0000644 0001762 0000144 00000001752 15147425256 014664 0 ustar ligges users # based on code by Ed Williams
# licence GPL
# http://www.edwilliams.org/avform.htm#XTE
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
alongTrackDistance <- function(p1, p2, p3, r=6378137) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p3 <- .pointsToMatrix(p3)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], p3[,1], p3[,2], as.vector(r))
p1 <- p[,1:2,drop=FALSE]
p2 <- p[,3:4,drop=FALSE]
p3 <- p[,5:6,drop=FALSE]
r = p[,7]
tc <- bearing(p1, p2) * toRad
tcp <- bearing(p1, p3) * toRad
dp <- distCosine(p1, p3, r=1)
xtr <- asin(sin(tcp-tc) * sin(dp))
# +1/-1 for ahead/behind [lat1,lon1]
bearing <- sign(cos(tc - tcp))
angle <- cos(dp) / cos(xtr)
# Fixing limits for the angle between [-1, 1] to avoid NaNs
angle[angle > 1] <- 1
angle[angle < -1] <- -1
dist <- bearing * acos(angle) * r
if (is.vector(dist)) { dist <- matrix(dist) }
colnames(dist) <- 'distance'
return(abs(dist))
}
geosphere/R/areaPolygon.R 0000644 0001762 0000144 00000007566 15147425256 015070 0 ustar ligges users # Robert Hijmans
# April 2010
# version 1
# license GPL3
if (!isGeneric("areaPolygon")) {
setGeneric("areaPolygon", function(x, ...)
standardGeneric("areaPolygon"))
}
setMethod('areaPolygon', signature(x='data.frame'),
function(x, a=6378137, f=1/298.257223563, ...) {
areaPolygon(as.matrix(x), a=a, f=f, ...)
} )
setMethod('areaPolygon', signature(x='SpatVector'),
function(x, a=6378137, f=1/298.257223563, ...) {
stopifnot(terra::geomtype(x) == "polygons")
if (terra::crs(x) == "") {
warning('Coordinate reference system of x is not set. Assuming it is degrees (longitude/latitude)!')
} else {
if (!terra::is.lonlat(x, perhaps=FALSE, warn=FALSE)) {
stop('The coordinate reference system of x is not longitude/latitude.')
}
}
x <- data.frame(terra::geom(x))
x <- split(x, x$geom)
n <- length(x)
res <- vector(length=n)
for (i in 1:n) {
y <- x[[i]]
y <- split(y, y[,2])
parts <- length(y)
sumarea <- 0
for (j in 1:parts) {
crd <- y[[j]][, c("x", "y")]
ar <- areaPolygon(crd, a=a, f=f, ...)
if (y[[j]]$hole[1]) {
sumarea <- sumarea - ar
} else {
sumarea <- sumarea + ar
}
}
res[i] <- sumarea
}
res
}
)
setMethod('areaPolygon', signature(x='sf'),
function(x, a=6378137, f=1/298.257223563, ...) {
areaPolygon(terra::vect(x), a=a, f=f)
})
setMethod('areaPolygon', signature(x='SpatialPolygons'),
function(x, a=6378137, f=1/298.257223563, ...) {
test <- sp::is.projected(x)
if ( isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of x is not set. Assuming it is degrees (longitude/latitude)!')
} else {
stop('The coordinate reference system is not longitude/latitude.')
}
# or rather transform them ....?
}
x <- x@polygons
n <- length(x)
res <- vector(length=n)
for (i in 1:n) {
parts <- length(x[[i]]@Polygons )
sumarea <- 0
for (j in 1:parts) {
crd <- x[[i]]@Polygons[[j]]@coords
ar <- areaPolygon(crd, a=a, f=f, ...)
if (x[[i]]@Polygons[[j]]@hole) {
sumarea <- sumarea - ar
} else {
sumarea <- sumarea + ar
}
}
res[i] <- sumarea
}
return(res)
} )
setMethod('areaPolygon', signature(x='matrix'),
function(x, a=6378137, f=1/298.257223563, ...) {
r <- list(...)$r
if (!is.null(r)) {
# for backwards compatibility
warning('remove argument "r" to use an better algorithm')
return( .old_areaPolygon(x, r=r) )
}
# calling geographiclib
x <- .polygonarea(as.double(x[,1]), as.double(x[,2]), as.double(a), as.double(f))
abs(x[3])
})
.old_areaPolygon <- function(x, r=6378137, ...) {
# Based on code by Jason_Steven (http://forum.worldwindcentral.com/showthread.php?p=69704)
# Reference: Bevis, M. and G. Cambareri, 1987. Computing the area of a spherical polygon of arbitrary shape. Mathematical Geology 19: 335-346
haversine <- function(y) { (1-cos(y))/2 }
x <- .pointsToMatrix(x, poly=TRUE)
x <- makePoly(x) # for some corner cases
# rotate?
dif1 <- max(x[,1]) - min(x[,1])
if (dif1 > 180) {
x2 <- x
x2[,1] <- x2[,1] %% 360 - 180
#dif1 <- max(x[,1]) - min(x[,1])
dif2 <- max(x2[,1]) - min(x2[,1])
if (dif2 < dif1) {
x <- x2
}
}
x <- x * pi / 180
r <- r[1]
j <- 1:nrow(x)
k <- c(2:nrow(x), 1)
i <- x[j,1] != x[k,1]
j <- j[i]
k <- k[i]
lam1 <- x[j,1]
lam2 <- x[k,1]
beta1 <- x[j,2]
beta2 <- x[k,2]
cosB1 <- cos( beta1 )
cosB2 <- cos( beta2 )
hav <- haversine( beta2 - beta1 ) + cosB1 * cosB2 * haversine( lam2 - lam1 )
a <- 2 * asin( sqrt( hav ) )
b <- pi / 2 - beta2
c <- pi / 2 - beta1
s <- 0.5 * ( a + b + c )
t <- tan( s / 2 ) * tan( ( s - a ) / 2 ) * tan( ( s - b ) / 2 ) * tan( ( s - c ) / 2 )
excess <- abs( 4 * atan( sqrt( abs( t ) ) ) )
excess[lam2 < lam1] <- -excess[lam2 < lam1]
arsum <- abs( sum( excess ) ) * r * r
return(arsum )
}
geosphere/R/finalBearing.R 0000644 0001762 0000144 00000001110 15147425256 015144 0 ustar ligges users # Robert Hijmans
# October 2009
# version 0.1
# Licence: GPL3
finalBearing <- function(p1, p2, a=6378137, f=1/298.257223563, sphere=FALSE) {
if (sphere) {
# for backwards compatibility
return(.old_bearing(p2, p1) )
}
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
r <- .inversegeodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a[1]), as.double(f[1]))
r <- matrix(r, ncol=3, byrow=TRUE)
# colnames(r) <- c('lon', 'lat', 'finalbearing')
return(r[, 3])
}
geosphere/R/perimeter.R 0000644 0001762 0000144 00000003446 15147425256 014575 0 ustar ligges users # Robert Hijmans
# April 2010
# version 1
# License GPL3
if (!isGeneric("perimeter")) {
setGeneric("perimeter", function(x, ...)
standardGeneric("perimeter"))
}
setMethod("perimeter", signature(x='SpatialPolygons'),
function(x, a=6378137, f=1/298.257223563, ...) {
x <- x@polygons
n <- length(x)
res <- vector(length=n)
for (i in 1:n) {
parts <- length( x[[i]]@Polygons )
perim <- 0
for (j in 1:parts) {
if (! x[[i]]@Polygons[[j]]@hole) {
crd <- x[[i]]@Polygons[[j]]@coords
perim <- perim + perimeter(crd, a=a, f=f, ...)
}
}
res[i] <- perim
}
return(res)
} )
setMethod("perimeter", signature(x='SpatialLines'),
function(x, a=6378137, f=1/298.257223563, ...) {
x <- x@lines
n <- length(x)
res <- vector(length=n)
for (i in 1:n) {
parts <- length( x[[i]]@Lines )
lng <- 0
for (j in 1:parts) {
crd <- x[[i]]@Lines[[j]]@coords
lng <- lng + perimeter(crd, a=a, f=f, ...)
}
res[i] <- lng
}
return(res)
} )
setMethod("perimeter", signature(x='data.frame'),
function(x, a=6378137, f=1/298.257223563, ...) {
perimeter(as.matrix(x), a=a, f=f, ...)
} )
setMethod("perimeter", signature(x='matrix'),
function(x, a=6378137, f=1/298.257223563, ...) {
r <- list(...)$r
if (!is.null(r)) {
# for backwards compatibility
warning('removed argument "r" to use improved method')
return( .old_perimeter(x, r=r) )
}
n <- nrow(x)
d <- .inversegeodesic(as.double(x[-n,1]), as.double(x[-n,2]), as.double(x[-1,1]), as.double(x[-1,2]), as.double(a), as.double(f))
sum(abs(x))
})
.old_perimeter <- function(x, r=6378137, ...) {
x <- x[,1:2]
if (isTRUE(all.equal(x[1,], x[nrow(x),]))) {
x <- x[-nrow(x), ]
}
y <- rbind(x[-1,], x[1,])
d <- distHaversine(x, y, r=r)
return(sum(d))
}
geosphere/R/refEllipsoids.R 0000644 0001762 0000144 00000002630 15147425256 015377 0 ustar ligges users
refEllipsoids <- function() {
data.frame(
ellipsoid =
c('Airy (1930)', 'Australian National', 'Bessel 1841', 'Ethiopia, Indonesia, Japan, Korea', 'Namibia', 'Clarke 1866', 'Clarke 1880', 'Everest - Brunei & E. Malasia (Sabah & Sarawak)', 'Everest - India 1830', 'Everest - India 1956', 'Everest - Pakistan', 'Everest - W. Malasia and Singapore 1948', 'Everest - W. Malasia 1969', 'Geodetic Reference System 1980 (GRS 80)', 'Helmert 1906', 'Hough 1960', 'Indonesian 1974', 'International 1924', 'Krassovsky 1940', 'Modified Airy', 'Modified Fischer 1960 (South Asia)', 'South American 1969', 'World Geodetic System 1972 (WGS 72)', 'World Geodetic System 1984 (WGS 84)'),
code =
c('AA', 'AN', '??', 'BR', 'BN', 'CC', 'CD', 'EB', 'EA', 'EC', 'EF', 'EE', 'ED', 'RF', 'HE', 'HO', 'ID', 'IN', 'KA', 'AM', 'FA', 'SA', 'WD', 'WE'),
invf =
c(299.3249646, 298.25, 299.1528434, 299.1528128, 299.1528128, 294.9786982, 293.465, 300.8017, 300.8017, 300.8017, 300.8017, 300.8017, 300.8017, 298.2572221, 298.3, 297, 298.247, 297, 298.3, 299.3249646, 298.3, 298.25, 298.26, 298.2572236),
a =
c(6377563.396, 6378160, 6377397.155, 6377397.155, 6377483.865, 6378206.4, 6378249.145, 6377298.556, 6377276.345, 6377301.243, 6377309.613, 6377304.063, 6377295.664, 6378137, 6378200, 6378270, 6378160, 6378388, 6378245, 6377340.189, 6378155, 6378160, 6378135, 6378137),
stringsAsFactors=FALSE )
}
geosphere/R/makePoly.R 0000644 0001762 0000144 00000007530 15147425256 014360 0 ustar ligges users # author Robert Hijmans
# April 2010
# version 0.1
# license GPL
.makeSinglePoly <- function(p, interval=10000, ...) {
res <- p[1,]
for (i in 1:(nrow(p)-1)) {
if (! isTRUE( all.equal(p[i,], p[i+1,]) )) {
d <- distGeo(p[i,], p[i+1,], ...)
n <- floor(d / interval)
if (n > 0) {
pts <- gcIntermediate(p[i,],p[i+1,], n)
pts <- rbind(p[i,], pts, p[i+1,])
res <- rbind(res, pts, p[i+1,])
} else {
res <- rbind(res, p[i+1,])
}
}
}
if (nrow(res) < 3) stop('cannot make a valid polygon')
return(res)
}
.makeSingleLine <- function(p, interval=10000, ...) {
res <- p[1,]
for (i in 1:(nrow(p)-1)) {
if (! isTRUE( all.equal(p[i,], p[i+1,]) )) {
d <- distGeo(p[i,], p[i+1,], ...)
n <- floor(d / interval)
if (n > 0) {
pts <- gcIntermediate(p[i,],p[i+1,], n)
pts <- rbind(p[i,], pts, p[i+1,])
res <- rbind(res, pts, p[i+1,])
} else {
res <- rbind(res, p[i+1,])
}
}
}
if (nrow(res) < 2) stop('cannot make a valid line')
return(res)
}
makePoly <- function(p, interval=10000, sp=FALSE, ...) {
if (inherits(p, 'SpatialPolygons')) {
test <- !sp::is.projected(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of sp::SpatialPolygons object is not set. Assuming it is degrees (longitude/latitude)!')
} else {
stop('Points are projected. They should be in degrees (longitude/latitude)')
}
# or rather transform them ....?
}
x <- p@polygons
n <- length(x)
polys = list()
for (i in 1:n) {
parts <- length(x[[i]]@Polygons )
partlist <- list()
for (j in 1:parts) {
crd <- x[[i]]@Polygons[[j]]@coords
crd <- .makeSinglePoly(crd, interval=interval, ...)
partlist[[j]] <- sp::Polygons(crd)
}
polys[[i]] <- sp::Polygons(partlist, i)
}
polys <- sp::SpatialPolygons(polys)
if (inherits(p, 'SpatialPolygonsDataFrame')) {
rownames(p@data) <- 1:nrow(p@data)
polys <- sp::SpatialPolygonsDataFrame(polys, p@data)
}
polys@proj4string <- p@proj4string
return(polys)
} else {
p <- .pointsToMatrix(p)
if (nrow(p) < 3) {
stop('cannot make a polygon (insufficent number of vertices)')
}
if (! isTRUE(all.equal(p[1,], p[nrow(p),]))) {
p <- rbind(p, p[1,])
}
res <- .makeSinglePoly(p, interval=interval, ...)
if (sp) {
res <- sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(res)), 1)))
res@proj4string <- sp::CRS("+proj=longlat +datum=WGS84")
}
return(res)
}
}
makeLine <- function(p, interval=10000, sp=FALSE, ...) {
if (inherits(p, 'SpatialLines')) {
test <- !sp::is.projected(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of sp::SpatialPolygons object is not set. Assuming it is degrees (longitude/latitude)!')
} else {
stop('Points are projected. They should be in degrees (longitude/latitude)')
}
# or rather transform them ....?
}
x = p@lines
n = length(x)
lines = list()
for (i in 1:n) {
parts = length(x[[i]]@Lines )
partlist = list()
for (j in 1:parts) {
crd = x[[i]]@Lines[[j]]@coords
crd = .makeSingleLine(crd, interval=interval, ...)
partlist[[j]] = sp::Line(crd)
}
lines[[i]] = sp::Lines(partlist, i)
}
lines <- sp::SpatialLines(lines)
if (inherits(p, 'SpatialLinesDataFrame')) {
lines <- sp::SpatialLinesDataFrame(lines, p@data)
}
lines@proj4string <- p@proj4string
return(lines)
} else {
p <- .pointsToMatrix(p)
if (nrow(p) < 3) {
stop('cannot make a polygon (insufficent number of vertices)')
}
res <- .makeSingleLine(p, interval=interval, ...)
if (sp) {
res <- sp::SpatialLines(list(sp::Lines(list(sp::Line(res)), 1)))
res@proj4string <- sp::CRS("+proj=longlat +datum=WGS84")
}
return(res)
}
}
geosphere/R/distGeo.R 0000644 0001762 0000144 00000001230 15147425256 014164 0 ustar ligges users # Author: Robert J. Hijmans
# Date : May 2015
# Licence GPL v3
distGeo <- function(p1, p2, a=6378137, f=1/298.257223563) {
p1 <- .pointsToMatrix(p1)
if (missing(p2)) {
if (nrow(p1) == 1) return(0)
if (nrow(p1) == 0) return(NULL)
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
addNA <- TRUE
} else {
p2 <- .pointsToMatrix(p2)
addNA <- FALSE
}
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
r <- .inversegeodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f))
r <- matrix(r, ncol=3, byrow=TRUE)
if (addNA){
c(r[,1], NA)
} else {
r[,1]
}
}
geosphere/R/centroid.R 0000644 0001762 0000144 00000003341 15150650134 014367 0 ustar ligges users # Author: Robert J. Hijmans
# April 2010
# version 0.1
# license GPL3
# See http://local.wasp.uwa.edu.au/~pbourke/geometry/polyarea/
.basiccentroid <- function(p) {
p2 <- rbind(p[-1,], p[1,])
P <- p[,1] * p2[,2] - p2[,1] * p[,2]
area6 <- 6 * sum(P) / 2
x <- sum((p[,1] + p2[,1]) * P)
y <- sum((p[,2] + p2[,2]) * P)
return(cbind(x, y) / area6 )
}
if (!isGeneric("centroid")) {
setGeneric("centroid", function(x, ...)
standardGeneric("centroid"))
}
setMethod("centroid", signature(x='data.frame'),
function(x) {
centroid(as.matrix(x))
})
setMethod("centroid", signature(x='matrix'),
function(x) {
x <- .pointsToMatrix(x, poly=TRUE)
dif1 <- max(x[,1]) - min(x[,1])
rotated <- FALSE
if (dif1 > 180) {
x2 <- x
x2[,1] <- x2[,1]%%(360) - 180
dif1 <- max(x[,1]) - min(x[,1])
dif2 <- max(x2[,1]) - min(x2[,1])
if (dif2 < dif1) {
rotated <- TRUE
x <- x2
}
}
x <- mercator(x, r=1)
cenM <- .basiccentroid(x)
cenG <- mercator(cenM, r=1, inverse=TRUE)
if (rotated) {
cenG[,1] <- cenG[,1] + 180
cenG[,1] <- .normalizeLonDeg(cenG[,1])
}
rownames(cenG) <- NULL
return(cenG)
}
)
setMethod("centroid", signature(x='SpatialPolygons'),
function(x) {
if ( isTRUE(sp::is.projected(x)) ) {
return( sp::coordinates(x))
}
x <- x@polygons
n <- length(x)
res <- matrix(nrow=n, ncol=2)
for (i in 1:n) {
parts <- length(x[[i]]@Polygons )
parea <- sapply(x[[i]]@Polygons, function(y){ methods::slot(y, "area")} )
hole <- sapply(x[[i]]@Polygons, function(y){ methods::slot(y, "hole")} )
parea[hole] <- -1
j <- which.max(parea)
crd <- x[[i]]@Polygons[[j]]@coords
res[i,] <- centroid(crd)
}
return(res)
} )
geosphere/R/gcIntersectBearing.R 0000644 0001762 0000144 00000004420 15147425256 016334 0 ustar ligges users # author Chris Veness, Robert Hijmans
# based on formulae by Ed Willians at
# http://www.edwilliams.org/avform.htm#Intersection
# October 2009
# version 0.1
# license GPL3
gcIntersectBearing <- function(p1, brng1, p2, brng2) {
#crs13 true bearing from point 1 and the crs23 true bearing from point 2:
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
p2 <- .pointsToMatrix(p2) * toRad
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(brng1), as.vector(brng2))
lon1 <- p[,1]
lat1 <- p[,2]
lon2 <- p[,3]
lat2 <- p[,4]
lat1[lat1==90|lat1==-90] <- NA
lat2[lat2==90|lat2==-90] <- NA
brng13 <- p[,5] * toRad
brng23 <- p[,6] * toRad
dLat <- lat2-lat1
dLon <- lon2-lon1
dist12 <- 2*asin( sqrt( sin(dLat/2)*sin(dLat/2) + cos(lat1)*cos(lat2)*sin(dLon/2)*sin(dLon/2) ) )
lat3 <- lon3 <- vector(length=length(nrow(lon1)))
i <- rep(TRUE, length(dist12))
i[dist12 == 0] <- FALSE
brngA <- acos( ( sin(lat2) - sin(lat1)*cos(dist12) ) / ( sin(dist12)*cos(lat1) ) )
brngA[is.na(brngA)] <- 0 # protect against rounding
brngB <- acos( ( sin(lat1) - sin(lat2)*cos(dist12) ) / ( sin(dist12)*cos(lat2) ) )
g <- (sin(lon2-lon1) > 0)
brng12 <- vector(length=length(g))
brng21 <- brng12
brng12[g] <- brngA[g]
brng21[g] <- 2*pi - brngB[g]
brng12[!g] <- 2*pi - brngA[!g]
brng21[!g] <- brngB[!g]
alpha1 <- (brng13 - brng12 + pi) %% (2*pi) - pi #// angle 2-1-3
alpha2 <- (brng21 - brng23 + pi) %% (2*pi) - pi #// angle 1-2-3
g <- sin(alpha1) == 0 & sin(alpha2) == 0
h <- (sin(alpha1) * sin(alpha2)) < 0
i <- !(g | h) & i
lon3[!i] <- lat3[!i] <- NA
alpha1 <- abs(alpha1)
alpha2 <- abs(alpha2)
alpha3 <- acos( -cos(alpha1)*cos(alpha2) + sin(alpha1)*sin(alpha2)*cos(dist12) )
dist13 <- atan2( sin(dist12)*sin(alpha1)*sin(alpha2), cos(alpha2)+cos(alpha1)*cos(alpha3) )
lat3[i] <- asin( sin(lat1[i])*cos(dist13[i]) + cos(lat1[i]) * sin(dist13[i]) * cos(brng13[i]) )
dLon13 <- atan2( sin(brng13)*sin(dist13)*cos(lat1), cos(dist13)-sin(lat1)*sin(lat3) )
lon3[i] <- lon1[i]+dLon13[i]
lon3 <- (lon3+pi) %% (2*pi) - pi # // normalise to -180..180 degrees
int <- cbind(lon3, lat3) / toRad
colnames(int) <- c('lon', 'lat')
int <- cbind(int, antipode(int))
rownames(int) <- NULL
return(int)
}
geosphere/R/span.R 0000644 0001762 0000144 00000004763 15147425256 013545 0 ustar ligges users # Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : April 2010
# Version 1
# Licence GPL v3
if (!isGeneric("span")) {
setGeneric("span", function(x, ...)
standardGeneric("span"))
}
setMethod("span", signature(x='matrix'),
function(x, nbands='fixed', n=100, res=0.1, fun, r=6378137, ...) {
dif1 <- max(x[,1]) - min(x[,1])
rotated <- FALSE
if (dif1 > 180) {
x2 <- x
x2[,1] <- x2[,1] %% 360 - 180
dif1 <- max(x[,1]) - min(x[,1])
dif2 <- max(x2[,1]) - min(x2[,1])
if (dif2 < dif1) {
rotated <- TRUE
x <- x2
}
}
x <- sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(x)), 1)))
if (missing(fun)) {
x <- span(x, nbands=nbands, n=n, res=res, ...)
} else {
x <- span(x, nbands=nbands, n=n, res=res, fun=fun, ...)
}
if (rotated & missing(fun)) {
x$longitude = x$longitude + 180
}
return(x)
} )
setMethod("span", signature(x='SpatialPolygons'),
function(x, nbands='fixed', n=100, res=0.1, fun, ...) {
span(terra::vect(x), nbands=nbands, n=n, res=res, fun=fun, ...)
})
setMethod("span", signature(x='sf'),
function(x, nbands='fixed', n=100, res=0.1, fun, ...) {
span(terra::vect(x), nbands=nbands, n=n, res=res, fun=fun, ...)
})
setMethod("span", signature(x='SpatVector'),
function(x, nbands='fixed', n=100, res=0.1, fun, ...) {
if (! nbands %in% c('fixed', 'variable')) {
stop('bandwidth should be "fixed" or "variable"')
}
if (nbands == 'fixed') {
n = max(n, 1)
} else {
if (res <= 0) {
stop('res should be larger than zero')
}
}
npol <- nrow(x)
lonspan <- list()
latspan <- list()
lon <- list()
lat <- list()
for (i in 1:npol) {
pp <- x[i,]
rs <- terra::rast(pp)
if (nbands == 'fixed') {
dim(rs) <- c(n, n)
} else {
terra::res(rs) <- res
}
latitude <- terra::yFromRow(rs, 1:nrow(rs))
longitude <- terra::xFromCol(rs, 1:ncol(rs))
xd <- distGeo(cbind(0,latitude), cbind(terra::xres(rs),latitude), ...)
yd <- distGeo(cbind(0,0), cbind(0,terra::yres(rs)), ...)
rs <- terra::rasterize(pp, rs)
rs <- terra::values(rs, format='matrix')
latspan[[i]] <- as.vector(apply(rs, 1, sum, na.rm=TRUE) * yd)
lonspan[[i]] <- as.vector(apply(rs, 2, sum, na.rm=TRUE) * xd)
lat[[i]] <- latitude
lon[[i]] <- longitude
}
if (! missing(fun)) {
lon = sapply(lonspan, fun)
lat = sapply(latspan, fun)
return(cbind(lon, lat))
} else {
return(c(lonspan=lonspan, latspan=latspan, longitude=lon, latitude=lat))
}
}
)
geosphere/R/distHaversine.R 0000644 0001762 0000144 00000005004 15147425256 015401 0 ustar ligges users # author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
distHaversine <- function(p1, p2, r=6378137) {
#* Haversine formula to calculate distance between two points specified by
#* from: Haversine formula - R.W. Sinnott, "Virtues of the Haversine",
#* Sky and Telescope, vol 68, no 2, 1984
#* http:#//www.census.gov/cgi-bin/geo/gisfaq?Q5.1
# source http://www.movable-type.co.uk/scripts/latlong.html
# (c) 2002-2009 Chris Veness
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p = cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
dLat <- p[,4]-p[,2]
dLon <- p[,3]-p[,1]
a <- (sin(dLat/2))^2 + cos(p[,2]) * cos(p[,4]) * (sin(dLon/2))^2
# to avoid values of 'a' that are a sliver above 1
# which may occur at antipodes
# https://stackoverflow.com/questions/45889616/why-does-disthaversine-return-nan-for-some-pairs-of-sp::coordinates#
a <- pmin(a, 1)
dist <- 2 * atan2(sqrt(a), sqrt(1-a)) * p[,5]
return( as.vector(dist))
}
# lon1 <- p[,1]
# lat1 <- p[,2]
# lon2 <- p[,3]
# lat2 <- p[,4]
# r <- p[,5]
# dLat <- (lat2-lat1)
# dLon <- (lon2-lon1)
# a <- sin(dLat/2) * sin(dLat/2) + cos(lat1) * cos(lat2) * sin(dLon/2) * sin(dLon/2)
# dist <- 2 * atan2(sqrt(a), sqrt(1-a)) * r
.distHaversine2 <- function(p1, p2, r=6378137) {
## following wikipedia
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p = cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
dLat <- p[,4]-p[,2]
dLon <- p[,3]-p[,1]
a <- (sin(dLat/2))^2 + cos(p[,2]) * cos(p[,4]) * (sin(dLon/2))^2
a <- pmin(a, 1)
dist <- 2 * r * asin(sqrt(a))
return( as.vector(dist))
}
# from Thierry de Meeus
.distHaversine3 <- function(p1, p2, r=6378137) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
r*(pi/2-asin(sin((p[,4]))*sin((p[,2]))+cos((p[,3])-(p[,1]))*cos((p[,4]))*cos((p[,2]))))
}
geosphere/R/lengthLine.R 0000644 0001762 0000144 00000001621 15147425256 014663 0 ustar ligges users # Author: Robert J. Hijmans
# August 2016
# version 1
# license GPL3
lengthLine <- function(line) {
if (inherits(line, 'SpatialPolygons')) {
line <- terra::as.lines(terra::vect(line))
} else if (inherits(line, 'SpatialLines')) {
line <- terra::vect(line)
} else if (inherits(line, 'sf')) {
line <- terra::as.lines(terra::vect(line))
}
if (inherits(line, "SpatVector")) {
line <- terra::geom(line)
} else {
line <- cbind(object=1, part=1, cump=1, line[, 1:2])
colnames(line)[4:5] <- c('x', 'y')
}
ids <- unique(line[,1])
len <- rep(0, length(ids))
for (i in 1:length(ids)) {
d <- line[line[,1] == ids[i], ]
parts <- unique(d[,2])
for (p in parts) {
dd <- d[d[,2] == p, ,drop=FALSE]
for (j in 1:(nrow(dd)-1)) {
len[i] <- len[i] + distGeo(dd[j, c('x', 'y'), drop=FALSE], dd[j+1, c('x', 'y'), drop=FALSE])
}
}
}
return(len)
}
geosphere/R/distRhumb.R 0000644 0001762 0000144 00000002231 15147425256 014531 0 ustar ligges users # author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# see http://www.edwilliams.org/avform.htm#Rhumb
# for the original formulae
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
distRhumb <- function(p1, p2, r=6378137) {
# distance on a rhumb line
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
if (missing(p2)) {
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
} else {
p2 <- .pointsToMatrix(p2) * toRad
}
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], as.vector(r))
lon1 <- p[,1]
lat1 <- p[,2]
lon2 <- p[,3]
lat2 <- p[,4]
r <- p[,5]
dLat <- (lat2-lat1)
dLon <- abs(lon2-lon1)
dPhi <- log(tan(lat2/2 + pi/4)/tan(lat1/2 + pi/4))
i <- abs(dLat) > 1e-10
q <- vector(length=length(i))
q[i] <- dLat[i]/dPhi[i]
q[!i] <- cos(lat1[!i])
#// if dLon over 180 degrees take shorter rhumb across 180 degrees meridian:
dLon[dLon > pi] <- 2*pi - dLon[dLon > pi]
d <- sqrt(dLat*dLat + q*q*dLon*dLon)
return(d * r)
}
geosphere/R/onGreatCircle.R 0000644 0001762 0000144 00000001663 15147425256 015321 0 ustar ligges users # Author: Robert J. Hijmans
# based on Dr. Rick's advice at:
# http://mathforum.org/library/drmath/view/66114.html
# August 2010
# version 1
# license GPL3
onGreatCircle <- function(p1, p2, p3, tol=0.0001) {
# is p3 an intermediate points on a great circle defined by p1 and p2?
toRad <- pi / 180
p1 <- .pointsToMatrix(p1)
p2 <- .pointsToMatrix(p2)
p3 <- .pointsToMatrix(p3)
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2], p3[,1], p3[,2])
p1 <- p[,1:2, drop=FALSE] * toRad
p2 <- p[,3:4, drop=FALSE] * toRad
p3 <- p[,5:6, drop=FALSE] * toRad
lon1 <- p1[,1]
lat1 <- p1[,2]
lon2 <- p2[,1]
lat2 <- p2[,2]
lon <- p3[,1]
lat <- p3[,2]
newlat <- atan((sin(lat1)*cos(lat2)*sin(lon-lon2) - sin(lat2)*cos(lat1)*sin(lon-lon1)) / (cos(lat1)*cos(lat2)*sin(lon1-lon2)))
res <- abs(newlat - lat) < tol
meridian <- p1[,1] == p2[,1] & p1[,1] == p3[,1]
res[meridian] <- TRUE
return(as.vector(res))
}
geosphere/R/destPointRhumb.R 0000644 0001762 0000144 00000002353 15147425256 015544 0 ustar ligges users # based on JavaScript code by Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# see http://www.edwilliams.org/avform.htm#Rhumb
# for the original formulae
# Robert Hijmans
# October 2009
# version 0.1
# license GPL3
destPointRhumb <- function(p, b, d, r=6378137) {
toRad <- pi / 180
b <- as.vector(b)
d <- as.vector(d)
r <- as.vector(r)
p <- .pointsToMatrix(p)
p <- cbind(p[,1], p[,2], b, d, r)
r <- p[,5]
d <- p[,4] / r #angular distance in radians
b <- p[,3] * toRad
lon1 <- p[,1] * toRad
lat1 <- p[,2]
lat1[lat1==90|lat1==-90] <- NA
lat1 <- lat1 * toRad
lat2 <- lat1 + d * cos(b)
dLat <- lat2-lat1
dPhi <- log( tan(lat2/2 + pi/4) / tan(lat1/2 + pi/4) )
i <- abs(dLat) > 1e-10
q <- vector(length=length(i))
q[i] <- dLat[i]/dPhi[i]
q[!i] <- cos(lat1[!i])
dLon <- d * sin(b) / q
# check for points past the pole../
i <- (abs(lat2) > pi/2) & lat2 > 0
lat2[i] <- pi-lat2[i]
i <- (abs(lat2) > pi/2) & lat2 <= 0
lat2[i] <- (pi-lat2[i])
lon2 <- (lon1+dLon+pi)%%(2*pi) - pi
res <- cbind(lon2, lat2) / toRad
colnames(res) <- c('lon', 'lat')
return(res)
}
geosphere/R/bearingRhumb.R 0000644 0001762 0000144 00000002211 15147425256 015173 0 ustar ligges users # author of original JavaScript code: Chris Vennes
# (c) 2002-2009 Chris Veness
# http://www.movable-type.co.uk/scripts/latlong.html
# Licence: LGPL, without any warranty express or implied
# see http://www.edwilliams.org/avform.htm#Rhumb
# for the original formulae
# Port to R by Robert Hijmans
# October 2009
# version 0.1
# license GPL3
bearingRhumb <- function(p1, p2) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
p2 <- .pointsToMatrix(p2) * toRad
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
p1 <- p[, 1:2, drop=FALSE]
p2 <- p[, 3:4, drop=FALSE]
keep <- ! apply(p1 == p2, 1, sum) == 2
res <- rep(NA, length=nrow(p1))
if (sum(keep) == 0) { return(res) }
lon1 <- p1[keep, 1, drop=FALSE]
lat1 <- p1[keep, 2, drop=FALSE]
lon2 <- p2[keep, 1, drop=FALSE]
lat2 <- p2[keep, 2, drop=FALSE]
dLon <- (lon2-lon1)
dPhi <- log(tan(lat2/2 + pi/4)/tan(lat1/2+pi/4))
i <- (abs(dLon) > pi)
j <- i & dLon > 0
dLon[j] <- -(2*pi-dLon[j])
j <- i & dLon <= 0
dLon[j] <- dLon[j] <- (2*pi+dLon[j])
b <- atan2(dLon, dPhi)
b <- b / toRad
b <- (b+360) %% 360
res[keep] = b
return(res)
}
geosphere/R/bearing.R 0000644 0001762 0000144 00000002544 15147425256 014206 0 ustar ligges users # Author: Robert J. Hijmans
# Date : March 2010 / May 2015
# Version 2.0
# Licence GPL v3
bearing <- function(p1, p2, a=6378137, f=1/298.257223563) {
p1 <- .pointsToMatrix(p1)
if (missing(p2)) {
if (nrow(p1) < 2) {
return(NA)
}
p2 <- p1[-1, ,drop=FALSE]
p1 <- p1[-nrow(p1), ,drop=FALSE]
addNA <- TRUE
} else {
p2 <- .pointsToMatrix(p2)
addNA <- FALSE
}
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
r <- .inversegeodesic(as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a[1]), as.double(f[1]))
r <- matrix(r, ncol=3, byrow=TRUE)
if (addNA) {
c(r[, 2], NA)
} else {
r[, 2]
}
}
.old_bearing <- function(p1, p2) {
toRad <- pi / 180
p1 <- .pointsToMatrix(p1) * toRad
p2 <- .pointsToMatrix(p2) * toRad
p <- cbind(p1[,1], p1[,2], p2[,1], p2[,2])
p1 <- p[, 1:2, drop=FALSE]
p2 <- p[, 3:4, drop=FALSE]
keep <- ! apply(p1 == p2, 1, sum) == 2
res <- rep(NA, length=nrow(p1))
if (sum(keep) == 0) { return(res) }
p1 <- p1[keep, , drop=FALSE]
p2 <- p2[keep, , drop=FALSE]
dLon <- p2[,1] - p1[,1]
y <- sin(dLon) * cos(p2[,2])
x <- cos(p1[,2]) * sin(p2[,2]) - sin(p1[,2]) * cos(p2[,2]) * cos(dLon)
azm <- atan2(y, x) / toRad
azm <- (azm+360) %% 360
i <- azm > 180
azm[i] <- -1 * (360 - azm[i])
res[keep] <- azm
return(res)
}
geosphere/R/horizon.R 0000644 0001762 0000144 00000000225 15147425256 014261 0 ustar ligges users
horizon <- function(h, r=6378137) {
x = cbind(as.vector(h), as.vector(r))
h = x[,1]
r = x[,2]
b = 0.8279
sqrt( 2 * r * h / b )
}
geosphere/R/pointsToMatrix.R 0000644 0001762 0000144 00000005221 15147425256 015576 0 ustar ligges users # Author: Robert J. Hijmans & Jacob van Etten
# October 2009
# version 1
# license GPL3
.pointsToMatrix <- function(p, checkLonLat=TRUE, poly=FALSE) {
if (inherits(p, "sf")) {
p <- terra::vect(p)
}
if (inherits(p, 'SpatVector')) {
stopifnot(terra::geomtype(p) == "points")
test <- terra::is.lonlat(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of SpatVector is not set. Assuming it is degrees (longitude/latitude)!')
} else if (checkLonLat) {
p <- terra::project(p, "+proj=longlat")
}
}
p <- terra::crds(p)
} else if (inherits(p, 'SpatialPoints')) {
test <- !sp::is.projected(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of SpatialPoints object is not set. Assuming it is degrees (longitude/latitude)!')
} else if (checkLonLat) {
stop('Points are projected. They should be in degrees (longitude/latitude)')
}
}
p <- sp::coordinates(p)
} else if (is.data.frame(p)) {
p <- as.matrix(p)
} else if (is.vector(p)){
if (length(p) != 2) {
stop('Wrong length for a vector, should be 2')
} else {
p <- matrix(p, ncol=2)
}
} else if (is.matrix(p)) {
if (ncol(p) != 2) {
stop( 'A points matrix should have 2 columns')
}
cn <- colnames(p)
if (length(cn) == 2) {
if (toupper(cn[1]) == 'Y' | toupper(cn[2]) == 'X') {
warning('Suspect column names (x and y reversed?)')
}
if (toupper(substr(cn[1],1,3) == 'LAT' | toupper(substr(cn[2],1,3)) == 'LON')) {
warning('Suspect column names (longitude and latitude reversed?)')
}
}
} else {
stop('points should be vectors of length 2, matrices with 2 columns, or inheriting from a SpatialPoints or SpatVector object')
}
if (! is.numeric(p) ) { p[] <- as.numeric(p) }
if (checkLonLat & nrow(p) > 0) {
if (length(stats::na.omit(p[,1])) > 0) {
if (min(p[,1], na.rm=TRUE) < -360) { stop('longitude < -360') }
if (max(p[,1], na.rm=TRUE) > 360) { stop('longitude > 360') }
if (min(p[,1], na.rm=TRUE) < -180) { warning('longitude < -180') }
if (max(p[,1], na.rm=TRUE) > 180) { warning('longitude > 180') }
}
if (length(stats::na.omit(p[,2])) > 0) {
if (min(p[,2], na.rm=TRUE) < -90) { stop('latitude < -90') }
if (max(p[,2], na.rm=TRUE) > 90) { stop('latitude > 90') }
}
}
if (poly) {
if (! isTRUE(all.equal(p[1,], p[nrow(p),]))) {
p <- rbind(p, p[1,])
}
i <- p[-nrow(p),1] == p[-1,1] & p[-nrow(p),2] == p[-1,2]
i <- which(isTRUE(i))
if (length(i) > 0) {
p <- p[-i, ,drop=FALSE]
}
.isPolygon(p)
}
return(p)
}
geosphere/vignettes/ 0000755 0001762 0000144 00000000000 15164275510 014251 5 ustar ligges users geosphere/vignettes/geosphere.Rnw 0000644 0001762 0000144 00000040336 15150653427 016732 0 ustar ligges users \documentclass{article}
\usepackage{natbib}
\usepackage{graphics}
\usepackage{amsmath}
\usepackage{indentfirst}
\usepackage[utf8]{inputenc}
\usepackage{hyperref}
\usepackage{hanging}
%\VignetteIndexEntry{Introduction to the geosphere package}
\SweaveOpts{keep.source=TRUE}
\SweaveOpts{png=TRUE, pdf=FALSE}
\SweaveOpts{resolution=100}
\begin{document}
<>=
options(keep.source = TRUE, width = 60)
foo <- packageDescription("geosphere")
@
\title{Introduction to the "geosphere" package \\ (Version \Sexpr{foo$Version})}
\author{Robert J. Hijmans}
\maketitle
\section{Introduction}
This vignette describes the R package '\verb@geosphere@'. The package implements spherical trigonometry functions for geographic applications. Many of the functions have applications in navigation, but others are more general, or have no relation to navigation at all.
There is a number of functions to compute distance and direction (= bearing, azimuth, course) along great circles (= shortest distance on a sphere, or "as the crow flies") and along rhumb lines (lines of constant bearing).
There are also functions that compute distances on a spheroid.
Other functions include the computation of the location of an object at a given direction and distance; and the area, perimeter, and centroid of a spherical polygon.
Geographic locations must be specified in longitude and latitude (and in that order!) in degrees (i.e., NOT in radians). Degrees are (obviously) in decimal notation. Thus 12 degrees, 10 minutes, 30 seconds = 12 + 10/60 + 30/3600 = 12.175 degrees. The southern and western hemispheres have a negative sign.
The default unit of distance is meter; but this can be adjusted by supplying a different radius 'r' to functions. Directions are expressed in degrees (N = 0 and 360, E = 90, S = 180, and W = 270 degrees). If arguments of functions that take several arguments (e.g. points, bearings, radius of the earth), do not have the same length (for vectors) or number of rows (for matrices) the shorter arguments are re-cycled.
Many functions in this package are based on formulae provided by Ed Williams (\url{https://www.edwilliams.org/ftp/avsig/avform.txt}, and partly on javascript implementations of these formulae by Chris Veness (\url{https://www.movable-type.co.uk/scripts/latlong.html} )
Most geodesic computations (for a spheroid rather than a sphere) use the GeographicLib by C.F.F. Karney (\url{https://geographiclib.sourceforge.io/}).
\section{Great circle distance}
There are four different functions to compute distance between two points. These are, in order of increasing complexity of the algorithm, the 'Spherical law of cosines', 'Haversine' (Sinnott, 1984), 'Vincenty Sphere' and 'Vincenty Ellipsoid' (Vincenty, 1975) methods. The first three assume the earth to be a sphere, while the 'Vincenty Ellipsoid' assumes it is an ellipsoid (which is closer to the truth).
The results from the first three functions are identical for practical purposes. The Haversine ('half-versed-sine') formula was published by R.W. Sinnott in 1984, although it has been known for much longer. At that time computational precision was lower than today (15 digits precision). With current precision, the spherical law of cosines formula appears to give equally good results down to very small distances. If you want greater accuracy, you could use the distVincentyEllipsoid method.
Below the differences between the three spherical methods are illustrated. At very short distances, there are small differences between the 'law of the Cosine' and the other two methods. There are even smaller differences between the 'Haversine' and 'Vincenty Sphere' methods at larger distances.
<>=
library(geosphere)
Lon <- c(1:9/1000, 1:9/100, 1:9/10, 1:90*2)
Lat <- c(1:9/1000, 1:9/100, 1:9/10, 1:90)
dcos <- distCosine(c(0,0), cbind(Lon, Lat))
dhav <- distHaversine(c(0,0), cbind(Lon, Lat))
dvsp <- distVincentySphere(c(0,0), cbind(Lon, Lat))
par(mfrow=(c(1,2)))
plot(log(dcos), dcos-dhav, col='red', ylim=c(-1e-05, 1e-05),
xlab="Log 'Law of Cosines' distance (m)",
ylab="Law of Cosines minus Haversine distance")
plot(log(dhav), dhav-dvsp, col='blue',
xlab="Log 'Haversine' distance (m)",
ylab="Vincenty Sphere minus Haversine distance")
@
The difference with the 'Vincenty Ellipsoid' method is more pronounced. In the example below (using the default WGS83 ellipsoid), the difference is about 0.3% at very small distances, and 0.15% at larger distances.
<>=
dvse <- distVincentyEllipsoid(c(0,0), cbind(Lon, Lat))
plot(dvsp/1000, (dvsp-dvse)/1000, col='blue', xlab='Vincenty Sphere Distance (km)',
ylab="Difference between 'Vincenty Sphere' and 'Vincenty Ellipsoid' methods (km)")
@
For the most precise distance computation use the 'distGeo' function.
\section{Points on great circles}
Points on a great circle are returned by the function 'greatCircle', using two points on the great circle to define it, and an additional argument to indicate how many points should be returned. You can also use greatCircleBearing, and provide starting points and bearing as arguments. gcIntermediate only returns points on the great circle that are on the track of shortest distance between the two points defining the great circle; and midPoint computes the point half-way between the two points. You can use onGreatCircle to test whether a point is on a great circle between two other points.
<>=
LA <- c(-118.40, 33.95)
NY <- c(-73.78, 40.63)
data(wrld)
plot(wrld, type='l')
gc <- greatCircle(LA, NY)
lines(gc, lwd=2, col='blue')
gci <- gcIntermediate(LA, NY)
lines(gci, lwd=4, col='green')
points(rbind(LA, NY), col='red', pch=20, cex=2)
mp <- midPoint(LA, NY)
onGreatCircle(LA,NY, rbind(mp,c(0,0)))
points(mp, pch='*', cex=3, col='orange')
greatCircleBearing(LA, brng=270, n=10)
@
\section{Point at distance and bearing}
Function destPoint returns the location of point given a point of origin, and a distance and bearing. Its perhaps obvious use in georeferencing locations of distant sitings. It can also be used to make circular polygons (with a fixed radius, but in longitude/latitude coordinates)
<>=
destPoint(LA, b=65, d=100000)
circle=destPoint(c(0,80), b=1:365, d=1000000)
circle2=destPoint(c(0,80), b=1:365, d=500000)
circle3=destPoint(c(0,80), b=1:365, d=100000)
plot(circle, type='l')
polygon(circle, col='blue', border='black', lwd=4)
polygon(circle2, col='red', lwd=4, border='orange')
polygon(circle3, col='white', lwd=4, border='black')
@
\section{Maximum latitude on a great circle}
You can use the functions illustrated below to find out what the maximum latitude is that a great circle will reach; at what latitude it crosses a specified longitude; or at what longitude it crosses a specified latitude. From the map below it appears that Clairaut's formula, used in gcMaxLat is not very accurate. Through optimization with function greatCircle, a more accurate value was found. The southern-most point is the antipode (a point at the opposite end of the world) of the northern-most point.
<>=
ml <- gcMaxLat(LA, NY)
lat0 <- gcLat(LA, NY, lon=0)
lon0 <- gcLon(LA, NY, lat=0)
plot(wrld, type='l')
lines(gc, lwd=2, col='blue')
points(ml, col='red', pch=20, cex=2)
points(cbind(0, lat0), pch=20, cex=2, col='yellow')
points(t(rbind(lon0, 0)), pch=20, cex=2, col='green' )
f <- function(lon){gcLat(LA, NY, lon)}
opt <- optimize(f, interval=c(-180, 180), maximum=TRUE)
points(opt$maximum, opt$objective, pch=20, cex=2, col='dark green' )
anti <- antipode(c(opt$maximum, opt$objective))
points(anti, pch=20, cex=2, col='dark blue' )
@
\section{Great circle intersections}
Points of intersection of two great circles can be computed in two ways. We use a second great circle that connects San Francisco with Amsterdam. We first compute where they cross by defining the great circles using two points on it (gcIntersect). After that, we compute the same points using a start point and initial bearing (gcIntersectBearing). The two points where the great circles cross are antipodes. Antipodes are connected with an infinite number of great circles.
<>=
SF <- c(-122.44, 37.74)
AM <- c(4.75, 52.31)
gc2 <- greatCircle(AM, SF)
plot(wrld, type='l')
lines(gc, lwd=2, col='blue')
lines(gc2, lwd=2, col='green')
int <- gcIntersect(LA, NY, SF, AM)
int
antipodal(int[,1:2], int[,3:4])
points(rbind(int[,1:2], int[,3:4]), col='red', pch=20, cex=2)
bearing1 <- bearing(LA, NY)
bearing2 <- bearing(SF, AM)
bearing1
bearing2
gcIntersectBearing(LA, bearing1, SF, bearing2)
@
\section{Triangulation}
Below is triangulation example. We have three locations (NY, LA, MS) and three directions (281, 60, 195) towards a target. Because we are on a sphere, there are two (antipodal) results. We only show one here (by only using int[,1:2]). We compute the centroid from the polygon defined with the three points. To accurately draw a spherical polygon, we can use makePoly. This function inserts intermediate points along the paths between the vertices provided (default is one point every 10 km).
<>=
MS <- c(-93.26, 44.98)
gc1 <- greatCircleBearing(NY, 281)
gc2 <- greatCircleBearing(MS, 195)
gc3 <- greatCircleBearing(LA, 55)
plot(wrld, type='l', xlim=c(-125, -70), ylim=c(20, 60))
lines(gc1, col='green')
lines(gc2, col='blue')
lines(gc3, col='red')
int <- gcIntersectBearing(rbind(NY, NY, MS),
c(281, 281, 195), rbind(MS, LA, LA), c(195, 55, 55))
int
distm(rbind(int[,1:2], int[,3:4]))
int <- int[,1:2]
points(int)
poly <- rbind(int, int[1,])
centr <- centroid(poly)
poly2 <- makePoly(int)
polygon(poly2, col='yellow')
points(centr, pch='*', col='dark red', cex=2)
@
\section{Bearing}
Below we first compute the distance and bearing from Los Angeles (LA) to New York (NY). These are then used to compute the point from LA at that distance in that (initial) bearing (direction). Bearing changes continuously when traveling along a Great Circle. The final bearing, when approaching NY, is also given.
<>=
d <- distCosine(LA, NY)
d
b <- bearing(LA, NY)
b
destPoint(LA, b, d)
NY
finalBearing(LA, NY)
@
\section{Getting off-track}
What if we went off-course and were flying over Minneapolis (MS)? The closest point on the planned route (p) can be computed with the alongTrackDistance and destPoint functions. The distance from 'p' to MS can be computed with the dist2gc (distance to great circle, or cross-track distance) function. The light green line represents the along-track distance, and the dark green line represents the cross-track distance.
<>=
atd <- alongTrackDistance(LA, NY, MS)
p <- destPoint(LA, b, atd)
plot(wrld, type='l', xlim=c(-130,-60), ylim=c(22,52))
lines(gci, col='blue', lwd=2)
points(rbind(LA, NY), col='red', pch=20, cex=2)
points(MS[1], MS[2], pch=20, col='blue', cex=2)
lines(gcIntermediate(LA, p), col='green', lwd=3)
lines(gcIntermediate(MS, p), col='dark green', lwd=3)
points(p, pch=20, col='red', cex=2)
dist2gc(LA, NY, MS)
distCosine(p, MS)
@
\section{Distance to a polyline}
The two function describe above are used in the dist2Line function that computes the shortest distance between a set of points and a set of spherical poly-lines (or polygons).
<>=
line <- rbind(c(-180,-20), c(-150,-10), c(-140,55), c(10, 0), c(-140,-60))
pnts <- rbind(c(-170,0), c(-75,0), c(-70,-10), c(-80,20), c(-100,-50),
c(-100,-60), c(-100,-40), c(-100,-20), c(-100,-10), c(-100,0))
d = dist2Line(pnts, line)
plot( makeLine(line), type='l')
points(line)
points(pnts, col='blue', pch=20)
points(d[,2], d[,3], col='red', pch='x', cex=2)
for (i in 1:nrow(d)) lines(gcIntermediate(pnts[i,], d[i,2:3], 10), lwd=2, col='green')
@
\section{Rhumb lines}
Rhumb (from the Spanish word for course, 'rumbo') lines are straight lines on a Mercator projection map (and at most latitudes pretty straight on an equirectangular projection (=unprojected lon/lat) map). They were used in navigation because it is easier to follow a constant compass bearing than to continually adjust direction as is needed to follow a great circle, even though rhumb lines are normally longer than great-circle (orthodrome) routes. Most rhumb lines will gradually spiral towards one of the poles.
<>=
NP <- c(0, 85)
bearing(SF, NP)
b <- bearingRhumb(SF, NP)
b
dc <- distCosine(SF, NP)
dr <- distRhumb(SF, NP)
dc / dr
pr <- destPointRhumb(SF, b, d=round(dr/100) * 1:100)
pc <- rbind(SF, gcIntermediate(SF, NP), NP)
par(mfrow=c(1,2))
data(wrld)
plot(wrld, type='l', xlim=c(-140,10), ylim=c(15,90), main='Equirectangular')
lines(pr, col='blue')
lines(pc, col='red')
data(merc)
plot(merc, type='l', xlim=c(-15584729, 1113195),
ylim=c(2500000, 22500000), main='Mercator')
lines(mercator(pr), col='blue')
lines(mercator(pc), col='red')
@
\section{Characterizing polygons}
The package has functions to compute the area, perimeter, centroid, and 'span' of a spherical polygon. One approach to compute these measures is to project the polygons first. Here we directly compute them based on spherical coordinates (longitude / latitude), except for centroid, which is computed by projecting the data to the Mercator projection (and inversely projecting the result). The function makePoly inserts additional vertices into a spherical polygon such that it can be plotted (perhaps after first projecting it) more correctly in a plane. Vertices are inserted, where necessary, at a specified distance. The function is only beneficial for polygons with large inter-vertex distances (in terms of longitude), particularly at high latitudes.
<>=
pol <- rbind(c(-120,-20), c(-80,5), c(0, -20), c(-40,-60), c(-120,-20))
areaPolygon(pol)
perimeter(pol)
centroid(pol)
#span(pol, fun=max)
nicepoly = makePoly(pol)
plot(pol, xlab='longitude', ylab='latitude', cex=2, lwd=3, xlim=c(-140, 0))
lines(wrld, col='grey')
lines(pol, col='red', lwd=2)
lines(nicepoly, col='blue', lwd=2)
points(centroid(pol), pch='*', cex=3, col='dark green')
text(centroid(pol)-c(0,2.5), 'centroid')
legend(-140, -48, c('planar','spherical'), lty=1, lwd=2,
col=c('red', 'blue'), title='polygon type')
@
\section{Sampling}
Random or regular sampling of longitude/latitude values on the globe needs to consider that the globe is spherical. That is, if you would take random points for latitude between -90 and 90 and for longitude between -180 and 180, the density of points would be higher near the poles than near the equator.
In contrast, functions 'randomCoordinates' and 'randomCoordinates' return samples that are spatially balanced.
<>=
plot(wrld, type='l', col='grey')
a = randomCoordinates(500)
points(a, col='blue', pch=20, cex=0.5)
b = regularCoordinates(3)
points(b, col='red', pch='x')
@
\section{Daylength}
You can compute daylenght according to the formula by Forsythe et al. (1995). For any day of the year (an integer between 1 and 365; or a 'Date' object.
<>=
as.Date(80, origin='2009-12-31')
as.Date(172, origin='2009-12-31')
plot(0:90, daylength(lat=0:90, doy=1), ylim=c(0,24), type='l', xlab='Latitude',
ylab='Daylength', main='Daylength by latitude and day of year', lwd=2)
lines(0:90, daylength(lat=0:90, doy=80), col='green', lwd=2)
lines(0:90, daylength(lat=0:90, doy=172), col='blue', lwd=2)
legend(0,24, c('1','80','172'), lty=1, lwd=2, col=c('black', 'green', 'blue'),
title='Day of year')
@
\section{References}
\begin{hangparas}{3em}{1}
\noindent Forsythe, W.C., E.J. Rykiel Jr., R.S. Stahl, H. Wu and R.M. Schoolfield, 1995. A model comparison for daylength as a function of latitude and day of the year. Ecological Modeling 80:87-95.
\noindent Sinnott, R.W, 1984. Virtues of the Haversine. Sky and Telescope 68(2): 159
\noindent Vincenty, T. 1975. Direct and inverse solutions of geodesics on the ellipsoid with application of nested equations. Survey Review 23(176): 88-93. Available here: \url{https://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf}
\end{hangparas}
\end{document}
geosphere/data/ 0000755 0001762 0000144 00000000000 15147425256 013157 5 ustar ligges users geosphere/data/merc.RData 0000644 0001762 0000144 00001062054 15147425256 015032 0 ustar ligges users ý7zXZ i"Þ6 ! ÏXÌá~5ïþ] )TW"änRÊŸãXVÀØø%>Áƒ§"UZ
t»Bk×öô}ùMI™ÞÞtrøàÎî€U)ËÓW*v´î*‰t6€_uXý¤éŽžS…H\±5èKØRahwX¿A-H€±ÏF*˜ÓË«f‰…\vfÄ!Î0"q¹ô=ï1´Ê:ï¨(±m7AÚþ$*˶–Ê•¢MwiÁé bjˆâq©„©ºÂÜ—‰aÐ(î…Àû—,Âz)¿˜ Ø=àÌÖJ«9(årD†ï€Nå–rQÃ葹#rá<\@Í
|üPâ¹ÏÒl8ðŒMþ›é…Öq4°‚hR6ÉFÄ ®Á¡¬8é¹aå^|}íCby<Ûª€ãÄEC$qŃ׉ü>øÞ1ðßЄ¾à‘Fâû½Þ…±¿B߈æÊï-¬¼ŸŠ*p}º“…j{Nk0vkIÉ3£+tG¬þð3¡}rè:íâ9vd^ {ý¥"éñeú'¡•¤BL ÏËYþSŸU»AqëP(¹Ü˜úLy±OßWôÛÏÒ8N÷‡Ø5P‹™¹àŸÞ’ýÞìÁCº!ß].45è@èE¡Gà°Ö,)
n#¸f¡Õÿ`'Dà)”èáZÎSÓâGè´*ˆÚéÜÔ0h[0·še¿Ê©‚8^[ôÝœq´š‘†>J_±lß
ás¹£|ø
Ä ÿÙÅH"œ^Iùp?}ùë[﫟® sÚDÛ[`FVvÍÍ“›94q2rPs4f#ûÜhù—)!”ñÀPLˆ0Åä_F‰é°”ÉÊ«§õF76Xèðÿ|½Ã1â(á