Related
I am trying to draw a cuboid of given coordinates of vertices : (-3,-2,-5), (-3,-2,6), (-3,3,-5), (-3,3,6), (7,-2,-5), (7,-2,6), (7,3,-5), (7,3,6) using rgl package. That I have done in the following manner :
library(rgl)
vertices1 <- c(
-3, -2, -5, 1,
7, -2, -5, 1,
7, 3, -5, 1,
-3, 3, -5, 1
)
vertices2 <- c(
-3, -2, 6, 1,
7, -2, 6, 1,
7, 3, 6, 1,
-3, 3, 6, 1
)
vertices3 <- c(
-3, -2, -5, 1,
-3, -2, 6, 1,
-3, 3, 6, 1,
-3, 3, -5, 1
)
vertices4 <- c(
7, -2, -5, 1,
7, -2, 6, 1,
7, 3, 6, 1,
7, 3, -5, 1
)
vertices5 <- c(
-3, 3, -5, 1,
7, 3, -5, 1,
7, 3, 6, 1,
-3, 3, 6, 1
)
vertices6 <- c(
-3, -2, -5, 1,
7, -2, -5, 1,
7, -2, 6, 1,
-3, -2, 6, 1
)
indices <- c( 1, 2, 3, 4 )
open3d()
wire3d( qmesh3d(vertices1, indices) , col = "blue")
wire3d( qmesh3d(vertices2, indices) , col = "blue" )
wire3d( qmesh3d(vertices3, indices) , col = "blue")
wire3d( qmesh3d(vertices4, indices) , col = "blue")
shade3d(qmesh3d(vertices1, indices) , col = "blue", alpha = 0.1)
shade3d(qmesh3d(vertices2, indices) , col = "blue", alpha = 0.1)
shade3d(qmesh3d(vertices3, indices) , col = "blue", alpha = 0.1)
shade3d(qmesh3d(vertices4, indices) , col = "blue", alpha = 0.1)
shade3d(qmesh3d(vertices5, indices) , col = "blue", alpha = 0.1)
shade3d(qmesh3d(vertices6, indices) , col = "blue", alpha = 0.1)
Is there any better way to do it using rgl ?
More concisely, and avoiding to repeat some vertices:
library(rgl)
vertices <- cbind(
c(-3,-2,-5),
c(-3,-2, 6),
c(-3, 3,-5),
c(-3, 3, 6),
c( 7,-2,-5),
c( 7,-2, 6),
c( 7, 3,-5),
c( 7, 3, 6)
)
indices <- cbind(
c(1, 5, 7, 3),
c(2, 6, 8, 4),
c(1, 2, 4, 3),
c(5, 6, 8, 7),
c(3, 7, 8, 4)
c(1, 5, 6, 2)
)
cuboid <- qmesh3d(
vertices = vertices,
indices = indices,
homogeneous = FALSE
)
shade3d(cuboid, color = "blue", alpha = 0.1)
wire3d(cuboid, color = "blue")
Though this problem has been 'solved' many times, it turns out there's always another problem.
Without the print function it runs with no errors, but with it I get the following:
Error in .subset2(x, i) : recursive indexing failed at level 2
Which I'm taking to mean it doesn't like graphs being created in two layers of iteration? Changing the method to 'qplot(whatever:whatever)' has the exact same problem.
It's designed to print a graph for every pairing of the variables I'm looking at. There's too many for them to fit in a singular picture, such as for the pairs function, and I need to be able to see the actual variable names in the axes.
load("Transport_Survey.RData")
variables <- select(Transport, "InfOfReceievingWeather", "InfOfReceievingTraffic", "InfOfSeeingTraffic", "InfWeather.Ice", "InfWeather.Rain", "InfWeather.Wind", "InfWeather.Storm", "InfWeather.Snow", "InfWeather.Cold", "InfWeather.Warm", "InfWeather.DarkMorn", "InfWeather.DarkEve", "HomeParking", "WorkParking", "Disability", "Age", "CommuteFlexibility", "Gender", "PassionReduceCongest")
varnames <- list("InfOfReceivingWeather", "InfOfReceivingTraffic", "InfOfSeeingTraffic", "InfWeather.Ice", "InfWeather.Rain", "InfWeather.Wind", "InfWeather.Storm", "InfWeather.Snow", "InfWeather.Cold", "InfWeather.Warm", "InfWeather.DarkMorn", "InfWeather.DarkEve", "HomeParking", "WorkParking", "Disability", "Age", "CommuteFlexibility", "Gender", "PassionReduceCongest")
counterx = 1
countery = 1
for (a in variables) {
for (b in variables) {
print(ggplot(variables, mapping=aes(x=variables[[a]], y=variables[[b]],
xlab=varnames[counterx], ylab=varnames[countery]))+
geom_point())
countery = countery+1
counterx = counterx+1
}
}
#variables2 <- select(Transport, one_of(InfOfReceivingWeather, InfOfReceivingTraffic, InfOfSeeingTraffic, InfWeather.Ice, InfWeather.Rain, InfWeather.Wind, InfWeather.Storm, InfWeather.Snow, InfWeather.Cold, InfWeather.Warm, InfWeather.DarkMorn, InfWeather.DarkEve, HomeParking, WorkParking, Disability, Age, CommuteFlexibility, Gender, PassionReduceCongest))
Here is a mini-data frame for reference, sampled from the columns I'm using:
structure(list(InfOfReceievingWeather = c(1, 1, 1, 1, 4), InfOfReceievingTraffic = c(1,
1, 1, 1, 4), InfOfSeeingTraffic = c(1, 1, 1, 1, 4), InfWeather.Ice = c(3,
1, 3, 5, 5), InfWeather.Rain = c(1, 1, 2, 2, 4), InfWeather.Wind = c(1,
1, 2, 2, 4), InfWeather.Storm = c(1, 1, 1, 2, 5), InfWeather.Snow = c(1,
1, 2, 5, 5), InfWeather.Cold = c(1, 1, 1, 2, 5), InfWeather.Warm = c(1,
1, 1, 1, 3), InfWeather.DarkMorn = c(1, 1, 1, 1, 1), InfWeather.DarkEve = c(1,
1, 1, 1, 1), HomeParking = c(1, 1, 3, 1, 1), WorkParking = c(1,
4, 4, 5, 4), Disability = c(1, 1, 1, 1, 1), Age = c(19, 45, 35,
40, 58), CommuteFlexibility = c(2, 1, 5, 1, 2), Gender = c(2,
2, 2, 2, 1), PassionReduceCongest = c(0, 0, 2, 0, 2)), row.names = c(NA,
-5L), class = c("tbl_df", "tbl", "data.frame"))
You get an error in the assignment of your a and b. Basically, when defining a and b in variables, they become the vector of values contained in columns of variables. Thus, in your aes mapping, when you are calling variables[[a]], basically, you are writing (for the first iteration of a in variables):
variables[[c(1, 1, 1, 1, 4)]] instead of variables[["InfOfReceievingWeather"]]. So, it can't work.
To get over this issue, you have to either choose between:
for (a in variables) {
for (b in variables) {
print(ggplot(variables, mapping=aes(x=a, y=b)) ...
or
for (a in 1:ncol(variables)) {
for (b in 1:ncol(variables)) {
print(ggplot(variables, mapping=aes(x=variables[[a]], y=variables[[b]])) ...
Despite the first one seems to be simpler, I will rather prefere the second option because it will allow you to recycle a and b as column indicator to extract colnames of variables for xlab and ylab.
At the end, writing something like this should work:
for (a in 1:ncol(variables)) {
for (b in 1:ncol(variables)) {
print(ggplot(variables, mapping=aes(x=variables[[a]], y=variables[[b]])) +
xlab(colnames(variables)[a])+
ylab(colnames(variables)[b])+
geom_point())
}
}
Does it answer your question ?
This question is a continuation of my previous question here.
I have a heatmap with a dataset available. The dataset is pasted below:
library(ggplot2)
library(colorspace)
library(directlabels)
smalltest <- structure(list(x = c(-8, -7, -6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8,
-8, -7, -6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, -8,
-7, -6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, -8, -7,
-6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, -8, -7, -6,
-5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, -8, -7, -6, -5,
-4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8),
y = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5),
z = c(0.353727812855041, 0.512450876310741,
0.668920303216554, 0.770942367746301, 0.829915628317595, 0.873001682466956,
0.900219155289838, 0.918353789896507, 0.936488424503176, 0.954641684205298,
0.961439844045867, 0.972770110446816, 0.975042372092157, 0.981846740297877,
0.986385055223408, 0.986385055223408, 0.986385055223408, 0.33104865495769,
0.464820298870698, 0.62128351741136, 0.752801524774481, 0.804964208774903,
0.850322524569605, 0.879812259037828, 0.913821683336127, 0.934222371222986,
0.950109577644919, 0.959173790765678, 0.970504057166626, 0.975042372092157,
0.981846740297877, 0.986385055223408, 0.986385055223408, 0.986385055223408,
0.31064175870568, 0.428544821292209, 0.589558771488704, 0.725596468681902,
0.786835782533385, 0.838986049803505, 0.872995474101805, 0.897946893644497,
0.920613634811545, 0.943299001074047, 0.956907737485488, 0.970504057166626,
0.970504057166626, 0.981840531932726, 0.986385055223408, 0.986385055223408,
0.986385055223408, 0.29023486245367, 0.419493024901753, 0.569145666871543,
0.702929727514853, 0.775480682671832, 0.827655783402557, 0.866197314261236,
0.891148733803927, 0.916075319886014, 0.931943901212494, 0.952369422559957,
0.970504057166626, 0.970504057166626, 0.981840531932726, 0.981840531932726,
0.986385055223408, 0.986385055223408, 0.272100227847001, 0.396807658639251,
0.557778150279687, 0.691580836018451, 0.766410261185922, 0.807248887150547,
0.857126892775325, 0.888876472158586, 0.911543213325635, 0.929684056297455,
0.941020531063555, 0.959155165670224, 0.968231795521285, 0.977302217007196,
0.981840531932726, 0.984112793578067, 0.984112793578067, 0.265302068006432,
0.396789033543797, 0.557784358644838, 0.680244361252351, 0.761871946260391,
0.800444518944826, 0.841264519813997, 0.882078312318017, 0.909277160045445,
0.931950109577645, 0.941014322698404, 0.954623059109845, 0.961421218950414,
0.972763902081665, 0.977302217007196, 0.984112793578067, 0.984112793578067)),
row.names = c(NA, -102L), class = c("tbl_df", "tbl", "data.frame"))
I can generate a heatmap and contour lines based on the dataset presented above.
ggplot(smalltest, aes(x = x, y = y)) +
geom_tile(aes(fill = z)) +
scale_fill_continuous_divergingx(palette = 'RdBu', rev = FALSE, mid = 0.9, l3 = 0, p3 = 0.95, p4 = 0.85) +
scale_x_continuous(expand = c(0, 0), breaks = -8:8) +
scale_y_continuous(expand = c(0, 0), breaks = 0:5) +
geom_contour(aes(z = z), breaks = c(0.8, 0.9, 0.95), color = 'black', size = 1) +
geom_dl(aes(label = c(rep(NA, 99), 'Low', 'Middle', 'High')), method = 'last.points')
I have the following questions:
How do I have the geom_dl() only look/use the ends or the sides of the contour lines for those labels? I added the rep(NA,99) initially as I get an error stating that the length of label must either be equal to 1 or the length of the dataset (102 here). But how can I simply just pass through a vector of custom strings?
How do I extend the contour lines to the ends of the tile?
Thanks!
Created on 2019-11-07 by the reprex package (v0.3.0)
I have a data frame:
tes <- data.frame(x = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
y = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
d = c(10, 20, 30, 100, 11, 12, 403, 43, 21))
They look like this on the plot
ggplot(aes(x = x, y = y), data = tes) + geom_point(aes(color = factor(d)), size = 5)
I'd like to "mirror the outer rows in this data to obtain such data and plot
tes1 <- data.frame(x = c(0, 0, 0, 0,0, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4),
y = c(0, 1, 2, 3, 4, 0, 1, 2, 3, 4, 0, 1, 2, 3, 4, 0, 1, 2, 3, 4, 0, 1, 2, 3, 4),
d = c(10, 10, 20, 30, 30, 10, 10, 20, 30, 30, 100, 100, 11, 12, 12, 403, 403, 43, 21, 21, 403, 403, 43, 21, 21))
ggplot(aes(x = x, y = y), data = tes1) + geom_point(aes(color = factor(d)), size = 4)
Does this do what you're after?
Explanation: We first convert tes into a flattened table with ftable(xtabs(...). Then we simply replicate the first and last column, and first and last row. We then give new column and row names to reflect the extra "flanking" rows and columns, and finally convert back to a long dataframe with data.frame(table(...))
# Convert to table then matrix
m <- ftable(xtabs(d ~ x + y, data = tes));
class(m) <- "matrix";
# Replicate first and last column/row by binding to the beginning
# and end, respectively of the matrix
m <- cbind(m[, 1], m, m[, ncol(m)]);
m <- rbind(m[1, ], m, m[nrow(m), ]);
# Set column/row names
rownames(m) <- seq(min(tes$x) - 1, max(tes$x) + 1);
colnames(m) <- seq(min(tes$y) - 1, max(tes$y) + 1);
# Convert back to long dataframe
tes.ext <- data.frame(as.table(m));
colnames(tes.ext) <- colnames(tes);
# Plot
ggplot(aes(x = x, y = y), data = tes.ext) + geom_point(aes(color = factor(d)), size = 5)
Data
tes <- data.frame(x = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
y = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
d = c(10, 20, 30, 100, 11, 12, 403, 43, 21))
I´ve tried to calculate the rate of population increase, denoted as r, which is obtained from:
sum(e^(r*x)*lx*mx) = 1
I know the values of x, lx, and mx, but r value should be iteratively obtained to get a sum of one.
This is the code I wrote (or tried to), which it´s not correct as it returns values for the sum but not for r.
I don´t know what´s wrong. I´ll appreciate any clue to solve this.
Thanks.
lx <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0)
mx <- c(1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0)
x <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
18, 19, 20, 21, 22)
radj = sum((exp(-r*x))*lx*mx)
for (radj in 0:1) {
repeat { radj <- sum((exp(-r*x))*lx*mx)
print(radj)
if (radj < 1) break ()} }
Try this:
root <- uniroot( f = function(r) sum(exp(r*x)*lx*mx) - 1, interval = c(-1, 0))
root$root
> [1] -0.8340894