geosphere/ 0000755 0001762 0000144 00000000000 14677706706 012257 5 ustar ligges users geosphere/MD5 0000644 0001762 0000144 00000023560 14677706706 012575 0 ustar ligges users 7f22976807c2cc107c3f2f88362a3e96 *ChangeLog
bf70aefe51169130e4dadc3936c9957c *DESCRIPTION
823071db3a642bdc2d26dacadcff50ea *NAMESPACE
ea5fcc0276d17d2012801761b5c911b8 *R/RcppExports.R
43807c455fbc2424fe107fcb978a79d0 *R/alongTrack.R
c603e867d2d36b565c0223b52c1c769e *R/antipodal.R
c85737b543ca52765261f0d48c44ff6e *R/areaPolygon.R
b32846602a0f755c189e48bae7d59a06 *R/bearing.R
495cb8e6ca1422490b1c6058f9450a46 *R/bearingRhumb.R
aeefe269b66e57f93cdd2acf0547321f *R/centroid.R
1743d120f033b849e8e77ca463d7c815 *R/daylength.R
1e9e4acd9a27238f46135af46902db60 *R/destPoint.R
19e711a9e49bbc7200d3d6a92af583c5 *R/destPointRhumb.R
825ed606555476f8b20a40c25b34a63b *R/dist2Line.R
7f333bbd90b64c3aa7f9d34b39ed539d *R/dist2gc.R
ef4a2cf12c3ed6b1f6c685ad3c9640d6 *R/distCosines.R
30118ba1a360d8679c7f8885f76a2f32 *R/distGeo.R
e46f596d3547a7918d737a7d1c4b43ff *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
71f5cb986eea1e42b7af9a26f358fd6d *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
e05b9ce8c5b6851519e138156fa0527d *R/geomedian.R
e83d7662049f48f412d7f54a5766c3c8 *R/greatCircle.R
2818b0933c09267f0c05b1ae07bec869 *R/greatCircleBearing.R
088fe0172bbf3794e16cecc29e17a3ee *R/helper.R
ea4c7189b67965e4517e648f27e062b2 *R/horizon.R
a6cb94430b50c900a10f0d8fce1b6102 *R/lengthLine.R
2fe3bf69af5f16df458a3e21ae436978 *R/makePoly.R
323eadc05c03f5d11b51558ec412640d *R/mercator.R
430c0a96d811acc0eb31638a108ef44b *R/midPoint.R
13f88662ae5bcb6f0584facd6bd57e29 *R/old_destPoint.R
caba5729f0e9429c56c9e6dd6c0d4b3c *R/onGreatCircle.R
70aa176635f101570c71808e71c4353a *R/perimeter.R
e50d15fc59606d5967fbaaf2ff495739 *R/plotPoly.R
1c72c4ba1c75cdc485bb545238459995 *R/pointsToMatrix.R
63372c1d29b6fd85bc82e2695ef831cf *R/randomCoordinates.R
ad94d2fb3c7bab9fcc660132ae3534bb *R/refEllipsoids.R
a0903ff2b54c613bedcd723a0b3784f7 *R/regularCoordinates.R
4400c83027e73243e6d8e9f30075dda2 *R/sampleAlong.R
ff01ac40ecb1cd5d7051ffbfe7c2d64d *R/span.R
b54db8794555342c4feee5fe0b1b8f5b *build/partial.rdb
3c25c136eded52ef9afec56b9ca679b7 *build/vignette.rds
990871f1c55db0d5b160d786c86e6850 *data/merc.RData
464a29b93751536caa7f2cf583124960 *data/wrld.RData
538f4c2b1ae4ddf2242766b02f340b1d *inst/doc/geosphere.R
5090e95e97f748525ed9905c51309b22 *inst/doc/geosphere.Rnw
e3493e9cfb8090bda87f77e9a5fe0337 *inst/doc/geosphere.pdf
81ce1c4eb1d5bd1302cd0e07987e9186 *man/OSGB.Rd
6d96299e3d47a6bc59572c331080d5c6 *man/alongTrackDistance.Rd
e3149675013c8042a7e4b1d189ebb502 *man/antipode.Rd
2c3927acdf4de92b9470bea1cb288079 *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
b5f2fe72f907c3f528e62213eb87a231 *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
e5a815ce847782faf61535d948b2681f *man/span.Rd
a4f1af295fda57e6a3112e05ad49f5d0 *src/Accumulator.cpp
0aa8161898fd7d220aa8c9a6e55cfd7e *src/Accumulator.h
65d999d849559059880d30fa17c728df *src/AlbersEqualArea.cpp
613e27b027ce4a7d01e20f1c17ad1a17 *src/AlbersEqualArea.h
4f720c6a7880cac42563a6082aeb2430 *src/AzimuthalEquidistant.cpp
454f2764ef60b26ec4bca4d40db98a39 *src/AzimuthalEquidistant.h
66d28d9f0cd1a13c9d683b4092f7e545 *src/CassiniSoldner.cpp
9ad224a201a50f809afca481fed300e2 *src/CassiniSoldner.h
f863389f50c731b61342aa30a9b2bf0e *src/CircularEngine.cpp
51e082771fb0efc9c3a3c8b3e78dd846 *src/CircularEngine.h
b02a5ff1471c0c641e0f9552a6a02915 *src/Config.h
298f0446b13a6e9bc1c81482b4f4a0be *src/Constants.h
176494ce4ccf4d95521ce3e9b29dbb30 *src/DMS.cpp
452e04ac606d08eee8472f294d44dd55 *src/DMS.h
bd4d742a4990b8c1b4190fefcfcf9926 *src/DST.cpp
84d4f37b1a949a3ae8a6bf560fa84846 *src/DST.h
2b15aa4044b0ac7d62596ce1561e2235 *src/Ellipsoid.cpp
ba65b0b4b14faebc65ffcb360435575b *src/Ellipsoid.h
cc2aac2c8587b421d8d7dc0cccbe50ec *src/EllipticFunction.cpp
270b441b7b7219a5a7a626793cf35d97 *src/EllipticFunction.h
15df156ad40a67e891718bc1c43f1f05 *src/GARS.cpp
e8a9fc1081d2a90896e2cb4aba68cb17 *src/GARS.h
07f41ba8d52fdf4665569924a365c5c8 *src/GeoCoords.cpp
2fb3588bd0380ee788a8f1b19c6a7e35 *src/GeoCoords.h
42b5f8ec7145a610f7560d7a150f7c79 *src/Geocentric.cpp
9e186369dab5d975104449329300ccfc *src/Geocentric.h
0828f7d35c55c3fae12dff14af00f59f *src/Geodesic.cpp
5e03c52f08e49ada7587c69cde93b875 *src/Geodesic.h
d626029da193038b914444ec50aff59e *src/GeodesicExact.cpp
cd6c9f983799b305fd0fdad2fbc2d351 *src/GeodesicExact.h
1c52e19fffbe0b675d6102082d16355e *src/GeodesicExactC4.cpp
859bd28e47472e5c05c9c6c0122d561c *src/GeodesicLine.cpp
992e0cade521fe85ceddc6918af16540 *src/GeodesicLine.h
3b472239ba504d61d695d3dba9f30ec6 *src/GeodesicLineExact.cpp
73dd836a7fb8b8fd3a28a003bbea5903 *src/GeodesicLineExact.h
b6463220d42691c0ffb93c2952b9dcef *src/Geohash.cpp
21feff1fa04d3fcc78b69f2dcd46a69c *src/Geohash.h
4dd9826e6d83b6c89d08685294bb2f14 *src/Geoid.cpp
724cc4f25313567d721c14c436eed644 *src/Geoid.h
b84e90f1cb351d21452131a728a7d7ec *src/Georef.cpp
775509d3fca422cc65728bac75584318 *src/Georef.h
428e1035348953548c711941539b369d *src/Gnomonic.cpp
397e20abfb0bd202be28690e906f12ed *src/Gnomonic.h
02bf2d8b4380c368bdf6a8fc48199224 *src/GravityCircle.cpp
ba5d092850216e35155d1b3c03846e8e *src/GravityCircle.h
dd0035dc88ca6a93a7098d0f3c9272a4 *src/GravityModel.cpp
6ce12d35eda74e4d86d5e70da03a18e6 *src/GravityModel.h
9676b43e04fe0e0be8218144f66e5dee *src/LambertConformalConic.cpp
7df7fc01a622e363fa92ce373f2d9a66 *src/LambertConformalConic.h
b347319eb57a2ac97c4b69f9162a31b1 *src/LocalCartesian.cpp
54bea88bffa43fdc3ae2459a896f7c0e *src/LocalCartesian.h
b882be74d9757cd7ae2f048a674bc2d7 *src/MGRS.cpp
18d923b5a882e3c84cf55f73f602c6ea *src/MGRS.h
30bb9f629d15f6418326fb0d37f75caf *src/MagneticCircle.cpp
1ae0eebc6b24213eb5e42a9a8b6093ff *src/MagneticCircle.h
969e8862c07dd85a0ef4c380a8efca6e *src/MagneticModel.cpp
ef25fdb0f3ed45c3c9fa15d47635032a *src/MagneticModel.h
382eb547fdb12d134f16ee34551e5ee5 *src/Math.cpp
b3c07ab34c65495e5a3b9a1dcc5d885f *src/Math.h
0ea1f1f5292380a4a12b056995b8aa9b *src/NearestNeighbor.h
4f06f0e83ccd2997b9789a5a9dd60d39 *src/NormalGravity.cpp
6ec1fd88fa880c3ed2baba6677157457 *src/NormalGravity.h
9652d30e99789c0f098382e99ae9e3cc *src/OSGB.cpp
8d25b4cba73c7ebcee26bf733d1a6b5c *src/OSGB.h
faf0e1ef694e3213d70ecc94aaa1db14 *src/PolarStereographic.cpp
dfecb81a62c645b639b2010a755e1e62 *src/PolarStereographic.h
e653d09c1005ae3c416a1aba45e1c89c *src/PolygonArea.cpp
c3c9f2cd934cfb88631a7357973ef315 *src/PolygonArea.h
76a3ffc6ea694b29cbde3bc8db11a5b8 *src/RcppExports.cpp
4e696b8deb94baf24c9afbd3d0f034b0 *src/Rhumb.cpp
6c7010c04e7686a0204a6077c0fd024d *src/Rhumb.h
73f7f8dc4e2831e69c6ac126301f0491 *src/SphericalEngine.cpp
63c9ca32661471b1cbb24a90922b98a7 *src/SphericalEngine.h
8c2a6941999f8214a3c3eb352efbc5ca *src/SphericalHarmonic.h
b015765fc4db3a70714508bc05060835 *src/SphericalHarmonic1.h
95f2a6ec9b16f9eed2c713ffa35efb09 *src/SphericalHarmonic2.h
1eaf3edd3970b709c5d9bad53230e5bc *src/TransverseMercator.cpp
405c21a9998da0d1411f02f47bc038d0 *src/TransverseMercator.h
bfd1353ffff0dbd4e443e633a5b8f420 *src/TransverseMercatorExact.cpp
c7ea66a004d40eab0e52a5c8da649db1 *src/TransverseMercatorExact.h
3663ed9f1fa29e801ea447b1d7bd2b1b *src/UTMUPS.cpp
7798d751ed7a751ff6712e34a4ec7d12 *src/UTMUPS.h
3b07e76a301647c1ac46db3de84905d8 *src/Utility.cpp
368b04eb42039edcd6a753e06be95f48 *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
12d5a31445574f0a6501536eb8563800 *src/intersect.cpp
d554906e5117a31c97b4ed41eecafb09 *src/kissfft.h
5090e95e97f748525ed9905c51309b22 *vignettes/geosphere.Rnw
geosphere/R/ 0000755 0001762 0000144 00000000000 14677357014 012452 5 ustar ligges users geosphere/R/gcIntermediate.R 0000644 0001762 0000144 00000006321 14172663435 015520 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, sp=FALSE, sepNA=FALSE) {
# Intermediate points on a great circle
# source: http://www.edwilliams.org/avform.htm
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 (sp) {
for (i in 1:length(res)) {
if (! is.list(res[[i]])) {
res[[i]] <- Lines( list( Line (res[[i]])), ID=as.character(i))
} else {
res[[i]] <- Lines( list( Line (res[[i]][[1]]), Line(res[[i]][[2]])), ID=as.character(i))
}
}
res <- SpatialLines(res, 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)
}
.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 13472155746 015403 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 13472155746 015065 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 00000003103 13472155746 014522 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) {
requireNamespace('raster')
if (inherits(xy, 'SpatialPolygons') | inherits(xy, 'SpatialPoints')) {
stopifnot(raster::isLonLat(xy))
xy <- 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 14161534066 014356 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 14430062652 015052 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 14161534117 014533 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 13472155746 013645 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 14334225267 014554 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 13472155746 014134 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 00000003563 13472155746 014426 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(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 13472155746 017137 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 00000004641 13472155746 015044 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')) {
line <- methods::as(line, 'SpatialLines')
}
if (inherits(x, 'SpatialLines')) {
requireNamespace('raster')
x <- raster::geom(x)
allpts <- NULL
for (p in unique(x[, 'cump'])) {
y <- x[x[, 'cump']==p, c('x', 'y')]
pts <- .evenspace(y, interval, direction=FALSE)
allpts <- rbind(allpts, pts)
}
return(allpts)
} else {
x <- .pointsToMatrix(x)
.evenspace(x, interval, direction=FALSE)
}
}
.sampleAlongPerpendicular <- function(x, interval, pdist, np=1 ) {
if (inherits(x, 'SpatialPolygons')) {
line <- methods::as(line, 'SpatialLines')
}
if (inherits(x, 'SpatialLines')) {
requireNamespace('raster')
x <- raster::geom(x)
allpts <- NULL
for (p in unique(x[, 'cump'])) {
y <- x[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 13472155746 015063 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 00000002204 13472155746 015017 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 <- SpatialLines( list( Lines( list( Line (res)), ID=as.character(1)) ), 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]] <- Lines( list( Line (res[[i]])), ID=as.character(i))
}
res <- SpatialLines(res, 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 13472155746 016433 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 00000005405 13472155746 014436 0 ustar ligges users # Author: George Wang & Robert J. Hijmans
# August 2010
# version 1
# license GPL3
.spDistPoint2Line <- function(p, line, distfun) {
test <- !is.projected(line)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of 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, '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 14430063054 014164 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 13472155746 014416 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 13472155746 014536 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 13472155746 013721 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 13472155746 013624 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 13472155746 014052 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 13472155746 014211 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 14161435516 014542 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 13472155746 016314 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 13472155746 014303 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 13472155746 014367 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 13472155746 016425 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 13472155746 016247 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 00000001702 14677357014 014662 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 00000005570 14161540713 015050 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='SpatialPolygons'),
function(x, a=6378137, f=1/298.257223563, ...) {
test <- is.projected(x)
if ( isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of SpatialPolygons object 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 14161534151 015132 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 14172661303 014565 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 13472155746 015402 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 00000007407 14472423123 014352 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 <- !is.projected(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of 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]] <- Polygon(crd)
}
polys[[i]] <- Polygons(partlist, i)
}
polys <- SpatialPolygons(polys)
if (inherits(p, 'SpatialPolygonsDataFrame')) {
rownames(p@data) <- 1:nrow(p@data)
polys <- 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 <- SpatialPolygons(list(Polygons(list(Polygon(res)), 1)))
res@proj4string <- CRS("+proj=longlat +datum=WGS84")
}
return(res)
}
}
makeLine <- function(p, interval=10000, sp=FALSE, ...) {
if (inherits(p, 'SpatialLines')) {
test <- !is.projected(p)
if (! isTRUE (test) ) {
if (is.na(test)) {
warning('Coordinate reference system of 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]] = Line(crd)
}
lines[[i]] = Lines(partlist, i)
}
lines <- SpatialLines(lines)
if (inherits(p, 'SpatialLinesDataFrame')) {
lines <- 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 <- SpatialLines(list(Lines(list(Line(res)), 1)))
res@proj4string <- CRS("+proj=longlat +datum=WGS84")
}
return(res)
}
}
geosphere/R/distGeo.R 0000644 0001762 0000144 00000001230 14161534041 014150 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 00000003331 13472155746 014404 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(is.projected(x)) ) {
return( 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 13472155746 016337 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 00000004437 13472155746 013546 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 <- SpatialPolygons(list(Polygons(list(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, ...) {
if (!requireNamespace('raster')) {stop('you need to install the "raster" package to use this function')}
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 <- length(x@polygons)
lonspan <- list()
latspan <- list()
lon <- list()
lat <- list()
for (i in 1:npol) {
pp <- x[i,]
rs <- raster::raster(pp)
if (nbands == 'fixed') {
dim(rs) <- c(n, n)
} else {
raster::res(rs) <- res
}
latitude <- raster::yFromRow(rs, 1:nrow(rs))
longitude <- raster::xFromCol(rs, 1:ncol(rs))
xd <- distGeo(cbind(0,latitude), cbind(raster::xres(rs),latitude), ...)
yd <- distGeo(cbind(0,0), cbind(0,raster::yres(rs)), ...)
rs <- raster::rasterize(pp, rs, silent=TRUE)
rs <- raster::getValues(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 00000005000 14032771416 015367 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-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 00000001501 13472155746 014663 0 ustar ligges users # Author: Robert J. Hijmans
# August 2016
# version 1
# license GPL3
lengthLine <- function(line) {
if (inherits(line, 'SpatialPolygons')) {
requireNamespace('raster')
line <- raster::geom(methods::as(line, 'SpatialLines'))
} else if (inherits(line, 'SpatialLines')) {
requireNamespace('raster')
line <- raster::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 13472155746 014534 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 13472155746 015324 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 13472155746 015547 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 13472155746 015176 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 14161534017 014175 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 13472155746 014264 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 00000005127 14472422775 015606 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, '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 14677403144 014255 5 ustar ligges users geosphere/vignettes/geosphere.Rnw 0000644 0001762 0000144 00000040331 13472155746 016733 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{http://www.edwilliams.org/ftp/avsig/avform.txt}, and partly on javascript implementations of these formulae by Chris Veness (\url{http://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{http://geographiclib.sourceforge.net/}.
\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{http://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf}
\end{hangparas}
\end{document}
geosphere/data/ 0000755 0001762 0000144 00000000000 13472155746 013162 5 ustar ligges users geosphere/data/merc.RData 0000644 0001762 0000144 00001062054 13472155746 015035 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â(á