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.
Related
I've been trying to create a combination of radar/polar chart of a given vector of polygon vertices, without packages, but just with base R, which I really struggle with. So far, with some help, I have reached the following point:
a <- a <- abs(rnorm(5, mean = 4, sd = 2))
names(a) <- LETTERS[1:5]
stars(matrix(a,nrow=1),axes=TRUE, scale=FALSE,col.lines="blue",radius=FALSE)
center <- c(x=2.1, y=2.1) #the starchart for some reason chooses this as a center
half <- seq(0, pi, length.out = 51)
angle=45
for (D in a) {
Xs <- D * cos(half); Ys <- D * sin(half)
lines(center["x"] + Xs, center["y"] + Ys, col = "gray", xpd = NA, lty="dashed")
lines(center["x"] + Xs, center["y"] - Ys, col = "gray", xpd = NA, lty="dashed")
}
which gives me something this:
What I would need to take further is:
center this mixed radar/polar chart at (0,0) and mark the center
color the polygon area transparently
add radii starting from the outermost circle and reaching the center through the polygon vertices
put the vector name labels on the ends of the radii on the outermost circle
So, the final result should look something like this:
I have experimented with the polygon(), symbols() functions and par() graphic parametres, but I am really struggling to combine them...My problem is that I don't understand how the stars() function plot coordinates selection relates to my input.
Did not liked the stars functions... so I made a full rondabout with polygon:
polar_chart <- function(values){
k <- length(values)
m <- max(values)
# initialise plot
plot(1, type="n", xlab="", ylab="", xlim=1.2*m*c(-1,1), ylim=1.2*m*c(-1,1))
# radial lines & letters
sapply(k:1, function(x){
text(1.1*m*cos(-(x-1)*2*pi/k + 2*pi/3), 1.1*m*sin(-(x-1)*2*pi/k + 2*pi/3),
LETTERS[x], cex = 0.75)
lines(c(0, m*cos((x-1)*2*pi/k + 2*pi/3)), c(0, m*sin((x-1)*2*pi/k + 2*pi/3)),
col = "grey",lty="dashed")
})
# circles
aux <- seq(2*pi + 0.1, 0, -0.1)
sapply(values, function(x) lines(x*cos(aux), x*sin(aux), col = "grey",lty="dashed"))
# polygon
x <- values*cos(-(1:k-1)*2*pi/k + 2*pi/3)
y <- values*sin(-(1:k-1)*2*pi/k + 2*pi/3)
polygon(c(x, x[1]),c(y, y[1]), col = "red", border = "blue", density = 50)
}
values <- abs(rnorm(5, mean = 4, sd = 2))
polar_chart(values)
And returns a plot like the following:
I made this image in powerpoint to illustrate what I am trying to do:
I am trying to make a series of circles (each of which are the same size) that "move" along the x-axis in consistent intervals; for instance, the center of each consecutive circle would be 2 points away from the previous circle.
I have tried several things, including the DrawCircle function from the DescTools package, but cant produce this. For example, here I am trying to draw 20 circles, where the center of each circle is 2 points away from the previous, and each circle has a radius of 2 (which doesnt work)
library(DescTools)
plotdat <- data.frame(xcords = seq(1,50, by = 2.5), ycords = rep(4,20))
Canvas()
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, radius = 2)
How can this be done in R?
This is basically #Peter's answer but with modifications. Your approach was fine but there is no radius= argument in DrawCircle. See the manual page ?DrawCircle for the arguments:
dev.new(width=12, height=4)
Canvas(xlim = c(0,50), ylim=c(2, 6), asp=1, xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
But your example has axes:
plot(NA, xlim = c(0,50), ylim=c(2, 6), xlab="", ylab="", yaxt="n", asp=1, xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
My solution requires the creation of some auxiliary functions
library(tidyverse)
##First function: create circle with a predefined radius, and a x-shift and y-shift
create_circle <- function(radius,x_shift, y_shift){
p <- tibble(
x = radius*cos(seq(0,2*pi, length.out = 1000)) + x_shift ,
y = radius*sin(seq(0,2*pi, length.out = 1000))+ y_shift
)
return(p)
}
##Use lapply to create circles with multiple x shifts:
##Group is only necessary for plotting
l <- lapply(seq(0,40, by = 2), function(i){
create_circle(2,i,0) %>%
mutate(group = i)
})
##Bind rows and plot
bind_rows(l) %>%
ggplot(aes(x = x, y = y, group =group)) +
geom_path()
Does this do the trick?
library(DescTools)
plotdat <- data.frame(xcords = seq(1, 5, length.out = 20), ycords = rep(4,20))
Canvas(xlim = c(0, 5), xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
I've assumed when you say circle centres are 2 points apart you mean 0.2 units apart.
You may have to experiment with the values to get what you need.
I found many resources on how to draw Venn diagrams in R. Stack Overflow has a lot of them. However, I still can't draw my diagrams the way I want. Take the following code as an example:
library("VennDiagram")
A <- 1:4
B <- 3:6
d <- list(A, B)
vp <- venn.diagram(d, fill = c("white", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp)
I want the intersection between the sets to be red. However, if I change any of the white colors to red, I get the following:
vp_red <- venn.diagram(d, fill = c("red", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_red)
That's not quite what I want. I want only the intersection to be red. If I change the alpha, this is what I get:
vp_alpha <- venn.diagram(d, fill = c("red", "white"), alpha = 0.5, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_alpha)
Now I have pink in my intersection. This is not what I want as well. What I want is something like this image from Wikipedia:
How can I do this? Maybe VennDiagram package can't do it and I need some other package, but I've been testing different ways to do it, and I'm not being able to find a solution.
I will show two different possibilities. In the first example, polyclip::polyclip is used to get the intersection. In the second example, circles are converted to sp::SpatialPolygons and we get the intersection using rgeos::gIntersection. Then we re-plot the circles and fill the intersecting area.
The resulting object when using venn.diagram is
"of class gList containing the grid objects that make up the diagram"
Thus, in both cases we can grab relevant data from "vp". First, check the structure and list the grobs of the object:
str(vp)
grid.ls()
# GRID.polygon.234
# GRID.polygon.235
# GRID.polygon.236 <~~ these are the empty circles
# GRID.polygon.237 <~~ $ col : chr "black"; $ fill: chr "transparent"
# GRID.text.238 <~~ labels
# GRID.text.239
# GRID.text.240
# GRID.text.241
# GRID.text.242
1. polyclip
Grab x- and y-values, and put them in the format required for polyclip:
A <- list(list(x = as.vector(vp[[3]][[1]]), y = as.vector(vp[[3]][[2]])))
B <- list(list(x = as.vector(vp[[4]][[1]]), y = as.vector(vp[[4]][[2]])))
Find intersection:
library(polyclip)
AintB <- polyclip(A, B)
Grab labels:
ix <- sapply(vp, function(x) grepl("text", x$name, fixed = TRUE))
labs <- do.call(rbind.data.frame, lapply(vp[ix], `[`, c("x", "y", "label")))
Plot it!
plot(c(0, 1), c(0, 1), type = "n", axes = FALSE, xlab = "", ylab = "")
polygon(A[[1]])
polygon(B[[1]])
polygon(AintB[[1]], col = "red")
text(x = labs$x, y = labs$y, labels = labs$label)
2. SpatialPolygons and gIntersection
Grab the coordinates of the circles:
# grab x- and y-values from first circle
x1 <- vp[[3]][["x"]]
y1 <- vp[[3]][["y"]]
# grab x- and y-values from second circle
x2 <- vp[[4]][["x"]]
y2 <- vp[[4]][["y"]]
Convert points to SpatialPolygons and find their intersection:
library(sp)
library(rgeos)
p1 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x1, y1))), ID = 1)))
p2 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x2, y2))), ID = 2)))
ip <- gIntersection(p1, p2)
Plot it!
# plot circles
plot(p1, xlim = range(c(x1, x2)), ylim = range(c(y1, y2)))
plot(p2, add = TRUE)
# plot intersection
plot(ip, add = TRUE, col = "red")
# add labels (see above)
text(x = labs$x, y = labs$y, labels = labs$label)
I'm quite sure you could work directly on the grobs using clipping functions in grid or gridSVG package.
It's very easy in eulerr R package
library(eulerr)
plot(euler(c("A"=5,"B"=4,"A&B"=2)),quantities = TRUE,fills=c("white","white","red"))
euler set colours
Does anyone know of a way to 1) complete the missing gridlines in the grid3d call for y, and 2) draw horizontal gridlines to close the top of the grids constructed by the grid3d calls for x and y? I've played around with various combinations of pretty calls within grid3d to no avail and am wondering if this is an rgl quirk or a misspecification on my part. Additionally, I'd like to extend the vertical axis numbering to wherever the closed grids end up.
library(rgl)
cpts <- seq(0, 2, length = 40)
spts <- seq(0, 1, length = 20)
grid <- expand.grid(s=spts, c=cpts)
UFn <- function(s,c){c^(0.5) - exp(s) + 1}
U <- UFn(grid$s, grid$c)
open3d()
rgl.surface(x = spts, y = matrix(U,nrow = 40, ncol = 20), z = cpts,
coords = c(1,3,2), specular = "black")
axes3d("x", at = pretty(spts, n = 2), color = "black")
axes3d("y", at = pretty(cpts, n = 5), color = "black")
axes3d("z--", color = "black")
grid3d("x")
grid3d("y", at = pretty(spts, n = 2))
title3d(xlab ='s', ylab = 'c', zlab = 'U', color = "black")
rgl.snapshot("3d.png")
I would say it is a bug. You don't get any z-lines when using grid3d("y",n=2) even though it should be the same. You can work around it by using the list specification of at, setting the x element of the list, eg:
grid3d("y", at = list(x=pretty(spts, n = 2)))
I am producing a color density scatterplot in R using the smoothScatter() function.
Example:
## A largish data set
n <- 10000
x1 <- matrix(rnorm(n), ncol = 2)
x2 <- matrix(rnorm(n, mean = 3, sd = 1.5), ncol = 2)
x <- rbind(x1, x2)
oldpar <- par(mfrow = c(2, 2))
smoothScatter(x, nrpoints = 0)
Output:
The issue I am having is that I am unsure how to add a legend/color scale that describes the relative difference in numeric terms between different shades. For example, there is no way to tell whether the darkest blue in the figure above is 2 times, 10 times or 100 times as dense as the lightest blue without some sort of legend or color scale. Is there any way in R to retrieve the requisite information to make such a scale, or anything built in that can produce a color scale of this nature automatically?
Here is an answer that relies on fields::imageplot and some fiddling with par(mar) to get the margins correct
fudgeit <- function(){
xm <- get('xm', envir = parent.frame(1))
ym <- get('ym', envir = parent.frame(1))
z <- get('dens', envir = parent.frame(1))
colramp <- get('colramp', parent.frame(1))
fields::image.plot(xm,ym,z, col = colramp(256), legend.only = T, add =F)
}
par(mar = c(5,4,4,5) + .1)
smoothScatter(x, nrpoints = 0, postPlotHook = fudgeit)
You can fiddle around with image.plot to get what you want and look at ?bkde2D and the transformation argument to smoothScatter to get an idea of what the colours represent.