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)
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 have created a 3d sphere with rgl.spheres() using rgl, and plotted two point on the surface of the sphere. Does anyone know how to draw an arc between these two point?
You'll have to calculate points along the arc, and use lines3d to draw the curve. You might want to move the arc a little bit outside
the sphere to avoid problems if they intersect: neither one is really
spherical, so intersections are likely to look ugly.
For example,
r <- 1.3
center <- matrix(1:3, ncol=3)
library(rgl)
open3d()
spheres3d(center, radius = r, col = "white")
# A couple of random points
pts <- matrix(rnorm(6, mean=c(center, center)), ncol = 3)
# Set the radius to 1.001*r
setlen <- function(pt) {
center + 1.001*r*(pt - center)/sqrt(sum((pt - center)^2))
}
pts <- t(apply(pts, 1, setlen))
points3d(pts, col = "black")
# Now draw the arc
n <- 20
frac <- seq(0, 1, len = n)
arc <- matrix(0, ncol = 3, nrow = n)
for (i in seq_along(frac)) {
# First a segment
arc[i,] <- frac[i]*pts[1,] + (1-frac[i])*pts[2,]
# Now set the radius
arc[i,] <- setlen(arc[i,])
}
lines3d(arc, col = "red")
This produces
Edited to add:
The very latest version of rgl (0.100.5, only currently available on R-forge) has a new function arc3d. With that version the code to draw the image can be simplified to
library(rgl)
open3d()
spheres3d(center, radius = r, col = "white")
points3d(pts, col = "black")
arc3d(pts[1,], pts[2,], center, col = "red")
If the points are at different distances from center, it will join them
with an arc from a logarithmic spiral instead of a circular arc.
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")
I am new to R environment. I have generated a simulated time lapse plot using the following code.
seq_x<-seq(1,10)
seq_y<-function(y)
{
z<-y^2+y+1
return (c(z))
}
yrange<-seq_y(1)
yrange[2]<-seq_y(length(seq_x))
for(i in 1:length(seq_x) )
{
xdata<-seq_x[1:i]
ydata<-seq_y(xdata)
plot(xdata,ydata,xlim=range(seq_x),ylim=range(yrange),type="o",col="royalblue",plot.first=grid())
Sys.sleep(1)
}
I get the following plot(after the final iteration).
Now I need to plot a straight line and a circle right across the plot as shown below.
The straight line should grow with the data sequence. The circle should be at the center of the data sequence with user specified radius. Any advice in this regard will be highly appreciated.
Try this:
#draw circle
require(plotrix)
userRadius <- 1
draw.circle(median(xdata), median(ydata), userRadius)
#draw line
segments(x0=xdata[1],y0=ydata[1],
x1=xdata[length(xdata)],y1=ydata[length(ydata)])
You can use lines to add additional lines to your plot. Then you just have to calculate the points on the circle (or ellipsis) and you can draw both the extra line and the circle.
# data
x <- seq(1,10)
y <- x^2 + x + 1
# function to calculate points on the ellipsis
ellipsis_fct <- function(mx, my, rx, ry){
phi <- seq(0, 2*pi, length = 100) # change length if you need better resolution
data.frame(x = mx + rx*sin(phi),
y = my + ry*cos(phi))
}
# actually calculate the points.
circ <- ellipsis_fct(mean(range(x)), mean(range(y)), diff(range(x))/5, diff(range(y))/5)
# plotting commands
plot(x, y, xlim=range(x), ylim=range(y), type="o", col="royalblue", plot.first=grid())
lines(range(x), range(y), col = "darkred", lty = "dashed")
lines(circ, col = "orange")