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)
Related
I am working with the R programming language.
In a previous question that I asked (Understanding 3D traces in Plotly and R: Evaluating and Plotting Functions Over a Grid), I learned how to plot mathematical functions by first evaluating the mathematical function at different points, then by plotting these points on a 3D grid, and finally "interpolating" a 3D surface over these points:
# set seed for reproducibility
#load libraries
set.seed(123)
library(dplyr)
library(plotly)
#create more data
n <- 50
my_grid <- expand.grid(i1 = 1:n, i2 = 1:n)
my_grid$final_value = with(my_grid, sin(i1) + cos(i2) )
#make plot
plot_ly(data = my_grid, x=~i1, y=~i2, z=~final_value, type='mesh3d', intensity = ~final_value, colors = colorRamp(c("blue", "grey", "red")))
I am trying to use this same approach to plot the following function (https://en.wikipedia.org/w/index.php?title=Test_functions_for_optimization&oldid=1030693803, https://en.wikipedia.org/w/index.php?title=Test_functions_for_optimization&oldid=1030693803#/media/File:ConstrTestFunc03.png) :
I first defined the function:
my_function <- function(x,y) {
final_value = (1 - x)^2 + 100*((y - x^2)^2)
}
Then, I defined the "grid":
input_1 <- seq(-1.5, 1.5,0.1)
input_2 <- seq(-1.5, 1.5,0.1)
my_grid <- data.frame(input_1, input_2)
my_grid$final_value = (1 - input_1)^2 + 100*((input_2 - input_1^2)^2)
Then, I tried to plot this function:
x <- my_grid$input_1
y <- my_grid$input_2
z <- matrix(my_grid$final_value, nrow = length(x), ncol = length(y)) # proper matrix & dimensions
plot_ly(x = x, y = y, z = z) %>% add_surface()
My Problem: The final result does not look similar to the result from the Wikipedia page:
Can someone please show me what I am doing wrong? Is there an easier way to do this?
Thanks!
Your problem is that you are not actually creating a grid, you are creating a single vector of equal x, y points and running your formula on that, so your matrix is wrong (every column will be the same due to it being repeated). The easiest fix is to run outer on your function to evaluate it at every pair of input 1 and input 2:
z <- outer(input_1, input_2, my_function)
plot_ly(x = input_1, y = input_2, z = z) %>% add_surface()
I am trying to create a contour plot of 1000 data points. I have the matrix with all of the values in it. Here is my code.
mu1 <- rbind(2, 2)
mu2 <- rbind(-2, -2)
sigma1 <- rbind(c(.6, 0), c(0, .6))
simga2 <- sigma1
det1 <- det(sigma1)
det2 <- det1
inv1 <- solve(sigma1)
inv2 <- inv1
x <- runif(1000, -5, 5)
y <- runif(1000, -5, 5)
w <- rbind(x, y)
ratio <- function(v){
quotient <- (exp((-1/2)*t(v-mu1)%*%inv1%*%(v-mu1)))/(exp((-1/2)*t(v-mu2)%*%inv2%*%(v-mu2)))
return(quotient)
}
z <- apply(w, 2, ratio)
round.z <- round(z, digits=0)
df <- cbind(x, y, z, round.z)
df <- as.data.frame(df)
I want to plot the contours of x and y by the round.z values including where round.z=1. I know that the contour where round.z=1 should be the line y=-x, but I don't know how to get it to show up. Thanks for the help.
The contour and related functions in R want to have the data on a grid, not a random sample like yours. The akima::interp function can convert your data to this format. For example, after running your code,
library(akima)
grid <- with(df, interp(x, y, round.z))
contour(grid, levels = 10^(0:10))
which produces this image:
I made 3d plot in rgl.persp3d but I don't know how to smooth that to see trend. Or maybe next solution is to implement wireframe in rgl.persp3d (because I need this plot to be interactive). Please, help.
library(mgcv)
x<- rnorm(200)
y<- rnorm(200)
z<-rnorm(200)
tab<-data.frame(x,y,z)
tab
#surface wireframe:
mod <- gam(z ~ te(x, y), data = tab)
wyk <- matrix(fitted(mod), ncol = 20) #8 i 10 też ok
wireframe(wyk, drape=TRUE, colorkey=TRUE)
#surface persp3d
library(rgl)
library(akima)
z_interpolation <- 200
tabint <- interp(x, y, z)
x.si <- tabint$x
y.si <- tabint$y
z.si <- tabint$z
nbcol <- 200
vertcol <- cut(t, nbcol)
color = rev(rainbow(nbcol, start = 0/6, end = 4/6))
persp3d(x.si, y.si, z.si, col = color[vertcol], smooth=T)
So wireframe is neither smoothed nor interactive
...and rgl.persp3d is interactive but no smoothed. And I can't have both smoothed and interactive.
rgl just draws what you give it. You need to use mgcv as in your first example to do the smoothing, but you don't get a matrix of fitted values back at the end, so you'll want to use deldir to turn the results into a surface. For example,
library(mgcv)
x<- rnorm(200)
y<- rnorm(200)
z<-rnorm(200)
tab<-data.frame(x,y,z)
tab
#surface wireframe:
mod <- gam(z ~ te(x, y), data = tab)
library(rgl)
library(deldir)
zfit <- fitted(mod)
col <- cm.colors(20)[1 +
round(19*(zfit - min(zfit))/diff(range(zfit)))]
persp3d(deldir(x, y, z = zfit), col = col)
aspect3d(1, 2, 1)
This gives a nice smooth surface, for example
A simpler way, without the delaunay stuff:
library(mgcv)
x <- rnorm(200)
y <- rnorm(200)
z <- rnorm(200)
tab <- data.frame(x,y,z)
mod <- mgcv::gam(z ~ te(x, y), data = tab)
grid <- -5:5
zfit <- predict(mod, expand.grid(x = grid, y = grid))
persp3d(grid, grid, zfit)
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")
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) )