Calculate 2d spline path in R, with customizable number of interpolation points - r

I'd like calculate (not plot) 2d spline paths in R. There's an old question on that topic that suggests xspline(): Calculate a 2D spline curve in R
xspline() somewhat works for my purpose, but has important limitations:
I cannot customize the number of interpolation points
I need to call plot.new(), even if I don't want it to draw anything
I only have a single parameter (shape) to customize the spline; I'd like to be able to try a few more different types, if possible
Reproducible example:
library(ggplot2)
# control points
x <- c(.1, .5, .7, .8)
y <- c(.9, .6, .5, .1)
plot.new() # necessary for xspline(); would be great if it could be avoided
# how do I set the number of interpolation points?
# how do I modify the exact path (beyond shape parameter)?
path <- xspline(x, y, shape = 1, draw = FALSE)
# plot path (black) and control points (blue) with ggplot
ggplot(data = NULL, aes(x, y)) +
geom_point(data = as.data.frame(path), size = 0.5) +
geom_point(data = data.frame(x, y), size = 2, color = "blue")
Created on 2021-08-14 by the reprex package (v2.0.0)
Are there any easily available alternatives to xspline()?

It's not clear from your example, but base R's spline function might meet your needs. We can wrap it in a function to make it easier to use the output:
f <- function(x, y, n, method = "natural") {
new_x <- seq(min(x), max(x), length.out = n)
data.frame(x = new_x, y = spline(x, y, n = n, method = method)$y)
}
So the co-ordinates for 10 evenly spaced points along the curve can be obtained like this:
f(x, y, 10)
#> x y
#> 1 0.1000000 0.9000000
#> 2 0.1777778 0.8042481
#> 3 0.2555556 0.7173182
#> 4 0.3333333 0.6480324
#> 5 0.4111111 0.6052126
#> 6 0.4888889 0.5976809
#> 7 0.5666667 0.6222222
#> 8 0.6444444 0.6013374
#> 9 0.7222222 0.4303155
#> 10 0.8000000 0.1000000
And we can show the shape of the curve like this:
ggplot(data = NULL, aes(x, y)) +
geom_point(data = f(x, y, 100), size = 0.5) +
geom_point(data = data.frame(x, y), size = 2, color = "blue")
You can change the method argument to get different shapes - the options are listed in ?spline
EDIT
To use spline on paths, simply create splines on x and y separately. These can be as a function of another variable t, or this can be left out if you want to assume equal time spacing on the path:
f2 <- function(x, y, t = seq_along(x), n, method = "natural") {
new_t <- seq(min(t), max(t), length.out = n)
new_x <- spline(t, x, xout = new_t, method = method)$y
new_y <- spline(t, y, xout = new_t, method = method)$y
data.frame(t = new_t, x = new_x, y = new_y)
}
x <- rnorm(10)
y <- rnorm(10)
ggplot(data = NULL, aes(x, y)) +
geom_point(data = f2(x, y, n = 1000), size = 0.5) +
geom_point(data = data.frame(x, y), size = 2, color = "blue")
Created on 2021-08-14 by the reprex package (v2.0.0)

The xsplinePoints()from the {grid} package allows you to convert a xsplineGrob object to xy coordinates. One solution might be to wrap these functions to return points along an x-spline.
library(grid)
splines <- function(x, y, shape = 1, ..., density = 1) {
# Density controls number of points, though not the exact number
xs <- xsplineGrob(x * density, y * density, shape = shape, ...,
default.units = "inches")
# xsplinePoints seem to always return inches
xy <- xsplinePoints(xs)
# Drop units
xy <- lapply(xy, convertUnit, unitTo = "inches", valueOnly = TRUE)
data.frame(x = xy$x / density, y = xy$y / density)
}
I presume xsplinePoints() makes some behind the scenes calculation based on the size of the graphics device where smaller devices need less points.
The idea behind the density parameter is to let you (indirectly) control how many points are returned by artifically inflating the dimensions before handing the data to grid, and then deflating before returning to the user.
To compare with your example:
library(ggplot2)
# control points
x <- c(.1, .5, .7, .8)
y <- c(.9, .6, .5, .1)
plot.new()
path <- xspline(x, y, shape = 1, draw = FALSE)
# plot path (black) and control points (blue) with ggplot
ggplot(data = NULL, aes(x, y)) +
geom_point(data = as.data.frame(path), size = 0.5) +
geom_point(data = data.frame(x, y), size = 2, color = "blue") +
# density = 1 (red) and density = 3 (green)
geom_point(data = splines(x, y), colour = "red") +
geom_point(data = splines(x, y, density = 3), colour = "green")
Created on 2021-08-14 by the reprex package (v1.0.0)

Related

Manually Set Scale of contour plot using geom_contour_filled

I would like manually adjust the scales of two contour plots such that each have the same scale even though they contain different ranges of values in the z-direction.
For instance, lets say that I want to make contour plots of z1 and z2:
x = 1:15
y = 1:15
z1 = x %*% t(y)
z2 = 50+1.5*(x %*% t(y))
data <- data.frame(
x = as.vector(col(z1)),
y = as.vector(row(z1)),
z1 = as.vector(z1),
z2 = as.vector(z2)
)
ggplot(data, aes(x, y, z = z1)) +
geom_contour_filled(bins = 8)
ggplot(data, aes(x, y, z = z2)) +
geom_contour_filled(bins = 8)
Is there a way I can manually adjust the scale of each plot such that each contain the same number of levels (in this case bins = 8), the minimum is the same for both (in this case min(z1)), and the max is the same for both (max(z2))?
One can manually define a vector of desired breaks points and then pass the vector to the "breaks" option in the geom_contour_filled() function.
In the below script, finds 8 break intervals between the grand minimum and the grand maximum of the dataset.
Also there are 2 functions defined to create the palette and label names for the legend.
#establish the min and max of scale
grandmin <- min(z1, z2)-1
grandmax <- max(z2, z2)
#define the number of breaks. In this case 8 +1
mybreaks <- seq(grandmin, ceiling(round(grandmax, 0)), length.out = 9)
#Function to return the dersired number of colors
mycolors<- function(x) {
colors<-colorRampPalette(c("darkblue", "yellow"))( 8 )
colors[1:x]
}
#Function to create labels for legend
breaklabel <- function(x){
labels<- paste0(mybreaks[1:8], "-", mybreaks[2:9])
labels[1:x]
}
ggplot(data, aes(x, y, z = z1)) +
geom_contour_filled(breaks= mybreaks, show.legend = TRUE) +
scale_fill_manual(palette=mycolors, values=breaklabel(8), name="Value", drop=FALSE) +
theme(legend.position = "right")
ggplot(data, aes(x, y, z = z2)) +
geom_contour_filled(breaks= mybreaks, show.legend = TRUE) +
scale_fill_manual(palette=mycolors, values=breaklabel(8), name="Value", drop=FALSE)

Draw line through 2d density plot

I have a large dataset of gene expression from ~10,000 patient samples (TCGA), and I'm plotting a predicted expression value (x) and the actual observed value (y) of a certain gene signature. For my downstream analysis, I need to draw a precise line through the plot and calculate different parameters in samples above/below the line.
No matter how I draw a line through the data (geom_smooth(method = 'lm', 'glm', 'gam', or 'loess')), the line always seems imperfect - it doesn't cut through the data to my liking (red line is lm in figure).
After playing around for a while, I realized that the 2d kernel density lines (geom_density2d) actually do a good job of showing the slope/trends of my data, so I manually drew a line that kind of cuts through the density lines (black line in figure).
My question: how can I automatically draw a line that cuts through the kernel density lines, as for the black line in the figure? (Rather than manually playing with different intercepts and slopes till something looks good).
The best approach I can think of is to somehow calculate intercept and slope of the longest diameter for each of the kernel lines, take an average of all those intercepts and slopes and plot that line, but that's a bit out of my league. Maybe someone here has experience with this and can help?
A more hacky approach may be getting the x,y coords of each kernel density line from ggplot_build, and going from there, but it feels too hacky (and is also out of my league).
Thanks!
EDIT: Changed a few details to make the figure/analysis easier. (Density lines are smoother now).
Reprex:
library(MASS)
set.seed(123)
samples <- 10000
r <- 0.9
data <- mvrnorm(n=samples, mu=c(0, 0), Sigma=matrix(c(2, r, r, 2), nrow=2))
x <- data[, 1] # standard normal (mu=0, sd=1)
y <- data[, 2] # standard normal (mu=0, sd=1)
test.df <- data.frame(x = x, y = y)
lm(y ~ x, test.df)
ggplot(test.df, aes(x, y)) +
geom_point(color = 'grey') +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = c(2,2)) + ### EDIT: h = c(2,2)
geom_smooth(method = "glm", se = F, lwd = 1, color = 'red') +
geom_abline(intercept = 0, slope = 0.7, lwd = 1, col = 'black') ## EDIT: slope to 0.7
Figure:
I generally agree with #Hack-R.
However, it was kind of a fun problem and looking into ggplot_build is not such a big deal.
require(dplyr)
require(ggplot2)
p <- ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = c(2,2))
#basic version of your plot
p_built <- ggplot_build(p)
p_data <- p_built$data[[1]]
p_maxring <- p_data[p_data[['level']] == min(p_data[['level']]),] %>%
select(x,y) # extracts the x/y coordinates of the points on the largest ellipse from your 2d-density contour
Now this answer helped me to find the points on this ellipse which are furthest apart.
coord_mean <- c(x = mean(p_maxring$x), y = mean(p_maxring$y))
p_maxring <- p_maxring %>%
mutate (mean_dev = sqrt((x - mean(x))^2 + (y - mean(y))^2)) #extra column specifying the distance of each point to the mean of those points
coord_farthest <- c('x' = p_maxring$x[which.max(p_maxring$mean_dev)], 'y' = p_maxring$y[which.max(p_maxring$mean_dev)])
# gives the coordinates of the point farthest away from the mean point
farthest_from_farthest <- sqrt((p_maxring$x - coord_farthest['x'])^2 + (p_maxring$y - coord_farthest['y'])^2)
#now this looks which of the points is the farthest from the point farthest from the mean point :D
coord_fff <- c('x' = p_maxring$x[which.max(farthest_from_farthest)], 'y' = p_maxring$y[which.max(farthest_from_farthest)])
ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = c(2,2)) +
# geom_segment using the coordinates of the points farthest apart
geom_segment((aes(x = coord_farthest['x'], y = coord_farthest['y'],
xend = coord_fff['x'], yend = coord_fff['y']))) +
geom_smooth(method = "glm", se = F, lwd = 1, color = 'red') +
# as per your request with your geom_smooth line
coord_equal()
coord_equal is super important, because otherwise you will get super weird results - it messed up my brain too. Because if the coordinates are not set equal, the line will seemingly not pass through the point furthest apart from the mean...
I leave it to you to build this into a function in order to automate it. Also, I'll leave it to you to calculate the y-intercept and slope from the two points
Tjebo's approach was kind of good initially, but after a close look, I found that it found the longest distance between two points on an ellipse. While this is close to what I wanted, it failed with either an irregular shape of the ellipse, or the sparsity of points in the ellipse. This is because it measured the longest distance between two points; whereas what I really wanted is the longest diameter of an ellipse; i.e.: the semi-major axis. See image below for examples/details.
Briefly:
To find/draw density contours of specific density/percentage:
R - How to find points within specific Contour
To get the longest diameter ("semi-major axis") of an ellipse:
https://stackoverflow.com/a/18278767/3579613
For function that returns intercept and slope (as in OP), see last piece of code.
The two pieces of code and images below compare two Tjebo's approach vs. my new approach based on the above posts.
#### Reprex from OP
require(dplyr)
require(ggplot2)
require(MASS)
set.seed(123)
samples <- 10000
r <- 0.9
data <- mvrnorm(n=samples, mu=c(0, 0), Sigma=matrix(c(2, r, r, 2), nrow=2))
x <- data[, 1] # standard normal (mu=0, sd=1)
y <- data[, 2] # standard normal (mu=0, sd=1)
test.df <- data.frame(x = x, y = y)
#### From Tjebo
p <- ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = 2)
p_built <- ggplot_build(p)
p_data <- p_built$data[[1]]
p_maxring <- p_data[p_data[['level']] == min(p_data[['level']]),][,2:3]
coord_mean <- c(x = mean(p_maxring$x), y = mean(p_maxring$y))
p_maxring <- p_maxring %>%
mutate (mean_dev = sqrt((x - mean(x))^2 + (y - mean(y))^2)) #extra column specifying the distance of each point to the mean of those points
p_maxring = p_maxring[round(seq(1, nrow(p_maxring), nrow(p_maxring)/23)),] #### Make a small ellipse to illustrate flaws of approach
coord_farthest <- c('x' = p_maxring$x[which.max(p_maxring$mean_dev)], 'y' = p_maxring$y[which.max(p_maxring$mean_dev)])
# gives the coordinates of the point farthest away from the mean point
farthest_from_farthest <- sqrt((p_maxring$x - coord_farthest['x'])^2 + (p_maxring$y - coord_farthest['y'])^2)
#now this looks which of the points is the farthest from the point farthest from the mean point :D
coord_fff <- c('x' = p_maxring$x[which.max(farthest_from_farthest)], 'y' = p_maxring$y[which.max(farthest_from_farthest)])
farthest_2_points = data.frame(t(cbind(coord_farthest, coord_fff)))
plot(p_maxring[,1:2], asp=1)
lines(farthest_2_points, col = 'blue', lwd = 2)
#### From answer in another post
d = cbind(p_maxring[,1], p_maxring[,2])
r = ellipsoidhull(d)
exy = predict(r) ## the ellipsoid boundary
lines(exy)
me = colMeans((exy))
dist2center = sqrt(rowSums((t(t(exy)-me))^2))
max(dist2center) ## major axis
lines(exy[dist2center == max(dist2center),], col = 'red', lwd = 2)
#### The plot here is made from the data in the reprex in OP, but with h = 0.5
library(MASS)
set.seed(123)
samples <- 10000
r <- 0.9
data <- mvrnorm(n=samples, mu=c(0, 0), Sigma=matrix(c(2, r, r, 2), nrow=2))
x <- data[, 1] # standard normal (mu=0, sd=1)
y <- data[, 2] # standard normal (mu=0, sd=1)
test.df <- data.frame(x = x, y = y)
## MAKE BLUE LINE
p <- ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = 0.5) ## NOTE h = 0.5
p_built <- ggplot_build(p)
p_data <- p_built$data[[1]]
p_maxring <- p_data[p_data[['level']] == min(p_data[['level']]),][,2:3]
coord_mean <- c(x = mean(p_maxring$x), y = mean(p_maxring$y))
p_maxring <- p_maxring %>%
mutate (mean_dev = sqrt((x - mean(x))^2 + (y - mean(y))^2))
coord_farthest <- c('x' = p_maxring$x[which.max(p_maxring$mean_dev)], 'y' = p_maxring$y[which.max(p_maxring$mean_dev)])
farthest_from_farthest <- sqrt((p_maxring$x - coord_farthest['x'])^2 + (p_maxring$y - coord_farthest['y'])^2)
coord_fff <- c('x' = p_maxring$x[which.max(farthest_from_farthest)], 'y' = p_maxring$y[which.max(farthest_from_farthest)])
## MAKE RED LINE
## h = 0.5
## Given the highly irregular shape of the contours, I will use only the largest contour line (0.95) for draing the line.
## Thus, average = 1. See function below for details.
ln = long.diam("x", "y", test.df, h = 0.5, average = 1) ## NOTE h = 0.5
## PLOT
ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 0.5, contour = T, h = 0.5) + ## NOTE h = 0.5
geom_segment((aes(x = coord_farthest['x'], y = coord_farthest['y'],
xend = coord_fff['x'], yend = coord_fff['y'])), col = 'blue', lwd = 2) +
geom_abline(intercept = ln[1], slope = ln[2], color = 'red', lwd = 2) +
coord_equal()
Finally, I came up with the following function to deal with all this. Sorry for the lack of comments/clarity
#### This will return the intercept and slope of the longest diameter (semi-major axis).
####If Average = TRUE, it will average the int and slope across different density contours.
long.diam = function(x, y, df, probs = c(0.95, 0.5, 0.1), average = T, h = 2) {
fun.df = data.frame(cbind(df[,x], df[,y]))
colnames(fun.df) = c("x", "y")
dens = kde2d(fun.df$x, fun.df$y, n = 200, h = h)
dx <- diff(dens$x[1:2])
dy <- diff(dens$y[1:2])
sz <- sort(dens$z)
c1 <- cumsum(sz) * dx * dy
levels <- sapply(probs, function(x) {
approx(c1, sz, xout = 1 - x)$y
})
names(levels) = paste0("L", str_sub(formatC(probs, 2, format = 'f'), -2))
#plot(fun.df$x,fun.df$y, asp = 1)
#contour(dens, levels = levels, labels=probs, add=T, col = c('red', 'blue', 'green'), lwd = 2)
#contour(dens, add = T, col = 'red', lwd = 2)
#abline(lm(fun.df$y~fun.df$x))
ls <- contourLines(dens, levels = levels)
names(ls) = names(levels)
lines.info = list()
for (i in 1:length(ls)) {
d = cbind(ls[[i]]$x, ls[[i]]$y)
exy = predict(ellipsoidhull(d))## the ellipsoid boundary
colnames(exy) = c("x", "y")
me = colMeans((exy)) ## center of the ellipse
dist2center = sqrt(rowSums((t(t(exy)-me))^2))
#plot(exy,type='l',asp=1)
#points(d,col='blue')
#lines(exy[order(dist2center)[1:2],])
#lines(exy[rev(order(dist2center))[1:2],])
max.dist = data.frame(exy[rev(order(dist2center))[1:2],])
line.fit = lm(max.dist$y ~ max.dist$x)
lines.info[[i]] = c(as.numeric(line.fit$coefficients[1]), as.numeric(line.fit$coefficients[2]))
}
names(lines.info) = names(ls)
#plot(fun.df$x,fun.df$y, asp = 1)
#contour(dens, levels = levels, labels=probs, add=T, col = c('red', 'blue', 'green'), lwd = 2)
#abline(lines.info[[1]], col = 'red', lwd = 2)
#abline(lines.info[[2]], col = 'blue', lwd = 2)
#abline(lines.info[[3]], col = 'green', lwd = 2)
#abline(apply(simplify2array(lines.info), 1, mean), col = 'black', lwd = 4)
if (isTRUE(average)) {
apply(simplify2array(lines.info), 1, mean)
} else {
lines.info[[average]]
}
}
Finally, here's the final implementation of the different answers:
library(MASS)
set.seed(123)
samples = 10000
r = 0.9
data = mvrnorm(n=samples, mu=c(0, 0), Sigma=matrix(c(2, r, r, 2), nrow=2))
x = data[, 1] # standard normal (mu=0, sd=1)
y = data[, 2] # standard normal (mu=0, sd=1)
#plot(x, y)
test.df = data.frame(x = x, y = y)
#### Find furthest two points of contour
## BLUE
p <- ggplot(test.df, aes(x, y)) +
geom_density2d(color = 'red', lwd = 2, contour = T, h = 2)
p_built <- ggplot_build(p)
p_data <- p_built$data[[1]]
p_maxring <- p_data[p_data[['level']] == min(p_data[['level']]),][,2:3]
coord_mean <- c(x = mean(p_maxring$x), y = mean(p_maxring$y))
p_maxring <- p_maxring %>%
mutate (mean_dev = sqrt((x - mean(x))^2 + (y - mean(y))^2))
coord_farthest <- c('x' = p_maxring$x[which.max(p_maxring$mean_dev)], 'y' = p_maxring$y[which.max(p_maxring$mean_dev)])
farthest_from_farthest <- sqrt((p_maxring$x - coord_farthest['x'])^2 + (p_maxring$y - coord_farthest['y'])^2)
coord_fff <- c('x' = p_maxring$x[which.max(farthest_from_farthest)], 'y' = p_maxring$y[which.max(farthest_from_farthest)])
#### Find the average intercept and slope of 3 contour lines (0.95, 0.5, 0.1), as in my long.diam function above.
## RED
ln = long.diam("x", "y", test.df)
#### Plot everything. Black line is GLM
ggplot(test.df, aes(x, y)) +
geom_point(color = 'grey') +
geom_density2d(color = 'red', lwd = 1, contour = T, h = 2) +
geom_smooth(method = "glm", se = F, lwd = 1, color = 'black') +
geom_abline(intercept = ln[1], slope = ln[2], col = 'red', lwd = 1) +
geom_segment((aes(x = coord_farthest['x'], y = coord_farthest['y'],
xend = coord_fff['x'], yend = coord_fff['y'])), col = 'blue', lwd = 1) +
coord_equal()

Transform color scale to probability-transformed color distribution with scale_fill_gradientn()

I am trying to visualize heavily tailed raster data, and I would like a non-linear mapping of colors to the range of the values. There are a couple of similar questions, but they don't really solve my specific problem (see links below).
library(ggplot2)
library(scales)
set.seed(42)
dat <- data.frame(
x = floor(runif(10000, min=1, max=100)),
y = floor(runif(10000, min=2, max=1000)),
z = rlnorm(10000, 1, 1) )
# colors for the colour scale:
col.pal <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))
fill.colors <- col.pal(64)
This is how the data look like if not transformed in some way:
ggplot(dat, aes(x = x, y = y, fill = z)) +
geom_tile(width=2, height=30) +
scale_fill_gradientn(colours=fill.colors)
My question is sort of a follow-up question related to
this one or this one , and the solution given here actually yields exactly the plot I want, except for the legend:
qn <- rescale(quantile(dat$z, probs=seq(0, 1, length.out=length(fill.colors))))
ggplot(dat, aes(x = x, y = y, fill = z)) +
geom_tile(width=2, height=30) +
scale_fill_gradientn(colours=fill.colors, values = qn)
Now I want the colour scale in the legend to represent the non-linear distribution of the values (now only the red part of the scale is visible), i.e. the legend should as well be based on quantiles. Is there a way to accomplish this?
I thought the trans argument within the colour scale might do the trick, as suggested here , but that throws an error, I think because qnorm(pnorm(dat$z)) results in some infinite values (I don't completely understand the function though..).
norm_trans <- function(){
trans_new('norm', function(x) pnorm(x), function(x) qnorm(x))
}
ggplot(dat, aes(x = x, y = y, fill = z)) +
geom_tile(width=2, height=30) +
scale_fill_gradientn(colours=fill.colors, trans = 'norm')
> Error in seq.default(from = best$lmin, to = best$lmax, by = best$lstep) : 'from' must be of length 1
So, does anybody know how to have a quantile-based colour distribution in the plot and in the legend?
This code will make manual breaks with a pnorm transformation. Is this what you are after?
ggplot(dat, aes(x = x, y = y, fill = z)) +
geom_tile(width=2, height=30) +
scale_fill_gradientn(colours=fill.colors,
trans = 'norm',
breaks = quantile(dat$z, probs = c(0, 0.25, 1))
)
I believe you have been looking for a quantile transform. Unfortunately there is none in scales, but it is not to hard to build one yourself (on the fly):
make_quantile_trans <- function(x, format = scales::label_number()) {
name <- paste0("quantiles_of_", deparse1(substitute(x)))
xs <- sort(x)
N <- length(xs)
transform <- function(x) findInterval(x, xs)/N # find the last element that is smaller
inverse <- function(q) xs[1+floor(q*(N-1))]
scales::trans_new(
name = name,
transform = transform,
inverse = inverse,
breaks = function(x, n = 5) inverse(scales::extended_breaks()(transform(x), n)),
minor_breaks = function(x, n = 5) inverse(scales::regular_minor_breaks()(transform(x), n)),
format = format,
domain = xs[c(1, N)]
)
}
ggplot(dat, aes(x = x, y = y, fill = z)) +
geom_tile(width=2, height=30) +
scale_fill_gradientn(colours=fill.colors, trans = make_quantile_trans(dat$z))
Created on 2021-11-12 by the reprex package (v2.0.1)

topoplot in ggplot2 – 2D visualisation of e.g. EEG data

Can ggplot2 be used to produce a so-called topoplot (often used in neuroscience)?
Sample data:
label x y signal
1 R3 0.64924459 0.91228430 2.0261520
2 R4 0.78789621 0.78234410 1.7880972
3 R5 0.93169511 0.72980685 0.9170998
4 R6 0.48406513 0.82383895 3.1933129
Full sample data.
Rows represent individual electrodes. Columns x and y represent the projection into 2D space and the column signal is essentially the z-axis representing voltage measured at a given electrode.
stat_contour doesn't work, apparently due to unequal grid.
geom_density_2d only provides a density estimation of x and y.
geom_raster is one not fitted for this task or I must be using it incorrectly since it quickly runs out of memory.
Smoothing (like in the image on the right) and head contours (nose, ears) aren't necessary.
I want to avoid Matlab and transforming the data so that it fits this or that toolbox… Many thanks!
Update (26 January 2016)
The closest I've been able to get to my objective is via
library(colorRamps)
ggplot(channels, aes(x, y, z = signal)) + stat_summary_2d() + scale_fill_gradientn(colours=matlab.like(20))
which produces an image like this:
Update 2 (27 January 2016)
I've tried #alexforrence's approach with full data and this is the result:
It's a great start but there is a couple of issues:
The last call (ggplot()) takes about 40 seconds on an Intel i7 4790K while Matlab toolboxes manage to generate these almost instantly; my ‘emergency solution’ above takes about a second.
As you can see, the upper and lower border of the central part appear to be ‘sliced’ – I'm not sure what causes this but it could be the third issue.
I'm getting these warnings:
1: Removed 170235 rows containing non-finite values (stat_contour).
2: Removed 170235 rows containing non-finite values (stat_contour).
Update 3 (27 January 2016)
Comparison between two plots produced with different interp(xo, yo) and stat_contour(binwidth) values:
Ragged edges if one chooses low interp(xo, yo), in this case xo/yo = seq(0, 1, length = 100):
Here's a potential start:
First, we'll attach some packages. I'm using akima to do linear interpolation, though it looks like EEGLAB uses some sort of spherical interpolation here? (the data was a little sparse to try it).
library(ggplot2)
library(akima)
library(reshape2)
Next, reading in the data:
dat <- read.table(text = " label x y signal
1 R3 0.64924459 0.91228430 2.0261520
2 R4 0.78789621 0.78234410 1.7880972
3 R5 0.93169511 0.72980685 0.9170998
4 R6 0.48406513 0.82383895 3.1933129")
We'll interpolate the data, and stick that in a data frame.
datmat <- interp(dat$x, dat$y, dat$signal,
xo = seq(0, 1, length = 1000),
yo = seq(0, 1, length = 1000))
datmat2 <- melt(datmat$z)
names(datmat2) <- c('x', 'y', 'value')
datmat2[,1:2] <- datmat2[,1:2]/1000 # scale it back
I'm going to borrow from some previous answers. The circleFun below is from Draw a circle with ggplot2.
circleFun <- function(center = c(0,0),diameter = 1, npoints = 100){
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))
}
circledat <- circleFun(c(.5, .5), 1, npoints = 100) # center on [.5, .5]
# ignore anything outside the circle
datmat2$incircle <- (datmat2$x - .5)^2 + (datmat2$y - .5)^2 < .5^2 # mark
datmat2 <- datmat2[datmat2$incircle,]
And I really liked the look of the contour plot in R plot filled.contour() output in ggpplot2, so we'll borrow that one.
ggplot(datmat2, aes(x, y, z = value)) +
geom_tile(aes(fill = value)) +
stat_contour(aes(fill = ..level..), geom = 'polygon', binwidth = 0.01) +
geom_contour(colour = 'white', alpha = 0.5) +
scale_fill_distiller(palette = "Spectral", na.value = NA) +
geom_path(data = circledat, aes(x, y, z = NULL)) +
# draw the nose (haven't drawn ears yet)
geom_line(data = data.frame(x = c(0.45, 0.5, .55), y = c(1, 1.05, 1)),
aes(x, y, z = NULL)) +
# add points for the electrodes
geom_point(data = dat, aes(x, y, z = NULL, fill = NULL),
shape = 21, colour = 'black', fill = 'white', size = 2) +
theme_bw()
With improvements mentioned in the comments (setting extrap = TRUE and linear = FALSE in the interp call to fill in gaps and do a spline smoothing, respectively, and removing NAs before plotting), we get:
mgcv can do spherical splines. This replaces akima (the chunk containing interp() isn't necessary).
library(mgcv)
spl1 <- gam(signal ~ s(x, y, bs = 'sos'), data = dat)
# fine grid, coarser is faster
datmat2 <- data.frame(expand.grid(x = seq(0, 1, 0.001), y = seq(0, 1, 0.001)))
resp <- predict(spl1, datmat2, type = "response")
datmat2$value <- resp

Interpolating a path/curve within R

Within R, I want to interpolate an arbitrary path with constant distance
between interpolated points.
The test-data looks like that:
require("rgdal", quietly = TRUE)
require("ggplot2", quietly = TRUE)
r <- readOGR(".", "line", verbose = FALSE)
coords <- as.data.frame(r#lines[[1]]#Lines[[1]]#coords)
names(coords) <- c("x", "y")
print(coords)
x y
-0.44409 0.551159
-1.06217 0.563326
-1.09867 0.310255
-1.09623 -0.273754
-0.67283 -0.392990
-0.03772 -0.273754
0.63633 -0.015817
0.86506 0.473291
1.31037 0.998899
1.43934 0.933198
1.46854 0.461124
1.39311 0.006083
1.40284 -0.278621
1.54397 -0.271321
p.orig <- ggplot(coords, aes(x = x, y = y)) + geom_path(colour = "red") +
geom_point(colour = "yellow")
print(p.orig)
I tried different methods, none of them were really satisfying:
aspline (akima-package)
approx
bezierCurve
with the tourr-package I couldn't get started
aspline
aspline from the akima-package does some weird stuff when dealing with arbitrary paths:
plotInt <- function(coords) print(p.orig + geom_path(aes(x = x, y = y),
data = coords) + geom_point(aes(x = x, y = y), data = coords))
N <- 50 # 50 points to interpolate
require("akima", quietly = TRUE)
xy.int.ak <- as.data.frame(with(coords, aspline(x = x, y = y, n = N)))
plotInt(xy.int.ak)
approx
xy.int.ax <- as.data.frame(with(coords, list(x = approx(x, n = N)$y,
y = approx(y, n = N)$y)))
plotInt(xy.int.ax)
At first sight, approx looks pretty fine; however, testing it with real data gives me
problems with the distances between the interpolated points. Also a smooth, cubic interpolation would be a nice thing.
bezier
Another approach is to use bezier-curves; I used the following
implementation
source("bez.R")
xy.int.bz <- as.data.frame(with(coords, bezierCurve(x, y, N)))
plotInt(xy.int.bz)
How about regular splines using the same method you used for approx? Will that work on the larger data?
xy.int.sp <- as.data.frame(with(coords, list(x = spline(x)$y,
y = spline(y)$y)))
Consider using xspline or grid.xspline (the first is for base graphics, the second for grid):
plot(x,y, type='b', col='red')
xspline(x,y, shape=1)
You can adjust the shape parameter to change the curve, this example just plots the x spline, but you can also have the function return a set of xy coordinates that you would plot yourself.

Resources