Related
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.
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"))
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 have challenge in plotting a bivariate raster data in one plot with one legend for both variables. my first layer is a continuous variable ranging between -2 and 2 while the second layer is a categorical variable (in years form 1980 to 2011). I need help in ploting the data as one rastr plot with a color scheme and legend which shows both variables as shown here. I appreciate your help.
r <- raster(ncols=100, nrows=100)
r[] <- runif(ncell(r))
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
r1 <- raster(ncols=100, nrows=100)
r1[] <- 1980:2011
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
dta=stack(r,r1)
See ?raster::plot for examples, or do spplot(dta)
I successfully applied the code from the site you mentioned.
kpacks <- c("classInt", 'raster', 'rgdal',
'dismo', 'XML', 'maps', 'sp')
new.packs <- kpacks[!(kpacks %in% installed.packages()[, "Package"])]
if (length(new.packs))
install.packages(new.packs)
lapply(kpacks, require, character.only = T)
remove(kpacks, new.packs)
r <- raster(ncols = 100, nrows = 100)
r[] <- runif(ncell(r))
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
r1 <- raster(ncols = 100, nrows = 100)
r1[] <- sample(1980:2011, 10000, replace = T)
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
dta = stack(r, r1)
plot(dta)
colmat <-
function(nquantiles = 10,
upperleft = rgb(0, 150, 235, maxColorValue = 255),
upperright = rgb(130, 0, 80, maxColorValue = 255),
bottomleft = "grey",
bottomright = rgb(255, 230, 15, maxColorValue = 255),
xlab = "x label",
ylab = "y label") {
my.data <- seq(0, 1, .01)
my.class <- classIntervals(my.data, n = nquantiles, style = "quantile")
my.pal.1 <- findColours(my.class, c(upperleft, bottomleft))
my.pal.2 <- findColours(my.class, c(upperright, bottomright))
col.matrix <- matrix(nrow = 101, ncol = 101, NA)
for (i in 1:101) {
my.col <- c(paste(my.pal.1[i]), paste(my.pal.2[i]))
col.matrix[102 - i, ] <- findColours(my.class, my.col)
}
plot(
c(1, 1),
pch = 19,
col = my.pal.1,
cex = 0.5,
xlim = c(0, 1),
ylim = c(0, 1),
frame.plot = F,
xlab = xlab,
ylab = ylab,
cex.lab = 1.3
)
for (i in 1:101) {
col.temp <- col.matrix[i - 1, ]
points(
my.data,
rep((i - 1) / 100, 101),
pch = 15,
col = col.temp,
cex = 1
)
}
seqs <- seq(0, 100, (100 / nquantiles))
seqs[1] <- 1
col.matrix <- col.matrix[c(seqs), c(seqs)]
}
col.matrix <-
colmat(
nquantiles = 10,
upperleft = "blue",
upperright = "yellow",
bottomleft = "green",
bottomright = "red",
xlab = "My x label",
ylab = "My y label"
)
bivariate.map <-
function(rasterx,
rastery,
colormatrix = col.matrix,
nquantiles = 10) {
quanmean <- getValues(rasterx)
temp <- data.frame(quanmean, quantile = rep(NA, length(quanmean)))
brks <-
with(temp, quantile(temp, na.rm = TRUE, probs = c(seq(0, 1, 1 / nquantiles))))
r1 <-
within(
temp,
quantile <-
cut(
quanmean,
breaks = brks,
labels = 2:length(brks),
include.lowest = TRUE
)
)
quantr <- data.frame(r1[, 2])
quanvar <- getValues(rastery)
temp <- data.frame(quanvar, quantile = rep(NA, length(quanvar)))
brks <-
with(temp, quantile(temp, na.rm = TRUE, probs = c(seq(0, 1, 1 / nquantiles))))
r2 <-
within(temp,
quantile <-
cut(
quanvar,
breaks = brks,
labels = 2:length(brks),
include.lowest = TRUE
))
quantr2 <- data.frame(r2[, 2])
as.numeric.factor <- function(x) {
as.numeric(levels(x))[x]
}
col.matrix2 <- colormatrix
cn <- unique(colormatrix)
for (i in 1:length(col.matrix2)) {
ifelse(is.na(col.matrix2[i]),
col.matrix2[i] <- 1,
col.matrix2[i] <- which(col.matrix2[i] == cn)[1])
}
cols <- numeric(length(quantr[, 1]))
for (i in 1:length(quantr[, 1])) {
a <- as.numeric.factor(quantr[i, 1])
b <- as.numeric.factor(quantr2[i, 1])
cols[i] <- as.numeric(col.matrix2[b, a])
}
r <- rasterx
r[1:length(r)] <- cols
return(r)
}
my.colors = colorRampPalette(c("white", "lightblue", "yellow", "orangered", "red"))
plot(
r,
frame.plot = F,
axes = F,
box = F,
add = F,
legend.width = 1,
legend.shrink = 1,
col = my.colors(255)
)
map(interior = T, add = T)
bivmap <- bivariate.map(r, r1, colormatrix = col.matrix, nquantiles = 10)
# Plot the bivariate map:
plot(
bivmap,
frame.plot = F,
axes = F,
box = F,
add = F,
legend = F,
col = as.vector(col.matrix)
)
col.matrix