This is the 3d version of this question.
Consider the following data:
Income2<-structure(list(X = 1:30, Education = c(21.5862068965517, 18.2758620689655,
12.0689655172414, 17.0344827586207, 19.9310344827586, 18.2758620689655,
19.9310344827586, 21.1724137931034, 20.3448275862069, 10, 13.7241379310345,
18.6896551724138, 11.6551724137931, 16.6206896551724, 10, 20.3448275862069,
14.1379310344828, 16.6206896551724, 16.6206896551724, 20.3448275862069,
18.2758620689655, 14.551724137931, 17.448275862069, 10.4137931034483,
21.5862068965517, 11.2413793103448, 19.9310344827586, 11.6551724137931,
12.0689655172414, 17.0344827586207), Seniority = c(113.103448275862,
119.310344827586, 100.689655172414, 187.586206896552, 20, 26.2068965517241,
150.344827586207, 82.0689655172414, 88.2758620689655, 113.103448275862,
51.0344827586207, 144.137931034483, 20, 94.4827586206897, 187.586206896552,
94.4827586206897, 20, 44.8275862068966, 175.172413793103, 187.586206896552,
100.689655172414, 137.931034482759, 94.4827586206897, 32.4137931034483,
20, 44.8275862068966, 168.965517241379, 57.2413793103448, 32.4137931034483,
106.896551724138), Income = c(99.9171726114381, 92.579134855529,
34.6787271520874, 78.7028062353695, 68.0099216471551, 71.5044853814318,
87.9704669939115, 79.8110298331255, 90.00632710858, 45.6555294997364,
31.9138079371295, 96.2829968022869, 27.9825049000603, 66.601792415137,
41.5319924201478, 89.00070081522, 28.8163007592387, 57.6816942573605,
70.1050960424457, 98.8340115435447, 74.7046991976891, 53.5321056283034,
72.0789236655191, 18.5706650327685, 78.8057842852386, 21.388561306174,
90.8140351180409, 22.6361626208955, 17.613593041445, 74.6109601985289
)), .Names = c("X", "Education", "Seniority", "Income"), class = "data.frame", row.names = c(NA,
-30L))
How can one do a 3d plot of the model, including: 3d scatterplot + model surface + connecting points to surface ?
I already have one easy and beautiful solution using car and rgl packages:
scatter3d(Income ~Seniority + Education, data=Income2, fit="smooth")
But I would like to see more ways to do it, specially with base graphics, lattice and "pure" rgl.
I figured out how to do it with base graphics:
Fit model:
model <- loess(Income ~Education + Seniority, data=Income2)
Create sequencies of x's and y's:
x <-range(Income2$Education)
x <- seq(x[1], x[2], length.out=50)
y <- range(Income2$Seniority)
y <- seq(y[1], y[2], length.out=50)
Create values of z with all the combinations of x and y:
z <- outer(x,y,
function(Education,Seniority)
predict(model, data.frame(Education,Seniority)))
Plot with persp:
p <- persp(x,y,z, theta=30, phi=30,
col="lightblue",expand = 0.5,shade = 0.2,
xlab="Education", ylab="Seniority", zlab="Income")
Project 3d points to 2d, so you can use points and segment:
obs <- trans3d(Income2$Education, Income2$Seniority,Income2$Income,p)
pred <- trans3d(Income2$Education, Income2$Seniority,fitted(model),p)
points(obs, col="red",pch=16)
segments(obs$x, obs$y, pred$x, pred$y)
Related
I want to fit my points with logarithmic curve. Here is my data which contains x and y. I desire to plot x and y and the add a logarithmic fitting curve.
x<-structure(list(X2.y = c(39.99724745, 29.55541525, 23.39578201,
15.46797044, 10.52063652, 7.296161198, 6.232038434, 4.811851132,
4.641281547, 4.198523289, 3.325515839, 2.596563723, 1.894902523,
1.556380314), X5.y = c(62.76037622, 48.54726084, 37.71302646,
24.93942365, 17.71060023, 13.31130267, 10.36341862, 7.706914722,
7.170517624, 6.294292013, 4.917428837, 3.767836298, 2.891519878,
2.280974128), X10.y = c(77.83154815, 61.12151516, 47.19228808,
31.21034981, 22.47098182, 17.29384973, 13.09875178, 9.623698726,
8.845091983, 7.681873268, 5.971413758, 4.543320659, 3.551367285,
2.760718282), X25.y = c(96.87401383, 77.00911883, 59.16936025,
39.13368164, 28.48573658, 22.32580849, 16.55485248, 12.0455604,
10.96092113, 9.435085861, 7.303126501, 5.523147205, 4.385086234,
3.366876291), X50.y = c(111.0008027, 88.79545082, 68.05463659,
45.01166182, 32.94782526, 26.05880295, 19.11878542, 13.84223574,
12.53056405, 10.73571912, 8.291067088, 6.25003851, 5.003586577,
3.81655893), X100.y = c(125.0232816, 100.4947544, 76.87430545,
50.84623991, 37.37696657, 29.76423356, 21.66378667, 15.6256447,
14.08861698, 12.0267487, 9.271712877, 6.971562563, 5.61752001,
4.262921183)), class = "data.frame", row.names = c(NA, -14L))
I tried this:
single_idf<-function(x) {
idf<-x
durations = c(5/60, 10/60, 15/60, 30/60, 1, 2, 3, 4, 5, 6, 8, 12, 18, 24)
nd = length(durations)
Tp = c(2, 5, 10, 25, 50, 100)
nTp = length(Tp)
psym = seq(1, nTp)
# open new window for this graph, set plotting parameters for a single graph panel
windows()
par(mfrow = c(1,1), mar = c(5, 5, 5, 5), cex = 1)
# set up custom axis labels and grid line locations
ytick = c(1,2,3,4,5,6,7,8,9,10,20,30,40,50,60,70,80,90,100,
200,300,400,500,600,700,800,900,1000,1100,1200,1300,1400)
yticklab = as.character(ytick)
xgrid = c(5,6,7,8,9,10,15,20,30,40,50,60,120,180,240,300,360,
420,480,540,600,660,720,840,960,1080,1200,1320,1440)
xtick = c(5,10,15,20,30,60,120,180,240,300,360,480,720,1080,1440)
xticklab = c("5","10","15","20","30","60","2","3","4","5","6","8","12","18","24")
ymax1 = max(idf)
durations = durations*60
plot(durations, col=c("#FF00FF") ,lwd=c(1), idf[, 1],
xaxt="n",yaxt="n",
pch = psym[1], log = "xy",
xlim = c(4, 24*60), ylim = range(c(1,idf+150)),
xlab = "(min) Duration (hr)",
ylab = "Intensity (mm/hr)"
)
for (iT in 2:nTp) {
points(durations, idf[, iT], pch = psym[iT], col="#FF00FF",lwd=1)
}
for (iT in 1:nTp) {
mod.lm = lm(log10(idf[, iT]) ~ log10(durations))
b0 = mod.lm$coef[1]
b1 = mod.lm$coef[2]
yfit = log(10^(b0 + b1*log10(durations)))
lines(durations,col=c("#FF00FF"),yfit, lty = psym[iT],lwd=1)
}
}
But when I run this, the curves stands far away from the points. I want to see curves over the points. How can I arrange this?
single_idf(x)
Consider this as an option for you using ggplot2 and dplyr. Also added method='lm' to match OP expected output (Many thanks and credits to #AllanCameron for his magnificent advice):
library(ggplot2)
library(dplyr)
#Data
df <- data.frame(x,y)
#Plot
df %>%
pivot_longer(-y) %>%
ggplot(aes(x=log(y),y=log(value),color=name,group=name))+
geom_point()+
stat_smooth(geom = 'line',method = 'lm')
Output:
The main problem is that you were plotting the natural log of the fit rather than the fit itself.
If you change the line
yfit = log(10^(b0 + b1*log10(durations)))
To
yfit = 10^(b0 + b1*log10(durations))
And rerun your code, you get
I would like to make some plots from my data. Unfortunately, it is hard to predict how many plots I will generate because it depends on data and may be different. It is a reason why I would like to make it easy adjustable. However, it will be most often a plot from group of 3 rows each time.
So, I would like to plot from rows 1:3, 4-6,7-9, etc.
This is data:
> dput(DF_final)
structure(list(AC = c(0.0031682160632777, 0.00228591145206846,
0.00142094444568728, 0.000661218113472149, 0.0010078157353918,
0.000400289437089513, 40.4634784175177, 40.5055070858594, 0.0183737773741582
), SD = c(0.00250647379467532, 0.0013244185401148, 0.000469332241199189,
0.000294558308707343, 0.000385553400676202, 0.000104447914881357,
11.0693842400794, 8.78768774254084, 0.00696532251341454), ln_AC = c(-5.75458660556339,
-6.08099044923792, -6.556433525855, -7.32142679754668, -6.89996992823399,
-7.8233226797995, 3.70039979980691, 3.70143794229703, -3.99683077355773
), ln_SD = c(-5.98887837626238, -6.62678175351058, -7.66419963690747,
-8.13003358225542, -7.86083085139947, -9.16682203300101, 2.40418312097106,
2.17335162163583, -4.96681136795312), Percent_AC = c(126.401324043689,
172.597361244303, 302.758754023937, 224.477834753288, 261.394591157605,
383.243109777925, 365.544076706723, 460.934756361151, 263.789326894369
), Percent_SD = c(100, 100, 100, 100, 100, 100, 100, 100, 100
), TP = c(0, 40, 80, 0, 40, 80, 0, 40, 80)), row.names = c("Tim_0",
"Tim_40", "Tim_80", "Jack_0", "Jack_40", "Jack_80", "Tom_0",
"Tom_40", "Tom_80"), class = "data.frame")
Column ln_AC should be set as an Y axis and column TP as X axis. First of all I would like to have all of them on separate graphs next to each other (remember about issue that the number of plots may be igh at some point) and if possible everything at the same graph. It should be a point plot with trend line.
Is it also possible to get a slope, SD slope, R^2 on a plot from linear regression ?
I manage to do it a for a single plot but regression line looks strange...
The code below was used to generate this plot and regression line.
fit <- lm(DF_final$ln_AC~DF_final$TP, data=DF_final)
plot(DF_final[1:3,7], DF_final[1:3,3], type = "p", ylim = c(-10,0), xlim=c(0,100), col = "red")
lines(DF_final$TP, fitted(fit), col="blue")
In base R (without so many packages), you can do:
# splits every 3 rows
DF = split(DF_final,gsub("_[^ ]*","",rownames(DF_final) ))
# you can also do
# DF = split(DF_final,(1:nrow(DF_final) - 1) %/%3 ))
To store your values:
slopes = vector("numeric",3)
names(slopes) = names(DF)
rsq = vector("numeric",3)
names(rsq) = names(DF)
To plot:
par(mfrow=c(1,3))
for(i in names(DF)){
fit <- lm(ln_AC~TP, data=DF[[i]])
plot(DF[[i]]$TP, DF[[i]]$ln_AC, type = "p", col = "red",main=i)
abline(fit, col="blue")
slopes[i]=round(fit$coefficients[2],digits=2)
rsq[i]=round(summary(fit)$r.squared,digits=2)
mtext(side=1,paste("slope=",slopes[i],"\nrsq=",rsq[i]),
padj=-2,cex=0.7)
}
And your values:
slopes
Jack Tim Tom
-0.01 -0.01 -0.10
rsq
Jack Tim Tom
0.29 0.99 0.75
If I understand correctly, the reason you want 3 observation per graph is because you have different individuals (Jack,Tim,Tom) . Is that so?
If you don't want to worry about that number, you can do this
# move rownames to column
data$person <- rownames(data)
data$person <- gsub("\\_.*","",data$person) # remove TP from names
# better to use library(data.table) for this step
data <- melt(data,id.vars=c("person","TP","ln_AC"))
ggplot(data,aes(x=TP, y=ln_AC)) + geom_point() +
geom_smooth(method = "lm") + facet_grid(~person)
This results in a plot like #giocomai, but it will work also if you have 4,5,6 or whatever persons in your data.
---- Edit
If you want to add R2 values, you can do something like this. Note, that it may not be the best and elegant solution, but it works.
data <- data.frame(...)
data$person <- rownames(data)
data$person <- gsub("\\_.*","",data$person)
# run lm for all persons and save them in a data.frame
nomi <- unique(data$person)
#lmStats <- data.frame()
lmStats <- sapply(nomi,
function(ita){
model <- lm(ln_AC~TP,data= data[which(data$person == ita),])
lmStat <- summary(model)
# I only save r2, but you can get all the statistics you need
lmRow <- data.frame("r2" = lmStat$r.squared )
#lmStats <- rbind(lmStats,lmRow)
}
)
lmStats <- do.call(rbind,lmStats)
# format the output,and create a dataframe we will use to annotate facet_grid
lmStats <- as.data.frame(lmStats)
rownames(lmStats) <- gsub("\\..*","",rownames(lmStats))
lmStats$person <- rownames(lmStats)
colnames(lmStats)[1] <- "r2"
lmStats$r2 <- round(lmStats$r2,2)
lmStats$TP <- 40
lmStats$ln_AC <- 0
lmStats$lab <- paste0("r2= ",lmStats$r2)
# melt and add r2 column to the data (not necessary, but I like to have everything I plot in teh data)
data <- melt(data,id.vars=c("person","TP","ln_AC"))
data$r2 <- lmStats[match(data$person,rownames(lmStats)),1]
ggplot(data,aes(x=TP, y=ln_AC)) + geom_point() +
geom_smooth(method = "lm") + facet_grid(~person) +
geom_text(data=lmStats,label=lmStats$lab)
An easier way (less steps) would be to use facet_grid(~r2), so that you have the R.square value in the title.
If I understand correctly what you mean, assuming you will always have three observation per graph, your main issue would be creating a categorical variable to separate them. Here's one way to accomplish it. Depending on the layout you prefer, you may want to check facet_wrap instead of facet_grid.
library("dplyr")
library("ggplot2")
DF_final <- structure(list(AC = c(0.0031682160632777, 0.00228591145206846,
0.00142094444568728, 0.000661218113472149, 0.0010078157353918,
0.000400289437089513, 40.4634784175177, 40.5055070858594, 0.0183737773741582
), SD = c(0.00250647379467532, 0.0013244185401148, 0.000469332241199189,
0.000294558308707343, 0.000385553400676202, 0.000104447914881357,
11.0693842400794, 8.78768774254084, 0.00696532251341454), ln_AC = c(-5.75458660556339,
-6.08099044923792, -6.556433525855, -7.32142679754668, -6.89996992823399,
-7.8233226797995, 3.70039979980691, 3.70143794229703, -3.99683077355773
), ln_SD = c(-5.98887837626238, -6.62678175351058, -7.66419963690747,
-8.13003358225542, -7.86083085139947, -9.16682203300101, 2.40418312097106,
2.17335162163583, -4.96681136795312), Percent_AC = c(126.401324043689,
172.597361244303, 302.758754023937, 224.477834753288, 261.394591157605,
383.243109777925, 365.544076706723, 460.934756361151, 263.789326894369
), Percent_SD = c(100, 100, 100, 100, 100, 100, 100, 100, 100
), TP = c(0, 40, 80, 0, 40, 80, 0, 40, 80)), row.names = c("Tim_0",
"Tim_40", "Tim_80", "Jack_0", "Jack_40", "Jack_80", "Tom_0",
"Tom_40", "Tom_80"), class = "data.frame")
DF_final %>%
mutate(id = as.character(sapply(1:(nrow(DF_final)/3), rep, 3))) %>%
ggplot(aes(x=TP, y=ln_AC)) +
geom_point() +
geom_smooth(method = "lm") +
facet_grid(~id)
Created on 2020-02-06 by the reprex package (v0.3.0)
> dput(head(inputData))
structure(list(Date = c("2018:07:00", "2018:06:00", "2018:05:00",
"2018:04:00", "2018:03:00", "2018:02:00"), IIP = c(125.8, 127.5,
129.7, 122.6, 140.3, 127.4), CPI = c(139.8, 138.5, 137.8, 137.1,
136.5, 136.4), `Term Spread` = c(1.580025, 1.89438, 2.020112,
1.899074, 1.470544, 1.776862), RealMoney = c(142713.9916, 140728.6495,
140032.2762, 139845.5215, 139816.4682, 139625.865), NSE50 = c(10991.15682,
10742.97381, 10664.44773, 10472.93333, 10232.61842, 10533.10526
), CallMoneyRate = c(6.161175, 6.10112, 5.912088, 5.902226, 5.949956,
5.925538), STCreditSpread = c(-0.4977, -0.3619, 0.4923, 0.1592,
0.3819, -0.1363)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
I want to make my autoregressive plot like this plot:
#------> importing all libraries
library(readr)
install.packages("lubridtae")
library("lubridate")
install.packages("forecast")
library('ggplot2')
library('fpp')
library('forecast')
library('tseries')
#--------->reading data
inputData <- read_csv("C:/Users/sanat/Downloads/exercise_1.csv")
#--------->calculating the lag=1 for NSE50
diff_NSE50<-(diff(inputData$NSE50, lag = 1, differences = 1)/lag(inputData$NSE50))
diff_RealM2<-(diff(inputData$RealMoney, lag = 1, differences = 1)/lag(inputData$RealMoney))
plot.ts(diff_NSE50)
#--------->
lm_fit = dynlm(IIP ~ CallMoneyRate + STCreditSpread + diff_NSE50 + diff_RealM2, data = inputData)
summary(lm_fit)
#--------->
inputData_ts = ts(inputData, frequency = 12, start = 2012)
#--------->area of my doubt is here
VAR_data <- window(ts.union(ts(inputData$IIP), ts(inputData$CallMoneyRate)))
VAR_est <- VAR(y = VAR_data, p = 12)
plot(VAR_est)
I want to my plots to get plotted together in same plot. How do I serparate the var() plots to two separate ones.
Current plot:
My dataset :
dataset
Okay, so this still needs some work, but it should set the right framework for you. I would look more into working with the ggplot2 for future.
Few extra packages needed, namely library(vars) and library(dynlm).
Starting from,
VAR_est <- VAR(y = VAR_data, p = 12)
Now we extract the values we want from the VAR_est object.
y <- as.numeric(VAR_est$y[,1])
z <- as.numeric(VAR_est$y[,2])
x <- 1:length(y)
## second data set on a very different scale
par(mar = c(5, 4, 4, 4) + 0.3) # Leave space for z axis
plot(x, y, type = "l") # first plot
par(new = TRUE)
plot(x, z, type = "l", axes = FALSE, bty = "n", xlab = "", ylab = "")
axis(side=4, at = pretty(range(z)))
mtext("z", side=4, line=3)
I will leave you to add the dotted lines on etc...
Hint: Decompose the VAR_est object, for example, VAR_est$datamat, then see which bit of data corresponds to the part of the plot you want.
Used some of this
I have two matrices of bearing and speed data for ocean currents
bearings <- matrix(data = c(170.0833, 175.6863, 182.3538, 180.3335, 170.8965,
178.3276, 182.3693, 187.2196, 182.3533, 168.3498,
189.1664, 187.6813, 187.0393, 180.2259, 166.8412,
193.4223, 188.5367, 182.4128, 175.2626, 167.3058,
192.2930, 185.5073, 175.0302, 168.6284, 167.8392),
ncol = 5, nrow = 5, byrow = F)
speed <- matrix(data = c(0.1389173, 0.1585099, 0.1796583, 0.2021887, 0.2117295,
0.1196745, 0.1463118, 0.1637266, 0.1730471, 0.1804999,
0.1309982, 0.1546123, 0.1593298, 0.1517513, 0.1550037,
0.1621728, 0.1694083, 0.1606560, 0.1459710, 0.1457233,
0.1659898, 0.1535861, 0.1396885, 0.1294339, 0.1337756),
ncol = 5, nrow = 5, byrow = F)
I wanted to graph the direction of the current bearings with arrows, while the magnitude/speed of the current is represented by the length of the arrow, a bit something like these maps:
Wind stress figure taken from Shankar et al. 2002
I know the package oce may be able to do something like that, but it specifically works with different types of oceanographic data rather than matrices/data frames that I'm using.
Anyone happen to know how to do that? I have gotten as far as making them into raster objects using the raster() function from the raster library:
library(raster)
bearing.rst <- raster(bearings,
xmn = 66,
xmx = 67.3333,
ymn = 10.6667,
ymx = 12)
speed.rst <- raster(speed,
xmn = 66,
xmx = 67.3333,
ymn = 10.6667,
ymx = 12)
Ideally I'd do this with base R graphics, or with a package that plays nice with base R graphics (e.g. not ggplot2 or lattice).
Graph from:
Shankar, D., Vinayachandra, P.N., & Unnikrishnan, A.S. (2002). The monsoon currents in the north Indian Ocean. Progress in Oceanography, 52: 62-120. doi: 10.1016/S0079-6611(02)00024-1
with base R:
plot(bearing.rst) # your base map, I use this because I didn't have it
Get your starting coordinates:
arr.coor <- rasterToPoints(bearing.rst)
arr.coor <- cbind(arr.coor[,-3], bearing=c(t(bearings)), speed=c(t(speed)))
Calculate your finishing coordinates with trigonometric functions:
x1 <- arr.coor[,1] + arr.coor[,4] * cos(arr.coor[,3]*pi/180)
y1 <- arr.coor[,2] + arr.coor[,4] * sin(arr.coor[,3]*pi/180)
arr.coor <- cbind(arr.coor, x1, y1)
Plot your arrows:
arrows(arr.coor[,1],arr.coor[,2],arr.coor[,5],arr.coor[,6])
I guess the same principal could work with ggplot2. The idea is to get a table with all your arrows origin and end.
With ggplot
bearings <- c(170.0833, 175.6863, 182.3538, 180.3335, 170.8965,
178.3276, 182.3693, 187.2196, 182.3533, 168.3498,
189.1664, 187.6813, 187.0393, 180.2259, 166.8412,
193.4223, 188.5367, 182.4128, 175.2626, 167.3058,
192.2930, 185.5073, 175.0302, 168.6284, 167.8392)
speed <- c(0.1389173, 0.1585099, 0.1796583, 0.2021887, 0.2117295,
0.1196745, 0.1463118, 0.1637266, 0.1730471, 0.1804999,
0.1309982, 0.1546123, 0.1593298, 0.1517513, 0.1550037,
0.1621728, 0.1694083, 0.1606560, 0.1459710, 0.1457233,
0.1659898, 0.1535861, 0.1396885, 0.1294339, 0.1337756)
df <- data.frame(x = rep(1:5,5),
y = rep(1:5, each = 5),
bearings = bearings,
speed = speed)
df$dx <- sin((df$bearings)/360*pi*2)*df$speed
df$dy <- cos((df$bearings)/360*pi*2)*df$speed
ggplot(df, aes(x, y)) +
geom_segment(aes(xend = x + dx, yend = y + dy),
arrow = arrow(length = unit(0.1,"cm"))) +
theme_bw()
I am trying to develop pictorial charts. Is it possible to develop such charts in R ?
myd <- data.frame (categories = c("Planes", "Ships", "Cars", "Trains"),
values = c(15, 18, 22, 11))
Component icons are here:
Hope that this would be helpful four your house / parliament floor
Edit: I forget to mention my reference and I add some explanations.
library(lattice)
library(grid)
imgs.names <- c('WNinq','7dqJM','9E3Wj','tStmx')
library(png)
images <- lapply(imgs.names, function(x)
readPNG(paste(mypath,x,'.png',sep=''),native=TRUE))
## I generate some data because we don't give a reproducible example
x <- c(rep(0,4),rep(10,9),rep(20,3),rep(5,8),rep(4,8),rep(15,4),rep(13,8))
barchart(1:4~x, origin=0, col="yellow",xlim=c(0,30),
xlab ='values',ylab='categories',title = 'Pictorial',
scales = list(
y = list(cex=2,col='blue', at = 1:4,labels = c('Trains','Cars','Ships','Planes')),
x = list(cex=2,col='blue',at=seq(0,30,by=10))
),
panel=function(x, y, ...) {
panel.fill(col = rgb(1,1,205/255)) ## I had to pick up the same yellow color!!
panel.grid()
lapply(1:4,function(id){
grid.raster(images[[id]], x=x[which(y==id)], y=y[which(y==id)],
default.units="native",
just="left",
width =unit(2, "native"),
height=unit(0.7, "native"))
}
)
}
)