Related
I am trying to replicate the following visual with the following Matlab code:
% Pumpkin
[X,Y,Z]=sphere(200);
R=1-(1-mod(0:.1:20,2)).^2/12;
x=R.*X; y=R.*Y; z=Z.*R;
c=hypot(hypot(x,y),z)+randn(201)*.03;
surf(x,y,(.8+(0-(1:-.01:-1)'.^4)*.3).*z,c, 'FaceColor', 'interp', 'EdgeColor', 'none')
% Stem
s = [ 1.5 1 repelem(.7, 6) ] .* [ repmat([.1 .06],1,10) .1 ]';
[t, p] = meshgrid(0:pi/15:pi/2,0:pi/20:pi);
Xs = -(.4-cos(p).*s).*cos(t)+.4;
Zs = (.5-cos(p).*s).*sin(t) + .55;
Ys = -sin(p).*s;
surface(Xs,Ys,Zs,[],'FaceColor', '#008000','EdgeColor','none');
% Style
colormap([1 .4 .1; 1 1 .7])
axis equal
box on
material([.6 1 .3])
lighting g
camlight
I am working on the bottom but have not gotten very far (see here for reference). The code that I have is:
library(pracma)
library(rgl)
sphere <- function(n) {
dd <- expand.grid(theta = seq(0, 2*pi, length.out = n+1),
phi = seq(-pi, pi, length.out = n+1))
with(dd,
list(x = matrix(cos(phi) * cos(theta), n+1),
y = matrix(cos(phi) * sin(theta), n+1),
z = matrix(sin(phi), n+1))
)
}
# Pumpkin
sph<-sphere(200)
X<-sph[[1]]
Y<-sph[[2]]
Z<-sph[[3]]
R<- 1-(1-seq(from=0, to=20,by=0.1))^2/12
x<-R * X
y<-R * Y
z<-Z * R
c<-hypot(hypot(x,y),z)+rnorm(201)*0.3
persp3d(x,y,(0.8+(0-seq(from=1, to=-1, by=-0.01)^4)*0.3)*z,col=c)
and it gives me the following.
What is it that's going wrong in my present code? What would be a suggested fix?
As #billBokeey mentioned, there's a missing mod modulo operator function for periodic scaling factors.
In addition, the scaling on the z-axis 0.8 + (0-seq(from=1, to=-1, by=-0.01)^4) * 0.3 doesn't go well with the output from your sphere function. We maybe use Z[1,] to replace seq(from=1, to=-1, by=-0.01). phi = seq(-pi, pi, length.out = n+1)) shoud be seq(-pi/2, pi/2, length.out = n+1)) instead.
Finally, the color c needs to be convert to RGB code for persp3d.
Here's the result look like from the code below.
library(rgl)
sphere <- function(n) {
dd <- expand.grid(theta = seq(0, 2*pi, length.out = n+1),
phi = seq(-pi/2, pi/2, length.out = n+1))
with(dd,
list(x = matrix(cos(phi) * cos(theta), n+1),
y = matrix(cos(phi) * sin(theta), n+1),
z = matrix(sin(phi), n+1))
)
}
# Unit ball
sph <- sphere(200)
X <- sph[[1]]
Y <- sph[[2]]
Z <- sph[[3]]
# scaling
R <- 1 - (1 - seq(from=0, to=20, by=0.1) %% 2) ^ 2 / 12 # Modulo Operator %%
R2 <- 0.8 + (0 - seq(from=1, to=-1, by=-0.01)^4)*0.2 # didn't match with the order of z from sphere function
#R2 <- 0.8 - Z[1,]^4 * 0.2
x <- R * X # scale rows for wavy side
y <- R * Y # scale rows for wavy side
z <- t(R2 * t(Z)) # scale columns by transpose for flat oval shape
# color according to distance to [0,0,0]
hypot_3d <- function(x, y, z) {
return(sqrt(x^2 + y^2 + z^2))
}
c_ <- hypot_3d(x,y,z) + rnorm(201) * 0.03
color_palette <- terrain.colors(20) # color look-up table
col <- color_palette[ as.numeric(cut(c_, breaks = 20)) ] # assign color to 20 levels of c_
persp3d(x, y, z, color = col, aspect=FALSE)
## Define the moment generating function of Weibull distribution
scale <- 1/2
shape <- 1
lambda <- 2
beta <- 0.1
## I have specified nmax=160 since I cant perform the sum until infinity
mgfw <- function(x){
nmax <- 160
scale <- scale
shape <- shape
suma <- 0
for(n in 0:nmax){
suma <- suma + ((x^n) * ((scale)^n)) * gamma(1 + (n/shape)) / factorial(n)
}
return(suma)
}
curve(mgfw, from=0.1, 0.25, ylim=c(1, 1.2))
mu <- (scale) * gamma(1 + (1 / shape))
fun2 <- function(x) 1 + x * (1 + beta) * mu
x <- seq(0, 10, length.out=100)
y <- fun2(x)
curve(fun2, from=0, 10, add=TRUE)
grid()
Solving the previous equations I got the next results:
library(rootSolve)
r <- uniroot.all(function(x) mgfw(x) - fun2(x), c(0.1, 0.185))
r
abline(v=r)
I got a plot like this
The intersection of both lines is given by the vertical line. But I would like to get a plot where the intersection can be clear in the plot. How to resize the plot? Or see in the area with different scale?
I would like to achieve that the points I add to the plot have their size adjusted to obtain a better 3D impression. I know that I somehow have to use the transformation matrix that is returned to compute the length of the vector orthogonal to the 2d plane to the respective point in 3d, but I don't know how to do that.
Here is an example:
x1 <- rnorm(100)
x2 <- 4 + rpois(100, 4)
y <- 0.1*x1 + 0.2*x2 + rnorm(100)
dat <- data.frame(x1, x2, y)
m1 <- lm(y ~ x1 + x2, data=dat)
x1r <- range(dat$x1)
x1seq <- seq(x1r[1], x1r[2], length=30)
x2r <- range(dat$x2)
x2seq <- seq(x2r[1], x2r[2], length=30)
z <- outer(x1seq, x2seq, function(a,b){
predict(m1, newdata=data.frame(x1=a, x2=b))
})
res <- persp(x1seq, x2seq, z)
mypoints <- trans3d(dat$x1, dat$x2, dat$y, pmat=res)
points(mypoints, pch=1, col="red")
You can use the function presented here to determine distance to the observer, then scale the pointsize (cex) to that distance:
# volcano data
z <- 2 * volcano # Exaggerate the relief
x <- 10 * (1:nrow(z)) # 10 meter spacing (S to N)
y <- 10 * (1:ncol(z)) # 10 meter spacing (E to W)
# draw volcano and store transformation matrix
pmat <- persp(x, y, z, theta = 35, phi = 40, col = 'green4', scale = FALSE,
ltheta = -120, shade = 0.75, border = NA, box = TRUE)
# take some xyz values from the matrix
s = sample(1:prod(dim(z)), size=500)
xx = x[row(z)[s] ]
yy = y[col(z)[s]]
zz = z[s] + 10
# depth calculation function (adapted from Duncan Murdoch at https://stat.ethz.ch/pipermail/r-help/2005-September/079241.html)
depth3d <- function(x,y,z, pmat, minsize=0.2, maxsize=2) {
# determine depth of each point from xyz and transformation matrix pmat
tr <- as.matrix(cbind(x, y, z, 1)) %*% pmat
tr <- tr[,3]/tr[,4]
# scale depth to point sizes between minsize and maxsize
psize <- ((tr-min(tr) ) * (maxsize-minsize)) / (max(tr)-min(tr)) + minsize
return(psize)
}
# determine distance to eye
psize = depth3d(xx,yy,zz,pmat,minsize=0.1, maxsize = 1)
# from 3D to 2D coordinates
mypoints <- trans3d(xx, yy, zz, pmat=pmat)
# plot in 2D space with pointsize related to distance
points(mypoints, pch=8, cex=psize, col=4)
I am trying to transform an image (represented as a matrix) in R, into polar coordinate space with the origin being 0,0 (top left corner). Given the 215x215 matrix x which looks like:
x0 = as.vector(col(x))
y0 = as.vector(row(x))
r = sqrt( (x0^2) + (y0^2) )#x
a = atan(y0/x0)#y
m = as.matrix(data.frame(y=a, x=r))
m = round(m)
m[m>215] = NA
m[m==0] = NA
xn = x[m]
xn = matrix(xn, 215, 215)
However, xn just looks like:
When I expect this:
Any idea what i'm doing wrong?
There is a problem with the angle: atan returns an angle in radians.
if you round it, there is not much information left...
Try with:
a = atan(y0/x0) * 215 / (pi/2)
It is not the image you expect, which is apparently the inverse transformation,
with the center in the middle of the image.
# Load the image
library(png)
library(RCurl)
d <- readPNG( getBinaryURL( "http://i.stack.imgur.com/rMR3C.png" ) )
image(d, col=gray(0:255/255))
# Origin for the polar coordinates
x0 <- ncol(d)/2
y0 <- nrow(d)/2
# The value of pixel (i,j) in the final image
# comes from the pixel, in the original image,
# with polar coordinates (r[i],theta[i]).
# We need a grid for the values of r and theta.
r <- 1:ceiling(sqrt( max(x0,nrow(d))^2 + max(y0,ncol(d))^2))
theta <- -pi/2 + seq(0,2*pi, length = 200)
r_theta <- expand.grid(r=r, theta=theta)
# Convert those polar coordinates to cartesian coordinates:
x <- with( r_theta, x0 + r * cos(theta) )
y <- with( r_theta, y0 + r * sin(theta) )
# Truncate them
x <- pmin( pmax( x, 1 ), ncol(d) )
y <- pmin( pmax( y, 1 ), nrow(d) )
# Build an empty matrix with the desired size and populate it
r <- matrix(NA, nrow=length(r), ncol=length(theta))
r[] <- d[cbind(x,y)]
image(r, col=gray(0:255/255))
I'm trying to perfect a method for comparing regression and PCA, inspired by the blog Cerebral Mastication which has also has been discussed from a different angle on SO. Before I forget, many thanks to JD Long and Josh Ulrich for much of the core of this. I'm going to use this in a course next semester. Sorry this is long!
UPDATE: I found a different approach which almost works (please fix it if you can!). I posted it at the bottom. A much smarter and shorter approach than I was able to come up with!
I basically followed the previous schemes up to a point: Generate random data, figure out the line of best fit, draw the residuals. This is shown in the second code chunk below. But I also dug around and wrote some functions to draw lines normal to a line through a random point (the data points in this case). I think these work fine, and they are shown in First Code Chunk along with proof they work.
Now, the Second Code Chunk shows the whole thing in action using the same flow as #JDLong and I'm adding an image of the resulting plot. Data in black, red is the regression with residuals pink, blue is the 1st PC and the light blue should be the normals, but obviously they are not. The functions in First Code Chunk that draw these normals seem fine, but something is not right with the demonstration: I think I must be misunderstanding something or passing the wrong values. My normals come in horizontal, which seems like a useful clue (but so far, not to me). Can anyone see what's wrong here?
Thanks, this has been vexing me for a while...
First Code Chunk (Functions to Draw Normals and Proof They Work):
##### The functions below are based very loosely on the citation at the end
pointOnLineNearPoint <- function(Px, Py, slope, intercept) {
# Px, Py is the point to test, can be a vector.
# slope, intercept is the line to check distance.
Ax <- Px-10*diff(range(Px))
Bx <- Px+10*diff(range(Px))
Ay <- Ax * slope + intercept
By <- Bx * slope + intercept
pointOnLine(Px, Py, Ax, Ay, Bx, By)
}
pointOnLine <- function(Px, Py, Ax, Ay, Bx, By) {
# This approach based upon comingstorm's answer on
# stackoverflow.com/questions/3120357/get-closest-point-to-a-line
# Vectorized by Bryan
PB <- data.frame(x = Px - Bx, y = Py - By)
AB <- data.frame(x = Ax - Bx, y = Ay - By)
PB <- as.matrix(PB)
AB <- as.matrix(AB)
k_raw <- k <- c()
for (n in 1:nrow(PB)) {
k_raw[n] <- (PB[n,] %*% AB[n,])/(AB[n,] %*% AB[n,])
if (k_raw[n] < 0) { k[n] <- 0
} else { if (k_raw[n] > 1) k[n] <- 1
else k[n] <- k_raw[n] }
}
x = (k * Ax + (1 - k)* Bx)
y = (k * Ay + (1 - k)* By)
ans <- data.frame(x, y)
ans
}
# The following proves that pointOnLineNearPoint
# and pointOnLine work properly and accept vectors
par(mar = c(4, 4, 4, 4)) # otherwise the plot is slightly distorted
# and right angles don't appear as right angles
m <- runif(1, -5, 5)
b <- runif(1, -20, 20)
plot(-20:20, -20:20, type = "n", xlab = "x values", ylab = "y values")
abline(b, m )
Px <- rnorm(10, 0, 4)
Py <- rnorm(10, 0, 4)
res <- pointOnLineNearPoint(Px, Py, m, b)
points(Px, Py, col = "red")
segments(Px, Py, res[,1], res[,2], col = "blue")
##========================================================
##
## Credits:
## Theory by Paul Bourke http://local.wasp.uwa.edu.au/~pbourke/geometry/pointline/
## Based in part on C code by Damian Coventry Tuesday, 16 July 2002
## Based on VBA code by Brandon Crosby 9-6-05 (2 dimensions)
## With grateful thanks for answering our needs!
## This is an R (http://www.r-project.org) implementation by Gregoire Thomas 7/11/08
##
##========================================================
Second Code Chunk (Plots the Demonstration):
set.seed(55)
np <- 10 # number of data points
x <- 1:np
e <- rnorm(np, 0, 60)
y <- 12 + 5 * x + e
par(mar = c(4, 4, 4, 4)) # otherwise the plot is slightly distorted
plot(x, y, main = "Regression minimizes the y-residuals & PCA the normals")
yx.lm <- lm(y ~ x)
lines(x, predict(yx.lm), col = "red", lwd = 2)
segments(x, y, x, fitted(yx.lm), col = "pink")
# pca "by hand"
xyNorm <- cbind(x = x - mean(x), y = y - mean(y)) # mean centers
xyCov <- cov(xyNorm)
eigenValues <- eigen(xyCov)$values
eigenVectors <- eigen(xyCov)$vectors
# Add the first PC by denormalizing back to original coords:
new.y <- (eigenVectors[2,1]/eigenVectors[1,1] * xyNorm[x]) + mean(y)
lines(x, new.y, col = "blue", lwd = 2)
# Now add the normals
yx2.lm <- lm(new.y ~ x) # zero residuals: already a line
res <- pointOnLineNearPoint(x, y, yx2.lm$coef[2], yx2.lm$coef[1])
points(res[,1], res[,2], col = "blue", pch = 20) # segments should end here
segments(x, y, res[,1], res[,2], col = "lightblue1") # the normals
############ UPDATE
Over at Vincent Zoonekynd's Page I found almost exactly what I wanted. But, it doesn't quite work (obviously used to work). Here is a code excerpt from that site which plots normals to the first PC reflected through a vertical axis:
set.seed(1)
x <- rnorm(20)
y <- x + rnorm(20)
plot(y~x, asp = 1)
r <- lm(y~x)
abline(r, col='red')
r <- princomp(cbind(x,y))
b <- r$loadings[2,1] / r$loadings[1,1]
a <- r$center[2] - b * r$center[1]
abline(a, b, col = "blue")
title(main='Appears to use the reflection of PC1')
u <- r$loadings
# Projection onto the first axis
p <- matrix( c(1,0,0,0), nrow=2 )
X <- rbind(x,y)
X <- r$center + solve(u, p %*% u %*% (X - r$center))
segments( x, y, X[1,], X[2,] , col = "lightblue1")
And here is the result:
Alright, I'll have to answer my own question! After further reading and comparison of methods that people have put on the internet, I have solved the problem. I'm not sure I can clearly state what I "fixed" because I went through quite a few iterations. Anyway, here is the plot and the code (MWE). The helper functions are at the end for clarity.
# Comparison of Linear Regression & PCA
# Generate sample data
set.seed(39) # gives a decent-looking example
np <- 10 # number of data points
x <- -np:np
e <- rnorm(length(x), 0, 10)
y <- rnorm(1, 0, 2) * x + 3*rnorm(1, 0, 2) + e
# Plot the main data & residuals
plot(x, y, main = "Regression minimizes the y-residuals & PCA the normals", asp = 1)
yx.lm <- lm(y ~ x)
lines(x, predict(yx.lm), col = "red", lwd = 2)
segments(x, y, x, fitted(yx.lm), col = "pink")
# Now the PCA using built-in functions
# rotation = loadings = eigenvectors
r <- prcomp(cbind(x,y), retx = TRUE)
b <- r$rotation[2,1] / r$rotation[1,1] # gets slope of loading/eigenvector 1
a <- r$center[2] - b * r$center[1]
abline(a, b, col = "blue") # Plot 1st PC
# Plot normals to 1st PC
X <- pointOnLineNearPoint(x, y, b, a)
segments( x, y, X[,1], X[,2], col = "lightblue1")
###### Needed Functions
pointOnLineNearPoint <- function(Px, Py, slope, intercept) {
# Px, Py is the point to test, can be a vector.
# slope, intercept is the line to check distance.
Ax <- Px-10*diff(range(Px))
Bx <- Px+10*diff(range(Px))
Ay <- Ax * slope + intercept
By <- Bx * slope + intercept
pointOnLine(Px, Py, Ax, Ay, Bx, By)
}
pointOnLine <- function(Px, Py, Ax, Ay, Bx, By) {
# This approach based upon comingstorm's answer on
# stackoverflow.com/questions/3120357/get-closest-point-to-a-line
# Vectorized by Bryan
PB <- data.frame(x = Px - Bx, y = Py - By)
AB <- data.frame(x = Ax - Bx, y = Ay - By)
PB <- as.matrix(PB)
AB <- as.matrix(AB)
k_raw <- k <- c()
for (n in 1:nrow(PB)) {
k_raw[n] <- (PB[n,] %*% AB[n,])/(AB[n,] %*% AB[n,])
if (k_raw[n] < 0) { k[n] <- 0
} else { if (k_raw[n] > 1) k[n] <- 1
else k[n] <- k_raw[n] }
}
x = (k * Ax + (1 - k)* Bx)
y = (k * Ay + (1 - k)* By)
ans <- data.frame(x, y)
ans
}
Try changing this line of your code:
res <- pointOnLineNearPoint(x, y, yx2.lm$coef[2], yx2.lm$coef[1])
to
res <- pointOnLineNearPoint(x, new.y, yx2.lm$coef[2], yx2.lm$coef[1])
So you're calling the correct y values.
In Vincent Zoonekynd's code, change the line u <- r$loadings to u <- solve(r$loadings). In the second instance of solve(), the predicted component scores along the first principal axis (i.e., the matrix of predicted scores with the second predicted components scores set to zero) need to be multiplied by the inverse of the loadings/eigenvectors. Multiplying data by the loadings gives predicted scores; dividing predicted scores by the loadings give data. Hope that helps.