I using the following code to create a parliamentary seats graph with R for the German electoral results of 2013.
I would want to change the colors for each party (CDU/CSU -> red, SPD -> blue, Linke -> yellow and Gruene -> green). When I try to do this, the colors seem to appear randomly, destroying the sequences of the parties in the graph.
I also want to take off the black contour of the graph to leave only the seats graph visible.
VoteGermany2013 <- data.frame(Party=c( "CDU/CSU", "SPD", "LINKE","GRUENE"),
Result=c(311,193,64,63))
seats <- function(N,M, r0=2.5){
radii <- seq(r0, 1, len=M)
counts <- numeric(M)
pts = do.call(rbind,
lapply(1:M, function(i){
counts[i] <<- round(N*radii[i]/sum(radii[i:M]))
theta <- seq(0, pi, len = counts[i])
N <<- N - counts[i]
data.frame(x=radii[i]*cos(theta), y=radii[i]*sin(theta), r=i,
theta=theta)
} )
)
pts = pts[order(-pts$theta,-pts$r),]
pts
}
election <- function(seats, counts){
stopifnot(sum(counts)==nrow(seats))
seats$party = rep(1:length(counts),counts)
seats
}
layout = seats(631,16)
result = election(layout, VoteGermany2013$Result) # no overall majority!!!
plot(result$x, result$y, col=result$party,pch=19, asp=1)
Nice example. I'm guessing that you want to suppress the axes. This uses the result$party numeric values as an index into the color vector you specified. The col vector (which the index creates at equal length to the x and y arguments) needs to be as long as the 'x' and 'y' values if there is no regularity that is in sync with 'col's length. (If colors repeat their grouping in sync with the multiple of the length of the 'col'-vector, then no problem. Recycling takes care of everything.) With no regularity in the grouping, the 'col'-vector gets recycled, and chaos ensues.
plot(result$x, result$y,
col=c( "red", "blue", "yellow","green")[result$party], #numeric index
pch=19, asp=1,
frame.plot=FALSE, # gets rid of the surrounding rectangle
axes="F") # gets rid of the numbers and ticks
You can suppress the 'xlab' and 'ylab' by assigning to ""
There is a package for this as well: ggparliament.
Related
I have two 3D meshes of human faces and I wish to use heatmap to illustrate differences. I want to use red-blue divergent color scale.
My data can be found here. In my data, "vb1.xlsx" and "vb2.xlsx" contain 3D coordinates of the two meshes. "it.xlsx" is the face information. The "dat_col.xlsx" contains pointwise distances between the two meshes based on which heatmap could be produced. I used the following code to generate the two meshes based on vertex and face information. I then used the meshDist function in Morpho package to calculate distances between each pair of vertex on the two meshes.
library(Morpho)
library(xlsx)
library(rgl)
library(RColorBrewer)
library(tidyverse)
mshape1 <- read.xlsx("...\\vb1.xlsx", sheetIndex = 1, header = F)
mshape2 <- read.xlsx("...\\vb2.xlsx", sheetIndex = 1, header = F)
it <- read.xlsx("...\\it.xlsx", sheetIndex = 1, header = F)
# Preparation for use in tmesh3d
vb_mat_mshape1 <- t(mshape1)
vb_mat_mshape1 <- rbind(vb_mat_mshape1, 1)
rownames(vb_mat_mshape1) <- c("xpts", "ypts", "zpts", "")
vb_mat_mshape2 <- t(mshape2)
vb_mat_mshape2 <- rbind(vb_mat_mshape2, 1)
rownames(vb_mat_mshape2) <- c("xpts", "ypts", "zpts", "")
it_mat <- t(as.matrix(it))
rownames(it_mat) <- NULL
vertices1 <- c(vb_mat_mshape1)
vertices2 <- c(vb_mat_mshape2)
indices <- c(it_mat)
mesh1 <- tmesh3d(vertices = vertices1, indices = indices, homogeneous = TRUE,
material = NULL, normals = NULL, texcoords = NULL)
mesh2 <- tmesh3d(vertices = vertices2, indices = indices, homogeneous = TRUE,
material = NULL, normals = NULL, texcoords = NULL)
mesh1smooth <- addNormals(mesh1)
mesh2smooth <- addNormals(mesh2)
# Calculate mesh distance using meshDist function in Morpho package
mD <- meshDist(mesh1smooth, mesh2smooth)
pd <- mD$dists
The pd, containing information on pointwise distances between the two meshes, can be found in the first column of the "dat_col.xlsx" file.
A heatmap is generated from the meshDist function as follows:
I wish to have better control of the heatmap by using red-blue divergent color scale. More specifically, I want positive/negative values to be colored blue/red using 100 colors from the RdBu color pallete in the RColorBrewer package. To do so, I first cut the range of pd values into 99 intervals of equal lengths. I then determined which of the 99 intervals does each pd value lie in. The code is as below:
nlevel <- 99
breaks <- NULL
for (i in 1:(nlevel - 1)) {
breaks[i] <- min(pd) + ((max(pd) - min(pd))/99) * i
}
breaks <- c(min(pd), breaks, max(pd))
pd_cut <- cut(pd, breaks = breaks, include.lowest = TRUE)
dat_col <- data.frame(pd = pd, pd_cut = pd_cut, group = as.numeric(pd_cut))
The pd_cut is the inteval corresponding to each pd and group is the interval membership of each pd. Color is then assgined to each pd according to the value in group with the following code:
dat_col <- dat_col %>%
mutate(color = colorRampPalette(
brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group])
The final heatmap is as follows:
open3d()
shade3d(mesh1smooth, col=dat_col$color, specular = "#202020", polygon_offset = 1)
Since I have 99 intervals, the middle interval is the 50th, (-3.53e-05,-1.34e-05]. However, it is the 51th interval, (-1.34e-05,8.47e-06], that contains the 0 point.
Following my way of color assignment (colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group]), the center color (the 50th color imputed from colorRampPalette) is given to pds belonging to the 50th interval. However, I want pds that belong to the 51th interval, the interval that harbors 0, to be assgned the center color.
I understand that in my case, my issue won't affect the appearance of heatmap too much. But I believe this is not a trivial issue and can significantly affect the heatmap when the interval that contains 0 is far from the middle interval. This could happen when the two meshes under comparison is very different. It makes more sense to me to assign center color to the interval that contains 0 rather than the one(s) that lie in the middle of all intervals.
Of course I can manually replace hex code of the 50th imputed color to the desired center color as follows:
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
color2 <- color
color2[50] <- "#ffffff" #assume white is the intended center color
But the above approach affected the smoothness of color gradient since the color that was originally imputed by some smooth function is replaced by some arbitrary color. But how could I assign center color to pds that lie in the interval that transgresses 0 while at the same time not affecting the smoothness of the imputed color?
There are a couple of things to fix to get what you want.
First, the colours. You base the colours on this code:
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
You can look at the result of that calculation, and you'll see that there is no white in it. The middle color is color[50] which evaluates to "#F7F6F6", i.e.
a slightly reddish light gray colour. If you look at the original RdBu palette, the middle colour was "#F7F7F7", so this change was done by colorRampPalette(). To me it looks like a minor bug in that function: it truncates the colour values instead of rounding them, so the values
[50,] 247.00000 247.00000 247.00000
convert to "#F7F6F6", i.e. red 247, green 246, blue 246. You can avoid this by choosing some other number of colours in your palette. I see "F7F7F7" as the middle colour with both 97 and 101 colours. But being off by one probably doesn't matter much, so I wouldn't worry about this.
The second problem is your discretization of the range of the pd values. You want zero in the middle bin. If you want the bins all to be of equal size, then it needs to be symmetric: so instead of running from min(pd) to max(pd), you could use this calculation:
limit <- max(abs(pd))
breaks <- -limit + (0:nlevel)*2*limit/nlevel
This will put zero exactly in the middle of the middle bin, but some of the bins at one end or the other might not be used. If you don't care if the bins are of equal size, you could get just as many negatives as positives by dividing them up separately. I like the above solution better.
Edited to add: For the first problem, a better solution is to use
color <- hcl.colors(99, "RdBu")
with the new function in R 3.6.0. This does give a light gray as the middle color.
I'd like if someone could help me with this problem I've been hours trying to solve.
I have to plot a chessboard with no external libraries (using only the default graphical functions in R).
My attempt is working with black squares till I have to filter and paint the white squares:
plot(c(1:9),c(1:9),type="n")
for (i in 1:8){
rect(i,1:9,i+1,9,col="black",border="white")
}
I could do it manually in this way, but I know there's a simpler way:
plot(c(1:9),c(1:9),type="n")
rect(1, 2, 2, 1,col="black",border="white")
rect(4, 1, 3, 2,col="black",border="white")
rect(6, 1, 5, 2,col="black",border="white")
rect(7, 1, 8, 2,col="black",border="white")
(...)
I've tried adding a function to filter even numbers inside the loop but doesn't seems to works for me.
I would appreciate any suggestion!
Use image and just repeat 0:1 over and over. Then you can mess with the limits a bit to make it fit nice.
image(matrix(1:0, 9, 9), col=0:1, xlim=c(-.05,.93), ylim=c(-.05,.93))
Just change the col= argument in your solution as shown. Also note that c(1:9) can be written as just 1:9 :
plot(1:9, 1:9, type = "n")
for (i in 1:8) {
col <- if (i %% 2) c("white", "black") else c("black", "white")
rect(i, 1:9, i+1, 9, col = col, border = "white")
}
remembering Jeremy Kun's post
https://jeremykun.com/2018/03/25/a-parlor-trick-for-set/ on Set helped
me figure the hard part (for me) of this question. i realized that
diagonals on the board (what bishops move on) have a constant color.
and, so, their Y-intercept (where they hit the Y-axis) will uniquely
determine their color, and adjacent Y values will have different
colors. for a square at (x,y), the y intercept (since the slope is 1)
will be at Y == (y-x). since the parity is the same for addition as
for subtraction, and i'm never sure which mod functions (in which
languages) may give a negative result, i use "(x+y) %% 2".
b <- matrix(nrow=8,ncol=8) # basic board
colorindex <- (col(b)+row(b))%%2 # parity of the Y-intercept
# for each square
colors <- c("red", "white")[colorindex+1] # choose colors
side <- 1/8 # side of one square
ux <- col(b)*side # upper x values
lx <- ux-side # lower x values
uy <- row(b)*side # upper y
ly <- uy-side # upper y
plot.new() # initialize R graphics
rect(lx, ly, ux, uy, col=colors, asp=1) # draw the board
I have a matrix of complex values.
If I issue the command:
plot(myMatrix)
then it shows on the graphics device a kind of scatterplot, with X-axis labeled Re(myMatrix) and Y-axis with Im(myMatrix). This shows the information I'm looking for, as I can see distinct clusters, that I cannot see with only one column.
My questions are :
I assume there is one point per matrix row. Is it right ?
How is calculated Re(myMatrix) for each row vector ?
It is not Re(myMatrix[1,row]), but seems to be a mix of all values of row vector. I would like to be able to get these values, so to know how to compute them with R.
No, there is one point for each matrix element.
set.seed(42)
mat <- matrix(complex(real = rnorm(16), imaginary = rlnorm(16)), 4)
plot(mat)
points(Re(mat[1,1]), Im(mat[1,1]), col = "red", pch = ".", cex = 5)
Look for the red dot:
You'd get the same plot, if you plotted a vector instead of a matrix, i.e., plot(c(mat)).
This happens because plot.default calls xy.coords and that function contains the following code:
else if (is.complex(x)) {
y <- Im(x)
x <- Re(x)
xlab <- paste0("Re(", ylab, ")")
ylab <- paste0("Im(", ylab, ")")
}
else if (is.matrix(x) || is.data.frame(x)) {
This means, that the fact that input is complex takes priority over it being a matrix.
I'm trying to plot some path/connection based maps but am unable to figure out how.
I see a lot of possibilities for one point based metrics (crime hotspots in London, etc. with googleVis, ggmap, etc.) but I can't find too many examples of two points based metrics (immigrations between cities, train routes, etc.) There is an example with the package geosphere, but it seems to not be available for R 3.0.2.
Ideally I would like something like this D3 example and would also like to customise the thickness, colour, etc. of the lines and the circles.
PS: I don't suppose rCharts can do this just yet, right?
Here's something I started last year and never got around to polishing properly but hopefully it should answer your question of joining points on a map with great circle lines, with the flexibility to customise lines, circles etc.
I use the (my) rworldmap package for mapping, WDI for world bank data and geosphere for the great circle lines. The aim was to plot aid flows from all donor countries to all recipient countries (one plot per donor). Below is an example plot, and below that the code. Hope it helps. Would be nice to find time to pick it up again!
Andy
library(rworldmap)
library(WDI) # WORLD BANK INDICATORS
## lines of either type may obscure more than they add
##**choose line option here
addLines <- 'gc' #'none''straight' 'gc'
if ( addLines == 'gc' ) library(geosphere)
# setting background colours
oceanCol = rgb(7,0,30,maxColorValue=255)
landCol = oceanCol
#produces a list of indicator IDs and names as a matrix
indicatorList <- WDIsearch('aid flows')
#setting up a world map shaped plot window
#*beware this is windows specific
mapDevice('windows',width=10,height=4.5)
year <- 2000
#for(indNum in 1:2)
for(indNum in 1:nrow(indicatorList))
{
indID <- indicatorList[indNum][1]
donorISO3 <- substr(indID,start=8,stop=10)
dFdonor <- WDI(indicator=indID,start=year,end=year)
#divide by 10^6 for million dollars
dFdonor[indID] <- dFdonor[indID] * 1/10^6
sPDFdonor <- joinCountryData2Map(dFdonor,nameJoinColumn='country',joinCode='NAME')
#take out Antarctica
sPDFdonor <- sPDFdonor[-which(row.names(sPDFdonor)=='Antarctica'),]
legendTitle=paste("aid flow from",donorISO3,year,"(millions US$)")
mapBubbles(sPDFdonor, nameZSize=indID, plotZeroVals=FALSE, legendHoriz=TRUE, legendPos="bottom", fill=FALSE, legendTitle=legendTitle, oceanCol=oceanCol, landCol=landCol,borderCol=rgb(50,50,50,maxColorValue=255),lwd=0.5,lwdSymbols=1)
#removed because not working , main=paste('donor', donorISO3,year)
#now can I plot lines from the centroid of the donor to the centroids of the recipients
xDonor <- sPDFdonor$LON[ which(sPDFdonor$ISO3==donorISO3) ]
yDonor <- sPDFdonor$LAT[ which(sPDFdonor$ISO3==donorISO3) ]
xRecips <- sPDFdonor$LON[ which(sPDFdonor[[indID]] > 0) ]
yRecips <- sPDFdonor$LAT[ which(sPDFdonor[[indID]] > 0) ]
amountRecips <- sPDFdonor[[indID]][ which(sPDFdonor[[indID]] > 0) ]
## straight lines
if ( addLines == 'straight' )
{
for(line in 1:length(xRecips))
{
#col <- 'blue'
#i could modify the colour of the lines by the size of the donation
#col=rgb(1,1,1,alpha=amountRecips[line]/max(amountRecips))
#moving up lower values
col=rgb(1,1,0,alpha=sqrt(amountRecips[line])/sqrt(max(amountRecips)))
lines(x=c(xDonor,xRecips[line]),y=c(yDonor,yRecips[line]),col=col, lty="dotted", lwd=0.5) #lty = "dashed", "dotted", "dotdash", "longdash", lwd some devices support <1
}
}
## great circle lines
## don't work well when donor not centred in the map
## also the loop fails at CEC & TOT because not ISO3 codes
if ( addLines == 'gc' & donorISO3 != "CEC" & donorISO3 != "TOT" )
{
for(line in 1:length(xRecips))
{
#gC <- gcIntermediate(c(xDonor,yDonor),c(xRecips[line],yRecips[line]), n=50, breakAtDateLine=TRUE)
#30/10/13 lines command failed with Error in xy.coords(x, y) :
#'x' is a list, but does not have components 'x' and 'y'
#adding sp=TRUE solved
gC <- gcIntermediate(c(xDonor,yDonor),c(xRecips[line],yRecips[line]), n=50, breakAtDateLine=TRUE, sp=TRUE)
#i could modify the colour of the lines by the size of the donation
#col=rgb(1,1,1,alpha=amountRecips[line]/max(amountRecips))
#moving up lower values
col=rgb(1,1,0,alpha=sqrt(amountRecips[line])/sqrt(max(amountRecips)))
lines(gC,col=col,lwd=0.5)
}
}
#adding coasts in blue looks nice but may distract
data(coastsCoarse)
plot(coastsCoarse,add=TRUE,col='blue')
#repeating mapBubbles with add=T to go on top of the lines
mapBubbles(sPDFdonor, nameZSize=indID, plotZeroVals=FALSE, fill=FALSE, addLegend=FALSE, add=TRUE, ,lwd=2)
#removed because not working : , main=paste('donor', donorISO3,year)
#looking at adding country labels
text(xRecips,yRecips,sPDFdonor$NAME[ which(sPDFdonor[[indID]] > 0) ],col=rgb(1,1,1,alpha=0.3),cex=0.6,pos=4) #pos=4 right (1=b,2=l,3=ab)
#add a title
nameDonor <- sPDFdonor$NAME[ which(sPDFdonor$ISO3==donorISO3) ]
mtext(paste("Aid flow from",nameDonor,year), cex = 1.8, line=-0.8)
#savePlot(paste("C:\\rProjects\\aidVisCompetition2012\\Rplots\\greatCircles\\wdiAidFlowLinesDonor",donorISO3,year,sep=''),type='png')
#savePlot(paste("C:\\rProjects\\aidVisCompetition2012\\Rplots\\greatCircles\\wdiAidFlowLinesDonor",donorISO3,year,sep=''),type='pdf')
} #end of indNum loop
I am trying to create a simple heatmap in R, using a diverging colour palette. I want to use a gradient so that all numbers below a threshold N are designated a color (say purple), and all numbers above the threshold are designated another color (say orange). The further away the number is from the threshold, the darker the color should be.
Here is a sample dataset:
Division,COL1,COL2,COL3,COL4,COL5,COL6,COL7
Division 1,31.9221884012222,75.8181694429368,97.0480443444103,96.295954938978,70.5677134916186,63.0451830103993,93.0396212730557
Division 2,85.7012346852571,29.0621076244861,16.9130333233625,94.6443660184741,19.9103083927184,61.9562198873609,72.3791105207056
Division 3,47.1665125340223,99.4153356179595,8.51091076619923,79.1276383213699,41.915355855599,7.45079894550145,24.6946100145578
Division 4,66.0743870772421,24.6163331903517,78.694460215047,42.04714265652,50.2694897353649,73.0409651994705,87.3745442833751
Division 5,29.6664374880493,35.4036891367286,19.2967326845974,5.48460693098605,32.4517334811389,15.5926876701415,76.0523204226047
Division 6,95.4969164915383,8.63230894319713,61.7535551078618,24.5590241160244,25.5453423131257,56.397921172902,44.4693325087428
Division 7,87.5015622004867,28.7770316936076,56.5095080062747,34.6680747810751,28.1923673115671,65.0204187724739,13.795713102445
Division 8,70.1077231671661,72.4712177179754,38.4903231170028,36.1821102909744,97.0875509083271,17.184783378616,78.2292529474944
Division 9,47.3570406902581,90.2257485780865,65.6037972308695,77.0234781783074,25.6294377148151,84.900529962033,82.5080851092935
Division 10,58.0811711959541,0.493217632174492,58.5604055318981,53.5780876874924,9.12552657537162,20.313960686326,78.1371118500829
Division 11,34.6708688884974,76.711881859228,22.6064443588257,22.1724311355501,5.48891355283558,79.1159523651004,56.8405059166253
Division 12,33.6812808644027,44.1363711375743,70.6362190190703,3.78900407813489,16.6075889021158,9.12654218263924,39.9711143691093
Here is a simple snippet to produce a heatmap from the above data
data <- read.csv("dataset.csv", sep=",")
row.names(data) <- data$Division
data <- data[,2:7]
data_matrix <- data.matrix(data)
heatmap(data_matrix, Rowv=NA, Colv=NA, col = heat.colors(256), scale="column", margins=c(5,10))
How can I modify the above code to produce:
a color gradient (orange) for all numbers ABOVE 50 (darker the further the number is from 50)
a color gradient (purple) for all numbers BELOW 50 (darker the further the number is from 50)
Nice to have (but optional) write the number value in the grid cell
Nice to have (but optional), use a different color for grid cell that is EXACTLY the threshold number (50 in this case)
[[Edit]]
I have just seen this question on SO, which seems to be very similar. The answer uses ggplot (which I have no experience of), and I have so far, been unable to adapt the ggplot solution to my slightly more complicated data.
This should get you most of the way. (Note that you'll need to set scale="none" if you want the plotted colors to correspond to the actual (rather than the rescaled) values of the cells).
ncol <- 100
## Make a vector with n colors
cols <- RColorBrewer:::brewer.pal(11,"PuOr") # OR c("purple","white","orange")
rampcols <- colorRampPalette(colors = cols, space="Lab")(ncol)
rampcols[(n/2) + 1] <- rgb(t(col2rgb("green")), maxColorValue=256)
## Make a vector with n+1 breaks
rampbreaks <- seq(0, 100, length.out = ncol+1)
## Try it out
heatmap(data_matrix, Rowv = NA, Colv = NA, scale="none",
col = rampcols, breaks = rampbreaks)
EDIT
For finer control over the placement of the threshold, I'd suggest creating two separate palettes -- one for values less than the threshold and one for values above the threshold -- and then "suturing" them together. Try something like this, playing around with different values for Min, Max, Thresh, etc.:
nHalf <- 50
Min <- 0
Max <- 100
Thresh <- 50
## Make vector of colors for values below threshold
rc1 <- colorRampPalette(colors = c("purple", "white"), space="Lab")(nHalf)
## Make vector of colors for values above threshold
rc2 <- colorRampPalette(colors = c("white", "orange"), space="Lab")(nHalf)
rampcols <- c(rc1, rc2)
## In your example, this line sets the color for values between 49 and 51.
rampcols[c(nHalf, nHalf+1)] <- rgb(t(col2rgb("green")), maxColorValue=256)
rb1 <- seq(Min, Thresh, length.out=nHalf+1)
rb2 <- seq(Thresh, Max, length.out=nHalf+1)[-1]
rampbreaks <- c(rb1, rb2)
heatmap(data_matrix, Rowv = NA, Colv = NA, scale="none",
col = rampcols, breaks = rampbreaks)
I found this thread very useful and also pulled some ideas from here, but for my purposes I needed to generalize some things and wanted to use the RColorBrewer package. While I was working on it Dr. Brewer (of Color Brewer fame) stopped in my office and told me I needed to interpolate within the smaller color breaks rather than just pick the end points. I thought others might find this useful so I am posting my function here for posterity.
The function takes in your data vector, the name of a diverging colorBrewer palette, and the center point for your color scheme (default is 0). It outputs a list containing 2 objects: a classIntervals object and a vector of colors: The function is set to interpolate a total of 100 colors but that can be modified with some care.
diverge.color <- function(data,pal_choice="RdGy",centeredOn=0){
nHalf=50
Min <- min(data,na.rm=TRUE)
Max <- max(data,na.rm=TRUE)
Thresh <- centeredOn
pal<-brewer.pal(n=11,pal_choice)
rc1<-colorRampPalette(colors=c(pal[1],pal[2]),space="Lab")(10)
for(i in 2:10){
tmp<-colorRampPalette(colors=c(pal[i],pal[i+1]),space="Lab")(10)
rc1<-c(rc1,tmp)
}
rb1 <- seq(Min, Thresh, length.out=nHalf+1)
rb2 <- seq(Thresh, Max, length.out=nHalf+1)[-1]
rampbreaks <- c(rb1, rb2)
cuts <- classIntervals(data, style="fixed",fixedBreaks=rampbreaks)
return(list(cuts,rc1))
}
in my work I am using this scheme to plot a raster layer (rs) using spplot like so:
brks<-diverge.color(values(rs))
spplot(rs,col.regions=brks[[2]],at=brks[[1]]$brks,colorkey=TRUE))