I have a plot where I draw arrows from points to points. I would like to put this arrow heads not to the end of the line, but to middle. Is there a simple way to do it other than placing extra arrows with half length of the according line?
My code is this:
plot(x, y, xlim=range(x), ylim=range(y), xlab="x", ylab="y", pch=16,
main="Filled Plane")
for(i in 1:20){
arrows(x[i], y[i], x[i+1], y[i+1], length = 0.25, angle = 30, col = i)
}
Make a custom function myArrow() and add one new argument cut to control the proportion of the arrows
myArrow <- function(x0, y0, x1, y1, cut = 1, ...){
x.new <- (1 - cut) * x0 + cut * x1
y.new <- (1 - cut) * y0 + cut * y1
# segments(x0, y0, x1, y1, ...)
arrows(x0, y0, x.new, y.new, ...)
}
Note1 : The computation of x.new and y.new in this custom function uses a simple mathematical concept, i.e. the Section Formula. The value of cut must be between 0 to 1.
Note2 : The use of this function is equivalent to that of the original functionarrows() other than that it has one more new argument cut.
Note3 : If you want complete lines behind the arrows, just remove the hash(#) in the function.
Plot and try different cut value. For example, I use cut = 0.7. (If you want the arrowheads to the middle, use cut = 0.5.)
# Toy Data
x <- seq(1, 5.5, by = 0.5)
y <- rep(c(1, 5), 5)
plot(x, y, pch = 16)
for(i in 1:9){
myArrow(x[i], y[i], x[i+1], y[i+1], cut = 0.7, col = i, lwd = 2)
}
Since you do not provide your x and y, I made up some data. There is no need for the loop. arrows will handle a vector of coordinates. One way is to draw a full-length arrow with no arrowhead and another that just goes halfway but has the arrowhead.
## Some bogus data
set.seed(123)
x = runif(4)
y = runif(4)
## Compute the midpoints
midx = diff(x)/2 + x[-length(x)]
midy = diff(y)/2 + y[-length(y)]
## Draw it
plot(x,y,xlim=range(x), ylim=range(y), xlab="x", ylab="y",
main="Filled Plane",pch=16)
arrows(x[-length(x)], y[-length(y)],x[-1],y[-1],
angle = 0, col = 1:3)
arrows(x[-length(x)], y[-length(y)],midx,midy,
length = 0.25, angle = 30, col = 1:3)
I am trying to visualize a curve for pollination distribution. I am very new to R so please don't be upset by my stupidity.
llim <- 0
ulim <- 6.29
f <- function(x,y) {(.156812/((2*pi)*(.000005^2)*(gamma(2/.156812)))*exp(-((sqrt(x^2+y^2))/.000005)^.156812))}
integrate(function(y) {
sapply(y, function(y) {
integrate(function(x) f(x,y), llim, ulim)$value
})
}, llim, ulim)
fv <- Vectorize(f)
curve(fv, from=0, to=1000)
And I get:
Error in y^2 : 'y' is missing
I'm not quite sure what you're asking to plot. But I know you want to visualise your scalar function of two arguments.
Here are some approaches. First we define your function.
llim <- 0
ulim <- 6.29
f <- function(x,y) {
(.156812/((2*pi)*(.000005^2)*(gamma(2/.156812)))*exp(-((sqrt(x^2+y^2))/.000005)^.156812))
}
From your title I thought of the following. The function defined below intf integrates your function over the square [0,ul] x [0,ul] and return the value. We then vectorise and plot the integral over the square as a function the length of the side of the square.
intf <- function(ul) {
integrate(function(y) {
sapply(y, function(y) {
integrate(function(x) f(x,y), 0, ul)$value
})
}, 0, ul)$value
}
fv <- Vectorize(intf)
curve(fv, from=0, to=1000)
If f is a distribution, I guess you can make your (somewhat) nice probability interpretation of this curve. (I.e. ~20 % probability of pollination(?) in the 200 by 200 meter square.)
However, you can also do a contour plot (of the log-transformed values) which illustrate the function we are integrating above:
logf <- function(x, y) log(f(x, y))
x <- y <- seq(llim, ulim, length.out = 100)
contour(x, y, outer(x, y, logf), lwd = 2, drawlabels = FALSE)
You can also plot some profiles of the surface:
plot(1, xlim = c(llim, ulim), ylim = c(0, 0.005), xlab = "x", ylab = "f")
y <- seq(llim, ulim, length.out = 6)
for (i in seq_along(y)) {
tmp <- function(x) f(x, y = y[i])
curve(tmp, llim, ulim, add = TRUE, col = i)
}
legend("topright", lty = 1, col = seq_along(y),
legend = as.expression(paste("y = ",y)))
They need to be modified a bit to make them publication worthy, but you get the idea. Lastly, you can do some 3d plots as others have suggested.
EDIT
As per your comments, you can also do something like this:
# Define the function times radius (this time with general a and b)
# The default of a and b is as before
g <- function(z, a = 5e-6, b = .156812) {
z * (b/(2*pi*a^2*gamma(2/b)))*exp(-(z/a)^b)
}
# A function that integrates g from 0 to Z and rotates
# As g is not dependent on the angle we just multiply by 2pi
intg <- function(Z, ...) {
2*pi*integrate(g, 0, Z, ...)$value
}
# Vectorize the Z argument of intg
gv <- Vectorize(intg, "Z")
# Plot
Z <- seq(0, 1000, length.out = 100)
plot(Z, gv(Z), type = "l", lwd = 2)
lines(Z, gv(Z, a = 5e-5), col = "blue", lwd = 2)
lines(Z, gv(Z, b = .150), col = "red", lwd = 2)
lines(Z, gv(Z, a = 1e-4, b = .2), col = "orange", lwd = 2)
You can then plot the curves for the a and b you want. If either is not specified, the default is used.
Disclaimer: my calculus is rusty and I just did off this top of my head. You should verify that I've done the rotation of the function around the axis properly.
The lattice package has several functions that can help you draw 3 dimensional plots, including wireframe() and persp(). If you prefer not to use a 3d-plot, you can create a contour plot using contour().
Note: I don't know if this is intentional, but your data produces a very large spike in one corner of the plot. This produces a plot that is for all intents flat, with a barely noticable spike in one corner. This is particularly problematic with the contour plot below.
library(lattice)
x <- seq(0, 1000, length.out = 50)
y <- seq(0, 1000, length.out = 50)
First the wire frame plot:
df <- expand.grid(x=x, y=y)
df$z <- with(df, f(x, y))
wireframe(z ~ x * y, data = df)
Next the perspective plot:
dm <- outer(x, y, FUN=f)
persp(x, y, dm)
The contour plot:
contour(x, y, dm)
I was searching for a way to plot this function as a scalar field, in particular as continuous scalar field:
library(rgl)
points = seq(-2, 0, length=20)
XY = expand.grid(X=points,Y=-points)
Zf <- function(X,Y){
X^2-Y^2;
}
Z <- Zf(XY$X, XY$Y)
open3d()
rgl.surface(x=points, y=matrix(Z,20), coords=c(1,3,2),z=-points)
axes3d()
A scalar field is usually plotted with two axis X and Y, where Z is represent by a colour( http://en.wikipedia.org/wiki/Scalar_field)
With ggplot() I can do this:
daf=data.frame(XY$X,XY$Y,Z)
ggplot(daf)+geom_point(aes(XY.X,XY.Y,color=Z))
But still not a continuous field.
This can be achieved by the 'image' function:
Z <- outer(points, points, Zf)
image(points, points, Z)
This method just uses nearest neighbor interpolation, but if you want a smoother representation, you can use other types of interpolation:
library(fields)
# Bilinear interpolation
interp_points = seq(-2, 0, length = 200)
interp_bilinear <- interp.surface(list(x = X, y = Y, z = Z),
loc = expand.grid(interp_points, interp_points))
image(interp_points, interp_points, matrix(interp_bilinear, 200, 200))
# Bicubic interpolation
library(akima)
interp_bicubic <- bicubic.grid(X, Y, Z, xlim = c(-2, 0), ylim = c(-2, 0),
dx = 2 / (200 - 1), dy = 2 / (200 - 1))
image(interp_bicubic)
The difference between different interpolation schemes becomes clearer when you have fewer observations or more wildly behaving functions:
I want to plot the results from a six factor personality test as a circumplex.
The test in question is the Allgemeiner Interessen-Struktur-Test (AIST-R; Bergmann & Eder, 2005) [General Interest Structure Test], which measures vocational choice based on the theory of J. L. Holland (Holland codes, RIASEC). You can use the answers below to plot the "Felddarstellung" [field representation] recommended in the manual in stead of the interest profile to better visualize the vector of differentiation.
The resulting graphic should look similar to this:
The test results are given as angles and lengths.
How can I draw an axis or geometric vector in R from a starting point with a specific length, without defining the end coordinates (as required by arrows)?
How can I add tickmarks to such a vector?
How can I define the points of a polygon (here in grey) in a similar manner, i.e. by providing an angle and a distance from the origin, instead of coordinates)?
I can of course calculate the endpoints, but I would like to avoid this. Also, I wouldn't know how to add tick marks to an arrow.
My attempts that did not work:
par(pin = c(4, 4))
plot(0, 0, type = "n", xlim = c(-60, 60), ylim = c(-60, 60))
symbols(c(0, 0, 0), c(0, 0, 0), circles = c(60, 1.5, 1.5), inches = FALSE, add = TRUE, fg = c("black", "black", "white"), bg = c("transparent", "#000000", "transparent"))
arrows(0, 0, length = c(60, 60, 60, 60, 60, 60), angle = c(0, 60, 120, 180, 240, 300))
The following uses base functions and a couple of functions that we define ourselves.
While you requested a method that doesn't require calculating coordinates of segments' end points, I think this is impossible. However, we can define a simple helper function that uses some basic trigonometry to calculate the coordinates given the angle (clockwise from the positive y-axis) and the segment length. We do this below, as well as defining a function that plots a rotated axis.
get.coords <- function(a, d, x0, y0) {
a <- ifelse(a <= 90, 90 - a, 450 - a)
data.frame(x = x0 + d * cos(a / 180 * pi),
y = y0+ d * sin(a / 180 * pi))
}
rotatedAxis <- function(x0, y0, a, d, symmetrical=FALSE, tickdist, ticklen, ...) {
if(isTRUE(symmetrical)) {
axends <- get.coords(c(a, a + 180), d, x0, y0)
tick.d <- c(seq(0, d, tickdist), seq(-tickdist, -d, -tickdist))
} else {
axends <- rbind(get.coords(a, d, x0, y0), c(x0, y0))
tick.d <- seq(0, d, tickdist)
}
invisible(lapply(apply(get.coords(a, d=tick.d, x0, y0), 1, function(x) {
get.coords(a + 90, c(-ticklen, ticklen), x[1], x[2])
}), function(x) lines(x$x, x$y, ...)))
lines(axends$x, axends$y, ...)
}
get.coords takes arguments a (a vector of angles), d (a vector of segment lengths), and x0 and y0, the coordinates of the known point. Vectors a and d are recycled as necessary. The function returns a data.frame with elements x and y giving the coordinates corresponding to each angle/length pair.
rotatedAxis plots an axis between x0, y0 and the point d units away along the line at angle a. If symmetrical is TRUE, the axis extends d units in opposite directions. Tick marks, of height ticklen are plotted tickdist units apart.
Plotting of the circle uses get.coords to calculate coordinates along the circumference, and plots the line connecting these with polygon (inspired by #timriffe).
Below we use these functions to replicate the plot provided by the OP.
# Set up plotting device
plot.new()
plot.window(xlim=c(-70, 70), ylim=c(-70, 70), asp=1)
# Plot circle with radius = 60 units and centre at the origin.
polygon(get.coords(seq(0, 360, length.out=1000), 60, 0, 0), lwd=2)
# Plot a polygon with vertices along six axes, at distances of 17, 34, 44, 40,
# 35, and 10 units from the centre.
poly.pts <- get.coords(seq(0, 300, 60), c(17, 34, 44, 40, 35, 10), 0, 0)
polygon(poly.pts$x, poly.pts$y, col='gray', lwd=2)
# Plot the rotated axes
rotatedAxis(0, 0, a=60, d=60, symmetrical=TRUE, tickdist=10, ticklen=1)
rotatedAxis(0, 0, a=120, d=60, symmetrical=TRUE, tickdist=10, ticklen=1)
rotatedAxis(0, 0, a=180, d=60, symmetrical=TRUE, tickdist=10, ticklen=1)
# Add text labels to circumference
text.coords <- get.coords(seq(0, 300, 60), 65, 0, 0)
text(text.coords$x, text.coords$y, c('I', 'A', 'S', 'E', 'C', 'R'))
# Plot a second point and connect to centre by a line
point2 <- get.coords(145, 50, 0, 0)
points(point2, pch=20, cex=2)
segments(0, 0, point2$x, point2$y, lwd=3)
# Plot central point
points(0, 0, pch=21, bg=1, col=0, lwd=2, cex=2)
(Edit: I heavily edited this post - without changing it's general message drastically - in order to make it easier to read and more generally applicable. Additions/changes include that I now define a function to plot rotated axes, plot the circle by calculating coordinates of vertices along the circumference and plotting with polygon, as inspired by #timriffe.)
A solution based on the comment by Thomas and the answer by jbaums.
I used jbaums' method to draw the axes, because I did not want the unbroken circular grid provided by plotrix.
I did not use jbaums' method to draw the circle, because that has a wavy/bumpy line.
I call par(new = TRUE) twice, because the scale in jbaums answer is a tenth of the true scale and I couldn't figure out how to adjust that.
I manually placed the lables, which I'm not happy with.
There's also a lot of superfluous code in there, but I left it in case someone wants to use it to work on their own version.
Here's the code:
# test results
R <- 95
I <- 93
A <- 121
S <- 111
E <- 114
C <- 80
dimensions <- c("R", "I", "A", "S", "E", "C")
values <- c(R, I, A, S, E, C)
RIASEC <- data.frame(
"standard.values" = values,
"RIASEC" = dimensions
)
person.typ <- paste(
head(
RIASEC[
with(
RIASEC,
order(-standard.values)
),
]$RIASEC,
3
),
collapse = ""
)
# length of vector
vi1 <- 0
vi2 <- I
va1 <- 0.8660254 * A
va2 <- 0.5 * A
vs1 <- 0.8660254 * S
vs2 <- -0.5 * S
ve1 <- 0
ve2 <- -E
vc1 <- -0.8660254 * C
vc2 <- -0.5 * C
vr1 <- -0.8660254 * R
vr2 <- 0.5 * R
vek1 <- va1 + vi1 + vr1 + vc1 + ve1 + vs1 # x-axix
vek2 <- vr2 + vi2 + va2 + vs2 + ve2 + vc2 # y-axis
vektor <- sqrt(vek1^2 + vek2^2) # vector length
# angle of vector
if (vek1 == 0) {tg <- 0} else {tg <- vek2 / vek1}
wink <- atan(tg) * 180 / pi
if (vek1 > 0) {
winkel <- 90 - wink
} else if (vek1 == 0) {
if (vek2 >= 0) {winkel <- 360}
else if (vek2 < 0) {winkel <- 180}
} else if (vek1 < 0) {
if (vek2 <= 0) {winkel <- 270 - wink}
else if (vek2 >= 0) {winkel <- 270 - wink}
}
library(plotrix)
axis.angle <- c(0, 60, 120, 180, 240, 300)
axis.rad <- axis.angle * pi / 180
value.length <- values - 70
dev.new(width = 5, height = 5)
radial.plot(value.length, axis.rad, labels = dimensions, start = pi-pi/6, clockwise=TRUE,
rp.type="p", poly.col = "grey", show.grid = TRUE, grid.col = "transparent", radial.lim = c(0,60))
radial.plot.labels(value.length + c(4, 2, -2, 1, 1, 4), axis.rad, radial.lim = c(0,60), start = pi-pi/6, clockwise = TRUE, labels = values, pos = c(1,2,3,1,2,1))
get.coords <- function(a, d, x0=0, y0=0) {
a <- ifelse(a <= 90, 90 - a, 450 - a)
data.frame(x = x0 + d * cos(a / 180 * pi), y = y0+ d * sin(a / 180 * pi) )
}
par(new = TRUE)
plot(NA, xlim = c(-6, 6), ylim=c(-6, 6), type='n', xlab='', ylab='', asp = 1,
axes=FALSE, new = FALSE, bg = "transparent")
circumf.pts <- get.coords(seq(60, 360, 60), 6)
segments(circumf.pts$x[1:3], circumf.pts$y[1:3],
circumf.pts$x[4:6], circumf.pts$y[4:6])
ticks.locs <- lapply(seq(60, 360, 60), get.coords, d=1:6)
ticks <- c(apply(do.call(rbind, ticks.locs[c(1, 4)]), 1, function(x)
get.coords(150, c(-0.1, 0.1), x[1], x[2])),
apply(do.call(rbind, ticks.locs[c(2, 5)]), 1, function(x)
get.coords(30, c(-0.1, 0.1), x[1], x[2])),
apply(do.call(rbind, ticks.locs[c(3, 6)]), 1, function(x)
get.coords(90, c(-0.1, 0.1), x[1], x[2])))
lapply(ticks, function(x) segments(x$x[1], x$y[1], x$x[2], x$y[2]))
par(new = TRUE)
plot(NA, xlim = c(-60, 60), ylim=c(-60, 60), type='n', xlab='', ylab='', asp = 1,
axes=FALSE, new = FALSE, bg = "transparent")
segments(0, 0, vek1, vek2, lwd=3)
points(vek1, vek2, pch=20, cex=2)
symbols(c(0, 0, 0), c(0, 0, 0), circles = c(60, 2, 1.3), inches = FALSE, add = TRUE, fg = c("black", "white", "black"), bg = c("transparent", "white", "black"))
And here's the graphic: