I am trying to create a plot of the (X0,Ujn) points created in the repeat function. Is there a way to do this in R? Here is my code:
LaxFriedrichs <- function(X0,delx,delt,t){
repeat{
Uj <- sin(X0)
U <- sin(X0+2*delx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*delx))
X0 <- X0+delx
t <- delt + t
plot(X0,Ujn)
if (X0 > 2*pi/40) break
}
}
This might not be the most efficient implementation, but it at least gets all your points plotted (keeps appending to x and y list and then plots those points at the end):
LaxFriedrichs <- function(X0,delx,delt,t){
all.x = c()
all.y = c()
repeat{
Uj <- sin(X0)
U <- sin(X0+2*delx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*delx))
X0 <- X0+delx
t <- delt + t
all.x <- c(all.x, X0)
all.y <- c(all.y, Ujn)
if (X0 > 2*pi/40) break
}
plot(all.x, all.y)
}
LaxFriedrichs(.001, .001, .001, 0.5)
A slightly shorter version that takes advantage of R's vector operations.
f <- function(x0, dx, dt, t0) {
x <- seq(x0,2*pi/40,by=dx)
t <- seq(t0,t0+(length(x)-1)*dt,by=dt)
Uj <- sin(x)
U <- sin(x+2*dx)
Ujn <- (Uj + U)/2 + (Uj - U)*(t/(2*dx))
plot(x,Ujn)
}
f(.001, .001, .001, .5)
Here, x and t are vectors, so Uj, U, and finally Ujn are calculated in one step, rather than in a loop.
One thing to note: in the original algorithm, at each step Ujn is calculated at x but x+dx is stored, so you end up plotting Ujn(x) vs (x+dx). The approach here corrects that, so the x-axis is offset by -dx.
Related
I would like to plot a sphere in R with the gridlines on the surface corresponding to the equal area gridding of the sphere using the arcos transformation.
I have been experimenting with the R packakge rgl and got some help from :
Plot points on a sphere in R
Which plots the gridlines with equal lat long spacing.
I have the below function which returns a data frame of points that are the cross over points of the grid lines I want, but not sure how to proceed.
plot_sphere <- function(theta_num,phi_num){
theta <- seq(0,2*pi,(2*pi)/(theta_num))
phi <- seq(0,pi,pi/(phi_num))
tmp <- seq(0,2*phi_num,2)/phi_num
phi <- acos(1-tmp)
tmp <- cbind(rep(seq(1,theta_num),each = phi_num),rep(seq(1,phi_num),times = theta_num))
results <- as.data.frame(cbind(theta[tmp[,1]],phi[tmp[,2]]))
names(results) <- c("theta","phi")
results$x <- cos(results$theta)*sin(results$phi)
results$y <- sin(results$theta)*sin(results$phi)
results$z <- cos(results$phi)
return(results)
}
sphere <- plot_sphere(10,10)
Can anyone help, in general I am finding the rgl functions tricky to work with.
If you use lines3d or plot3d(..., type="l"), you'll get a plot joining the points in your dataframe. To get breaks (you don't want one long line), add rows containing NA values.
The code in your plot_sphere function seems really messed up (you compute phi twice, you don't generate vectors of the requested length, etc.), but this function based on it works:
function(theta_num,phi_num){
theta0 <- seq(0,2*pi, len = theta_num)
tmp <- seq(0, 2, len = phi_num)
phi0 <- acos(1-tmp)
i <- seq(1, (phi_num + 1)*theta_num) - 1
theta <- theta0[i %/% (phi_num + 1) + 1]
phi <- phi0[i %% (phi_num + 1) + 1]
i <- seq(1, phi_num*(theta_num + 1)) - 1
theta <- c(theta, theta0[i %% (theta_num + 1) + 1])
phi <- c(phi, phi0[i %/% (theta_num + 1) + 1])
results <- data.frame( x = cos(theta)*sin(phi),
y = sin(theta)*sin(phi),
z = cos(phi))
lines3d(results)
}
In R I'm interested in the general case to generate a matrix from a formula such as:
X = some other matrix
Y(i, j) = X(i, j) + Y(i - 1, j - 1)
Unfortunately I can't find how to account for the matrix self-referencing.
Obviously order of execution and bounds checking are factors here, but I imagine these could be accounted for by the matrix orientation and formula respetively.
Thanks.
This solution assumes that you want Y[1,n] == X[1,n] and Y[n,1] == X[n,1]. If not, you can apply the same solution on the sub-matrix X[-1,-1] to fill in the values of Y[-1,-1]. It also assumes that the input matrix is square.
We use the fact that Y[N,N] = X[N,N] + X[N-1, N-1] + ... + X[1,1] plus similar relations for off-diagonal elements. Note that off-diagonal elements are a diagonal of a particular sub-matrix.
# Example input
X <- matrix(1:16, ncol=4)
Y <- matrix(0, ncol=ncol(X), nrow=nrow(X))
diag(Y) <- cumsum(diag(X))
Y[1,ncol(X)] <- X[1,ncol(X)]
Y[nrow(X),1] <- X[nrow(X),1]
for (i in 1:(nrow(X)-2)) {
ind <- seq(i)
diag(Y[-ind,]) <- cumsum(diag(X[-ind,])) # lower triangle
diag(Y[,-ind]) <- cumsum(diag(X[,-ind])) # upper triangle
}
Well, you can always use a for loop:
Y <- matrix(0, ncol=3, nrow=3)
#boundary values:
Y[1,] <- 1
Y[,1] <- 2
X <- matrix(1:9, ncol=3)
for (i in 2:nrow(Y)) {
for (j in 2:ncol(Y)) {
Y[i, j] <- X[i, j] + Y[i-1, j-1]
}
}
If that is too slow you can translate it to C++ (using Rcpp) easily.
I would like to plot:
production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y) as function of x,y,z
As something like this plot from Mathematica, (if possible in R):
http://i.stack.imgur.com/3PRaf.png
I have a function:
library("lubridate"); library("rgl")
production.ts <- function(a, b, z, c, d, e,
f, g, h, j, r, k) {
elapsed <- (4-z)*10 + (4-c)
un.days <- 100 - elapsed
gone.days <- day(as.Date(h))
rem.days <- day(as.Date(j))
r.days <- as.numeric(as.Date(j) - as.Date(h))
m.r <- f/100*d
inputs <- d * a * (gone.days - 1)/365 + r
prin <- m.r + inputs
costs <- (r.days/365 * r + 1) * prin
added.p <- a/100*d + r
due <- d * 1-un.days
tomr.f <- 1- due + k^2
acct.paid <- (d - due)*tomr.f
net <- added.p + due + acct.paid
pv.net <- net/(1+r*(e-30-day(as.Date(j)))/365)
end <- d - due - acct.paid
more.add.p <- end*a*(rem.days-1)/365
rem <- (f-g)/100 * end
total.fv <- pv.net + rem + more.add.p
out <- costs - total.fv
out
}
x<-seq(-10,10,by=.1)
y<-seq(0,1000,by=.1)
z<-seq(0,90,by=.1)
I have tried:
func.3d<-Vectorize(production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y))
c <- func.3d; c <- cut(c,breaks=64); cols <- rainbow(64)[as.numeric(c)]
open3d()
plot3d(x, y, z, col=cols,type="s",size=1)
But this plots lines and the colors don't line up with the values the function should output.
Does anyone know how I could do this? Thanks, I really appreciate your time!
Like this?
x<-seq(-10,10,length=100)
y<-seq(0,1000,length=100)
z<-seq(0,90,length=100)
df <- expand.grid(x=x,y=y,z=z)
f <- function(x,y,z) {production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y)}
df$c <- f(df$x,df$y,df$z)
c <- cut(df$c,breaks=64)
cols <- rainbow(64)[as.numeric(c)]
open3d()
plot3d(df$x, df$y, df$z, col=cols,type="p",size=1)
Your code was not plotting lines. When you pass x, y, and z like that to plot3d(...) it cycles through all the elements together, so x[1],y[1],z[1] is a point, x[2],y[2],z[2] is another point, and so on. Since the vectors are different lengths, the shorter ones are recycled to fill out to the length of the longest. The visual effect of this is that the points lie on a line.
You want yo plot every combination of x, y, and z, and give each point a color based on that combination. The code above does that. The plot does not quite look like yours, but I can't tell if that is because of the way you have defined your function.
Also, the way you defined x, y, and z there would be 201 X 10001 X 901 = 1,811,191,101 points, which is too many to handle. The code above plots 1,000,000 points.
Finally, plotting spheres (type="s") is very expensive and unnecessary in this case.
I am making flow plots for spatial interation models, with x-y coordinates for both origins and destinations:
The problem is that I keep using nested for loops (one for origins, one for destinations) to plot these lines and am sure there's a better way in R.
Anyway to help answer this question I set-up a simple reproducible example with 4 origins and 2 destinations. Suspect the answer to plotting quicker is in matrix algebra, but not sure where to start. Test it out and please let me know:
o <- data.frame(x = c(3,5,6,1), y = c(8,2,3,2))
plot(o)
d <- data.frame(x = c(5,3), y = c(5,3))
points(d, col="red", pch=3)
beta <- 0.6
dist <- matrix(sqrt(c(o[,1] - d[1,1], o[,1] - d[2,1] )^2 +
c(o[,2] - d[1,2], o[,2] - d[2,2] )^2), ncol = 2)
s <- dist
for(i in 1:nrow(o)){
for(j in 1:nrow(d)){
s[i,j] <- exp(-beta * dist[i,j])
}
}
for(i in 1:nrow(o)){
for(j in 1:nrow(d)){
lines(c(o[i,1], d[j,1]), c(o[i,2], d[j,2]),
lwd = 2 * s[i,j] / mean(s))
}
}
Edit - for some context on this project, please see here http://rpubs.com/RobinLovelace/9697
A way to replace the second loop is to use mapply:
fun <- function(row.o, row.d)
{
lines(c(o[row.o,1], d[row.d,1]), c(o[row.o,2], d[row.d,2]),
lwd = 2 * s[row.o,row.d] / mean(s))
}
#all combinatios of rows of `d` and `o`
args.od <- expand.grid(1:nrow(o), 1:nrow(d))
mapply(fun, row.o = args.od[,1], row.d = args.od[,2])
The plot:
A common display of spectroscopic data (intensity vs wavelength) is used below to compare the position of peaks in the data across multiple spectra. Assuming they all share a baseline at 0, it is convenient to offset the multiple lines vertically by a constant spacing, to avoid the distraction of overlapping lines.
Thus becomes
I'm looking for a better strategy to perform this vertical shift automatically, starting from data in long format. Here is a minimal example.
# fake data (5 similar-looking spectra)
spec <- function(){
x <- runif(100, 0, 100)
data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
require(plyr)
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))
My current strategy is as follows:
convert the spectra from long format to wide format. This involves interpolation, as the spectra do not necessarily have identical x axis values.
find the minimum offset between spectra to avoid overlap between neighbours
shift the spectra by multiples of this distance
melt back to long format
I implemented this using plyr,
# function that evenly spaces the spectra to avoid overlap
# d is in long format, s is a scaling factor for the vertical shift
require(plyr); require(ggplot2)
spread_plot <- function(d, s=1){
ranges <- ddply(d, "id", with, each(min,max,length)(x))
common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
new_y <- dlply(d, "id", function(x) approx(x$x, x$y, common_x)$y)
mat <- do.call(cbind, new_y)
test <- apply(mat, 1, diff)
shift <- max(-test[test < 0])
origins <- s*seq(0, by=shift, length=ncol(mat))
for(ii in seq_along(origins)){
current <- unique(d[["id"]])[ii]
d[d[["id"]] == current, "y"] <-
d[d[["id"]] == current, "y"] + origins[ii]
}
d
}
test <- spread_plot(all)
ggplot(test, aes(x, y, colour=id, group=id))+
geom_line() + guides(colour=guide_legend())
This strategy suffers from a few shortcomings:
it is slow
the offset is not a pretty number; I do not know how to automatically round it well so that spectra are offset e.g. by 0.02, or 50, etc. depending on the range of the intensities. pretty(origins) is problematic in that it can return a different number of values.
I feel I'm missing a simpler solution, perhaps working directly with the original data in long format.
Interesting question.
Here's a possibility, offered without detailed comment, except to point out that it:
Should be very fast, due to a combo of its avoidance of plyr, use of data.table, and operation on data in its original long format.
Uses pretty() to pick a pretty offset.
Like your code, is not guaranteed to produce no intersections of lines, since overlap can happen between the lattice of points formed by common_x.
Here's the code
## Setup
library(data.table)
library(plyr)
library(ggplot2)
spec <- function(){
x <- runif(100, 0, 100)
data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))
## Function that uses data.table rather than plyr to compute and add offsets
spread_plot <- function(d, s=1){
d <- data.table(d, key="id")
ranges <- d[, list(min=min(x), max=max(x), length=length(x)),by="id"]
common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
new_y <- d[,list(y=approx(x, y, common_x)$y, N=seq_along(common_x)),
by="id"]
shift <- max(new_y[, max(abs(diff(y))), by = "N"][[2]])
shift <- pretty(c(0, shift), n=0)[2]
origins <- s*seq(0, by=shift, length=length(unique(d$id)))
d[,y:=(y + origins[.GRP]),by="id"]
d
}
## Try it out
test <- spread_plot(all)
ggplot(test, aes(x, y, colour=id, group=id))+
geom_line() + guides(colour=guide_legend())
I still think you could rely on some assumptions about typical data from spectroscopy. Usually, x values are sorted, the number of them is equal for all spectra and they are quite similar:
# new fake data (5 similar-looking spectra)
spec <- function(){
x <- jitter(seq(0,100,1),0.1)
data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
require(plyr)
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))
If these assumptions are valid, you could treat the spectra as having identical x values:
library(ggplot2)
spread_plot <- function(d, s=0.05) {
#add some checks here, e.g., for equal length
d <- d[order(d$x),]
d$id <- factor(d$id)
l <- levels(d$id)
pretty_offset <- pretty(s*min(tapply(d$y, d$id, function(x) abs(diff(range(x))))))[2]
for (i in seq_len(length(l)-1)+1) {
mean_delta_y <- mean(d[d$id == l[i], "y"] - d[d$id == l[i-1], "y"])
d[d$id == l[i], "y"] <- d[d$id == l[i], "y"] - mean_delta_y
min_delta_y <- abs(1.05 * min(d[d$id == l[i], "y"] - d[d$id == l[i-1], "y"]))
pretty_delta_y <- max(min_delta_y, pretty_offset)
d[d$id == l[i], "y"] <- d[d$id == l[i], "y"] + pretty_delta_y
}
p <- ggplot(d, aes(x=x, y=y, col=id)) + geom_line()
print(p)
}
spread_plot(all, s=0)
spread_plot(all, s=0.5)
As suggested by hadley, the for loop can be avoided very simply,
d$y <- d$y + origins[d$id]
Full code:
spread_plot <- function(d, s=1){
ranges <- ddply(d, "id", with, each(min,max,length)(x))
common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
new_y <- dlply(d, "id", function(x) approx(x$x, x$y, common_x)$y)
mat <- do.call(cbind, new_y)
test <- apply(mat, 1, diff)
shift <- max(-test[test < 0])
origins <- s*seq(0, by=shift, length=ncol(mat))
d$y <- d$y + origins[d$id]
d
}
test <- spread_plot(all)
ggplot(test, aes(x, y, colour=id, group=id))+
geom_line() + guides(colour=guide_legend())