I have a curve, derived from empirical data, and I can obtain a reasonable model of it. I need to identify a point (x, y) where the curve intersects a circle of known center and radius. The following code illustrates the question.
x <- c(0.05, 0.20, 0.35, 0.50, 0.65, 0.80, 0.95,
1.10, 1.25, 1.40, 1.55, 1.70, 1.85, 2.00,
2.15, 2.30, 2.45, 2.60, 2.75, 2.90, 3.05)
y <- c(1.52, 1.44, 1.38, 1.31, 1.23, 1.15, 1.06,
0.96, 0.86, 0.76, 0.68, 0.61, 0.54, 0.47,
0.41, 0.36, 0.32, 0.29, 0.27, 0.26, 0.26)
fit <- loess(y ~ x, control = loess.control(surface = "direct"))
newx <- data.frame(x = seq(0, 3, 0.01))
fitline <- predict(fit, newdata = newx)
est <- data.frame(newx, fitline)
plot(x, y, type = "o",lwd = 2)
lines(est, col = "blue", lwd = 2)
library(plotrix)
draw.circle(x = 3, y = 0, radius = 2, nv = 1000, lty = 1, lwd = 1)
To obtain the point of intersection we can use the optim function in r to do so:
circle=function(x){
if(4<(x-3)^2) return(NA)# Ensure it is limited within the radius
sqrt(4-(x-3)^2)
}
fun=function(x)predict(fit,data.frame(x=x))
g=function(x)(circle(x)-fun(x))# We need to set this to zero. Ie solve this
sol1=optimise(function(x)abs(g(x)),c(1,5))$min
[1] 1.208466
Thus the two functions should evaluate to the same value at x=1.208466..
To make it even more precise, you can use the optim function:
sol2= optim(1,function(x)abs(g(x)),g,method="Brent",upper=5,lower=1)$par
[1] 1.208473
Now you can evaluate:
circle(sol1)
[1] 0.889047
fun(sol1)
1
0.8890654
circle(sol2)
[1] 0.889061
fun(sol2)
1
0.889061
From the above, you can tell that solution 2 is very close..
Plotting this point on the graph will be challenging since the draw.circle function draws circles in proportionality with the zxes.. Thus changing everytime depending on how big the plot region is.
If you were to write your own circle function:
circleplot=function(x,y,r){
theta=seq(0,2*pi,length.out = 150)
cbind(x+r*cos(theta),y+r*sin(theta))
}
Then you can do:
plot(x, y, type = "o",lwd = 2)
lines(est, col = "blue", lwd = 2)
lines(circleplot(3,0,2))
abline(v=sol2,col=2)
points(sol2,fun(sol2),col=2,pch=16)
It's straightforward to find the intersection using functions from the sf package.
Calculate the circle values (inspired by this answer and as done by #Onyambu)
circ <- function(xc = 0, yc = 0, r = 1, n = 100){
v <- seq(0, 2 * pi, len = n)
cbind(x = xc + r * cos(v),
y = yc + r * sin(v))
}
m <- circ(xc = 3, yc = 0, r = 2)
Convert the predicted values and the circle values to "simple features" (LINESTRING), and find their intersection (a POINT):
library(sf)
int <- st_intersection(st_linestring(as.matrix(est)),
st_linestring(m))
int
# POINT (1.2091 0.8886608)
Add the intersection to your plot:
plot(x, y, type = "o", lwd = 2)
lines(est, col = "blue", lwd = 2)
lines(m)
points(int[1], int[2], col = "red", pch = 19)
Related
I am trying to fit a model that linearly relates two variables using R. I need to fit a Orthogonal Linear Regression (total least squares). So I'm trying to use the odregress() function of the pracma package which performs an Orthogonal Linear Regression via PCA.
Here an example data:
x <- c(1.0, 0.6, 1.2, 1.4, 0.2, 0.7, 1.0, 1.1, 0.8, 0.5, 0.6, 0.8, 1.1, 1.3, 0.9)
y <- c(0.5, 0.3, 0.7, 1.0, 0.2, 0.7, 0.7, 0.9, 1.2, 1.1, 0.8, 0.7, 0.6, 0.5, 0.8)
I'm able to fit the model and get the coefficient using:
odr <- odregress(y, x)
c <- odr$coeff
So, the model is defined by the following equation:
print(c)
[1] 0.65145762 -0.03328271
Y = 0.65145762*X - 0.03328271
Now I need to plot the line fit, compute the RMSE and the R-squared. How can I do that?
plot(x, y)
Here are two functions to compute the MSE and RMSE.
library(pracma)
x <- c(1.0, 0.6, 1.2, 1.4, 0.2, 0.7, 1.0, 1.1, 0.8, 0.5, 0.6, 0.8, 1.1, 1.3, 0.9)
y <- c(0.5, 0.3, 0.7, 1.0, 0.2, 0.7, 0.7, 0.9, 1.2, 1.1, 0.8, 0.7, 0.6, 0.5, 0.8)
odr <- odregress(y, x)
mse_odreg <- function(object) mean(object$resid^2)
rmse_odreg <- function(object) sqrt(mse_odreg(object))
rmse_odreg(odr)
#> [1] 0.5307982
Created on 2023-01-10 with reprex v2.0.2
Edit
The R^2 can be computed with the following function. Note that odr$ssq is not the sum of the squared residuals, odr$resid, it is the sum of the squared errors, odr$err.
r_squared_odreg <- function(object, y) {
denom <- sum((y - mean(y))^2)
1 - object$ssq/denom
}
r_squared_odreg(odr, y)
#> [1] 0.1494818
Created on 2023-01-10 with reprex v2.0.2
Here is another alternative to solve an Orthogonal Linear Regression (total least squares) via PCA according to what is explained in this post. It actually does the same as pracma::odregress.
x <- c(1.0, 0.6, 1.2, 1.4, 0.2, 0.7, 1.0, 1.1, 0.8, 0.5, 0.6, 0.8, 1.1, 1.3, 0.9)
y <- c(0.5, 0.3, 0.7, 1.0, 0.2, 0.7, 0.7, 0.9, 1.2, 1.1, 0.8, 0.7, 0.6, 0.5, 0.8)
In this case we perform a Principal Component Analysis using the prcomp() function.
v <- prcomp(cbind(x,y))$rotation
Then we calculate the slope (m) from the firs principal component and the intercept (n):
# Y = mX + n
m <- v[2,1]/v[1,1]
n <- mean(y) - (m*mean(x))
Our model is defined by: f <- function(x){(m*x) + n}
We can plot it using:
plot(x, y)
abline(n, m, col="blue")
Finally we plot the Total Least Squares fit versus the Ordinary Least Squares fit.
plot(x, y)
abline(n, m, col="blue")
abline(lm(y~x), col="red")
legend("topleft", legend=c("TLS", "OLS"), col=c("blue", "red"), lty=1, bty="n")
As you can see we obtain the same results as in pracma::odregress:
odr <- odregress(y, x)
print(odr$coeff)
print(paste(round(m, digits=7), round(n, digits=7)))
[1] 0.5199081 0.2558142
[1] 0.5199081 0.2558142
I need make meteorological maps with package lattice. But i found a problem in comand levelplot(). I can make maps with the comand using a regular label. E.g: Correlation maps with label 0, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35 0.4... In this example the label skip five by five (Fig.1).
h1<- levelplot(var~x*y,data = idw.msk.dfr,contour=F,at=seq(0,0.5,0.05),
par.settings = paleta1,main = "correlation map",
xlab = NULL, ylab = NULL, ylim = c(-60,15), xlim = c(-90,-30))
Figure 1:
But, i need make maps with non-regular values. E.g: 0, 0.1, 0.15, 0.2, 0.22, 0.25, 0.40... When put this values in code, i get this result (Fig.2):
h1<- levelplot(var~x*y,data = idw.msk.dfr,contour=F,at=c(0,0.1,0.15,0.2,0.22,0.25,0.4,0.5),
par.settings = paleta1,main = "correlation map",
xlab = NULL, ylab = NULL, ylim = c(-60,15), xlim = c(-90,-30))
Figure 2
Note that the label of map is very strange and inrregular.
So. How do i solve this problem? I will apreciate your help.
You need to specify a custom colorkey. Add colorkey to the levelplot function.
x <- seq(pi/4, 5 * pi, length = 100)
y <- seq(pi/4, 5 * pi, length = 100)
r <- as.vector(sqrt(outer(x^2, y^2, "+")))
grid <- expand.grid(x=x, y=y)
grid$z <- cos(r^2) * exp(-r/(pi^3))
breaks <- c(0, 0.1, 0.15, 0.2, 0.22, 0.25, 0.4, 0.5)
levelplot(z~x*y, grid, at=breaks)
myColorkey=list(at=breaks, labels=list(at=breaks, labels=breaks))
levelplot(z~x*y, grid, colorkey=myColorkey)
To have the same size for the intervals change the at argument:
ats=seq(0, 0.5, by=0.07)
myColorkey=list(at=ats, labels=list(at=ats, labels=breaks))
levelplot(z~x*y, grid, colorkey=myColorkey)
I am trying to use grid.arrange to combine multiple types of graph/table, one of which is a correlation matrix using corrplot. Is there a way to convert a corrplot to a grob or export/import as an image compatible with grid.arrange? Since the other plots I'm combining are from ggplot and tableGrob, I can't seem to use par(mfrow = c(2, 2)) or layout(matrix(1:2)) as suggested in other posts.
P1 <- corrplot(PANAcor, order="hclust", addgrid.col = "gray",
type="full", col = col2(50), tl.cex=1.5, tl.col="black",
method="color", tl.pos="lt", tl.srt=45, hclust.method = "average",
cl.ratio = 0.25, cl.align = "l", number.cex = 2)
summary <- grid.arrange(
top=textGrob(sprintf("%s Summary",subject), gp=gpar(fontsize=16,font=8)),
blank, P1, P2,
blank, T1, T2,
ncol=3, widths = c(0.1, 3, 3),
nrow=2, heights= c(1, 1),
bottom = textGrob(sprintf("%s run %s",version,runtime),
gp=gpar(fontsize=6,font=8), hjust=-1)
)
Error in gList(list(1, 0.45, 0.62, 0.55, 0.68, 0.64, -0.13, -0.37,
-0.22, : only 'grobs' allowed in "gList" In addition: Warning message: In grob$wrapvp <- vp : Coercing LHS to a list
Data:
PANAcor <- structure(c(1, 0.56, 0.68, -0.49, -0.4, -0.39, 0.56, 1, 0.64, -0.55,
-0.49, -0.54, 0.68, 0.64, 1, -0.69, -0.57, -0.65, -0.49,
-0.55, -0.69, 1, 0.82, 0.73, -0.4, -0.49, -0.57, 0.82, 1,
0.71, -0.39, -0.54, -0.65, 0.73, 0.71, 1),
.Dim = c(6L, 6L),
.Dimnames = list(c("Anxious", "Irritable", "Upset", "Happy",
"Enthusiastic", "Outgoing"),
c("Anxious", "Irritable", "Upset", "Happy",
"Enthusiastic", "Outgoing")))
col2 <- colorRampPalette(c("#7bffff","#7bbdff","#0000ff","black",
"#ff1a1a","#ff8000","#ffff4d"))
grid.echo + grid.grab from the gridGraphics package will convert a graphic drawn by corrplot into an identical-looking grob. Trouble is, the grob only looks identical at the exact same graphics device size.
Reproducing the problem:
library(gridGraphics)
library(grid)
corrplot(PANAcor, order="hclust", addgrid.col = "gray",
type="full", col = col2(50), tl.cex=1.5, tl.col="black",
method="color", tl.pos="lt", tl.srt=45, hclust.method = "average",
cl.ratio = 0.25, cl.align = "l", number.cex = 2)
## grab the scene as a grid object & save it to P1
grid.echo()
P1 <- grid.grab()
grid.draw(P1) # looks fine, until you resize the graphics device
Original size (looks identical to the graphic generated by corrplot:
Larger size (coloured regions remain squares, even though the matrix has extended to rectangular cells, & don't extend to the edge of each cell):
Smaller size (coloured regions have a minimum height / width, which cause them to spill out beyond the confines of each cell):
And if we arrange multiple grobs together, it's almost certainly going to look weird:
library(gridExtra)
grid.arrange(P1, P1, P1, layout_matrix = matrix(c(1, 1, 2, 3), nrow = 2, ncol = 2))
In short, due to the way corrplot draws the graphic, all other children grobs in P1 adjust in sync when the graphics device is re-sized, except for the grob responsible for colour.
Solution:
# save correlation matrix colors to a vector, then make coloured matrix grob transparent
matrix.colors <- getGrob(P1, gPath("square"), grep = TRUE)[["gp"]][["fill"]]
P1 <- editGrob(P1,
gPath("square"), grep = TRUE,
gp = gpar(col = NA,
fill = NA))
# apply the saved colours to the underlying matrix grob
P1 <- editGrob(P1,
gPath("symbols-rect-1"), grep = TRUE,
gp = gpar(fill = matrix.colors))
# convert the background fill from white to transparent, while we are at it
P1 <- editGrob(P1,
gPath("background"), grep = TRUE,
gp = gpar(fill = NA))
Replace gPath("square") with gPath("circle") if you use corrplot's default method. I haven't tested the other method options for the corresponding grob names, but the general principle should be similar.
Check that everything's aligned now:
grid.arrange(P1, P1, P1, layout_matrix = matrix(c(1, 1, 2, 3), nrow = 2, ncol = 2))
By the way, you may want to adjust the text size arguments in corrplot. Based on your current code, the labels appear rather large, and are liable to be cut off when you arrange multiple plots together.
I have two plots that I would like to overlay in a particular way. Instead of side by side like when using par(), I would like one to sit inside the other, but be about a quarter the size.
More details: one of my plots is a map, another is a scatterplot with colored quadrants. The colored quadrants represent the colors plotted onto the map, so I would like to inset it nicely in the same plot as the map so that it serves as a legend.
Thanks in advance
Here's an example, although the links in comments point to similar approaches.
Grab a shapefile:
download.file(file.path('http://www.naturalearthdata.com/http/',
'www.naturalearthdata.com/download/50m',
'cultural/ne_50m_admin_1_states_provinces_lakes.zip'),
{f <- tempfile()})
unzip(f, exdir=tempdir())
Plotting:
library(rgdal)
shp <- readOGR(tempdir(), 'ne_50m_admin_1_states_provinces_lakes')
plot(subset(shp, admin=='Australia'),
col=sample(c('#7fc97f', '#beaed4', '#fdc086', '#ffff99'),
9, repl=TRUE))
opar <- par(plt=c(0.75, 0.95, 0.75, 0.95), new=TRUE)
plot.new()
plot.window(xlim=c(0, 1), ylim=c(0, 1), xaxs='i', yaxs='i')
rect(0, 0, 0.5, 0.5, border=NA, col='#7fc97f')
rect(0.5, 0, 1, 0.5, border=NA, col='#beaed4')
rect(0, 0.5, 0.5, 1, border=NA, col='#fdc086')
rect(0.5, 0.5, 1, 1, border=NA, col='#ffff99')
points(runif(100), runif(100), pch=20, cex=0.8)
box(lwd=2)
par(opar)
See plt under ?par for clarification.
This is how I did it in the past
grid.newpage()
vp <- viewport(width = 1, height = 1)
submain <- viewport(width = 0.9, height = 0.9, x = 0.5, y = 1,just=c("center","top"))
print(p, vp = submain)
subvp2 <- viewport(width = 0.2, height = 0.2, x = 0.39, y = 0.35,just=c("right","top"))
print(hi, vp = subvp2)
subvp1 <- viewport(width = 0.28, height = 0.28, x = 0.0, y = 0.1,just=c("left","bottom"))
print(ak, vp = subvp1)
in my case p, ak and hi were gg objects (maps created with ggplot) and I was inserting a small version of each near the main use map (p) - as it is typically done
I have a data set like the following one:
data<-data.frame(x=c(50,100,250,400),y1=c(0.74,0.75,0.82,0.79),y2=c(0.81,0.83,0.87,0.88))
I generate the plot like this:
plot(data$x,data$y1,type='l',col="red",xaxs='i',yaxs='i',ylim=c(0.4,1),xlim=c(50,500))
lines(data$x, data$y2, type='l',col="blue")
The generated figure is:
How could I make the following modifications on this plot?
1) The current X axis starts with 50. But it does not mark 50 explicitly.
2) The current X axis is marked as 100, 200, 300, 400, 500, Can I mark it as 50,100, 250,500?
3) The current Y axis is marked as 0.5, 0.6,0.7.0.8,0.9,1.0. Can I mark it as 0.5, 0.55, 0.6, 0.65, 0.7,0.75, 0.8, 0.85, 0.9, 0.95, 1?
4) I would like to add some grid line parallel to X axis. These lines should start at points of 0.5, 0.55, 0.6, 0.65, 0.7,0.75, 0.8, 0.85, 0.9, 0.95, 1 along the Y-axis.
data<-data.frame(x=c(50,100,250,400),y1=c(0.74,0.75,0.82,0.79),y2=c(0.81,0.83,0.87,0.88))
windows()
plot(data$x,data$y1,type="l",col="red", ylim=c(0.5,1),xlim= c(50,500),col.axis = "white")
axis(1, xaxp=c(50,500,9))
axis(2, yaxp=c(0.5,1,10))
lines(data$x, data$y2, type='l',col="blue")
for(i in c(0.55,0.6,0.65,0.7,0.75,0.8,0.85,0.9,0.95)) {
lines(c(50,500),c(i,i),type="l",lty=2,lwd=0.5, col="black")
rm(i)
}