Intersect Spatial Lines in R - r

I have the next spatial object in R.
library(sp)
library(rgeos)
poly1 <- structure(c(-3.25753225, -3.33532866, -3.33503723, -3.35083008,
-3.35420388, -3.407372, -3.391667, -3.254167, -3.248129, -3.25753225,
47.78513433, 47.73738617, 47.73793803, 47.74440261, 47.74004583,
47.803846, 47.866667, 47.866667, 47.806292, 47.78513433),
.Dim = c(10L, 2L), .Dimnames = list(NULL, c("x", "y")))
poly2 <- structure(c(-3.101871, -3.097764, -3.20532, -3.260711, -3.248129,
-3.101871, 47.777041, 47.735975, 47.709087, 47.777982, 47.806292, 47.777041),
.Dim = c(6L, 2L), .Dimnames = list(NULL, c("x", "y")))
sobj <- SpatialPolygons(
list(
Polygons(list(Polygon(poly1)), ID = '1'),
Polygons(list(Polygon(poly2)), ID = '2')),
proj4string = CRS('+proj=merc'))
plot(sobj)
I would like to obtain a Spatial Object containing the border line that the two polygons have in common, that is, the line that is in green in the next image.
lines <- matrix(c(-3.248129, -3.25753225, 47.806292, 47.78513433), 2, 2)
lobj <- SpatialLines(
list(
Lines(list(Line(lines)), ID = '1')),
proj4string = CRS('+proj=merc'))
plot(lobj, col = 'green', add = TRUE)
lines <- matrix(c(-3.248129, -3.25753225, 47.806292, 47.78513433), 2, 2)
lobj <- SpatialLines(
list(
Lines(list(Line(lines)), ID = '1')),
proj4string = CRS('+proj=merc'))
plot(lobj, col = 'green', add = TRUE)
So far I have tried with the gIntersection function in rgeos package but it does not do what I require. How would I get this?

I think rgeos::gIntersection would be the method of choice, if your lines perfectly overlap. Consider the following simple example:
l1 <- SpatialLines(list(Lines(list(Line(rbind(c(1, 1), c(5, 1)))), 1)))
l2 <- SpatialLines(list(Lines(list(Line(rbind(c(3, 1), c(10, 1)))), 1)))
plot(0, 0, ylim = c(0, 2), xlim = c(0, 10), type = "n")
lines(l1, lwd = 2, lty = 2)
lines(l2, lwd = 2, lty = 3)
lines(gIntersection(l1, l2), col = "red", lwd = 2)
One solution to your problem, although not perfect and maybe someone else has a better solution, would be to add a tiny buffer.
xx <- as(sobj, "SpatialLines")
xx <- gBuffer(xx, width = 1e-5, byid = TRUE)
xx <- gIntersection(xx[1, ], xx[2, ])
plot(sobj)
plot(xx, border = "red", add = TRUE, lwd = 2)

Related

For-loop to dynamically change plot title

I have 5 variables which want to plot and export in one pdf. However, I have some trouble wiht the for-loop I am running,
parC <-list(unit = 100,labelx = "Time",labely = "Time",cols = "black",
pcex = .01, pch = 1,las = 1,
labax = seq(0,nrow(RP),100),
labay = seq(0,nrow(RP),100))
pdf("filename.pdf", onefile=TRUE)
for (i in RP_values){ # the values that are plotted
for (j in name) { # name is a list of names, so that the title changes dynamically
plotting(i, parC, j)
}
}
dev.off()
RP_values = list of values that is plotted
name = list of names to dynamically change the plotting title
plotting = an adjusted version from the plotRP() function of the crqa package. Here I added a main title to the plot.
The code for the plotting() function:
plotting <- function(RP, par, x){
if (exists("par") == FALSE){ # we use some defaults
## default values
unit = 2; labelx = "Time"; labely = "Time"
cols = "black"; pcex = .3; pch = 1; las = 0;
labax = seq(0, nrow(RP), unit); labay = seq(0, nrow(RP), unit);
} else { # we load the values that we desire
for (v in 1:length(par)) assign(names(par)[v], par[[v]])
}
xdim = nrow(RP)
ydim = ncol(RP)
RP = matrix(as.numeric(RP), nrow = xdim, ncol = ydim) # transform it for plotting
ind = which(RP == 1, arr.ind = T)
tstamp = seq(0, xdim, unit)
par(mar = c(5,5, 1, 3), font.axis = 2, cex.axis = 1,
font.lab = 2, cex.lab = 1.2)
plot(tstamp, tstamp, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", main = x)
matpoints(ind[,1], ind[,2], cex = pcex, col = cols, pch = pch)
mtext(labelx, at = mean(tstamp), side = 1, line = 2.2, cex = 1.2, font = 2)
mtext(labely, at = mean(tstamp), side = 2, line = 2.2, cex = 1.2, font = 2)
# if (is.numeric(labax)){ ## it means there is some default
# mtext(labax, at = seq(1, nrow(RP), nrow(RP)/10), side = 1, line = .5, cex = 1, font = 2)
# mtext(labay, at = seq(1, nrow(RP), nrow(RP)/10), side = 2, line = .5, cex = 1, font = 2)
# } else{
mtext(labax, at = tstamp, side = 1, line = .5, cex = .8, font = 2, las = las)
mtext(labay, at = tstamp, side = 2, line = .5, cex = .8, font = 2, las = las)
# }
}
My problem is instead of 5 plots I get 25, where each plot appears 5 times, but with a different title. If I do not include the "j" part everything works fine, but of course do not have any main title for each plot.
I appreciate any help.
Best,
Johnson
From your description and comments, it appears you need an elementwise loop and not a nested loop. Consider retrieving all pairwise combinations of names and RP_values with expand.grid and iterate through them with mapply. Also, since parC depends on nrows of corresponding RP, have parC defined inside function for only two parameters (with more informative names like title instead of x):
plotting <- function(RP, title) {
parC <- list(unit=100, labelx="Time", labely="Time",
cols="black", pcex=.01, pch=1, las=1,
labax=seq(0, nrow(RP), 100),
labay=seq(0, nrow(RP), 100))
...
plot(tstamp, tstamp, type="n", xlab="", ylab="",
xaxt="n", yaxt="n", main=title)
...
}
params <- expand.grid(RP_values=RP_values, name=name)
out <- mapply(plotting, RP=params$RP_values, title=params$name)

Plotting over multiple lengths and columns

I am wanting to plot on the X axis 17K sets of intervals, where I plot the start and stop intervals for each Chr column. However, these intervals are not plotting correctly to each chr? This I figured out from how the plot was running off the right side and the red dots did not match up with input data. Thoughts on a fix? To be clear chr.len is the length of each chromosome.
Data;
ID Chr Start Stop
XLOC_007681 2R 11896162 11896597
XLOC_024365 3R 11283380 11286479
XLOC_021494 3R 16392979 16396291
XLOC_012125 3L 136830 138533
XLOC_031405 X 8002493 8004054
XLOC_014371 3L 15537489 15538755
XLOC_005808 2L 20704834 20706685
XLOC_005809 2L 20706861 20708183
XLOC_005807 2L 20703325 20703897
============================================================
chr.len <- c(22422827, 204112, 347038, 23011544, 368872, 21146708, 3288731, 24543557, 2555491, 27905053, 2517507, 1351857, 10049037)
names(chr.len) <- c("X", "XHet", "YHet", "2L", "2LHet", "2R", "2RHet", "3L", "3LHet", "3R", "3RHet", "4", "U")
chr.gap <- 2000000
chr.cum <- cumsum(c(0, chr.len[1:12])) + (0:12)*chr.gap
names(chr.cum) <- names(chr.len)
# ============================================================
png(file = "C:/Users/cahighfi/Desktop/XLOC_Position.png", width = 10, height = 5, units = "in", res = 300)
plot(c(0, chr.cum["U"] + chr.len["U"]), c(0, 1), type = "n", axes = FALSE, ylab = "", xlab = "", )
segments(XLOC.pos$Start + chr.cum[XLOC.pos$Chr], 0.5, XLOC.pos$Stop + chr.cum[XLOC.pos$Chr], 0.5, lwd = 10)
segments(DrugXLOC.pos$Start + chr.cum[DrugXLOC.pos$Chr], 0.5, DrugXLOC.pos$Stop + chr.cum[DrugXLOC.pos$Chr], 0.5, lwd = 10, col = c("red"))
axis(side = 1, at = chr.cum + chr.len/2, labels = parse(text = paste("italic(\"", names(chr.len), "\")", sep = "")), mgp = c(2.5, 0.5, 0), tck = -0.015, cex.axis = 1.0)
dev.off()
[Output plot][[1]]
[[1]]: https://i.stack.imgur.com/qPObX.png

HeatMap: how to cluster only the rows and keep order of the heatmap's column labels as same as in the df?

I wanna plot a heatmap and cluster only the rows (i.e. genes in this tydf1).
Also, wanna keep order of the heatmap's column labels as same as in the df (i.e. tydf1)?
Sample data
df1 <- structure(list(Gene = c("AA", "PQ", "XY", "UBQ"), X_T0_R1 = c(1.46559502, 0.220140568, 0.304127515, 1.098842127), X_T0_R2 = c(1.087642983, 0.237500819, 0.319844338, 1.256624804), X_T0_R3 = c(1.424945196, 0.21066267, 0.256496284, 1.467120048), X_T1_R1 = c(1.289943948, 0.207778662, 0.277942721, 1.238400358), X_T1_R2 = c(1.376535013, 0.488774258, 0.362562315, 0.671502431), X_T1_R3 = c(1.833390311, 0.182798731, 0.332856558, 1.448757569), X_T2_R1 = c(1.450753714, 0.247576125, 0.274415259, 1.035410946), X_T2_R2 = c(1.3094609, 0.390028842, 0.352460646, 0.946426593), X_T2_R3 = c(0.5953716, 1.007079177, 1.912258811, 0.827119776), X_T3_R1 = c(0.7906009, 0.730242116, 1.235644748, 0.832287694), X_T3_R2 = c(1.215333041, 1.012914813, 1.086362205, 1.00918082), X_T3_R3 = c(1.069312467, 0.780421013, 1.002313082, 1.031761442), Y_T0_R1 = c(0.053317766, 3.316414959, 3.617213894, 0.788193798), Y_T0_R2 = c(0.506623748, 3.599442788, 1.734075583, 1.179462912), Y_T0_R3 = c(0.713670106, 2.516735845, 1.236204882, 1.075393433), Y_T1_R1 = c(0.740998252, 1.444496448, 1.077023349, 0.869258744), Y_T1_R2 = c(0.648231834, 0.097957459, 0.791438659, 0.428805547), Y_T1_R3 = c(0.780499252, 0.187840968, 0.820430227, 0.51636582), Y_T2_R1 = c(0.35344654, 1.190274584, 0.401845911, 1.223534348), Y_T2_R2 = c(0.220223951, 1.367784148, 0.362815405, 1.102117612), Y_T2_R3 = c(0.432856978, 1.403057729, 0.10802472, 1.304233845), Y_T3_R1 = c(0.234963735, 1.232129062, 0.072433381, 1.203096462), Y_T3_R2 = c(0.353770497, 0.885122768, 0.011662112, 1.188149743), Y_T3_R3 = c(0.396091395, 1.333921747, 0.192594116, 1.838029829), Z_T0_R1 = c(0.398000559, 1.286528398, 0.129147097, 1.452769794), Z_T0_R2 = c(0.384759325, 1.122251177, 0.119475721, 1.385513609), Z_T0_R3 = c(1.582230097, 0.697419716, 2.406671502, 0.477415567), Z_T1_R1 = c(1.136843842, 0.804552001, 2.13213228, 0.989075996), Z_T1_R2 = c(1.275683837, 1.227821594, 0.31900326, 0.835941568), Z_T1_R3 = c(0.963349308, 0.968589683, 1.706670339, 0.807060135), Z_T2_R1 = c(3.765036263, 0.477443352, 1.712841882, 0.469173869), Z_T2_R2 = c(1.901023385, 0.832736132, 2.223429427, 0.593558769), Z_T2_R3 = c(1.407713024, 0.911920317, 2.011259223, 0.692553388), Z_T3_R1 = c(0.988333629, 1.095130142, 1.648598854, 0.629915612), Z_T3_R2 = c(0.618606729, 0.497458337, 0.549147265, 1.249492088), Z_T3_R3 = c(0.429823986, 0.471389536, 0.977124788, 1.136635484)), row.names = c(NA, -4L ), class = c("data.table", "data.frame"))
Scripts used
library(dplyr)
library(stringr)
library(tidyr)
gdf1 <- gather(df1, "group", "Expression", -Gene)
gdf1$tgroup <- apply(str_split_fixed(gdf1$group, "_", 3)[, c(1, 2)],
1, paste, collapse ="_")
library(dplyr)
tydf1 <- gdf1 %>%
group_by(Gene, tgroup) %>%
summarize(expression_mean = mean(Expression)) %>%
spread(., tgroup, expression_mean)
#1 heatmap script is being used
library(tidyverse)
tydf1 <- tydf1 %>%
as.data.frame() %>%
column_to_rownames(var=colnames(tydf1)[1])
library(gplots)
library(vegan)
randup.m <- as.matrix(tydf1)
scaleRYG <- colorRampPalette(c("red","yellow","darkgreen"),
space = "rgb")(30)
data.dist <- vegdist(randup.m, method = "euclidean")
row.clus <- hclust(data.dist, "aver")
heatmap.2(randup.m, Rowv = as.dendrogram(row.clus),
dendrogram = "row", col = scaleRYG, margins = c(7,10),
density.info = "none", trace = "none", lhei = c(2,6),
colsep = 1:3, sepcolor = "black", sepwidth = c(0.001,0.0001),
xlab = "Identifier", ylab = "Rows")
#2 heatmap script is being used
df2 <- as.matrix(tydf1[, -1])
heatmap(df2)
Also, I want to add a color key.
It is still unclear to me, what the desired output is. There are some notes:
You don't need to use vegdist() to calculate distance matrix for your hclust() call. Because if you check all(vegdist(randup.m, method = "euclidian") == dist(randup.m)) it returns TRUE;
Specifying Colv = F in your heatmap.2() call will prevent reordering of the columns (default is TRUE);
Maybe it is better to scale your data by row (see the uncommented row);
Your call of heatmap.2() returns the heatmap with color key.
So summing it up - in your first script you just miss the Colv = F argument, and after a little adjustment it looks like this:
heatmap.2(randup.m,
Rowv = as.dendrogram(row.clus),
Colv = F,
dendrogram = "row",
#scale = "row",
col = scaleRYG,
density.info = "none",
trace = "none",
srtCol = -45,
adjCol = c(.1, .5),
xlab = "Identifier",
ylab = "Rows"
)
However I am still not sure - is it what you need?

Lattice Package in R: Is it possible to develop an interactive "scatterplot/network"?

I am developing an interactive scatterplot so that when the user rolls over a data point, a label is displayed. However, I would also like to add edges between certain data points.
I am successful at developing the interactive scatterplot using several libraries, including grid, gridSVG, lattice, and adegraphics. Below is a MWE:
library(grid)
library(gridSVG)
library(lattice)
library(adegraphics)
x = rnorm(10)
y = rnorm(10)
dat = data.frame(label = letters[1:10], x, y)
customPanel2 <- function(x, y, ...) {
for (j in 1:nrow(dat)) {
grid.circle(x[j], y[j], r = unit(.5, "mm"),
default.unit = "native",
name = paste("point", j, sep = "."))
}
}
xyplot(y ~ x, panel = customPanel2, xlab = "x variable", ylab=NULL, scales=list(tck = c(1,0), y=list(at=NULL)))
for (i in 1:nrow(dat)) {
grid.text(as.character(dat$label)[i], x = 0.1, y = 0.01, just = c("left", "bottom"), name = paste("label", i, sep = "."), gp = gpar(fontface = "bold.italic"))
}
for (i in 1:nrow(dat)) {
grid.garnish(paste("point", i, sep = "."), onmouseover = paste('highlight("', i, '.1.1")', sep = ""), onmouseout = paste('dim("', i, '.1.1")', sep = ""))
grid.garnish(paste("label", i, sep = "."), visibility = "hidden")
}
grid.script(filename = "aqm.js", inline = TRUE)
grid.export("interactiveScat.svg")
The resulting .svg file accomplishes everything I am aiming for - except that I also wish to add certain non-interactive edges. I tried to do this by incorporating the adeg.panel.edges method from the adegraphics library after defining the edges and the coordinates to be mapped. So, basically my xplot(...) function from before is replaced with:
edges = matrix(c(1, 2, 3, 2, 4, 1, 3, 4), byrow = TRUE, ncol = 2)
coords <- matrix(c(x[1], y[1], x[2], y[2], x[3], y[3], x[4], y[4]), byrow = TRUE, ncol = 2)
xyplot(y ~ x, panel = function(customPanel2){adeg.panel.edges(edges, coords, lty = 1:4, cex = 5)}, xlab = "x variable", ylab=NULL, scales=list(tck = c(1,0), y=list(at=NULL)))
It seems that this simply erases the interactive scatterplot made from the original xyplot, and simply outputs the static edge and coordinate image.
I tried to follow the example as seen in (http://finzi.psych.upenn.edu/library/adegraphics/html/adeg.panel.nb.html). Specifically, this example:
edges <- matrix(c(1, 2, 3, 2, 4, 1, 3, 4), byrow = TRUE, ncol = 2)
coords <- matrix(c(0, 1, 1, 0, 0, -1, -1, 0), byrow = TRUE, ncol = 2)
xyplot(coords[,2] ~ coords[,1],
panel = function(...){adeg.panel.edges(edges, coords, lty = 1:4, cex = 5)})
I am a bit at a loss as to how to troubleshoot this problem, especially as I am mimicking the example code. Any suggestions are greatly appreciated!
If what you are trying to produce is a node-link diagram of a network an alternate solution is to coerce your data into a network object and use the ndtv package to generate svg/htmlwidget interactive plots for your network. The ndtv package is designed for dynamic networks, but will generate interactive plots for static nets as well.
library(ndtv)
data(emon) # load a list of example networks
render.d3movie(emon[[5]]) # render network 5 in the browser
Much more detail is in the tutorial http://statnet.csde.washington.edu/workshops/SUNBELT/current/ndtv/ndtv-d3_vignette.html
However, this does not use grid/lattice graphics at all

labeling points on an archetype archmap

How might one add labels to an archmap from the archetypes package? Or alternatively, would it be possible to recreate the archmap output in ggplot?
Using code from the SportsAnalytics demo (I hope this isn't bad form)
library("SportsAnalytics")
library("archetypes")
data("NBAPlayerStatistics0910")
dat <- subset(NBAPlayerStatistics0910,
select = c(Team, Name, Position,
TotalMinutesPlayed, FieldGoalsMade))
mat <- as.matrix(subset(dat, select = c(TotalMinutesPlayed, FieldGoalsMade)))
a3 <- archetypes(mat, 3)
archmap(a3)
I'd like the player names ( NBAPlayerStatistics0910$Name ) over the points on the chart. Something like below but more readable.
If you don't mind tweaking things a bit, you can start with the archmap() function base, toss in an extra parameter and add a text() call:
amap2 <- function (object, a.names, projection = simplex_projection, projection_args = list(),
rotate = 0, cex = 1.5, col = 1, pch = 1, xlab = "", ylab = "",
axes = FALSE, asp = TRUE, ...)
{
stopifnot("archetypes" %in% class(object))
stopifnot(is.function(projection))
k <- object$k
if (k < 3) {
stop("Need at least 3 archetypes.\n")
}
cmds <- do.call(projection, c(list(parameters(object)), projection_args))
if (rotate != 0) {
a <- pi * rotate/180
A <- matrix(c(cos(a), -sin(a), sin(a), cos(a)), ncol = 2)
cmds <- cmds %*% A
}
hmds <- chull(cmds)
active <- 1:k %in% hmds
plot(cmds, type = "n", xlab = xlab, ylab = ylab, axes = axes,
asp = asp, ...)
points(coef(object) %*% cmds, col = col, pch = pch)
######################
# PLAY WITH THIS BIT #
######################
text(coef(object) %*% cmds, a.names, pos=4)
######################
rad <- ceiling(log10(k)) + 1.5
polygon(cmds[hmds, ])
points(cmds[active, ], pch = 21, cex = rad * cex, bg = "grey")
text(cmds[active, ], labels = (1:k)[active], cex = cex)
if (any(!active)) {
points(cmds[!active, , drop = FALSE], pch = 21, cex = rad *
cex, bg = "white", fg = "grey")
text(cmds[!active, , drop = FALSE], labels = (1:k)[!active],
cex = cex, col = "grey20")
}
invisible(cmds)
}
amap2(a3, dat$Name)
Obviously, my completely quick stab is not the end result you're looking for, but it should help you get on your way (if I read what you want to do correctly).

Resources