I want to calculate a least-cost path using gdistance::shortestPath. I have a raster file showing the cost of passing each cell, but before using it, I try to mimic the example 1 in the pdf manual to see how the package works as below when we assume constant cost to travel across cells.
library(gdistance)
raster <- raster(ymn = 35.6, ymx = 35.76, xmx = 139.9, xmn = 139.6, res = 0.001)
raster[] <- 1
speed <- function(x){1/(x[2]+x[1])}
# 8 is possible connections
trraster <- transition(raster, transitionFunction=speed, 8)
trraster <- geoCorrection(trraster, scl=FALSE)
plot(raster(trraster))
adj <- adjacent(raster, cells=1:ncell(raster), pairs=TRUE, directions=8)
speed <- trraster
# this is the cost function
speed[adj] <-trraster[adj]
x <- geoCorrection(speed, scl=FALSE)
origin <- c(139.7761,35.7136)
goal <- c(139.7582,35.66639)
path <- shortestPath(x, origin, goal, output="SpatialLines")
plot(raster(speed))
lines(path)
Because this assume constant costs to travel (See raster[] <- 1 and speed <- function(x){1/(x[2]+x[1])}), the result must be a straight line, but the result is different as below.
It does not seem to allow us travel cells diagonally. What is wrong with the code? I set direction as 8, so we should be able to travel cells diagonally. I am using gdistance 1.3-6 and R 4.0.5.
I solved it by removing trraster <- geoCorrection(trraster, scl=FALSE). In the original pdf manual, they apply geoCorrection twice to adjust the distance between cells when they calculate the slope (height difference / distance) and conductance (speed / distance). However, in my case, speed is constant, so we only need to apply it once in x <- geoCorrection(speed, scl=FALSE).
Related
I am attempting to create a disc for each point in a pattern; each disc will have the same radius. Then for each disc, I want to count the number of points falling within the disc. Each pattern has 100-400 points. I have written code to do this, but it is quite slow. The code is below. I cannot provide the shapefile and points as that would be very difficult, but I could create some dummy data if need be.
W <- as.owin(shape)
#Converts created .shp file into a "window"
#in which everything is plotted and calculated
SPDF <- SpatialPointsDataFrame(P[,1:2], P)
#Converts data frame to spatial points data frame
SP <- as(SPDF, "SpatialPoints") #Converts SPDF to spatial points
SP1 <- as.ppp(coordinates(SP), W)
SP2 <- as.ppp(SP1)
attr(SP1, "rejects")
attr(SP2, "rejects")
aw <- area.owin(W) #Area, in pixels squared, of leaf window created earlier
#awm <- aw * (meas)^2 * 100 #Area window in millimeters squared
# Trichome_Density_Count-----------------------------------------------------------------------------------------------
TC <- nrow(P) #Counts number of rows in XY data points file,
#this is number of trichomes from ImageJ
TD <- TC/awm #Trichome density, trichomes per mm^2
#SPDF2 <- as.SpatialPoints.ppp(SP2)
#kg <- knn.graph(SPDF2, k = 1)
#Creates the lines connecting each NND pairwise connection
#dfkg <- data.frame(kg) #Converts lines into a data frame
#dfkgl <- dfkg$length
meanlength <- 78
discstest <- discs(SP2, radii = meanlength,
separate = TRUE, mask = FALSE, trim = FALSE,
delta = NULL, npoly=NULL)
#Function creates discs for each trichome
#Using nearest neighbor lengths as radii
#NEED TO ADD CLIPPING
ratiolist <- c()
for (i in 1:length(discstest)) {
ow2sp <- owin2SP(discstest[[i]])
leafsp <- owin2SP(W)
tic("gIntersection")
intersect <- rgeos::gIntersection(ow2sp, leafsp)
Sys.sleep(1)
toc()
tic("over")
res <- as.data.frame(sp::over(SP, intersect, returnList = FALSE))
Sys.sleep(1)
toc()
res[is.na(res)] <- 0
newowin <- as.owin(intersect)
circarea <- area.owin(newowin)
trichactual <- sum(res)
trichexpect <- (TC / aw) * circarea
ratio <- trichactual / trichexpect
ratiolist[[i]] <- ratio
}
If I understand you correctly you want to loop through each point and check how many points fall within a disc of radius R centered in that point. This is done very efficiently in spatstat with the function closepaircounts:
closepaircounts(SP2, r = meanlength)
This simply returns a vector with the number of points contained in the disc of radius r for each point in SP2.
I have just tried this for 100,000 points where each point on average had almost 3000 other points in the disc around it, and it took 8 seconds on my laptop. If you have many more points or in particular if the disc radius is so big that each disc contains many more points it may become very slow to calculate this.
In order to conduct least cost analyses in R, I am trying to produce the cost surface from a DEM. I want to treat land areas in a different way from sea areas (sea costs being half of land travel costs on a plain). To do so, I have produced two transition layers which I calculated with two different transitionFunction (altDiff). (geoCorrection and the Tobler function I omitted here)
library(raster)
library(gdistance)
# functions ---------------------------------------------------------------
altDiff_land <- function(x) (x[2] - x[1])
altDiff_sea <- function(x) if((x[2]==0) & (x[1]==0)) { 0 } else { 99 }
# DEM ---------------------------------------------------------------------
dem <- raster(nrows=18, ncols=18)
dem <- setValues(dem, runif(ncell(dem),min = 0, max = 50))
# cost surface LAND -------------------------------------------------------
dem_land <- dem
land_trans <- transition(x = dem_land, transitionFunction = altDiff_land,
directions = 8, symm = FALSE)
# cost surface SEA --------------------------------------------------------
dem_sea <- dem
dem_sea[dem_sea[]>40] <- 1
dem_sea[dem_sea[]!=1] <- 0
sea_trans <- transition(x = dem_sea, transitionFunction = altDiff_sea,
directions = 8, symm = FALSE)
The next step would be to stack the two transition layers (land_trans, sea_trans) in order to select the maximum values from them producing a final transition layer that I can use for least cost analysis.
I tried
a <- stack(land_trans,sea_trans)
conductance <- max(a)
plot(raster(conductance))
text(raster(conductance))
(which is working in this example) but the problem is that with my original DEM (of 450 MB) I have never got a result (even with aggregating the DEM with factor 500!) which is either because the max function is incredibly slow or because it does not work well with transitionStacks/layers. Rasterizing the transition layers before the analysis is not an option since the costDistance function from gdistance needs a transition layer.
Is there an alternative for max?
It seems that the produced transitionlayers have different amounts of values (x) in their matrices. So, when I try
a_test <- land_trans
a_test#transitionMatrix#x[a_test#transitionMatrix#x<sea_trans#transitionMatrix#x]
<- sea_trans#transitionMatrix#x
as an alternative for max all I get is
Warning message:
In a_test#transitionMatrix#x[a_test#transitionMatrix#x <
test_sea#transitionMatrix#x] <- test_sea#transitionMatrix#x :
number of items to replace is not a multiple of replacement length
But the DEMs are of the same size! Why do the transitionlayers differ? Can I force them to have identical sizes?
Dear Crowd
Problem
I tried to calculate a spatial correlogram with the packages nfc, pgirmess, SpatialPack and spdep. However, I was troubling to define the start and end-point of the distance. I'm only interested in the spatial autocorrelation at smaller distances, but there on smaller bins. Additionally, as the raster is quite large (1.8 Megapixels), I run into memory troubles with these packages but the SpatialPack.
So I tried to produce my own code, using the function Moran from the package raster. But I must have some error, as the result for the complete dataset is somewhat different than the one from the other packages. If there is no error in my code, it might at least help others with similar problems.
Question
I'm not sure, whether my focal matrix is erroneous. Could you please tell me whether the central pixel needs to be incorporated? Using the testdata I can't show the differences between the methods, but on my complete dataset, there are differences visible, as shown in the Image below. However, the bins are not exactly the same (50m vs. 69m), so this might explain parts of the differences. However, at the first bin, this explanation seems not to be plausible to me. Or might the irregular shape of my raster, and different ways to handle NA's cause the difference?
Comparison of Own method with the one from SpatialPack
Runable Example
Testdata
The code for calculating the testdata is taken from http://www.petrkeil.com/?p=1050#comment-416317
# packages used for the data generation
library(raster)
library(vegan) # will be used for PCNM
# empty matrix and spatial coordinates of its cells
side=30
my.mat <- matrix(NA, nrow=side, ncol=side)
x.coord <- rep(1:side, each=side)*5
y.coord <- rep(1:side, times=side)*5
xy <- data.frame(x.coord, y.coord)
# all paiwise euclidean distances between the cells
xy.dist <- dist(xy)
# PCNM axes of the dist. matrix (from 'vegan' package)
pcnm.axes <- pcnm(xy.dist)$vectors
# using 8th PCNM axis as my atificial z variable
z.value <- pcnm.axes[,8]*200 + rnorm(side*side, 0, 1)
# plotting the artificial spatial data
r <- rasterFromXYZ(xyz = cbind(xy,z.value))
plot(r, axes=F)
Own Code
library(raster)
sp.Corr <- matrix(nrow = 0,ncol = 2)
formerBreak <- 0 #for the first run important
for (i in c(seq(10,200,10))) #Calculate the Morans I for these bins
{
cat(paste0("..",i)) #print the bin, which is currently calculated
w = focalWeight(r,d = i,type = 'circle')
wTemp <- w #temporarily saves the weigtht matrix
if (formerBreak>0) #if it is the second run
{
midpoint <- ceiling(ncol(w)/2) # get the midpoint
w[(midpoint-formerBreak):(midpoint+formerBreak),(midpoint-formerBreak):(midpoint+formerBreak)] <- w[(midpoint-formerBreak):(midpoint+formerBreak),(midpoint-formerBreak):(midpoint+formerBreak)]*(wOld==0)#set the previous focal weights to 0
w <- w*(1/sum(w)) #normalizes the vector to sum the weights to 1
}
wOld <- wTemp #save this weight matrix for the next run
mor <- Moran(r,w = w)
sp.Corr <- rbind(sp.Corr,c(Moran =mor,Distance = i))
formerBreak <- i/res(r)[1]#divides the breaks by the resolution of the raster to be able to translate them to the focal window
}
plot(x=sp.Corr[,2],y = sp.Corr[,1],type = "l",ylab = "Moran's I",xlab="Upper bound of distance")
Other methods to calculate the Spatial Correlogram
library(SpatialPack)
sp.Corr <- summary(modified.ttest(z.value,z.value,coords = xy,nclass = 21))
plot(x=sp.Corr$coef[,1],y = data$coef[,4],type = "l",ylab = "Moran's I",xlab="Upper bound of distance")
library(ncf)
ncf.cor <- correlog(x.coord, y.coord, z.value,increment=10, resamp=1)
plot(ncf.cor)
In order to compare the results of the correlogram, in your case, two things should be considered. (i) your code only works for bins proportional to the resolution of your raster. In that case, a bit of difference in the bins could make to include or exclude an important amount of pairs. (ii) The irregular shape of the raster has a strong impact of the pairs that are considered to compute the correlation for certain distance interval. So your code should deal with both, allow any value for the length of bin and consider the irregular shape of the raster. A small modification of your code to tackle those problems are below.
# SpatialPack correlation
library(SpatialPack)
test <- modified.ttest(z.value,z.value,coords = xy,nclass = 21)
# Own correlation
bins <- test$upper.bounds
library(raster)
sp.Corr <- matrix(nrow = 0,ncol = 2)
for (i in bins) {
cat(paste0("..",i)) #print the bin, which is currently calculated
w = focalWeight(r,d = i,type = 'circle')
wTemp <- w #temporarily saves the weigtht matrix
if (i > bins[1]) {
midpoint <- ceiling(dim(w)/2) # get the midpoint
half_range <- floor(dim(wOld)/2)
w[(midpoint[1] - half_range[1]):(midpoint[1] + half_range[1]),
(midpoint[2] - half_range[2]):(midpoint[2] + half_range[2])] <-
w[(midpoint[1] - half_range[1]):(midpoint[1] + half_range[1]),
(midpoint[2] - half_range[2]):(midpoint[2] + half_range[2])]*(wOld==0)
w <- w * (1/sum(w)) #normalizes the vector to sum the weights to 1
}
wOld <- wTemp #save this weight matrix for the next run
mor <- Moran(r,w=w)
sp.Corr <- rbind(sp.Corr,c(Moran =mor,Distance = i))
}
# Comparing
plot(x=test$upper.bounds, test$imoran[,1], col = 2,type = "b",ylab = "Moran's I",xlab="Upper bound of distance", lwd = 2)
lines(x=sp.Corr[,2],y = sp.Corr[,1], col = 3)
points(x=sp.Corr[,2],y = sp.Corr[,1], col = 3)
legend('topright', legend = c('SpatialPack', 'Own code'), col = 2:3, lty = 1, lwd = 2:1)
The image shows that the results of using the SpatialPack package and the own code are the same.
I have an irregular grid, that I need to convert to a regular grid to take advantage of image's useRaster=TRUE option for graphics devices. I can do this on a small scale by converting the irregular grid to points, then interpolate the points using akima's interp. However this scales horribly with larger dimensions, so I'm looking for options.
First, here is the small scale (5x10) example, where only the x-dimension is irregular:
nx <- 5
ny <- 10
si <- list() # irregular surface
si$x <- cumsum(runif(nx) * 10) + 100
si$y <- seq(20, 50, length.out=ny)
si$z <- matrix(rnorm(nx * ny), ncol=ny)
image(si)
And the bilinear interpolated result:
sr_x <- seq(min(si$x), max(si$x), length.out=nx * 5)
sr_y <- si$y # this dimension is already regular
require(akima) # interpolate from points repeated off irregular grid
sr <- interp(rep(si$x, length(si$y)), rep(si$y, each=length(si$x)), si$z,
xo=sr_x, yo=sr_y)
image(sr, useRaster=TRUE)
However, if a larger dimension irregular grid is used (e.g. nx <- 50; ny <- 100), the procedure is really slow. Is there either a library or technique that would speed up the process?
Update and possibly a solution. The data describes time vs time (both in years), where the irregular dimension has timesteps between 0.5 days to 30 days, and the second time axis has equal-spaced 365 day spacings. Since the spacings are much smaller along the irregular axis, interpolating will not work. Thus a smoothing or aggregating method will yield better results.
A more realistic data scenario, showing the finer irregular dimension:
nx <- 200
ny <- 10
si <- list() # irregular surface
si$x <- cumsum(runif(nx, 0.5, 30) / 365)
si$y <- 1:ny
si$z <- matrix(rnorm(nx * ny), ncol=ny)
image(si)
And some really crude aggregate means:
dx <- 1/12 # 1 month spacing along x-axis
sr <- list() # regular surface
sr$x <- seq(min(si$x), max(si$y), dx) # equal-width breaks
nsrx <- length(sr$x)
sr$y <- si$y # this dimension is already regular
sr$z <- matrix(nrow=length(sr$x), ncol=length(sr$y))
# Classify irregular dimension
si_xc <- cut(si$x, sr$x, include.lowest=TRUE, labels=FALSE)
# Aggregate means from irregular to regular dimension
for(xi in seq_len(nsrx))
sr$z[xi,] <- apply(si$z[si_xc == xi, , drop=FALSE], 2, mean)
image(sr, zlim=range(si$z), useRaster=TRUE)
This seems to do the trick, and scales on much larger datsets with 100s of years along each dimension. So I suppose my new question would be simply to tidy up the above code to perform aggregate means.
There are several packages w/ "kriging" tools, which is basically what you want. However, I dunno whether it'll be any faster than what akima::interp does.
I solved this using multicore techniques, so if you have a multicore processor, consider something similar to the following code snippet:
picbits <- clusterApply( myclus, 1:length(picsec) , function(j) { gc();
akima::interp(newx[picsec[[j]] ], newy[picsec[[j]] ], picture[picsec[[j]] ],
xo=trunc(min(newx[picsec[[j]] ])):trunc(max(newx[picsec[[j]] ])),
yo=trunc(min(newy[picsec[[j]] ])):trunc(max(newy[picsec[[j]] ])) )} )
That is extracted from a function I wrote to perform a rotational "swirl" on an image, so there's a lot of cruft there you won't need.
I know that white noise can be achieved by treating the output of rnorm() as a timeseries. Any suggestions on how to simulate pink noise?
Package tuneR has noise function which can generate a wave object that is either white or pink noise:
require(tuneR)
w <- noise(kind = c("white"))
p <- noise(kind = c("pink"))
par(mfrow=c(2,1))
plot(w,main="white noise")
plot(p,main="pink noise")
EDIT: I realized that the method above doesn't generate the vector (doh). Brutal way to convert it into the vector is to add the code below:
writeWave(p,"p.wav")#writes pink noise on your hard drive
require(audio)#loads `audio` package to use `load.wave` function
p.vec <- load.wave("path/to/p.wav")#this will load pink noise as a vector
As said by #mbq, you can just use p#left to get the vector, instead of saving and reading the wav file. On the other hand, you could directly use the function generating the time serie in tuneR:
TK95 <- function(N, alpha = 1){
f <- seq(from=0, to=pi, length.out=(N/2+1))[-c(1,(N/2+1))] # Fourier frequencies
f_ <- 1 / f^alpha # Power law
RW <- sqrt(0.5*f_) * rnorm(N/2-1) # for the real part
IW <- sqrt(0.5*f_) * rnorm(N/2-1) # for the imaginary part
fR <- complex(real = c(rnorm(1), RW, rnorm(1), RW[(N/2-1):1]),
imaginary = c(0, IW, 0, -IW[(N/2-1):1]), length.out=N)
# Those complex numbers that are to be back transformed for Fourier Frequencies 0, 2pi/N, 2*2pi/N, ..., pi, ..., 2pi-1/N
# Choose in a way that frequencies are complex-conjugated and symmetric around pi
# 0 and pi do not need an imaginary part
reihe <- fft(fR, inverse=TRUE) # go back into time domain
return(Re(reihe)) # imaginary part is 0
}
and this works perfectly :
par(mfrow=c(3,1))
replicate(3,plot(TK95(1000,1),type="l",ylab="",xlab="time"))