I wanted to create a contour plot using the ggplot library. I checked the documentation on this topic, and found the code to get this done. Unfortunately the code uses the indexes of the matrix z storing the surface, as x and y. How do I change this to the actual value of x and y?
Below my code generating the contour plot.
objective_function <- function(vec) {
basin_function <- function(vec){
if(all(vec == 0)) {
return(0)
} else{
return(sum(exp(-2.0/vec^2)+sin(vec*pi*2)))
}
}
return(basin_function(vec))
}
objective_function_wrapper <- function(x_vec, y_vec) {
vec <-rbind(x_vec,y_vec)
return(apply(vec,2, objective_function))
}
plotSurf <-function(){
x <- y <-seq(from=-5, to =5, by=0.1)
z <- outer(x,y, objective_function_wrapper)
surf3d <- melt(z)
names(surf3d) <- c("x", "y", "z")
p1 <- ggplot(data=surf3d, aes(x=x, y=y, z=z))
p1 <- p1 + geom_tile(aes(fill=z))+stat_contour()
print(p1)
}
plotSurf()
You need to substitute the x- and y-values for the row and column numbers that are currently sitting in the "melt"-ed result of the outer call:
x <- y <-seq(from=-5, to =5, by=0.1)
z <- outer(x,y, objective_function_wrapper)
surf3d <- melt(z)
names(surf3d) <- c("x", "y", "z")
surf3d$x <- rep(x, ncol(z) ); surf3d$y <- rep(y, each=nrow(z) )
Related
When we take the following example from ggplot2 docs
df <- data.frame(x = c(rnorm(100, 0, 3), rnorm(100, 0, 10)),
g = gl(2, 100))
library(ggplot2)
p <- ggplot(df, aes(x, colour = g)) +
stat_ecdf(geom = "step", na.rm = T) + # interchange point and step
theme_bw()
p
We can create a standard cdf plot. Now if we want to play with the plot in plotly, I obtain a very confusing image when I use the step command. See below. However, when I use the point command plotly behaves like it should. What is happening with the step command? Why can't I recreate the image from using ggplot only?
library(plotly)
ggplotly(p)
I found the solution here https://community.plotly.com/t/bug-with-ggplot2-stat-ecdf-function/1187/3.
You should reorder the dataframe along x.
df <- dplyr::arrange(df, x)
library(ggplot2)
p <- ggplot(df, aes(x, colour = g)) +
stat_ecdf(geom = "step", na.rm = T) +
theme_bw()
p
library(plotly)
ggplotly(p)
This can be solved using ecdf() function.
## ecdf function to get y and 1-y
rcdf <- function (x) {
cdf <- ecdf(x)
y1 <- cdf(x)
y <- unique(y1)
# xrcdf <- 1-y ## to get reverse cdf
xrcdf <- y ## to get cdf
}
ug <- unique(df$g)
ng <- length(ug)
xll <- min(df$x)
xul <- max(df$x)
adr <- data.frame(myxx=c(), myyy=c(), mygg=c())
lapply(1:ng, function(i){
ad2r <- subset(df, g==ug[i])
myx1 <- unique(ad2r$x)
myxx <- c(xll,myx1,xul) ## add lowest value - dummy to assign 100%
myy1 <- rcdf(ad2r$x)
# myyy <- c(1.0,myy1,0.0) ## add 100% to get reverse cdf
myyy <- c(0.0,myy1,1.0) ## add 0% to get cdf
mygg <- ug[i]
ad2rf <- data.frame(myxx,myyy,mygg)
adr <<- rbind(adr,ad2rf)
})
adf <- adr[order(adr$myxx),]
pp <- ggplot(data=adf,
aes_(x=adf$myxx, y=100*adf$myyy, col=adf$mygg, group=adf$mygg)) +
geom_step() +
labs(title="CDF", y = "Y", x = "X", col=NULL)
ppp <- ggplotly(pp, tooltip=c("x","y"))
ppp
This gives the following output:
CDF
Is there a neat way to color negative values in red and others in green for a (simplified) time series plot below, using lattice::xyplot?
set.seed(0)
xyplot(zoo(cumsum(rnorm(100))), grid=T)
Lattice is based on grid so you can use grid's clipping functionality
library(lattice)
library(grid)
set.seed(0)
x <- zoo(cumsum(rnorm(100)))
xyplot(x, grid=TRUE, panel = function(x, y, ...){
panel.xyplot(x, y, col="red", ...)
grid.clip(y=unit(0,"native"),just=c("bottom"))
panel.xyplot(x, y, col="green", ...) })
When using type="l" you only have one "line" and it's all one color, so you might instead choose to color points:
set.seed(0); require(zoo); require(lattice)
vals <- zoo(cumsum(rnorm(100)))
png()
xyplot(vals, type=c("l","p"), col=c("red", "green")[1+( vals>0)], grid=T)
dev.off()
I found a solution by, Sundar Dorai-Rag, a fellow now at Google, to a similar request (to color the enclosed areas above and below 0, for which his approach to getting the crossing values for the X's was to invert the results of approx ) as seen here: http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html. Instead of coloring the enclosed areas, I gave the borders of the polygons the desired colors and left the interior "transparent":
lpolygon <- function (x, y = NULL, border = NULL, col = NULL, ...) {
require(grid, TRUE)
xy <- xy.coords(x, y)
x <- xy$x
y <- xy$y
gp <- list(...)
if (!is.null(border)) gp$col <- border
if (!is.null(col)) gp$fill <- col
gp <- do.call("gpar", gp)
grid.polygon(x, y, gp = gp, default.units = "native")
}
find.zero <- function(x, y) {
n <- length(y)
yy <- c(0, y)
wy <- which(yy[-1] * yy[-n - 1] < 0)
if(!length(wy)) return(NULL)
xout <- sapply(wy, function(i) {
n <- length(x)
ii <- c(i - 1, i)
approx(y[ii], x[ii], 0)$y
})
xout
}
trellis.par.set(theme = col.whitebg())
png();
xyplot(vals, panel = function(x,y, ...) {
x.zero <- find.zero(x, y)
y.zero <- y > 0
yy <- c(y[y.zero], rep(0, length(x.zero)))
xx <- c(x[y.zero], x.zero)
ord <- order(xx)
xx <- xx[ord]
xx <- c(xx[1], xx, xx[length(xx)])
yy <- c(0, yy[ord], 0)
lpolygon(xx, yy, col="transparent", border = "green")
yy <- c(y[!y.zero], rep(0, length(x.zero)))
xx <- c(x[!y.zero], x.zero)
ord <- order(xx)
xx <- xx[ord]
xx <- c(xx[1], xx, xx[length(xx)])
yy <- c(0, yy[ord], 0)
lpolygon(xx, yy, col = "transparent", border = "red")
panel.abline(h = 0) ;panel.grid(v=-1, h=-1 )
}); dev.off()
I tried writing a custom panel function for this that will break a line on a given value
panel.breakline <- function(x,y,breakat=0,col.line,upper.col="red",lower.col="green",...){
f <- approxfun(x,y)
ff <- function(x) f(x)-breakat
psign <- sign(y-breakat)
breaks <- which(diff(psign) != 0)
interp <- sapply(breaks, function(i) uniroot(ff,c(x[i], x[i+1]))$root)
starts <- c(1,breaks+1)
ends <- c(breaks, length(x))
Map(function(start,end,left,right) {
x <- x[start:end]
y <- y[start:end]
col <- ifelse(y[1]>breakat,upper.col,lower.col)
panel.xyplot(c(left, x, right) ,c(breakat,y,breakat), col.line=col,...)
}, starts, ends, c(NA,interp), c(interp,NA))
}
You can run with
library(zoo)
library(lattice)
set.seed(0)
zz<-zoo(cumsum(rnorm(100)))
xyplot(zz, grid=T, panel.groups=panel.breakline)
And you can change the break point or the colors as well
xyplot(zz, grid=T, panel.groups=panel.breakline,
breakat=2, upper.col="blue", lower.col="orange")
If one was to do it without points, then I'd stick to plot (instead of lattice) and use clip , like in one of the answers here :
Plot a line chart with conditional colors depending on values
dat<- zoo(cumsum(rnorm(100)))
plot(dat, col="red")
clip(0,length(dat),0,max(dat) )
lines(dat, col="green")
Given 'n' images in a png/jpeg format and 'n' corresponding coordinates in 2 dimensions (x,y): I would like to plot these images at the given coordinates on a single plot. If I find the images to be too big, I would ideally like to plot them as a smaller/scaled version at the given coordinates. How can i achieve such a plot in R?
An example of how such a plot would look is given below:
xy <- data.frame(x=runif(10, 0, 100), y=runif(10, 0, 100))
require(png)
img <- readPNG(system.file("img", "Rlogo.png", package="png"))
thumbnails <- function(x, y, images, width = 0.1*diff(range(x)),
height = 0.1*diff(range(y))){
images <- replicate(length(x), images, simplify=FALSE)
stopifnot(length(x) == length(y))
for (ii in seq_along(x)){
rasterImage(images[[ii]], xleft=x[ii] - 0.5*width,
ybottom= y[ii] - 0.5*height,
xright=x[ii] + 0.5*width,
ytop= y[ii] + 0.5*height, interpolate=FALSE)
}
}
plot(xy, t="n")
thumbnails(xy[,1], xy[,2], img)
The my.symbols function along with ms.image function (both from the TeachingDemos package) can be used to plot with images.
Here is an example:
library(png)
flag.list <- lapply( list.files('flags/',pattern='png$', full=TRUE),
function(x) readPNG(x) )
library(TeachingDemos)
ms.flags <- function(ind,...) {
tmp <- array(0, dim=c(150,150,4) )
tmp[ 26:125, , 1:3] <- flag.list[[ind]]
tmp[ 26:125, , 4 ] <- 1
ms.image(tmp,...)
}
x <- rnorm(50)
y <- rnorm(50)
my.symbols(x,y, symb = ms.flags, ind=1:50, symb.plots=TRUE,
add=FALSE, xlim=c(-3,3), ylim=c(-3,3), inches=0.75)
the ggflags package provides a proof-of-principle example
library(ggflags)
set.seed(1234)
d <- data.frame(x=rnorm(50), y=rnorm(50),
country=sample(c("ar","fr", "nz", "gb", "es", "ca"), 50, TRUE),
stringsAsFactors = FALSE)
ggplot(d, aes(x=x, y=y, country=country, size=x)) +
geom_flag() +
scale_country()
I have a data.frame with 5 columns and I'd like to generate a matrix of density plots, such that each density plot is an overlay of two density plots. (This is akin to plotmatrix, except that in my case, the number of non-NA value in each column differ from column to column and I want overlaid distributions rather than scatter plots).
My first attempt, which didn't work, is given below:
library(ggplot2)
library(reshape)
tmp1 <- data.frame(do.call(cbind, lapply(1:5, function(x) {
r <- rnorm(100)
r[sample(1:100, 20)] <- NA
return(r)
})))
ggplot( melt(tmp1), aes(x=value, fill=variable))+
geom_density(alpha=0.2, position="identity")+opts(legend.position = "none")+
facet_grid(variable ~ variable)
My second approach got me nearly there, but instead of 5 different colors, I only want to use two colors across all the plots. And, I'm sure there is a more elegant way to construct this expanded matrix:
tmp2 <- do.call(rbind, lapply(1:5, function(i) {
do.call(rbind, lapply(1:5, function(j) {
r <- rbind(data.frame(var=sprintf('X%d', i), val=tmp1[,i]),
data.frame(var=sprintf('X%d', j), val=tmp1[,j]))
r <- data.frame(xx=sprintf('X%d', i), yy=sprintf('X%d', j), r)
return(r)
}))
}))
ggplot(tmp2, aes(x=val, fill=var))+
geom_density(alpha=0.2, position="identity")+opts(legend.position = "none")+
facet_grid(xx ~ yy)
My solution was to manually loop through the pairs of columns and generate the overlaid density plots by hand, saving them to a list. I then arranged them in a grid using `grid.arrange' giving the image below.
But is it possible to achieve this using facet_grid instead?
The easiest way is to reshape your data with all permutations (5 * 5 = 25 of them).
require(gregmisc)
perm <- permutations(5, 2, paste0("X", 1:5), repeats.allowed=TRUE)
# instead of gregmisc + permutations, you can use expand.grid from base as:
# perm <- expand.grid(paste0("X", 1:5), paste0("X", 1:5))
o <- apply(perm, 1, function(idx) {
t <- tmp1[idx]
names(t) <- c("A", "B")
t$id1 <- idx[1]
t$id2 <- idx[2]
t
})
require(ggplot2)
require(reshape2)
o <- do.call(rbind, o)
o.m <- melt(o, c("id1", "id2"))
o.m$id1 <- factor(o.m$id1)
o.m$id2 <- factor(o.m$id2)
p <- ggplot(o.m, aes(x = value))
p <- p + geom_density(alpha = 0.2, position = "identity", aes(fill = variable))
p <- p + theme(legend.position = "none")
p <- p + facet_grid(id1 ~ id2)
p
I have a matrix data here, and I visualized it with levelplot. The Plot is placed below. But I just couldn't put the values into the plot, I mean I read this question, but still couldn't figure it out.
How can I do that ? Thanks.
The problem with the code in the answer you linked to is that it only works when the objects in the levelplot's formula are named x, y, and z.
Here is an example that uses a more standard idiom for processing the arguments passed in to the custom panel function and so becomes more generally applicable:
library("lattice")
## Example data
x <- seq(pi/4, 5*pi, length.out=10)
y <- seq(pi/4, 5*pi, length.out=10)
grid <- expand.grid(X=x, Y=y)
grid$Z <- runif(100, -1, 1)
## Write a panel function (after examining 'args(panel.levelplot) to see what
## will be being passed on to the panel function by levelplot())
myPanel <- function(x, y, z, ...) {
panel.levelplot(x,y,z,...)
panel.text(x, y, round(z,1))
}
## Try it out
levelplot(Z ~ X*Y, grid, panel = myPanel)
mat <- read.csv("J_H2S1T6_PassTraffic.csv", header=F)
y <- as.numeric(mat[1,-1])
mat <- mat[-1,-1]
n <- dim(mat)[1]
Here a modification, I generate a new scale
x <- seq(min(y), max(y), length.out=n)
grid <- expand.grid(x=x, y=x)
mat <- as.matrix(mat)
dim(mat) <- c(n*n,1)
grid$z <- mat
Here the modification. I change the dimension of the matrix to a vector to put it in the grid .
mat <- as.matrix(mat)
dim(mat) <- c(n*n,1)
grid$z <- mat
p <- levelplot(z~x*y, grid,
panel=function(...) {
arg <- list(...)
panel.levelplot(...)
panel.text(arg$x, arg$y,arg$z)},
scales = list(y = list(at=y,labels=y),
x = list(at=y,labels=y)))
print(p)
Another option is to use layer() from latticeExtra. It allows you to overlay one plot on top of another, using the + operator familiar to ggplot2 enthusiasts:
library(latticeExtra)
## Applied to the example data in my other answer, this will produce
## an identical plot
levelplot(Z ~ X*Y, data = grid) +
layer(panel.text(X, Y, round(Z, 1)), data = grid)