Related
I have a lot of shapefiles of points that I have to manipulate in R.
My aim is to link all the points with a line, smooth it (to recreate a kind of path through points), segmentize the smoothed line in small sections (every section must have a precise length) and then create a buffer for every segments (then transform from lines to polygon) and finally count the points inside the polygons.
I start importing the points:
p <- st_read("/points.shp")
then I create the line:
l <- p %>% st_coordinates() %>% st_linestring()
From the line to the smoothed line:
ls <- smooth(l, method = "ksmooth")
Then I have created the segmentized smoothed line:
sls = st_segmentize(ls, 50)
And finally my buffer:
mybuf <- st_buffer(sls, dist= 30, endCapStyle="ROUND")
Unfortunately with this last command I can create only one buffer but I have to obtain a "segmented" buffer with a length of 50 meters and a height of 30m for each section.
I'm working with WGS84/UTM zone 32 N, epsg 32632 projection and my buffers must have the same projection.
Maybe there is another way to to that? Thanks...
Here the link to download a subset of the shapefile
From what I can tell, the main issue to surmount was that your code defines the line through your points as a single feature, so st_buffer was drawing a buffer around the whole line, rather than each segment between points. My goal was to figure out how to make sure each 50 meter segment was a unique feature.
library(sf)
library(smoothr)
cols <- c("red", "blue", "yellow")
source_file <- "./punti.shp"
par(mfrow = c(2,4))
p <- st_read(source_file)
plot(st_geometry(p), col = cols, main = "points")
l <- p %>% st_coordinates() %>% st_linestring()
plot(st_geometry(l), col = cols, main = "line")
l <- st_as_sf(data.frame(id = 1, geom=st_geometry(l)))
ls <- smooth(l, method = "ksmooth")
plot(st_geometry(ls), col = cols, main = "smoothed line")
# Note that segmentize doesn't slice a line
# Instead, it seems to just increases the number of vertices
sls <- st_segmentize(ls, 50)
slsp <- st_cast(sls, "POINT")
plot(st_geometry(slsp), col = cols, main = "segmented line vertices")
# Draw line between pairs of consecutive points
slsp <- st_as_sf(data.frame(id = 1, geom=st_geometry(slsp)))
slsp2 <- cbind(slsp[-nrow(slsp),"geometry"], slsp[-1,"geometry"])
ll <- st_sfc(mapply(function(a,b){
st_cast(st_union(a,b),"LINESTRING")}, slsp2$geometry, slsp2$geometry.1, SIMPLIFY=FALSE))
plot(st_geometry(ll), col = cols, main = "manually segmented line")
plot(st_geometry(head(ll)), col = cols, main = "man. segmented line, 1-10")
# Assign crs
st_crs(ll)
st_crs(ll) <- st_crs(p)
# Calculate buffers
mybuf <- st_buffer(ll, dist= 30, endCapStyle="ROUND")
plot(st_geometry(mybuf), col = cols, main = "buffers, all")
plot(st_geometry(head(mybuf)), col = cols, main = "buffers, 1-10")
# Count points in buffers
lengths(st_intersects(mybuf, p))
I would like to remove the pixels that form a large cluster and keep only the small cluster to analyse (means get pixels number and locations). First I apply a filter to color in white all pixels that has a value lower to 0.66. Then I use the function clump() in R. The model works but I cannot remove only the large cluster. I do not understand how clump function works.
Initial image:
Results image: plot_r is the image where the pixels with value < 0.66 are changed to 0. plot_rc is the results after clump() function. As observed I cannot remove only the large cluster of pixels (on top of the image plot_r). I changed the value (700 in the code) but not better, how to do?
Here the code:
library(magick)
library(pixmap)
library(raster)
library(igraph)
f <- "https://i.stack.imgur.com/2CjCh.jpg"
x <- image_read(f)
x <- image_convert(x, format = "pgm", depth = 8)
# Save the PGM file
f <- tempfile(fileext = ".pgm")
image_write(x, path = f, format = "pgm")
# Read in the PGM file
picture <- read.pnm(file = f, cellres = 1)
str(picture)
picture#size
mat <- picture#grey
mat[mat<0.66] <- 0; x
##############################################################
##Remove clumps of pixels in R using package Raster and igraph
#Detect clumps (patches) of connected cells
r <-raster(mat)
rc <- clump(r)
#extract IDs of clumps according to some criteria
clump9 = data.frame(freq(rc))
#remove clump observations with frequency smaller/larger than N
clump9 = clump9[ ! clump9$count > 700, ]
# record IDs from clumps which met the criteria in previous step
clump9 = as.vector(clump9$value)
#replace cells with IDs which do not belong to the group of interest
rc[rc != clump9[1] & rc != clump9[2]] = NA
# converting rasterlayer to matrix
n <- as.matrix(r)
m <- as.matrix(rc)
Perhaps something like this
library(raster)
library(igraph)
Short-cutting your approach a bit
f <- "https://i.stack.imgur.com/2CjCh.jpg"
b <- brick(f)
x <- sum(b)
r <- x > 450
rc <- clump(r)
f <- freq(rc, useNA="no")
Replace the clumps with the number of cells they consist of and then set the larger one (here more than 100 cells) to NA, and use the result to mask the original raster
rs <- subs(rc, data.frame(f))
rsc <- reclassify(rs, cbind(100,Inf,NA))
m <- mask(b, rsc)
plotRGB(m)
How can I find a non-linear path through raster image data? e.g., least cost algorithm? Starting and ending points are known and given as:
Start point = (0,0)
End point = (12,-5)
For example, extract the approximate path of a winding river through a (greyscale) raster image.
# fake up some noisy, but reproducible, "winding river" data
set.seed(123)
df <- data.frame(x=seq(0,12,by=.01),
y=sapply(seq(0,12,by=.01), FUN = function(i) 10*sin(i)+rnorm(1)))
# convert to "pixels" of raster data
# assumption: image color is greyscale, only need one numeric value, v
img <- data.frame(table(round(df$y,0), round(df$x,1)))
names(img) <- c("y","x","v")
img$y <- as.numeric(as.character(img$y))
img$x <- as.numeric(as.character(img$x))
## take a look at the fake "winding river" raster image...
library(ggplot2)
ggplot(img) +
geom_raster(aes(x=x,y=y,fill=v))
As I was writing up my example, I stumbled upon an answer using the 'gdistance' r package... hopefully others will find this useful.
library(gdistance)
library(sp)
library(ggplot2)
# convert to something rasterFromXYZ() understands
spdf <- SpatialPixelsDataFrame(points = img[c("x","y")], data = img["v"])
# use rasterFromXYZ to make a RasterLayer
r <- rasterFromXYZ(spdf)
# make a transition layer, specifying a sensible function and the number of connection directions
tl <- transition(r, function(x) min(x), 8)
## mean(x), min(x), and max(x) produced similar results for me
# extract the shortest path as something we can plot
sPath <- shortestPath(tl, c(0,0), c(12,-5), output = "SpatialLines")
# conversion for ggplot
sldf <- fortify(SpatialLinesDataFrame(sPath, data = data.frame(ID = 1)))
# plot the original raster, truth (white), and the shortest path solution (green)
ggplot(img) +
geom_raster(aes(x=x,y=y,fill=v)) +
stat_function(data=img, aes(x=x), fun = function(x) 10*sin(x), geom="line", color="white") +
geom_path(data=sldf, aes(x=long,y=lat), color="green")
I wanted to make sure that I wasn't just giving myself too easy of a problem... so I made a noisier version of the image.
img2 <- img
img2$v <- ifelse(img2$v==0, runif(sum(img2$v==0),3,8), img2$v)
spdf2 <- SpatialPixelsDataFrame(points = img2[c("x","y")], data = img2["v"])
r2 <- rasterFromXYZ(spdf2)
# for this noisier image, I needed a different transition function.
# The one from the vignette worked well enough for this example.
tl2 <- transition(r2, function(x) 1/mean(x), 8)
sPath2 <- shortestPath(tl2, c(0,0), c(12,-5), output = "SpatialLines")
sldf2 <- fortify(SpatialLinesDataFrame(sPath2, data = data.frame(ID = 1)))
ggplot(img2) +
geom_raster(aes(x=x,y=y,fill=v)) +
stat_function(data=img2, aes(x=x), fun = function(x) 10*sin(x), geom="line", color="white") +
geom_path(data=sldf2, aes(x=long,y=lat), color="green")
UPDATE: using real raster data...
I wanted to see if the same workflow would work on an actual real-world raster image and not just fake data, so...
library(jpeg)
# grab some river image...
url <- "https://c8.alamy.com/comp/AMDPJ6/fiji-big-island-winding-river-aerial-AMDPJ6.jpg"
download.file(url, "river.jpg", mode = "wb")
jpg <- readJPEG("./river.jpg")
img3 <- melt(jpg, varnames = c("y","x","rgb"))
img3$rgb <- as.character(factor(img3$rgb, levels = c(1,2,3), labels=c("r","g","b")))
img3 <- dcast(img3, x + y ~ rgb)
# convert rgb to greyscale
img3$v <- img3$r*.21 + img3$g*.72 + img3$b*.07
For rgb to greyscale, see: https://stackoverflow.com/a/27491947/2371031
# define some start/end point coordinates
pts_df <- data.frame(x = c(920, 500),
y = c(880, 50))
# set a reference "grey" value as the mean of the start and end point "v"s
ref_val <- mean(c(subset(img3, x==pts_df[1,1] & y==pts_df[1,2])$v,
subset(img3, x==pts_df[2,1] & y==pts_df[2,2])$v))
spdf3 <- SpatialPixelsDataFrame(points = img3[c("x","y")], data = img3["v"])
r3 <- rasterFromXYZ(spdf3)
# transition layer defines "conductance" between two points
# x is the two point values, "v" = c(v1, v2)
# 0 = no conductance, >>1 = good conductance, so
# make a transition function that encourages only small changes in v compared to the reference value.
tl3 <- transition(r3, function(x) (1/max(abs((x/ref_val)-1))^2)-1, 8)
sPath3 <- shortestPath(tl3, as.numeric(pts_df[1,]), as.numeric(pts_df[2,]), output = "SpatialLines")
sldf3 <- fortify(SpatialLinesDataFrame(sPath3, data = data.frame(ID = 1)))
# plot greyscale with points and path
ggplot(img3) +
geom_raster(aes(x,y, fill=v)) +
scale_fill_continuous(high="white", low="black") +
scale_y_reverse() +
geom_point(data=pts_df, aes(x,y), color="red") +
geom_path(data=sldf3, aes(x=long,y=lat), color="green")
I played around with different transition functions before finding one that worked. This one is probably more complex than it needs to be, but it works. You can increase the power term (from 2 to 3,4,5,6...) and it continues to work. It did not find a correct solution with the power term removed.
Alternative solution using igraph package.
Found an alternative set of answers using 'igraph' r package. I think it is important to note that one of the big differences here is that 'igraph' supports n-dimensional graphs whereas 'gdistance' only supports 2D graphs. So, for example, extending this answer into 3D is relatively easy.
library(igraph)
# make a 2D lattice graph, with same dimensions as "img"
l <- make_lattice(dimvector = c(length(unique(img$y)),
length(unique(img$x))), directed=F, circular=F)
summary(l)
# > IGRAPH ba0963d U--- 3267 6386 -- Lattice graph
# > + attr: name (g/c), dimvector (g/n), nei (g/n), mutual (g/l), circular (g/l)
# set vertex attributes
V(l)$x = img$x
V(l)$y = img$y
V(l)$v = img$v
# "color" is a known attribute that will be used by plot.igraph()
V(l)$color = grey.colors(length(unique(img$v)))[img$v+1]
# compute edge weights as a function of attributes of the two connected vertices
el <- get.edgelist(l)
# "weight" is a known edge attribute, and is used in shortest_path()
# I was confused about weights... lower weights are better, Inf weights will be avoided.
# also note from help: "if all weights are positive, then Dijkstra's algorithm is used."
E(l)$weight <- 1/(pmax(V(l)[el[, 1]]$v, V(l)[el[, 2]]$v))
E(l)$color = grey.colors(length(unique(E(l)$weight)))[E(l)$weight+1]
Edge weights calculation courtesy of: https://stackoverflow.com/a/27446127/2371031 (thanks!)
# find the start/end vertices
start = V(l)[V(l)$x == 0 & V(l)$y == 0]
end = V(l)[V(l)$x == 12 & V(l)$y == -5]
# get the shortest path, returning "both" (vertices and edges)...
result <- shortest_paths(graph = l, from = start, to = end, output = "both")
# color the edges that were part of the shortest path green
V(l)$color = ifelse(V(l) %in% result$vpath[[1]], "green", V(l)$color)
E(l)$color = ifelse(E(l) %in% result$epath[[1]], "green", E(l)$color)
# color the start and end vertices red
V(l)$color = ifelse(V(l) %in% c(start,end), "red", V(l)$color)
plot(l, vertex.shape = "square", vertex.size=2, vertex.frame.color=NA, vertex.label=NA, curved=F)
Second (noisier) example requires a different formula to compute edge weights.
img2 <- img
img2$v <- ifelse(img2$v==0, runif(sum(img2$v==0),3,8), img2$v)
l <- make_lattice(dimvector = c(length(unique(img2$y)),
length(unique(img2$x))), directed=F, circular=F)
# set vertex attributes
V(l)$x = img2$x
V(l)$y = img2$y
V(l)$v = img2$v
V(l)$color = grey.colors(length(unique(img2$v)))[factor(img2$v)]
# compute edge weights
el <- get.edgelist(l)
# proper edge weight calculation is the key to a good solution...
E(l)$weight <- (pmin(V(l)[el[, 1]]$v, V(l)[el[, 2]]$v))
E(l)$color = grey.colors(length(unique(E(l)$weight)))[factor(E(l)$weight)]
start = V(l)[V(l)$x == 0 & V(l)$y == 0]
end = V(l)[V(l)$x == 12 & V(l)$y == -5]
# get the shortest path, returning "both" (vertices and edges)...
result <- shortest_paths(graph = l, from = start, to = end, output = "both")
# color the edges that were part of the shortest path green
V(l)$color = ifelse(V(l) %in% result$vpath[[1]], "green", V(l)$color)
E(l)$color = ifelse(E(l) %in% result$epath[[1]], "green", E(l)$color)
# color the start and end vertices red
V(l)$color = ifelse(V(l) %in% c(start,end), "red", V(l)$color)
plot(l, vertex.shape = "square", vertex.size=2, vertex.frame.color=NA, vertex.label=NA, curved=F)
I have generated a pixel-based image by encoding each input character to a certain color in the image. For example, in input txt <- "ABACDAAFFEDDADFAFAED" i plotted 'A' as a red pixel, 'B' as purple, 'C' by blue and 'D' by some other color. I used R for it. Here is the answer from where I have taken help for this
Generate pixel based image in R from character array
Now, I want to update this for handling a case as well where I have a character presents 2 or three times consecutively and I want to give it a different color. For example txt <- "ABBACDAABBBEDDADCACABBDB", i want to give
A- red, AA maroon, AAA dark red.
B-green, BB- Pink, BBB-yellow,
C-light brown, CC brown, CCC dark brown etc.
I still want to give 1 pixel to each char but for consecutive 2 or 3 appearances color those 2 or 3 pixels with a different color. I am unable to code a reasonable solution for it in R. Your help will be appreciated. Thanks
I changed the function to support multiple character :
library(png)
library(tiff)
library(abind)
# function which plots the image
createImage <- function(txt,charToColorMap,destinationFile,format=c('png','tiff'),debugPlot=FALSE,unused.char='#'){
if(nchar(unused.char) != 1){
stop('unused.char must be a single character, and you should be sure that it will never be present in your text')
}
# helper function which finds all the divisors of a number
divisors <- function(x){
y <- seq_len(x)
y[ x%%y == 0 ]
}
# split the string in charaters
chars <- strsplit(txt,'')[[1]]
# find the most "squared" rectangle that contains all the characters without padding
d <- divisors(length(chars))
y <- d[length(d) %/% 2]
x <- length(chars) / y
# create an array with 4 matrices (or planes) one for each RGBA channel
RGBAmx <- col2rgb(charToColorMap,alpha=TRUE) / 255
colorIndexes <- match(chars,names(charToColorMap))
######################################
# MULTIPLE CHAR
######################################
# check if color map contains multiple character names
multiple <- names(charToColorMap)[nchar(names(charToColorMap)) > 1]
multiple <- multiple[order(nchar(multiple),decreasing=TRUE)]
txtForMultiple <- txt
for(m in multiple){
idxs <- gregexpr(pattern=m,text=txtForMultiple,fixed=TRUE)[[1]]
charRanges <- unlist(lapply(idxs,seq,length.out=nchar(m)))
colorIndexes[charRanges] <- which(names(charToColorMap)==m)[1]
tmp <- strsplit(txtForMultiple,'')[[1]]
tmp[charRanges] <- unused.char
txtForMultiple <- paste(tmp,collapse='')
}
#########################################################
colorIndexesR <- matrix(RGBAmx['red',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesG <- matrix(RGBAmx['green',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesB <- matrix(RGBAmx['blue',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesA <- matrix(RGBAmx['alpha',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
planes <- abind(colorIndexesR,colorIndexesG,colorIndexesB,colorIndexesA,along=3)
# write the PNG image
if(format[1] == 'png'){
writePNG(planes,destinationFile)
}else if(format[1] == 'tiff'){
writeTIFF(planes,destinationFile)
}else{
stop('usupported format')
}
# for debug purpose only we plot the image...
if(debugPlot){
mx <- matrix(colorIndexes,nrow=y,ncol=x,byrow = TRUE)
image(z=t(mx[nrow(mx):1,]),col=charToColorMap)
}
invisible()
}
Usage example ('AAA' set to white) :
charToColorMap <- c(A='red',B='blue',C='green',D='black',E='yellow',F='orange',AAA='white')
txt <- "ABACAAAFFEDDADFAFAED"
# please note that unused.char will be used to mark the characters of txt already analyzed
# during the multi-char handling, so it must not be present in txt
createImage(txt,charToColorMap,destinationFile = "test.png",debugPlot=TRUE,unused.char='#')
Result (zoom 800 %):
I have two binary files with the same dimensions: the first represents correlation between xm and df and the second represents also correlation between xm and gh data.I want to create one map out of these two representing the best correlations.for instance:
1- read the first pixel in the correlation map between xm and df and the corresponding pixel in the correlation map between xm and gh.
2- take the best correlation value and make it blue color if it comes from xm and df,otherwise make it green if it comes from xm and gh
3- do the same for all pixels
4- get something like the map associated
Here are the two files:
1- to read the first file correlation map:![enter image description here][1]
conn <- file("C:\\corr.bin","rb")![enter image description here][2]
corr<- readBin(conn, numeric(), size=4, n=1440*720, signed=TRUE)
y<-t(matrix((data=corr), ncol=720, nrow=1440))
image(y)
2- to read the second file land cover map:
conne <- file("C:\\cor06.bin","rb")
over<-readBin(conne, numeric(), size=4, n=1440*720, signed=TRUE)
y1<-t(matrix((data=over), ncol=720, nrow=1440))
image(y1)
3-to write the results:
to.write = file(paste("/orcomplete.bin",sep=""),"wb")
writeBin(as.double(results), to.write, size = 4)
If the dimensions of your data are the same (which in your case this is true) then you can use the raster package like so:
r <-raster(t(matrix((data=corr), ncol=720, nrow=1440)))
r1 <- raster(t(matrix((data=over), ncol=720, nrow=1440)))
m <- r > r1 #Compare the two rasters
image( m , col = c("#EF8A62" , "#67A9CF" ) ) #Hexadecimal colour specification
legend( "bottomleft" , legend = c( "Y" , "Y1") , fill = c("#EF8A62" , "#67A9CF" ) , border = "#D9D9D9" , bty = "n")
An example with base R:
## example data
set.seed(1)
cor1 <- runif(100)
cor2 <- runif(100)
## find max correlation
maxCor <- pmax(cor1, cor2)
## find correct color
col <- ifelse(maxCor==cor1, "blue", "green")