Sample data:
dat1 <- data.frame(month = 1:12, rain = sample(100:200,12, replace = T), temp = sample(20:30, 12,, replace = T))
par(mfrow=c(1,2))
with(dat1, barplot(rain), ylim = c(0,500))
par(new = TRUE)
with(dat1, plot(temp, type = "b", lwd = 2, col = "red",axes = F, bty = "n", xlab = "", ylab = "", ylim = c(12,30)))
axis(side = 4, las = 2)
This plot belongs to a region in France with Id = 12
library(raster)
dat <- getData('GADM', country='FRA', level=1)
plot(dat, col = ifelse(dat$ID_1 == 12, "red","grey"))
Is there any way I can combine the two figures into one so that map of France comes
as an inset? This is in opposite to the question here where barplots are put inside the maps
How to plot barchart onto ggplot2 map
I tried this:
dat1 <- data.frame(month = 1:12, rain = sample(100:200,12, replace = T), temp = sample(20:30, 12,, replace = T))
layout(matrix(c(1,1,2,1), nrow = 2, ncol = 2, byrow = TRUE))
with(dat1, barplot(rain), ylim = c(0,500))
par(new = TRUE)
with(dat1, plot(temp, type = "b", lwd = 2, col = "red",axes = F, bty = "n", xlab = "", ylab = "", ylim = c(12,30)))
axis(side = 4, las = 2)
library(raster)
dat <- getData('GADM', country='FRA', level=1)
plot(dat, col = ifelse(dat$ID_1 == 12, "red","grey"))
But this overlaps with my barplot. How can I show it like a small inset on topright or topleft.
I see 2 options.
1/ Use a transparent background:
...
par(bg=NA)
plot(dat, col = ifelse(dat$ID_1 == 12, "red","grey"))
2/ Increase the layout matrix:
dat1 <- data.frame(month = 1:12, rain = sample(100:200,12, replace = T), temp = sample(20:30, 12,, replace = T))
layout(matrix(c(2,1,1,1,1,1,1,1,1), nrow = 3, ncol = 3, byrow = TRUE))
with(dat1, barplot(rain), ylim = c(0,500))
par(new = TRUE)
with(dat1, plot(temp, type = "b", lwd = 2, col = "red",axes = F, bty = "n", xlab = "", ylab = "", ylim = c(12,30)))
axis(side = 4, las = 2)
dat <- getData('GADM', country='FRA', level=1)
par(bg=NA)
plot(dat, col = ifelse(dat$ID_1 == 12, "red","grey"))
Related
This a reproducible example of my data
dat<-data.frame(
prec<-rnorm(650,mean=300),
temp<-rnorm(650,mean = 22),
pet<-rnorm(650,mean = 79),
bal<-rnorm(650,mean = 225))
colnames(dat)<-c("prec","temp","pet","bal")
dat<-ts(dat,start = c(1965,1),frequency = 12)
#splines
fit1<-smooth.spline(time(dat),dat[,1],df=25)
fit2<-smooth.spline(time(dat),dat[,2],df=25)
fit3<-smooth.spline(time(dat),dat[,3],df=25)
fit4<-smooth.spline(time(dat),dat[,4],df=25)
dat2 <- cbind(dat, fitted(fit1), fitted(fit2), fitted(fit3), fitted(fit4))
plot.zoo(window(dat2, start = 1965), xlab = "", screen = 1:4,
col = c(1:4, 1, 2, 3, 4),yax.flip = TRUE, bty="n")
How can I modify the color and the scale of the y axes in each plot to match the same color of the time series?
Create dat2 which contains both the series and the smooth splines, use window to start it at 1965, specify in screen= that the the columns be in panels 1:4 (it will recycle for the last 4 columns) and specify that the last 4 columns be black, i.e. 1, or modify colors to suit.
dat2 <- cbind(dat, fitted(fit1), fitted(fit2), fitted(fit3), fitted(fit4))
plot.zoo(window(dat2, start = 1965), xlab = "", screen = 1:4,
col = c(1:4, 1, 1, 1, 1))
Regarding the comment, to me it seems easier to read if the ticks, labels and axes are black but if you want to do that anyways use the mfrow= graphical parameter with a for loop and specify col.axis and col.lab in the plot.zoo call:
nc <- ncol(dat)
cols <- 1:nc # specify desired colors
opar <- par(mfrow = c(nc, 1), oma = c(6, 0, 5, 0), mar = c(0, 5.1, 0, 2.1))
for(i in 1:nc) {
dat1965 <- window(dat[, i], start = 1965)
plot(as.zoo(dat1965), col = cols[i], ylab = colnames(dat)[i], col.axis = cols[i],
col.lab = cols[i])
fit <- smooth.spline(time(dat1965), dat1965, df = 25)
lines(cbind(dat1965, fitted(fit))[, 2]) # coerce fitted() to ts
}
par(opar)
mtext("4 plots", line = -2, font = 2, outer = TRUE)
I needed to include in the code below, a vertical line,
for example, in position x = 5 and that all points smaller than 5 have another color,
for example blue.
The values of a variable can be read from the x-axis, and the y-axis shows the order of the observations in the variable (from bottom to top). Isolated points as the far ends, and on either side in a plot, suggest potentional outliers
Thanks
library(dplyr)
library(lattice)
n = 1000
df <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
MyVar <- c("xx1","xx2","xx3")
MydotplotBR <- function(DataSelected){
P <- dotplot(as.matrix(as.matrix(DataSelected)),
groups=FALSE,
strip = strip.custom(bg = 'white',
par.strip.text = list(cex = 1.2)),
scales = list(x = list(relation = "same",tck = 1,
draw = TRUE, at=seq(0,10,1)),x=list(at=seq),
y = list(relation = "free", draw = FALSE),
auto.key = list(x =1)),
col=10,
axes = FALSE,
cex = 0.4, pch = 5,
xlim=c(0,10),
xlab = list(label = "Variable Value", cex = 1.5),
ylab = list(label = "Order of data in the file", cex = 1.5))
print(P)
}
(tempoi <- Sys.time())
Vertemp <- MydotplotBR(df[,MyVar])
(tempof <- Sys.time()-tempoi)
I find it weird that you want a color dependent only on the x-axis when values are also used on the y-axis of other plots.
Nevertheless, here's a homemade pairs_cutoff() function doing what you want.
pairs_cutoff <- function(data, cutoff, cols = c("red", "blue"),
only.lower = F, ...){
data <- as.data.frame(data)
cns <- colnames(data)
nc <- ncol(data)
layout(matrix(seq_len(nc^2), ncol = nc))
invisible(
sapply(seq_len(nc), function(i){
sapply(seq_len(nc), function(j){
if(i == j){
plot.new()
legend("center", bty = "n", title = cns[i], cex = 1.5, text.font = 2, legend = "")
} else {
if(j < i & only.lower)
plot.new()
else{
if(is.null(cutoff))
cols <- cols[1]
plot(data[,i], data[,j], col = cols[(data[,i] < cutoff) + 1],
xlab = cns[i], ylab = cns[j], ...)
}
}
})
})
)
}
Using your suggested data :
n = 1000
dat <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
pairs_cutoff(dat, cutoff = 5, only.lower = T)
outputs the following plot :
You can specify extra parameters to the plot function (eg. pch) directly to pairs_cutoff.
Also, if you want the full symmetric grid of plots, set only.lower = F.
I'm trying to run a piece of R code HERE on R-Fiddle with no success. The code runs very smoothly in R but doesn't run at all HERE on R-Fiddle?
Any advise is appreciated.
alt.hyp = function(N, d){
options(warn = -1) ; d = sort(d)
df = N - 1 ; d.SE = 1/sqrt(N) ; ncp.min = min(d)*sqrt(N) ; ncp.max = max(d)*sqrt(N)
min.d = d.SE*qt(1e-5, df, ncp.min) ; max.d = d.SE*qt(0.99999, df, ncp.max)
for(i in 1:length(d)){
H = curve(dt(d[i]*sqrt(N), df, x*sqrt(N)), min.d, max.d, n = 1e3, xlab = "Effect Size",
ylab = NA, ty = "n", add = i!= 1, bty = "n", yaxt = "n", font.lab = 2)
polygon(H, col = adjustcolor(i, .7), border = NA)
text(d[i], max(H$y), bquote(bolditalic(H[.(i-1)])), pos = 3, xpd = NA)
axis(1, at = d[i], col = i, col.axis = i, font = 2)
segments(d[i], 0, d[i], max(H$y), lty = 3)
}
}
# Example of use:
alt.hyp(N = 30, d = seq(0, 2, .5))
Looks like older version of R is used on the R fiddle.
Anyway, if I redo your script in old style, it works, see here. The only changes are replacement of assignment from = to <- and single statement per line.
Code
alt.hyp <- function(N, d) {
options(warn = -1)
d <- sort(d)
df <- N - 1
d.SE <- 1/sqrt(N)
ncp.min <- min(d)*sqrt(N)
ncp.max <- max(d)*sqrt(N)
min.d <- d.SE*qt(1e-5, df, ncp.min)
max.d <- d.SE*qt(0.99999, df, ncp.max)
for(i in 1:length(d)){
H <- curve(dt(d[i]*sqrt(N), df, x*sqrt(N)), min.d, max.d, n = 1e3, xlab = "Effect Size", ylab = NA, ty = "n", add = i!= 1, bty = "n", yaxt = "n", font.lab = 2)
polygon(H, col = adjustcolor(i, .7), border = NA)
text(d[i], max(H$y), bquote(bolditalic(H[.(i-1)])), pos = 3, xpd = NA)
axis(1, at = d[i], col = i, col.axis = i, font = 2)
segments(d[i], 0, d[i], max(H$y), lty = 3)
}
N
}
q <- alt.hyp(N = 30, d = seq(0, 2, .5))
print(q)
And the output in the R Fiddle
I've been working on a HTML document with Rmarkdown.
The document has several sp plots and ggplots and all of them appear in the HTML.
But when I call plotK (which is a function from stpp package to plot the spatio-temporal inhomogeneous k-funtion - STIKhat), the plot doesnt appear in the HTML.
Here's a reproducible example for Rmarkdown:
---
title: "Untitled"
output: html_document
---
```{r}
library(stpp)
data(fmd)
data(northcumbria)
FMD<-as.3dpoints(fmd[,1]/1000,fmd[,2]/1000,fmd[,3])
Northcumbria=northcumbria/1000
# estimation of the temporal intensity
Mt<-density(FMD[,3],n=1000)
mut<-Mt$y[findInterval(FMD[,3],Mt$x)]*dim(FMD)[1]
# estimation of the spatial intensity
h<-mse2d(as.points(FMD[,1:2]), Northcumbria, nsmse=50, range=4)
h<-h$h[which.min(h$mse)]
Ms<-kernel2d(as.points(FMD[,1:2]), Northcumbria, h, nx=5000, ny=5000)
atx<-findInterval(x=FMD[,1],vec=Ms$x)
aty<-findInterval(x=FMD[,2],vec=Ms$y)
mhat<-NULL
for(i in 1:length(atx)) mhat<-c(mhat,Ms$z[atx[i],aty[i]])
# estimation of the STIK function
u <- seq(0,10,by=1)
v <- seq(0,15,by=1)
stik1 <- STIKhat(xyt=FMD, s.region=northcumbria/1000,t.region=c(1,200),
lambda=mhat*mut/dim(FMD)[1], dist=u, times=v, infectious=TRUE)
```
```{r}
plotK(stik1)
```
after knitting, the plot doesnt appear in HTML. Does anyone has some idea what is going on?
Thank you so much!
This question is a little stale, but I couldn't help but take #ryanm comment (that I just noticed) as a fun challenge. As I mentioned in the comment above, the problem lies in how the plotK function is manipulating devices. Some trimming of (unnecessary?) code in the plotK function solves the problem:
---
title: "Untitled"
output: html_document
---
```{r}
library(stpp)
data(fmd)
data(northcumbria)
FMD<-as.3dpoints(fmd[,1]/1000,fmd[,2]/1000,fmd[,3])
Northcumbria=northcumbria/1000
# estimation of the temporal intensity
Mt<-density(FMD[,3],n=1000)
mut<-Mt$y[findInterval(FMD[,3],Mt$x)]*dim(FMD)[1]
# estimation of the spatial intensity
h<-mse2d(as.points(FMD[,1:2]), Northcumbria, nsmse=50, range=4)
h<-h$h[which.min(h$mse)]
Ms<-kernel2d(as.points(FMD[,1:2]), Northcumbria, h, nx=5000, ny=5000)
atx<-findInterval(x=FMD[,1],vec=Ms$x)
aty<-findInterval(x=FMD[,2],vec=Ms$y)
mhat<-NULL
for(i in 1:length(atx)) mhat<-c(mhat,Ms$z[atx[i],aty[i]])
# estimation of the STIK function
u <- seq(0,10,by=1)
v <- seq(0,15,by=1)
stik1 <- STIKhat(xyt=FMD, s.region=northcumbria/1000,t.region=c(1,200),
lambda=mhat*mut/dim(FMD)[1], dist=u, times=v, infectious=TRUE)
```
```{r,echo=FALSE}
plotK <- function (K, n = 15, L = FALSE, type = "contour", legend = TRUE,
which = NULL, main = NULL, ...)
{
old.par <- par(no.readonly = TRUE)
on.exit(par(old.par))
correc = c("none", "isotropic", "border", "modified.border",
"translate")
correc2 = K$correction
id <- match(correc2, correc, nomatch = NA)
if ((is.null(which) && length(id) > 1) || any(is.na(match(which,
correc, nomatch = NA)))) {
mess <- paste("Please specify the argument 'which', among:",
paste(dQuote(correc2), collapse = ", "))
stop(mess, call. = FALSE)
}
if (isTRUE(K$infectious))
which = "isotropic"
if (is.matrix(K$Khat)) {
if (is.null(which))
which = correc2
else {
if (!(is.null(which)) && which != correc2) {
mess <- paste("Argument 'which' should be", paste(dQuote(correc2),
collapse = ", "))
stop(mess, call. = FALSE)
}
}
}
if (!is.matrix(K$Khat)) {
id <- match(which, correc2, nomatch = NA)
if (is.na(id)) {
mess <- paste("Please specify the argument 'which', among:",
paste(dQuote(correc2), collapse = ", "))
stop(mess, call. = FALSE)
}
else K$Khat = K$Khat[[id]]
}
if (!is.null(main)) {
titl = main
subtitl = ""
if (isTRUE(L))
k <- K$Khat - K$Ktheo
else k <- K$Khat
}
else {
if (isTRUE(L)) {
k <- K$Khat - K$Ktheo
subtitl <- paste("edge correction method: ", which,
sep = "")
if (isTRUE(K$infectious))
titl <- expression(hat(K)[ST] * group("(", list(u,
v), ")") - pi * u^2 * v)
else titl <- expression(hat(K)[ST] * group("(", list(u,
v), ")") - 2 * pi * u^2 * v)
}
else {
k <- K$Khat
titl = expression(hat(K)[ST] * group("(", list(u,
v), ")"))
subtitl <- paste("edge correction method: ", which,
sep = "")
}
}
typeplot = c("contour", "image", "persp")
id <- match(type, typeplot, nomatch = NA)
if (any(nbg <- is.na(id))) {
mess <- paste("unrecognised plot type:", paste(dQuote(type[nbg]),
collapse = ", "))
stop(mess, call. = FALSE)
}
if ((length(id) != 1) || is.na(id))
stop("Please specify one type among \"contour\", \"image\" and \"persp\" ")
typeplot = rep(0, 3)
typeplot[id] = 1
colo <- colorRampPalette(c("red", "white", "blue"))
M <- max(abs(range(k)))
M <- pretty(c(-M, M), n = n)
n <- length(M)
COL <- colo(n)
if (typeplot[3] == 1) {
mask <- matrix(0, ncol = length(K$times), nrow = length(K$dist))
for (i in 1:length(K$dist)) {
for (j in 1:length(K$times)) {
mask[i, j] <- COL[findInterval(x = k[i, j], vec = M)]
}
}
COL <- mask[1:(length(K$dist) - 1), 1:(length(K$times) -
1)]
if (isTRUE(legend)) {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 1,
mar = c(0, 0, 3, 0))
par(fig = c(0, 0.825, 0, 1))
persp(x = K$dist, y = K$times, z = k, xlab = "u",
ylab = "v", zlab = "", expand = 1, col = COL,
...)
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0.825, 1, 0, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 1)
persp(x = K$dist, y = K$times, z = k, xlab = "u",
ylab = "v", zlab = "", expand = 1, col = COL,
...)
title(titl, cex.main = 1.5, sub = subtitl)
}
}
if (typeplot[1] == 1) {
if (isTRUE(legend)) {
par(cex.lab = 1.5, cex.axis = 1.5, font = 2, plt = c(0,
1, 0, 1), lwd = 1, mar = c(0.5, 0.5, 2.5, 0.5),
las = 1)
par(fig = c(0.1, 0.825, 0.1, 1))
contour(K$dist, K$times, k, labcex = 1.5, levels = M,
drawlabels = F, col = colo(n), zlim = range(M),
axes = F)
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0, 1, 0.1, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 2,
las = 1)
contour(K$dist, K$times, k, labcex = 1.5, levels = M,
drawlabels = T, col = colo(n), zlim = range(M),
axes = F)
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl)
}
}
if (typeplot[2] == 1) {
if (isTRUE(legend)) {
par(cex.lab = 1.5, cex.axis = 1.5, font = 2, lwd = 1,
plt = c(0, 1, 0, 1), mar = c(0.5, 0.5, 2.5, 0.5),
las = 1)
par(fig = c(0.1, 0.825, 0.1, 1))
image(K$dist, K$times, k, col = colo(n), zlim = range(M),
axes = F, xlab = "", ylab = "")
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0, 1, 0.1, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 2,
las = 1)
image(K$dist, K$times, k, col = colo(n), zlim = range(M),
axes = F, xlab = "", ylab = "")
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl)
}
}
par(old.par)
}
```
```{r}
plotK(stik1)
```
If you use the stpp package often, it might be worth an e-mail to the maintainer about why messing with the device is necessary.
Try this with some extra packages in your plotting chunk:
library(png)
library(grid)
library(gridExtra)
plotK(stik1)
dev.print(png, "plot.png", width=480, height=480)
img <- readPNG("plot.png")
img <- rasterGrob(img)
grid.draw(img)
I generally create a fanplot like this:
n.ahead <- 10
m <- matrix(,nrow = 5000,ncol = 10)
library(fanplot)
m[,1] <- rnorm(5000,0.01,sd = 0.005)
m[,2] <- rnorm(5000,0.02,0.006)
m[,3] <- rnorm(5000,0.03,0.008)
m[,4] <- rnorm(5000,0.04,0.01)
m[,5] <- rnorm(5000,0.06,0.013)
m[,6] <- rnorm(5000,0.1,0.015)
m[,7] <- rnorm(5000,0.11,0.02)
m[,8] <- rnorm(5000,0.13,0.025)
m[,9] <- rnorm(5000,0.14,0.05)
m[,10] <- rnorm(5000,0.18,0.07)
n.ahead <- 10
fancol <- colorRampPalette(c('black', 'white'))
plot(
NULL, type = 'n', lwd = 3, col = 'black',
xlim = c(0, n.ahead), ylab = 'Y', ylim = c(0,max(m)), xlab = 'Year',
las = 1, xaxt = 'n', main = 'Y'
)
fan(
m, fan.col = fancol, ln.col = 'grey', txt = c('90','95', '99'),
anchor = 0, frequency = 1, probs = c(seq(1, 99, 1), 99.9, 99.95, 99.99), ln =
c(50, 90, 99, 99.9, 99.95, 99.99)
)
axis(1, at = 0:n.ahead, tcl = 0.5)
axis(1, at = seq(0, n.ahead, 0.25), labels = FALSE, tcl = 0.25)
It does the trick in the sense that a fanlplot is created. However, I don't really like it. Are there alternatives with dynamic charts like we see in dygraphs and rCharts I can use in Shiny?
Thanks.