I wish to recreate this graph:
(from here)
Using R base graphics.
I have no clue how to do that. Any advice ?
(My motivation is that I wish to create a plot where the line width (and/or color) will reflect another dimension. Until now - ggplot2 is the only place I found in R for how to do this. I would be happy to be able to do this also in base R)
See help(polygon) and example(polygon) (esp the Brownian motion example) -- the varying width is pretty common in some fields to show variability through time.
The same example is also in demo(graphics):
## An example showing how to fill between curves.
par(bg="white")
n <- 100
x <- c(0,cumsum(rnorm(n)))
y <- c(0,cumsum(rnorm(n)))
xx <- c(0:n, n:0)
yy <- c(x, rev(y))
plot(xx, yy, type="n", xlab="Time", ylab="Distance")
polygon(xx, yy, col="gray")
title("Distance Between Brownian Motions")
I don't know if exactly replicating the graph is possible in base graphics. In grid graphics it is possible. Nevertheless, the following code gets you an example that's something like what you want. Adapt it to the data set.
n <- 20
x <- rnorm(n)
y <- rnorm(n)
o <- order(x)
x <- x[o]
y <- y[o]
m <- loess(y~x, span = 1) #ggplot seems to smooth more than default
f <- predict(m, se = TRUE)
ci <- f$se * qt(0.975, f$df)
cih <- f$fit + ci
cil <- f$fit - ci
plot(x,y, ylim = c(min(cil,y), max(cih,y)))
lines(x, f$fit, lwd = 2)
xx <- c(x, rev(x))
yy <- c(cil, rev(cih))
polygon(xx, yy, col="#A9A9A930", border = NA)
OK, I spent a little too much time messing with this... note the last line is the ggplot version so you can compare the two.
#loess and error curves almost just like ggplot2
op <- par(las=1, mar = c(3,3,1,1))
n <- 30
x <- sort(rnorm(n)) #(varying density in predictor)
x <- x + abs(min(x))
x <- x/max(x)*2*pi
y <- sin(x)+rnorm(n) #(curvy)
m <- loess(y~x)
xx <- seq(min(x), max(x), (max(x)-min(x))/1000) #increase density of values to predict over to increase quality of curve
f <- predict(m, xx, se = TRUE)
ci <- f$se * qt(0.975, f$df)
cih <- f$fit + ci
cil <- f$fit - ci
plot(x,y, ylim = c(min(cil,y), max(cih,y)), cex.axis = 0.85, xlab = '', ylab = '', type = 'n')
title(xlab = 'x', ylab = 'y',line = 2)
grid(col = 'gray')
points(x,y, pch = 19, cex = 0.65)
lines(xx, f$fit, col = 'blue', lwd = 1.2)
xx <- c(xx, rev(xx))
yy <- c(cil, rev(cih))
polygon(xx, yy, col=rgb(0.1,0.1,0.1,0.25), border = NA)
par(op)
#qplot(x,y, geom = 'point') + stat_smooth()
And to get the smooth curve, look at loess and predict.loess
Would geom_ribbon in GGPlot be what you need? This creates a variable-width line.
Related
I have a problem with the following code.
It calculates the drc curve correctly, but the ec50 wrongly, although the are closely related...
x <- c(-1, -0.114074, 0.187521, 0.363612, 0.488551, 0.585461, 0.664642, 0.730782, 0.788875, 0.840106, 0.885926, 0.92737, 0.965202, 1)
y <- c(100, 3.978395643, 0.851717911, 0.697307565, 0.512455497, 0.512455497, 0.482273052, 0.479293487, 0.361024717, 0.355324864, 0.303120838, 0.286539832, 0.465692047, 0.358045152)
mat <- cbind(x, y)
df <- as.data.frame(mat)
calc <- drm(
formula = y ~ x,
data = df,
fct = L.4(names = c("hill", "min_value", "max_value", "ec50"))
)
plot <- ggplot(df, aes(x=x, y=y), color="black") +
geom_point() +
labs(x = "x", y = "y") +
theme(
axis.title.x = element_text(color="black", size=10),
axis.title.y = element_text(color="black", size=10),
axis.line.x = element_line(color = "black"),
axis.line.y = element_line(color = "black")
) +
stat_smooth(
formula = y ~ x,
method = "drm", color="black",
method.args = list(fct = L.4(names = c("hill", "min_value", "max_value", "ec50"))),
se = FALSE
) +
theme(panel.background=element_rect(fill="white"))+
ylim(0, NA)
ec50 <- ED(calc,50)
print(ec50)
print(calc)
print(plot)
This is the graph I obtain:
But if I print the parameters of the function L.4, I have the following result:
hill:(Intercept) 6.3181
min_value:(Intercept) 0.3943
max_value:(Intercept) 111.0511
ec50:(Intercept) -0.6520
max_value:(Intercept) is obviously wrong (it has to be 100), and, as a consequence, ec50 is wrong too.
I would also add that for other sets of data, the min_value:(Intercept) is wrong too (with values < 0...)
I cannot find the mistake, because the graph derived from the same function L.4 shows the right values.
Thank you very much for your help!
The upper asymptote in your case assumes a symmetrical curve (due to 4PL fitting). Meaning that both bottom and upper asymptote have the same inflection.
Your data might max out at 100 but the formula calculates the upper asymptote further than 100 (111) because that's where the actual asymptote lies, not the end of your data.
So the graph is based on your data, but the estimated parameters forces a symmetrical curve to fit it, and your asymptote increases. This will also shift the EC50.
When using rasterToPolygons within the raster package each cell that meets the formula criteria becomes its own polygon:
library(raster)
r <- raster(nrow=18, ncol=36)
r[] <- runif(ncell(r)) * 10
r[r>8] <- NA
pol <- rasterToPolygons(r, fun=function(x){x>6})
plot(pol)
I however want each polygon that has an adjacent side or corner to be part of one larger polygon, decreasing the number of total polygons. Is there any way to accomplish this?
OLD ANSWER:
You can use the argument dissolve=TRUE
library(raster)
r <- raster(nrow=18, ncol=36)
r[] <- sample(2, ncell(r), replace=TRUE)
pol <- rasterToPolygons(r, dissolve=TRUE)
plot(pol)
NEW ANSWER
If you do not care about the values, you can do something like this
Your example data
library(raster)
r <- raster(nrow=18, ncol=36)
r[] <- runif(ncell(r)) * 10
r[r>8] <- NA
Set all values cells you want to one value, all others to NA
x <- reclassify(r, rbind(c(-Inf, 6, NA), c(6, Inf, 1)))
pol <- rasterToPolygons(x, dissolve=TRUE)
Note that pol now has only 1 (multi-)polygon. If you want to separate the non-connected parts, you can do
pols <- disaggregate(pol)
pols
#class : SpatialPolygonsDataFrame
#features : 80
Note that diagonally adjecent polygons are separate from each other as they cannot for a valid single polygon (it would be self-intersecting).
This can be accomplished by using the poly2nb function in the spdep package to define the neighbors of each polygon, using the function created below to create a vector of region assignments, using spCbind from the maptools package to bind regions to pol, then finally dissolving over regions using the unionSpatialPolygons function from maptools. The basic structure of the created function is if at least one of the polygon's neighbors has been assigned to a group then assign polygon and neighbors to that group else assign polygon and neighbors to new group.
library(raster)
library(spdep)
library(maptools)
r <- raster(nrow=18, ncol=36)
r[] <- runif(ncell(r)) * 10
r[r>8] <- NA
pol <- rasterToPolygons(r, fun=function(x){x>6}, dissolve = T)
plot(pol)
nb <- poly2nb(pol)
create_regions <- function(data) {
group <- rep(NA, length(data))
group_val <- 0
while(NA %in% group) {
index <- min(which(is.na(group)))
nb <- unlist(data[index])
nb_value <- group[nb]
is_na <- is.na(nb_value)
if(sum(!is_na) != 0){
prev_group <- nb_value[!is_na][1]
group[index] <- prev_group
group[nb[is_na]] <- prev_group
} else {
group_val <- group_val + 1
group[index] <- group_val
group[nb] <- group_val
}
}
group
}
region <- create_regions(nb)
pol_rgn <- spCbind(pol, region)
pol2 <- unionSpatialPolygons(pol_rgn, region)
plot(pol2)
I'm trying to optimise the layout of a network I'm constructing with the following code:
gr <- read.table("data.txt", header = F, stringsAsFactors = F)
node.names <- gr[,1]
node.names <- toupper(substr(node.names, 2, nchar(node.names)))
gr <- gr[,-1]
edge.table.index <- which(gr>0.5, arr.ind=T)
d <- data.frame(first = node.names[edge.table.index[,1]], second = node.names[edge.table.index[,2]])
g <- graph.data.frame(d, directed=F)
g[from=V(g), to=V(g)] <- 0
layout.g <- layout.fruchterman.reingold(g)
plot(g, layout = layout.g, vertex.size = 5, vertex.label.cex=.7, vertex.color = "lightblue", vertex.label.family = "sans", edge.color="black", vertex.frame.color= "white")
In particular, what I'm trying to do is decrease the area on which the nodes are displayed such that the connected components are closer together. Previous versions of igraph had the option 'area' in the layout.fruchterman.reingold() function but this doesn't seem to be the case anymore. I've tried playing with various options like vertex size, vertex font size and width/height of the exported pdf file but they don't really do the trick.
Does anyone have a suggestion? Here's a link to the data file, I hope it works:
data.txt
I want to write something like a virtual telescope that looks into the night sky.
Till now I've a star catalog and I want to project them into a plane to get a mock picture.
I speculate the projection to be a gnomonic projection, which can be found here and here.
In the second link, an alg on calculating the pixel position of stars.
Forward:
Define
scale: number of pixels per degree in the map
alpha, delta: Equatorial coordinates of a given position
alpha0, delta0: Equatorial coordinates of the map center
A = cos(delta) x cos(alpha - alpha0)
F = scale x (180/pi)/[sin(delta0) x sin(delta) + A x cos(delta0)]
then the pixel coordinates in the image are
LINE = -F x [cos(delta0) x sin(delta) - A x sin(delta0)]
SAMPLE = -F x cos(delta) x sin(alpha - alpha0)
Reverse:
Define
X = SAMPLE/(scale x 180/pi)
Y = LINE/(scale x 180/pi)
D = arctan[(X^2 + Y^2)^0.5]
B = arctan(-X/Y)
XX = sin(delta0) x sin(D) x cos(B) + cos(delta0) x cos(D)
YY = sin(D) x sin(B)
then the right ascension and declination are
alpha = alpha0 + arctan(YY/XX)
delta = arcsin[sin(delta0) x cos(D) - cos(delta0) x sin(D) x cos(B)]
NOTE: The arctangent functions for B and alpha must be four-quadrant arctangents.
However I don't know whether the angles should be in deg or rad, and what's the meaning of SAMPLE and LINE.
And I'm neither sure about using gnomonic projection.
Any help or discussion is welcome.
Yeah, just perform an ordinary camera projecion.
I have a data that looks like this:
for_y_axis <-c(0.49534,0.80796,0.93970,0.99998)
for_x_axis <-c(1,2,3,4)
count <-c(0,33,0,4)
What I want to do is to plot the graph using for_x_axis and for_y_axis
but will mark the point with "o" if the count value is equal to 0(zero) and
with "x" if the count value is greater than zero.
Is there a simple way to achieve that in R?
plot(for_x_axis, for_y_axis, pch = ifelse(count > 0, "x", "o"))
How does this sound? Adjust pch to your needs.
for_y_axis <- c(0.49534,0.80796,0.93970,0.99998)
for_x_axis <- c(1,2,3,4)
count <- c(0,33,0,4)
zerocount <- function(x) {
ifelse (x == 0, x <- 0, x <- 1)
}
pts <- sapply(count, zerocount)
plot(for_x_axis, for_y_axis, type = "n")
points(for_x_axis, for_y_axis, pch = pts)