Add labels to the center of a geom_curve line (ggplot) - r

Is there any way to add a label on or near the center of a geom_curve line? Currently, I can only do so by labeling either the start or end point of the curve.
library(tidyverse)
library(ggrepel)
df <- data.frame(x1 = 1, y1 = 1, x2 = 2, y2 = 3, details = "Object Name")
ggplot(df, aes(x = x1, y = y1, label = details)) +
geom_point(size = 4) +
geom_point(aes(x = x2, y = y2),
pch = 17, size = 4) +
geom_curve(aes(x = x1, y = y1, xend = x2, yend = y2)) +
geom_label(nudge_y = 0.05) +
geom_label_repel(box.padding = 2)
I would love some way to automatically label the curve near coordinates x=1.75, y=1.5. Is there a solution out there I haven't seen yet? My intended graph is quite busy, and labeling the origin points makes it harder to see what's happening, while labeling the arcs would make a cleaner output.

I've come to a solution for this problem. It's large and clunky, but effective.
The core problem is that geom_curve() does not draw a set path, but it moves and scales with the aspect ratio of the plot window. So short of locking the aspect ratio with coord_fixed(ratio=1) there is no way I can easily find to predict where the midpoint of a geom_curve() segment will be.
So instead I set about finding midpoint for a curve, and then forcing the curve to go through that point which I would later label. To find the midpoint I had to copy two functions from the grid package:
library(grid)
library(tidyverse)
library(ggrepel)
# Find origin of rotation
# Rotate around that origin
calcControlPoints <- function(x1, y1, x2, y2, curvature, angle, ncp,
debug=FALSE) {
# Negative curvature means curve to the left
# Positive curvature means curve to the right
# Special case curvature = 0 (straight line) has been handled
xm <- (x1 + x2)/2
ym <- (y1 + y2)/2
dx <- x2 - x1
dy <- y2 - y1
slope <- dy/dx
# Calculate "corner" of region to produce control points in
# (depends on 'angle', which MUST lie between 0 and 180)
# Find by rotating start point by angle around mid point
if (is.null(angle)) {
# Calculate angle automatically
angle <- ifelse(slope < 0,
2*atan(abs(slope)),
2*atan(1/slope))
} else {
angle <- angle/180*pi
}
sina <- sin(angle)
cosa <- cos(angle)
# FIXME: special case of vertical or horizontal line ?
cornerx <- xm + (x1 - xm)*cosa - (y1 - ym)*sina
cornery <- ym + (y1 - ym)*cosa + (x1 - xm)*sina
# Debugging
if (debug) {
grid.points(cornerx, cornery, default.units="inches",
pch=16, size=unit(3, "mm"),
gp=gpar(col="grey"))
}
# Calculate angle to rotate region by to align it with x/y axes
beta <- -atan((cornery - y1)/(cornerx - x1))
sinb <- sin(beta)
cosb <- cos(beta)
# Rotate end point about start point to align region with x/y axes
newx2 <- x1 + dx*cosb - dy*sinb
newy2 <- y1 + dy*cosb + dx*sinb
# Calculate x-scale factor to make region "square"
# FIXME: special case of vertical or horizontal line ?
scalex <- (newy2 - y1)/(newx2 - x1)
# Scale end points to make region "square"
newx1 <- x1*scalex
newx2 <- newx2*scalex
# Calculate the origin in the "square" region
# (for rotating start point to produce control points)
# (depends on 'curvature')
# 'origin' calculated from 'curvature'
ratio <- 2*(sin(atan(curvature))^2)
origin <- curvature - curvature/ratio
# 'hand' also calculated from 'curvature'
if (curvature > 0)
hand <- "right"
else
hand <- "left"
oxy <- calcOrigin(newx1, y1, newx2, newy2, origin, hand)
ox <- oxy$x
oy <- oxy$y
# Calculate control points
# Direction of rotation depends on 'hand'
dir <- switch(hand,
left=-1,
right=1)
# Angle of rotation depends on location of origin
maxtheta <- pi + sign(origin*dir)*2*atan(abs(origin))
theta <- seq(0, dir*maxtheta,
dir*maxtheta/(ncp + 1))[c(-1, -(ncp + 2))]
costheta <- cos(theta)
sintheta <- sin(theta)
# May have BOTH multiple end points AND multiple
# control points to generate (per set of end points)
# Generate consecutive sets of control points by performing
# matrix multiplication
cpx <- ox + ((newx1 - ox) %*% t(costheta)) -
((y1 - oy) %*% t(sintheta))
cpy <- oy + ((y1 - oy) %*% t(costheta)) +
((newx1 - ox) %*% t(sintheta))
# Reverse transformations (scaling and rotation) to
# produce control points in the original space
cpx <- cpx/scalex
sinnb <- sin(-beta)
cosnb <- cos(-beta)
finalcpx <- x1 + (cpx - x1)*cosnb - (cpy - y1)*sinnb
finalcpy <- y1 + (cpy - y1)*cosnb + (cpx - x1)*sinnb
# Debugging
if (debug) {
ox <- ox/scalex
fox <- x1 + (ox - x1)*cosnb - (oy - y1)*sinnb
foy <- y1 + (oy - y1)*cosnb + (ox - x1)*sinnb
grid.points(fox, foy, default.units="inches",
pch=16, size=unit(1, "mm"),
gp=gpar(col="grey"))
grid.circle(fox, foy, sqrt((ox - x1)^2 + (oy - y1)^2),
default.units="inches",
gp=gpar(col="grey"))
}
list(x=as.numeric(t(finalcpx)), y=as.numeric(t(finalcpy)))
}
calcOrigin <- function(x1, y1, x2, y2, origin, hand) {
# Positive origin means origin to the "right"
# Negative origin means origin to the "left"
xm <- (x1 + x2)/2
ym <- (y1 + y2)/2
dx <- x2 - x1
dy <- y2 - y1
slope <- dy/dx
oslope <- -1/slope
# The origin is a point somewhere along the line between
# the end points, rotated by 90 (or -90) degrees
# Two special cases:
# If slope is non-finite then the end points lie on a vertical line, so
# the origin lies along a horizontal line (oslope = 0)
# If oslope is non-finite then the end points lie on a horizontal line,
# so the origin lies along a vertical line (oslope = Inf)
tmpox <- ifelse(!is.finite(slope),
xm,
ifelse(!is.finite(oslope),
xm + origin*(x2 - x1)/2,
xm + origin*(x2 - x1)/2))
tmpoy <- ifelse(!is.finite(slope),
ym + origin*(y2 - y1)/2,
ifelse(!is.finite(oslope),
ym,
ym + origin*(y2 - y1)/2))
# ALWAYS rotate by -90 about midpoint between end points
# Actually no need for "hand" because "origin" also
# encodes direction
# sintheta <- switch(hand, left=-1, right=1)
sintheta <- -1
ox <- xm - (tmpoy - ym)*sintheta
oy <- ym + (tmpox - xm)*sintheta
list(x=ox, y=oy)
}
With that in place, I calculated a midpoint for each record
df <- data.frame(x1 = 1, y1 = 1, x2 = 10, y2 = 10, details = "Object Name")
df_mid <- df %>%
mutate(midx = calcControlPoints(x1, y1, x2, y2,
angle = 130,
curvature = 0.5,
ncp = 1)$x) %>%
mutate(midy = calcControlPoints(x1, y1, x2, y2,
angle = 130,
curvature = 0.5,
ncp = 1)$y)
I then make the graph, but draw two separate curves. One from the origin to the calculated midpoint, and another from the midpoint to the destination. The angle and curvature settings for both finding the midpoint and drawing these curves are tricky to keep the result from obviously looking like two different curves.
ggplot(df_mid, aes(x = x1, y = y1)) +
geom_point(size = 4) +
geom_point(aes(x = x2, y = y2),
pch = 17, size = 4) +
geom_curve(aes(x = x1, y = y1, xend = midx, yend = midy),
curvature = 0.25, angle = 135) +
geom_curve(aes(x = midx, y = midy, xend = x2, yend = y2),
curvature = 0.25, angle = 45) +
geom_label_repel(aes(x = midx, y = midy, label = details),
box.padding = 4,
nudge_x = 0.5,
nudge_y = -2)
Though the answer isn't ideal or elegant, it scales with a large number of records.

Maybe annotations would help here (see: http://ggplot2.tidyverse.org/reference/annotate.html)
library(tidyverse)
library(ggrepel)
df <- data.frame(x1 = 1, y1 = 1, x2 = 2, y2 = 3, details = "Object Name")
ggplot(df, aes(x = x1, y = y1, label = details)) +
geom_point(size = 4) +
geom_point(aes(x = x2, y = y2),
pch = 17, size = 4) +
geom_curve(aes(x = x1, y = y1, xend = x2, yend = y2)) +
geom_label(nudge_y = 0.05) +
geom_label_repel(box.padding = 2) +
annotate("label", x=1.75, y=1.5, label=df$details)

Related

How to automate plotting 3 different regular polygons recursively?

I want to plot 3 regular polygons - squares (4 sides), hexagons (6 sides) and dodecagons (12 sides) in a way that it produces a similar plot to the following figure:
So far, I have been hardcoding with the ggforce package to achieve my goal:
library(ggplot2)
library(ggforce)
df = data.frame(name = c("dodecagon", "square", "hexagon"),
x0 = c(0.5, 0.5, 0.63),
y0 = c(0.5, 0.745, 0.74),
sides = c(12, 4, 6),
angle = c(0, 0, -0.5),
r = c(0.2, 0.07, 0.09))
ggplot(data = df) +
geom_regon(aes(x0 = x0, y0 = y0, sides = sides, angle = angle, r = r, fill = name)) +
coord_fixed(xlim = c(0, 1), ylim = c(0, 1))
which produces:
As you can see, the polygons are not nicely aligned and it would take unreasonably long to actually achieve what I want to achieve.
Essentially, I would like to have a function which takes the number of dodecagons (12 sided polygon) as its argument and plots squares (4 sided polygon) and hexagons (6 sided polygon) around the dodecagon(s).
P.S. it does not have to be done using ggforce, but I would prefer to eventually have a ggplot2 plot.
I'm not sure what the easy way is to do this, but let me show you the hard way. First, define a function that produces a data frame of the co-ordinates of a regular dodecagon, given its centre co-ordinates and its radius (i.e. the radius of the circle on which its vertices sit):
dodecagon <- function(x = 0, y = 0, r = 1) {
theta <- seq(pi/12, 24 * pi/12, pi/6)
data.frame(x = x + r * cos(theta), y = y + r * sin(theta))
}
Now define functions which take the co-ordinates of a line segment and return a data frame of x, y co-ordinates representing a square and a hexagon:
square <- function(x1, x2, y1, y2) {
theta <- atan2(y2 - y1, x2 - x1) + pi/2
r <- sqrt((x2 - x1)^2 + (y2 - y1)^2)
data.frame(x = c(x1, x2, x2 + r * cos(theta), x1 + r * cos(theta), x1),
y = c(y1, y2, y2 + r * sin(theta), y1 + r * sin(theta), y1))
}
hexagon <- function(x1, x2, y1, y2) {
theta <- atan2(y2 - y1, x2 - x1)
r <- sqrt((x2 - x1)^2 + (y2 - y1)^2)
data.frame(x = c(x1, x2, x2 + r * cos(theta + pi / 3),
x2 + r * cos(theta + pi / 3) + r * cos(theta + 2 * pi / 3),
x1 + r * cos(theta + 2 * pi / 3) + r * cos(theta + pi / 3),
x1 + r * cos(theta + 2 * pi / 3),
x1),
y = c(y1, y2, y2 + r * sin(theta + pi / 3),
y2 + r * sin(theta + pi / 3) + r * sin(theta + 2 * pi / 3),
y1 + r * sin(theta + 2 * pi / 3) + r * sin(theta + pi / 3),
y1 + r * sin(theta + 2 * pi / 3),
y1))
}
Finally, write a function that co-ordinates the first 3 to return a single data frame of all the co-ordinates, labelled by shape type and with a unique number for each polygon:
pattern <- function(x = 0, y = 0, r = 1) {
d <- cbind(dodecagon(x, y, r), shape = "dodecagon", part = 0)
squares <- lapply(list(1:2, 3:4, 5:6, 7:8, 9:10, 11:12),
function(i) {
cbind(
square(d$x[i[2]], d$x[i[1]], d$y[i[2]], d$y[i[1]]),
shape = "square", part = i[2]/2)
})
hexagons <- lapply(list(2:3, 4:5, 6:7, 8:9, 10:11, c(12, 1)),
function(i) {
cbind(
hexagon(d$x[i[2]], d$x[i[1]], d$y[i[2]], d$y[i[1]]),
shape = "hexagon", part = i[1]/2 + 6)
})
rbind(d, do.call(rbind, squares), do.call(rbind, hexagons))
}
All that done, plotting is trivial:
library(ggplot2)
ggplot(data = pattern(), aes(x, y, fill = shape, group = part)) +
geom_polygon() +
coord_equal()
Or, reproducing your original figure:
ggplot(data = pattern(), aes(x, y, fill = shape, group = part)) +
geom_polygon() +
geom_polygon(data = pattern(2.111, 1.22)) +
geom_polygon(data = pattern(0, 2.44)) +
scale_fill_manual(values = c("#3d9af6", "#c4c4c4", "black")) +
coord_equal() +
theme_void() +
theme(panel.background = element_rect(fill = "#f5f5f5", color = NA))

ggplot2 doesn't plot all the points

I am trying to make a graph in ggplot2 of 7 points in the shape of a circle, but trying to graph them only shows me 6 and I don't know why this happens.
The code is the following:
# Function for the points
circleFun <- function(center = c(-1, 1), diameter = 1, npoints = 7) {
r <- diameter / 2
tt <- seq(0, 2 * pi, length.out = npoints)
xx <- center[1] + r * cos(tt)
yy <- center[2] + r * sin(tt)
return(data.frame(x = xx, y = yy))
}
# example with 7 points
ej <-
circleFun(diameter = 50, center = c(50,50), npoints = 7)
# plot
ej |>
ggplot(aes(x = x, y = y)) +
geom_point(alpha = 0.4) +
theme_bw()
Does anyone know why this happens?
Rows 1 and 7 are identical, so their points are overlapped. The dot is a bit darker (per your alpha = 0.4). You can make this obvious by adding x = jitter(x) (For demonstration, not that you'd do that in production). I'm not sure what you're expecting to see given the identical data.
If you want 7 distinct points, then I suggest you create n+1 and remove the last (or first) point.
circleFun <- function(center = c(-1, 1), diameter = 1, npoints = 7) {
r <- diameter / 2
tt <- seq(0, 2 * pi, length.out = npoints + 1) # changed
xx <- center[1] + r * cos(tt)
yy <- center[2] + r * sin(tt)
data.frame(x = xx, y = yy)[-1,,drop = FALSE] # changed
}
## unchanged from here on
ej <-
circleFun(diameter = 50, center = c(50,50), npoints = 7)
ej |>
ggplot(aes(x = x, y = y)) +
geom_point(alpha = 0.4) +
theme_bw()
(BTW, there is no need for an explicit call to return(.), especially when it is the only end-point of the function and "obvious" based on data flow. It certainly doesn't hurt, but it adds one step on the call stack that adds no value. It may be declarative/self-documenting, and as such this is a style/subjective point.)

Mean distance of the points from a fixed target point

I have some points in my data and I am trying to find the mean (arithmetic mean) distance to a target point.
I am taking two routes here:
One, using the 'Distance Between Two Points' formula to compute the distance between each point to the target and then getting a mean distance of those distance values.
Other, find the mean point of all points and then find the distance between this mean point and the target point.
I am not sure which approach is correct (both give different answers) if I want to get the average distance of all points to a target point?
My target point is in green and mean point is in red.
Following is my R code:
# three data points
a <- c(1.6, 2.3, 3.4)
b <- c(3.1, 4.1, 0.5)
# target point
t_x <- 1.1
t_y <- 0.1
df <- data.frame("x" = a, "y" = b)
# mean of the distances
df$distance <- sqrt(((df$x - t_x)^2) + ((df$y - t_y)^2))
print(mean(df$distance))
# distance from the mean point to the target
mean_x <- mean(df$x)
mean_y <- mean(df$y)
print(sqrt((mean_x - t_x)^2 + (mean_y - t_y)^2))
# plotting all
ggplot(df, aes(x = x, y = y)) +
geom_point() +
coord_cartesian(xlim = c(-5,5), ylim = c(-5,5)) +
geom_point(aes(x=mean_x, y=mean_y), color = "red") +
geom_point(aes(x=t_x, y=t_y), color = "green")
Just consider the case with one target point and two other points
Target: (0,0)
Point1: (-1,0)
Point2: (1, 0)
If you take the average of Points 1 and 2, you get (0,0) so the average distance to the target is 0. But the distance from each of the points to the target is 1 so the mean distance in 1. In general these two calcuations are quite different
It really just comes down to how you define the problem. In this example, do you expect the answer to be 0 or 1.
Here's an intuitive explanation of why your first method is the correct one. Imagine your target is at (0, 0):
t_x <- 0
t_y <- 0
Now suppose we draw some points around it that are all the same distance from it - in fact, they all lie on the unit circle and by definition are a distance of 1 from the target:
library(ggplot2)
t_x <- 0
t_y <- 0
rads <- seq(0, 2 * pi, length.out = 17)[-17]
df <- data.frame(x = cos(rads), y = sin(rads), xend = 0, yend = 0)
ggplot(df, aes(x, y)) +
geom_point(col = "red") +
geom_segment(aes(xend = xend, yend = yend), linetype = 2) +
coord_equal() +
geom_point(x = t_x, y = t_y, size = 5, colour = "red")
Now, not surprisingly, since all points are distance 1 from the target, the average distance by Pythagoras will also be 1:
# mean of the distances
df$distance <- sqrt(((df$x - t_x)^2) + ((df$y - t_y)^2))
print(mean(df$distance))
#> [1] 1
But now consider what happens if we take the average of all our x values - they cancel to 0. So do the y values, so the average of all points is (0, 0). When you measure the distance from (0, 0) to (0, 0), the answer, of course, is 0:
mean_x <- mean(df$x)
mean_y <- mean(df$y)
print(sqrt((mean_x - t_x)^2 + (mean_y - t_y)^2))
#> [1] 0
Created on 2020-08-22 by the reprex package (v0.3.0)

Add segments of circles to ggplot based on product of x & y

I want to add shaded areas to a chart to help people understand where bad, ok, and good points can fit.
Good = x*y>=.66
Ok = x*y>=.34
Bad = x*y<.34
Generating the right sequence of data to correctly apply the curved boundaries to the chart is proving tough.
What is the most elegant way to generate the curves?
Bonus Q: How would you do this to produce non-overlapping areas so that different colours could be used?
Updates
I've managed to do in a rather hacky way the drawing of the circle segments. I updated the MRE to use the revised segMaker function.
MRE
library(ggplot2)
pts<-seq(0,1,.02)
x<-sample(pts,50,replace=TRUE)
y<-sample(pts,50,replace=TRUE)
# What function will generate correct sequence of values as these are linear?
segMaker<-function(x,by){
# Original
# data.frame(x=c(seq(0,x,by),0)
# ,y=c(seq(x,0,-by),0)
# )
zero <- data.frame(x = 0, y = 0)
rs <- seq(0, pi, by)
xc <- x * cos(rs)
yc <- x * sin(rs)
gr <- data.frame(x = xc, y = yc)
gr <- rbind(gr[gr$x >= 0, ], zero)
return(gr)
}
firstSeg <-segMaker(.34,0.02)
secondSeg <-segMaker(.66,0.02)
thirdSeg <-segMaker(1,0.02)
ggplot(data.frame(x,y),aes(x,y, colour=x*y))+
geom_point() +
geom_polygon(data=firstSeg, fill="blue", alpha=.25)+
geom_polygon(data=secondSeg, fill="blue", alpha=.25)+
geom_polygon(data=thirdSeg, fill="blue", alpha=.25)
Current & desired shadings
You can create a data frame with the boundaries between each region and then use geom_ribbon to plot it. Here's an example using the conditions you supplied (which result in boundaries that are the reciprocal function, rather than circles, but the idea is the same, whichever function you use for the boundaries):
library(ggplot2)
# Fake data
pts<-seq(0,1,.02)
set.seed(19485)
x<-sample(pts,50,replace=TRUE)
y<-sample(pts,50,replace=TRUE)
df = data.frame(x,y)
# Region boundaries
x = seq(0.001,1.1,0.01)
bounds = data.frame(x, ymin=c(-100/x, 0.34/x, 0.66/x),
ymax=c(0.34/x, 0.66/x, 100/x),
g=rep(c("Bad","OK","Good"), each=length(x)))
bounds$g = factor(bounds$g, levels=c("Bad","OK","Good"))
ggplot() +
coord_cartesian(ylim=0:1, xlim=0:1) +
geom_ribbon(data=bounds, aes(x, ymin=ymin, ymax=ymax, fill=g), colour="grey50", lwd=0.2) +
geom_point(data=df, aes(x,y), colour="grey20") +
scale_fill_manual(values=hcl(c(15, 40, 240), 100, 80)) +
#scale_fill_manual(values=hcl(c(15, 40, 240), 100, 80, alpha=0.25)) + # If you want the fill colors to be transparent
labs(fill="") +
guides(fill=guide_legend(reverse=TRUE))
For circular boundaries, assuming we want boundaries at r=1/3 and r=2/3:
# Calculate y for circle, given r and x
cy = function(r, x) {sqrt(r^2 - x^2)}
n = 200
x = unlist(lapply(c(1/3,2/3,1), function(to) seq(0, to, len=n)))
bounds = data.frame(x, ymin = c(rep(0, n),
cy(1/3, seq(0, 1/3, len=n/2)), rep(0, n/2),
cy(2/3, seq(0, 2/3, len=2*n/3)), rep(0, n/3)),
ymax = c(cy(1/3, seq(0,1/3,len=n)),
cy(2/3, seq(0,2/3,len=n)),
rep(1,n)),
g=rep(c("Bad","OK","Good"), each=n))
bounds$g = factor(bounds$g, levels=c("Bad","OK","Good"))
If you can use a github package, ggforce adds geom_arc_bar():
# devtools::install_github('thomasp85/ggforce')
library(ggplot2)
library(ggforce)
pts<-seq(0,1,.02)
x<-sample(pts,50,replace=TRUE)
y<-sample(pts,50,replace=TRUE)
arcs <- data.frame(
x0 = 0,
y0 = 0,
start = 0,
end = pi / 2,
r0 = c(0, 1/3, 2/3),
r = c(1/3, 2/3, 1),
fill = c("bad", "ok", "good")
)
ggplot() +
geom_arc_bar(data = arcs,
aes(x0 = x0, y0 = y0, start = start, end = end, r0 = r0, r = r,
fill = fill), alpha = 0.6) +
geom_point(data = data.frame(x = x, y = y),
aes(x = x, y = y))
Based on #eipi10's great answer, to do the product component (basically ends up with the same thing) I did:
library(ggplot2)
library(data.table)
set.seed(19485)
pts <- seq(0, 1, .001)
x <- sample(pts, 50, replace = TRUE)
y <- sample(pts, 50, replace = TRUE)
df <- data.frame(x,y)
myRibbon<-CJ(pts,pts)
myRibbon[,prod:=V1 * V2]
myRibbon[,cat:=ifelse(prod<=1/3,"bad",
ifelse(prod<=2/3,"ok","good"))]
myRibbon<-myRibbon[
,.(ymin=min(V2),ymax=max(V2))
,.(cat,V1)]
ggplot() +
geom_ribbon(data=myRibbon
, aes(x=V1, ymin=ymin,ymax=ymax
, group=cat, fill=cat),
colour="grey90", lwd=0.2, alpha=.5)+
geom_point(data=df, aes(x,y), colour="grey20") +
theme_minimal()
This doesn't do anything fancy but works out for each value of x, what the smallest and largest values were that could give rise to a specific banding.
If I had just wanted arcs, the use of ggforce (#GregF) would be really great- it tucks away all the complexity.

Draw a polygon colored like this in R or Matlab

http://www.texample.net/tikz/examples/lindenmayer-systems/
My sample code shown below, I don't know how to colored with hue color.
plot.koch <- function(k,col="blue"){
plot(0,0,xlim=c(0,1), ylim=c(-sqrt(3)/6,sqrt(3)/2), asp = 1,type="n",xlab="", ylab="")
plotkoch <- function(x1,y1,x2,y2,n){
if (n > 1){
plotkoch(x1,y1,(2*x1+x2)/3,(2*y1+y2)/3,n-1);
plotkoch((2*x1+x2)/3,(2*y1+y2)/3,(x1+x2)/2-(y1-y2)*sqrt(3)/6,(y1+y2)/2-(x2-x1) *sqrt(3)/6,n-1);
plotkoch((x1+x2)/2-(y1-y2)*sqrt(3)/6,(y1+y2)/2-(x2-x1)*sqrt(3)/6,(2*x2+x1)/3,(2 *y2+y1)/3,n-1);
plotkoch((2*x2+x1)/3,(2*y2+y1)/3,x2,y2,n-1)
}
else {
x=c(x1,(2*x1+x2)/3,(x1+x2)/2-(y1-y2)*sqrt(3)/6,(2*x2+x1)/3,x2);
y=c(y1,(2*y1+y2)/3,(y1+y2)/2-(x2-x1)*sqrt(3)/6,(2*y2+y1)/3,y2);
polygon(x,y,type="l",col=col)
}
}
plotkoch(0,0,1,0,k)
plotkoch(0.5,sqrt(3)/2,0,0,k)
plotkoch(1,0,0.5,sqrt(3)/2,k)
}
plot.koch(3, col=3)
Here's a method using spatial objects in R, with sp, rgeos and raster packages in the mix.
Slight modifications to the function to return the x,y coordinates to the user (and in the correct order):
koch <- function(k) {
yy <- xx <- numeric(0)
Koch <- function(x1, y1, x2, y2, n) {
if (n > 1){
Koch(x1, y1, (2*x1+x2)/3, (2*y1+y2)/3, n-1);
Koch((2*x1+x2)/3, (2*y1+y2)/3, (x1+x2)/2-(y1-y2)*sqrt(3)/6,
(y1+y2)/2-(x2-x1) *sqrt(3)/6, n-1);
Koch((x1+x2)/2-(y1-y2)*sqrt(3)/6, (y1+y2)/2-(x2-x1)*sqrt(3)/6,
(2*x2+x1)/3, (2 *y2+y1)/3, n-1);
Koch((2*x2+x1)/3, (2*y2+y1)/3, x2, y2, n-1)
}
else {
x <- c(x1, (2*x1+x2)/3, (x1+x2)/2-(y1-y2)*sqrt(3)/6, (2*x2+x1)/3, x2);
xx <<- c(xx, x)
y <- c(y1, (2*y1+y2)/3, (y1+y2)/2-(x2-x1)*sqrt(3)/6, (2*y2+y1)/3, y2);
yy <<- c(yy, y)
}
}
Koch(0, 0, 1, 0, k)
Koch(1, 0, 0.5, sqrt(3)/2, k)
Koch(0.5, sqrt(3)/2, 0, 0, k)
xy <- data.frame(x=xx, y=yy)
rbind(unique(xy), xy[1, ])
}
Create a colour ramp:
colr <- colorRampPalette(hcl(h=seq(0, 360, len=100), c=100))
Use koch function to get vertices:
xy <- koch(4)
Load spatial packages and create SpatialPolygons object from fractal and plot it once to set up the plot area.
library(sp)
library(rgeos)
library(raster)
poly <- SpatialPolygons(list(Polygons(list(Polygon(xy)), 1)))
plot(poly)
Plot a series of segments with desired origin and large enough radius to cover the fractal polygon (here we use radius r <- 1).
r <- 1
mapply(function(theta, col) {
segments(0.5, 0.3, 0.5 + r*cos(theta), 0.3 + r*sin(theta), lwd=3, col=col)
}, seq(0, 360, length=1000)*pi/180, colr(1000))
Create a second polygon of the difference between the plot area and the fractal polygon, and plot this (with col='white') to mask out the unwanted gradient area.
plot(gDifference(as(extent(par('usr')), 'SpatialPolygons'), poly),
col='white', border='white', add=TRUE)
Plot the polygon once more.
plot(poly, add=TRUE)
Here's my attempt at solving your question. Currently it draws the color also outside of the snowflake. If you can figure out if points are inside or outside the snowflake, you should be able to just remove outside points in the df_fill.
Here I'm first creating the data.frame used for plotting the polygon. Then I'm creating the data.frame for the background color. And finally I'm using ggplot2 to plot the data.
# creating relevant data
data.koch <- function(k){
df <- data.frame(x = 0,
y = 0,
grp = 0)
plotkoch <- function(x1, y1, x2, y2, n, data){
if (n==1) {
x=c(x1,(2*x1+x2)/3,(x1+x2)/2-(y1-y2)*sqrt(3)/6,(2*x2+x1)/3,x2)
y=c(y1,(2*y1+y2)/3,(y1+y2)/2-(x2-x1)*sqrt(3)/6,(2*y2+y1)/3,y2)
df <- rbind(data, data.frame(x, y, grp=max(data$grp)+1))
}
if (n > 1){
df <- plotkoch(x1,y1,(2*x1+x2)/3,(2*y1+y2)/3,n-1, data = data)
df <- plotkoch((2*x1+x2)/3,(2*y1+y2)/3,(x1+x2)/2-(y1-y2)*sqrt(3)/6,(y1+y2)/2-(x2-x1) *sqrt(3)/6,n-1, data=df)
df <- plotkoch((x1+x2)/2-(y1-y2)*sqrt(3)/6,(y1+y2)/2-(x2-x1)*sqrt(3)/6,(2*x2+x1)/3,(2 *y2+y1)/3,n-1, data=df)
df <- plotkoch((2*x2+x1)/3,(2*y2+y1)/3,x2,y2,n-1, data=df)
}
return(df)
}
df <- plotkoch(0,0,1,0,k, data = df)
df <- plotkoch(0.5,sqrt(3)/2,0,0,k, data = df)
df <- plotkoch(1,0,0.5,sqrt(3)/2,k, data = df)
return(df)
}
# plotting functon
plot.koch <- function(k){
stopifnot(require(ggplot2))
if (is.data.frame(k)) df <- k
else df <- data.koch(k)
# filling data (CHANGE HERE TO GET ONLY INSIDE POINTS)
l <- 500
df_fill <- expand.grid(x=seq(0, 1, length=l),
y=seq(-sqrt(3)/6, sqrt(3)/2, length=l))
df_fill[, "z"] <- atan2(-df_fill[, "y"] + sqrt(3)/6, df_fill[, "x"] - 0.5) + pi/2
df_fill[df_fill[, "z"] < 0, "z"] <- df_fill[df_fill[, "z"] < 0, "z"] + 2*pi
# plotting
ggplot(df, aes(x, y, group=grp)) +
geom_raster(data = df_fill,
aes(fill=z, group=NULL),
hjust = 0,
vjust = 0,
linetype='blank') +
geom_path(data=df, size=1) +
scale_fill_gradientn(colours = rainbow(30), guide = 'none') +
scale_x_continuous(name = '', limits = c(0, 1), expand=c(0, 0)) +
scale_y_continuous(name = '', limits = c(-sqrt(3)/6,sqrt(3)/2), expand=c(0, 0)) +
coord_fixed() +
theme_bw() +
theme(axis.line = element_blank(),
panel.grid = element_blank(),
axis.ticks = element_blank(),
axis.text = element_blank())
}
#
p <- plot.koch(4)
print(p)
I would do it like this:
for any drawed pixel obtain its position x,y
compute the angle=atan2(y-y0,x-x0)
where x0,y0 is the koch's snowflake mid position
compute the color based on angle
if you use HSV then hue=angle and compute the target color value (I assume RGB). If you want the visible spectra colors you can try mine:
RGB values of visible spectrum
Just convert the angle range angle=<0,2*Pi> [rad] to wavelength l=<400,700> [nm] so:
l = 400.0 + (700.0-400.0)*angle/(2.0*M_PI)
render the pixel
[Notes]
not using R nor Matlab so you need to code it yourself. The angle may need some shifting to match your coordinate system for example:
const angle0=???; // some shift constant [rad]
angle+=angle0; // or angle=angle0-angle; if the direction is oposite
if (angle>=2.0*M_PI) angle-=2.0*M_PI;
if (angle< 0.0) angle+=2.0*M_PI;
If you drawing this as polygon then you need to compute color per vertex not per pixel but then you can get to problems because this is not convex polygon. So how to ensure the mid point color ??? I am afraid you will need to use some sort of triangulation because simple triangle fan will fail ...
The only thing that is obvious is to fill the color for whole space and then draw the outline with black color then flood fill all non black pixels from outside with white color
It's my solution with grid package.
##data
koch <- function(k) {
yy <- xx <- numeric(0)
Koch <- function(x1, y1, x2, y2, n) {
if (n > 1) {
Koch(x1, y1, (2 * x1 + x2)/3, (2 * y1 + y2)/3, n - 1)
Koch((2 * x1 + x2)/3, (2 * y1 + y2)/3, (x1 + x2)/2 - (y1 -
y2) * sqrt(3)/6, (y1 + y2)/2 - (x2 - x1) * sqrt(3)/6,
n - 1)
Koch((x1 + x2)/2 - (y1 - y2) * sqrt(3)/6, (y1 + y2)/2 -
(x2 - x1) * sqrt(3)/6, (2 * x2 + x1)/3, (2 * y2 + y1)/3,
n - 1)
Koch((2 * x2 + x1)/3, (2 * y2 + y1)/3, x2, y2, n - 1)
} else {
x <- c(x1, (2 * x1 + x2)/3, (x1 + x2)/2 - (y1 - y2) * sqrt(3)/6,
(2 * x2 + x1)/3, x2)
xx <<- c(xx, x)
y <- c(y1, (2 * y1 + y2)/3, (y1 + y2)/2 - (x2 - x1) * sqrt(3)/6,
(2 * y2 + y1)/3, y2)
yy <<- c(yy, y)
}
}
Koch(0, 0, 1, 0, k)
Koch(1, 0, 0.5, sqrt(3)/2, k)
Koch(0.5, sqrt(3)/2, 0, 0, k)
xy <- data.frame(x = (xx - min(xx))/(max(xx) - min(xx)), y = (yy -
min(yy))/(max(yy) - min(yy)))
rbind(unique(xy), xy[1, ])
}
xy <- koch(5)
##Plot
library(grid)
grid.newpage()
pushViewport(dataViewport(xy$x, xy$y), plotViewport(c(1, 1, 1, 1)))
for (i in 1:nrow(xy)) {
grid.path(x = c(xy[i, 1], xy[i + 1, 1], mean(xy$x)),
y = c(xy[i, 2], xy[i + 1, 2], mean(xy$y)),
gp = gpar(col = rainbow(nrow(xy))[i],
fill = rainbow(nrow(xy))[i]))
}

Resources