Is there a way I can plot a raster annotation in a ggplot, rotated at a specified angle (which is not necessarily a multiple of 90 degrees)? In particular, I need the scale of the image to appear unchanged.
What I've tried so far: based on the question How to rotate an image R raster I created a function to rotate an image and save it as a temp file (seems to be the only thing I can do to store the image created by persp), with the idea of then loading it in with ggplot2::annotation_raster.
raster_rotate <- function(img, theta, width) {
# only works with square imgs right now
theta <- theta %% 90
b <- cos(theta) + sin(theta)
x1 <- 0:ncol(img)
y1 <- 0:nrow(img)
z <- matrix(1, nrow = length(x1), ncol = length(y1))
col_mat <- t(apply(matrix(rgb(getValues(img)/255), nrow=nrow(img), byrow=TRUE), 2, rev))
tmppath = tempfile(pattern = "img", fileext = ".png", tmpdir = "tmp/imgrot")
side = round(b * width)
png(filename = tmppath, width = side, height = side)
persp(x1, y1, z, zlim = c(0, 2), theta = theta, phi = 90,
col = col_mat, scale = FALSE, border = NA, box = FALSE)
dev.off()
}
Because rotating the image inside the same sized canvas will appear to shrink the image as angles approach 45 degrees, I have to rescale the canvas size by a factor of cos(theta) + sin(theta) as I rotate. However, when I add this scaling to the png function I get an error:
Error in png(filename = tmppath, width = side, height = side) :
invalid 'width' or 'height'
I would accept a solution to this error to help me fix my messy hack, but if there's a cleaner way to do this directly into ggplot that would be even better.
Here is how I rotate maps, maybe tweaking it a bit will address your issue?
library(tidyverse)
rotate.axis <- function(xy,theta){
pimult <- (theta * 2 * pi) / 360
newx <- c(cos(pimult), sin(pimult))
newy <- c(-sin(pimult), cos(pimult))
XY <- as.matrix(xy) %*% cbind(newx, newy)
as.data.frame(XY)
}
ak <- map_data('world','USA:Alaska')
newd <- data.frame(longitude=ak$long, latitude=ak$lat)
rotate <- rotate.axis(newd,30)
newak <- bind_cols(ak,rotate)
No rotation of object
newak %>%
filter(long<0) %>%
ggplot() + geom_polygon(aes(long,lat,group=group),fill=8,color="black")
Rotated object
newak %>%
filter(long<0) %>%
ggplot() + geom_polygon(aes(newx,newy,group=group),fill=8,color="black")
Related
I want to cut a polygon from a photo and move it to another place in the photo and I want to plot the final image with ggplot2.
I use the terra package (feel free to suggest a better approach/method) to convert the photo into a data.frame which is necessary for ggplot2:
# load libraries
library(terra)
library(ggplot2)
# download the cat photo from internet (its an open source photo)
cat_url = "https://images.pexels.com/photos/104827/cat-pet-animal-domestic-104827.jpeg?auto=compress&cs=tinysrgb&w=600"
download.file(url = cat_url, destfile = "cat.jpeg")
# return the full path to the cat photo
cat_path = list.files(pattern = "cat.jpeg", full.names = TRUE)
# load the cat photo as rast from terra
cat_rast = rast(cat_path)
# convert the rast file into a dataframe containing the pixels in red, green and blue channels
cat_df = as.data.frame(cat_rast, xy = TRUE) # xy = TRUE returns x and y coordinates as 1st and 2nd columns
I can now plot the red channel of the image using ggplot2:
# plot red channel with ggplot2
ggplot(data = cat_df, aes(x, y, fill = cat_1)) + # cat_1 corresponds to the 1st channel in the image, which is red
geom_raster() +
coord_fixed(xlim = c(0, 1.5), ylim = c(0, 1.5))
which produces:
What I want to do at this point is to cut a polygon from the left side of the image and move all the pixels contained in the polygon to the right side of the image. I also want to cut a polygon from the bottom and move it up.
Using photoshop:
Here, the drawn "polygon" on the left should then be moved to the right side of the image and the drawn "polygon" on the bottom should be moved to the upper side of the image.
cat_url = "https://images.pexels.com/photos/104827/cat-pet-animal-domestic-104827.jpeg?auto=compress&cs=tinysrgb&w=600"
library(terra)
x <- rast(cat_url)
ext(x) <- c(0,1,0,1) # for forward compatibility and generality
You can draw polygons like this
#plot(x)
#p <- draw("polygon")
predefined polygon
p <- vect("POLYGON ((0.0 0.589041, 0.077283 0.534247, 0.210361 0.510763, 0.363008 0.508806, 0.419762 0.549902, 0.402149 0.48728, 0.327782 0.395303, 0.192748 0.365949, 0.061627 0.373777, 0.0 0.405088, 0.0 0.589041))")
Crop/mask the image with the polygon and shift it to the right or top
a <- crop(x, p, mask=TRUE)
r <- res(x)
b <- shift(a, 1, 0)
Remove the area from the original and merge
y <- mask(x, p, inverse=TRUE)
z <- merge(b, y)
Set RGB channels again and plot (here using base-plot)
RGB(z) <- 1:3
plot(z)
If you want to do this all within ggplot, perhaps it is just as easy to select which pixels you want to move and move them. For the curves you have drawn, the pixels are bounded by simple quadratic curves, so you could do:
cat_rast <- rast(cat_url)
cat_df = as.data.frame(cat_rast, xy = TRUE)
names(cat_df) <- c('x', 'y', 'R', 'G', 'B')
shift1 <- cat_df$y < 0.5 * (abs(cat_df$x-0.1))^1.8 + 0.45 &
cat_df$y > cat_df$x^2 + 0.25
shift2 <- cat_df$y < (cat_df$x + 0.2)^4 - 0.2 &
cat_df$y < (cat_df$x - 1.5)^4 - 0.2
cat_df$x[shift1] <- cat_df$x[shift1] + 1
cat_df$y[shift2] <- cat_df$y[shift2] + 1
ggplot(data = cat_df, aes(x, y, fill = R)) +
geom_raster() +
coord_fixed(xlim = c(0, 1.5), ylim = c(0, 1.5))
The goal is: Write and test a function that draws a triangle with coordinates by default(100,100); (200,100); (150,200). Using the control parameters, implement the movement of the point that defines one of the corners of the triangle, left-right, up-down. If I understood the problem correctly, with the change in the position of the point, the position of the other points remains unchanged. I tried to write(I leave my code below):
triangle <- function(p1, p2, p3, x.l=0, x.r=0,x.d=0,x.u=0) {
#move the point left-right
p1[1]<-p1[1]+x.l
p2[1]<-p2[1]+x.r
#moving the point up and down
p1[2]<-p1[2]+x.u
p2[2]<-p2[2]-x.d
x <- c(p1[1]:p2[1])
y.up <- 0 #the upper part of the triangle
for (i in x) {
#we calculate the value of y on the left side-according to the formula of a straight line passing through 2 given points
if (i <= p3[1]) {
y.up[i] <- p1[2] + (p3[2] - p1[2]) / (p3[1] - p1[1]) * (i - p1[1])
}
#----------we count the values of y on the right side
if (i > p3[1]) {
y.up[i] <- p2[2] + (p3[2] - p2[2]) / (p3[1] - p2[1]) * (i - p2[1])
}
}
y.up <- y.up[p1[1]:length(y.up)]
#draw the upper part of the triangle
plot(
x = x,
y = y.up,
type = 'l',
col = 'red',
lwd = 2
)
#lower part
y.bottom <- rep(p1[2], length(x))
lines(
x = x,
y = y.bottom,
type = 'l',
col = 'red',
lwd = 2
)
}
#checking the function operation
p1 <- c(100, 100)
p2 <- c(200, 100)
p3 <- c(150, 200)
triangle(p1, p2, p3, x.l=0, x.r=0,x.u=0,x.d=0)
Unfortunately, as a result, my triangle shape disappears and some kind of broken line is obtained. What is the reason for this?
I'm trying to connect every point in my array with all other points in this array using line segment and write some text slightly above this lines. So, I want to achieve next:
I already tried to use segments() and lines() functions, but I don't know how can I do exactly what I described.
And as I said, now I have only array of coordinates and array of strings which I want to write.
How can I achieve this(It will be good if I will need to use only standard R libraries)?
UPD:
dataset.csv:
,A,B,C
A,0,1,2
B,1,0,3
C,2,3,0
script.r:
myDataset <- read.csv("dataset.csv")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
Here's an example that uses combn to generate combinations of two points and then draw lines between them and to compute distances and write them in the middle too.
#DATA
set.seed(42)
df = data.frame(x = rnorm(4), y = rnorm(4))
#DRAW POINTS
plot(df)
#DRAW LINES
combn(1:NROW(df), 2, function(x)
lines(df[x,]), simplify = FALSE)
#WRITE TEXT
combn(1:NROW(df), 2, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = round(dist(df[x,]), 2), #calculate distance to write
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
UPDATE
myDataset <- read.csv(strip.white = TRUE, stringsAsFactors = FALSE, header = TRUE, text = ",A,B,C
A,0,1,2
B,1,0,3
C,2,3,0")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
df = data.frame(x, y)
#DRAW POINTS
plot(df, asp = 1)
text(x = df[,1], y = df[,2], labels = rownames(df), pos = 1)
#Create a list of combination of indices
temp = combn(1:NROW(df), 2, simplify = FALSE)
#DRAW LINES
sapply(temp, function(i) lines(df[i,]))
#WRITE TEXT
sapply(temp, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = myDataset[cbind(which(row.names(myDataset) == row.names(df)[x[1]]),
which(colnames(myDataset) == row.names(df)[x[2]]))],
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
Trying to achieve this with graphics primitives (such as lines) is bound to be a pain.
Use a dedicated library for graph plotting instead, e.g. ggraph. The “Edges” vignette has an example with edge labels:
ggraph(simple, layout = 'graphopt') +
geom_edge_link(aes(label = type),
angle_calc = 'along',
label_dodge = unit(2.5, 'mm'),
arrow = arrow(length = unit(4, 'mm')),
end_cap = circle(3, 'mm')) +
geom_node_point(size = 5)
The one drawback: ggraph doesn’t allow you to explicitly set the node positions; however, you can manipulate them manually.
TL;DR: What is the most efficient way to crop a rectangular image to a circle?
Explanation/Background:
I'm working on some code in R that will display Spotify artist images as circles instead of the default rectanges/squares. I couldn't find any packages or commands that crop images in R, especially to a circle, so I wrote my own function, circ, which reads 3-Dimensional (or 4-Dimensional) RGB(A) arrays and crops them to a circle using the parametric equation of a circle to determine the x values for every unique y. Here's my psuedocode:
Given an RGB(A) array:
Find the center of the image, radius = min(x coord, y coord)
Pre-crop the image to a square of dimensions 2r x 2r
For every unique y value:
Determine the x coordinates on the circle
Make pixels outside of the circle transparent
Return the cropped image as an RGBA array
This function is a tremendous improvement over my previous one, which checked the position of every pixel to see if it was inside or outside of the circle, but I still feel like it could be sped up further.
Is there a way I could check maybe half of the y-values instead of all of them, and mirror across the circle? Is there an actual cropping function I could use instead? Any and all help is much appreciated!
Edited to add some copy-paste-run code (thanks #lukeA):
My original cropping method:
circ = function(a){
# First part of the function finds the radius of the circle and crops the image accordingly
xc = floor(dim(a[,,1])[2]/2) # X coordinate of the center
yc = floor(dim(a[,,1])[1]/2) # Y coordinate of the center
r = min(xc, yc) - 1 # Radius is the smaller of the two -1 to avoid reading nonexistent data
ma = array(data = c(a[,,1][(yc-r):(yc+r),(xc-r):(xc+r)], # Read in the cropped image
a[,,2][(yc-r):(yc+r),(xc-r):(xc+r)], # Of dimensions 2r x 2r, centered
a[,,3][(yc-r):(yc+r),(xc-r):(xc+r)], # Around (xc, yc)
rep(1,length(a[,,1][(yc-r):(yc+r),(xc-r):(xc+r)]))), # Add fourth alpha layer
dim = c(length((yc-r):(yc+r)),length((xc-r):(xc+r)),4))
if(yc > xc) yc = xc else if(xc > yc) xc = yc # Re-evaluate your center for the cropped image
xmax = dim(ma[,,1])[2]; ymax = dim(ma[,,1])[1] # Find maximum x and y values
# Second part of the function traces circle by the parametric eqn. and makes outside pixels transparent
for(y in 1:ymax){ # For every y in the cropped image
theta = asin((y - yc) / r) # y = yc + r * sin(theta) by parametric equation for a circle
x = xc + r * cos(theta) # Then we can find the exact x coordinate using the same formula
x = which.min(abs(1:xmax - x)) # Find which x in array is closest to exact coordinate
if(!x - xc == 0 && !xmax - x == 0){ # If you're not at the "corners" of the circle
ma[,,4][y,c(1:(xmax-x), (x+1):xmax)] = 0 # Make pixels on either side of the circle trans.
} else if(!xmax - x == 0) ma[,,4][y,] = 0 # This line makes tops/bottoms transparent
}
return(ma)
}
library(jpeg)
a = readJPEG("http://1.bp.blogspot.com/-KYvXCEvK9T4/Uyv8xyDQnTI/AAAAAAAAHFY/swaAHLS-ql0/s1600/pink-smiley-face-balls-laughing-HD-image-for-faacebook-sharing.jpg")
par(bg = "grey"); plot(1:2, type="n") # Color background to check transparency
rasterImage(circ(a),1,1,2,2)
Modified version (thanks #dww):
dwwcirc = function(a){
# First part of the function finds the radius of the circle and crops the image accordingly
xc = floor(dim(a[,,1])[2]/2) # X coordinate of the center
yc = floor(dim(a[,,1])[1]/2) # Y coordinate of the center
r = min(xc, yc) - 1 # Radius is the smaller of the two -1 to avoid reading nonexistent data
ma = array(data = c(a[,,1][(yc-r):(yc+r),(xc-r):(xc+r)], # Read in the cropped image
a[,,2][(yc-r):(yc+r),(xc-r):(xc+r)], # Of dimensions 2r x 2r, centered
a[,,3][(yc-r):(yc+r),(xc-r):(xc+r)], # Around (xc, yc)
rep(1,length(a[,,1][(yc-r):(yc+r),(xc-r):(xc+r)]))), # Add fourth alpha layer
dim = c(length((yc-r):(yc+r)),length((xc-r):(xc+r)),4))
if(yc > xc) yc = xc else if(xc > yc) xc = yc # Re-evaluate your center for the cropped image
xmax = dim(ma[,,1])[2]; ymax = dim(ma[,,1])[1] # Find maximum x and y values
x = rep(1:xmax, ymax) # Vector containing all x values
y = rep(1:ymax, each=xmax) # Value containing all y values
r2 = r^2
ma[,,4][which(( (x-xc)^2 + (y-yc)^2 ) > r2)] = 0
return(ma)
}
library(jpeg)
a = readJPEG("http://1.bp.blogspot.com/-KYvXCEvK9T4/Uyv8xyDQnTI/AAAAAAAAHFY/swaAHLS-ql0/s1600/pink-smiley-face-balls-laughing-HD-image-for-faacebook-sharing.jpg")
par(bg = "grey"); plot(1:2, type="n") # Color background to check transparency
rasterImage(dwwcirc(a),1,1,2,2)
Version using magick and plotrix (thanks #lukeA and #hrbrmstr):
library(plotrix)
jpeg(tf <- tempfile(fileext = "jpeg"), 1000, 1000)
par(mar = rep(0,4), yaxs="i", xaxs = "i")
plot(0, type = "n", ylim = c(0, 1), xlim = c(0,1), axes=F, xlab=NA, ylab=NA)
draw.circle(.5,.5,.5,col="black")
dev.off()
library(magick)
img = image_read("http://1.bp.blogspot.com/-KYvXCEvK9T4/Uyv8xyDQnTI/AAAAAAAAHFY/swaAHLS-ql0/s1600/pink-smiley-face-balls-laughing-HD-image-for-faacebook-sharing.jpg")
mask = image_read(tf)
radius = min(c(image_info(img)$width, image_info(img)$height))
mask = image_scale(mask, as.character(radius))
par(bg = "grey"); plot(1:2, type="n")
rasterImage(as.raster(image_composite(image = mask, composite_image = img, operator = "plus")),1,1,2,2)
I dunno about "efficiency", but I would not reinvent the wheel here. Like suggested in the comments by #hrbrmstr, you may wanna try magick, which gives you all the flexibility you might need:
png(tf <- tempfile(fileext = ".png"), 1000, 1000)
par(mar = rep(0,4), yaxs="i", xaxs="i")
plot(0, type = "n", ylim = c(0,1), xlim=c(0,1), axes=F, xlab=NA, ylab=NA)
plotrix::draw.circle(.5,0.5,.5, col="black")
dev.off()
library(magick)
fn <- "https://www.gravatar.com/avatar/f57aba01c52e5c67696817eb87df84f2?s=328&d=identicon&r=PG&f=1"
img <- image_read(fn)
mask <- image_read(tf)
mask <- image_scale(mask, as.character(image_info(img)$width))
Now
img
mask
image_composite(mask, img, "plus")
image_composite(mask, img, "minus")
Some other composite operators:
# https://www.imagemagick.org/Magick++/Enumerations.html#CompositeOperator
ops <- c("over", "in", "out", "atop", "xor", "plus", "minus", "add", "difference", "multiply")
for (op in ops) {
print(image_composite(img, mask, op))
print(op)
readline()
}
You can improve the performance of your circ function if you do a vectorised subset-assign operation on your array (instead of looping) using the the fact that (x-xc)^2 +(y-yc)^2 > r^2 for points outside a circle.
To do this, replace the 2nd part of your function with
# Second part of the function traces circle by...
x = rep(1:xmax, ymax)
y = rep(1:ymax, each=xmax)
r2 = r^2
ma[,,4][which(( (x-xc)^2 + (y-yc)^2 ) > r2)] <- 0
return(ma)
I've been working on a rather complicated chart in R. I have a wireframe with a surface and points distributed in X,Y,Z space all over (e.g. under the surface and over it).
The problem is that the points that plot don't "look" like they are underneath the surface.
I am trying to figure out how best to visualize this chart to make the points look under the surface. Some sample code for the wireframe & cloud come from here: R-List Posting
The code in an example:
library(lattice)
surf <-
expand.grid(x = seq(-pi, pi, length = 50),
y = seq(-pi, pi, length = 50))
surf$z <-
with(surf, {
d <- 3 * sqrt(x^2 + y^2)
exp(-0.02 * d^2) * sin(d)
})
g <- surf
pts <- data.frame(x =rbind(2,2,2), y=rbind(-2,-2,-2), z=rbind(.5,0,-.5))
wireframe(z ~ x * y, g, aspect = c(1, .5),
drape=TRUE,
scales = list(arrows = FALSE),
pts = pts,
panel.3d.wireframe =
function(x, y, z,
xlim, ylim, zlim,
xlim.scaled, ylim.scaled, zlim.scaled,
pts,
...) {
panel.3dwire(x = x, y = y, z = z,
xlim = xlim,
ylim = ylim,
zlim = zlim,
xlim.scaled = xlim.scaled,
ylim.scaled = ylim.scaled,
zlim.scaled = zlim.scaled,
...)
xx <-
xlim.scaled[1] + diff(xlim.scaled) *
(pts$x - xlim[1]) / diff(xlim)
yy <-
ylim.scaled[1] + diff(ylim.scaled) *
(pts$y - ylim[1]) / diff(ylim)
zz <-
zlim.scaled[1] + diff(zlim.scaled) *
(pts$z - zlim[1]) / diff(zlim)
panel.3dscatter(x = xx,
y = yy,
z = zz,
xlim = xlim,
ylim = ylim,
zlim = zlim,
xlim.scaled = xlim.scaled,
ylim.scaled = ylim.scaled,
zlim.scaled = zlim.scaled,
...)
})
Looking at my example, the points in pts are in actually in vertical line where X,Y =(2,-2) and the z goes from .5 to -.5.
However, to my eye the third point doesn't look like it is under the surface, to it looks like it is at coordinates(2,-3,0).
Is this just my eye mis-interpreting this ?
Does anyone have a suggestion on how to make my points look more "3D" ? Perhaps muting the color of the point to make it look "under the surface" by using some sort of transparency on the surface ?
I tried making the colors of the points different (red for over the surface, blue for under the surface) but that does not really help the graph much.
This might get you started:
library(emdbook)
sfun <- function(x,y) {
d <- 3 * sqrt(x^2 + y^2)
exp(-0.02 * d^2) * sin(d)
}
cc <- curve3d(sfun(x,y),xlim=c(-pi,pi),ylim=c(-pi,pi),n=c(50,50),
sys3d="rgl")
colvec <- colorRampPalette(c("pink","white","lightblue"))(100)
with(cc,persp3d(x,y,z,col=colvec[cut(z,100)],alpha=0.5))
pts <- data.frame(x=c(2,2,2), y=c(-2,-2,-2), z=c(.5,0,-.5))
with(pts,spheres3d(x,y,z,col="blue",radius=0.1))
rgl.snapshot("rgltmp1.png")