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
Related
How can such a non-linear transformation be done?
here is the code to draw it
my.sin <- function(ve,a,f,p) a*sin(f*ve+p)
s1 <- my.sin(1:100, 15, 0.1, 0.5)
s2 <- my.sin(1:100, 21, 0.2, 1)
s <- s1+s2+10+1:100
par(mfrow=c(1,2),mar=rep(2,4))
plot(s,t="l",main = "input") ; abline(h=seq(10,120,by = 5),col=8)
plot(s*7,t="l",main = "output")
abline(h=cumsum(s)/10*2,col=8)
don't look at the vector, don't look at the values, only look at the horizontal grid, only the grid matters
####UPDATE####
I see that my question is not clear to many people, I apologize for that...
Here are examples of transformations only along the vertical axis, maybe now it will be more clear to you what I want
link Source
#### UPDATE 2 ####
Thanks for your answer, this looks like what I need, but I have a few more questions if I may.
To clarify, I want to explain why I need this, I want to compare vectors with each other that are non-linearly distorted along the horizontal axis .. Maybe there are already ready-made tools for this?
You mentioned that there are many ways to do such non-linear transformations, can you name a few of the best ones in my case?
how to make the function f() more non-linear, so that it consists, for example, not of one sinusoid, but of 10 or more. Тhe figure shows that the distortion is quite simple, it corresponds to one sinusoid
and how to make the function f can be changed with different combinations of sinusoids.
set.seed(126)
par(mar = rep(2, 4),mfrow=c(1,3))
s <- cumsum(rnorm(100))
r <- range(s)
gridlines <- seq(r[1]*2, r[2]*2, by = 0.2)
plot(s, t = "l", main = "input")
abline(h = gridlines, col = 8)
f <- function(x) 2 * sin(x)/2 + x
plot(s, t = "l", main = "input+new greed")
abline(h = f(gridlines), col = 8)
plot(f(s), t = "l", main = "output")
abline(h = f(gridlines), col = 8)
If I understand you correctly, you wish to map the vector s from the regular spacing defined in the first image to the irregular spacing implied by the second plot.
Unfortunately, your mapping is not well-defined, since there is no clear correspondence between the horizontal lines in the first image and the second image. There are in fact an infinite number of ways to map the first space to the second.
We can alter your example a bit to make it a bit more rigorous.
If we start with your function and your data:
my.sin <- function(ve, a, f, p) a * sin(f * ve + p)
s1 <- my.sin(1:100, 15, 0.1, 0.5)
s2 <- my.sin(1:100, 21, 0.2, 1)
s <- s1 + s2 + 10 + 1:100
Let us also create a vector of gridlines that we will draw on the first plot:
gridlines <- seq(10, 120, by = 2.5)
Now we can recreate your first plot:
par(mar = rep(2, 4))
plot(s, t = "l", main = "input")
abline(h = gridlines, col = 8)
Now, suppose we have a function that maps our y axis values to a different value:
f <- function(x) 2 * sin(x/5) + x
If we apply this to our gridlines, we have something similar to your second image:
plot(s, t = "l", main = "input")
abline(h = f(gridlines), col = 8)
Now, what we want to do here is effectively transform our curve so that it is stretched or compressed in such a way that it crosses the gridlines at the same points as the gridlines in the original image. To do this, we simply apply our mapping function to s. We can check the correspondence to the original gridlines by plotting our new curves with a transformed axis :
plot(f(s), t = "l", main = "output", yaxt = "n")
axis(2, at = f(20 * 1:6), labels = 20 * 1:6)
abline(h = f(gridlines), col = 8)
It may be possible to create a mapping function using the cumsum(s)/10 * 2 that you have in your original example, but it is not clear how you want this to correspond to the original y axis values.
Response to edits
It's not clear what you mean by comparing two vectors. If one is a non-linear deformation of the other, then presumably you want to find the underlying function that produces the deformation. It is possible to create a function that applies the deformation empirically simply by doing f <- approxfun(untransformed_vector, transformed_vector).
I didn't say there were many ways of doing non-linear transformations. What I meant is that in your original example, there is no correspondence between the grid lines in the original picture and the second picture, so there is an infinite choice for which gridines in the first picture correspond to which gridlines in the second picture. There is therefore an infinite choice of mapping functions that could be specified.
The function f can be as complicated as you like, but in this scenario it should at least be everywhere non-decreasing, such that any value of the function's output can be mapped back to a single value of its input. For example, function(x) x + sin(x)/4 + cos(3*(x + 2))/5 would be a complex but ever-increasing sinusoidal function.
I have a matrix called ht2. I use persp function to generate a 3D view.
ht2 <- matrix(1, 29, 36)
ht2[4:26,4:33] <- 0
ht2[6:10,6:31] <- 3
ht2[13:17,6:31] <- 3
ht2[20:24,6:31] <- 3
persp(ht2, expand=0.03, theta=25, phi=25, shade=0.75, col=terrain.colors(999,alpha=1))
This gives me:
As you can see, the color from green to yellow to brown changes along y-axis. However, I'd rather want to change it along z-axis.
I'm looking for any simple way to do that.
I found a possible solution in this site:
https://stat.ethz.ch/pipermail/r-help/2003-July/036151.html
levelpersp <- function(x, y, z, colors=topo.colors, ...) {
## getting the value of the midpoint
zz <- (z[-1,-1] + z[-1,-ncol(z)] + z[-nrow(z),-1] + z[-nrow(z),-ncol(z)])/4
## calculating the breaks
breaks <- hist(zz, plot=FALSE)$breaks
## cutting up zz
cols <- colors(length(breaks)-1)
zzz <- cut(zz, breaks=breaks, labels=cols)
## plotting
persp(x, y, z, col=as.character(zzz), ...)
## return breaks and colors for the legend
list(breaks=breaks, colors=cols)
}
## Example
x <- seq(-10, 10, length=60)
y <- x
f <- function(x,y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
z <- outer(x, y, f)
levelpersp(x, y, z, theta = 30, phi = 30, expand = 0.5)
Someone may suggest a way to implement this in original question.
In principle you just have to give col= a matrix with your colours you want to fill the squares with, as simple example:
col=terrain.colors(max(ht2)+1)[ht2[-1,-1]+1]
(this simple version works since ht2 contains integers, otherwise it wouldn't)
This creates all the colours needed: terrain.colours(max(ht2)+1)
and then selects them for each position based on one corner: [ht2[-1,-1]+1]
What Anuj Sharma's answer does is basically a nicer version of this, it assumes you have decimal numbers, so it bins them (breaks & cutting up) and instead of taking one corner it uses the height of the middle point (averaging of the four shifted matrices in getting the midpoint )
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.
I am working on avoid over crowding of the labels in the following plot:
set.seed(123)
position <- c(rep (0,5), rnorm (5,1,0.1), rnorm (10, 3,0.1), rnorm (3, 4, 0.2), 5, rep(7,5), rnorm (3, 8,2), rnorm (10,9,0.5),
rep (0,5), rnorm (5,1,0.1), rnorm (10, 3,0.1), rnorm (3, 4, 0.2), 5, rep(7,5), rnorm (3, 8,2), rnorm (10,9,0.5))
group <- c(rep (1, length (position)/2),rep (2, length (position)/2) )
mylab <- paste ("MR", 1:length (group), sep = "")
barheight <- 0.5
y.start <- c(group-barheight/2)
y.end <- c(group+barheight/2)
mydf <- data.frame (position, group, barheight, y.start, y.end, mylab)
plot(0,type="n",ylim=c(0,3),xlim=c(0,10),axes=F,ylab="",xlab="")
#Create two horizontal lines
require(fields)
yline(1,lwd=4)
yline(2,lwd=4)
#Create text for the lines
text(10,1.1,"Group 1",cex=0.7)
text(10,2.1,"Group 2",cex=0.7)
#Draw vertical bars
lng = length(position)/2
lg1 = lng+1
lg2 = lng*2
segments(mydf$position[1:lng],mydf$y.start[1:lng],y1=mydf$y.end[1:lng])
segments(mydf$position[lg1:lg2],mydf$y.start[lg1:lg2],y1=mydf$y.end[lg1:lg2])
text(mydf$position[1:lng],mydf$y.start[1:lng]+0.65, mydf$mylab[1:lng], srt = 90)
text(mydf$position[lg1:lg2],mydf$y.start[lg1:lg2]+0.65, mydf$mylab[lg1:lg2], srt = 90)
You can see some areas are crowed with the labels - when x value is same or similar. I want just to display only one label (when there is multiple label at same point). For example,
mydf$position[1:5] are all 0,
but corresponding labels mydf$mylab[1:5] -
MR1 MR2 MR3 MR4 MR5
I just want to display the first one "MR1".
Similarly the following points are too close (say the difference of 0.35), they should be considered a single cluster and first label will be displayed. In this way I would be able to get rid of overcrowding of labels. How can I achieve it ?
If you space the labels out and add some extra lines you can label every marker.
clpl <- function(xdata, names, y=1, dy=0.25, add=FALSE){
o = order(xdata)
xdata=xdata[o]
names=names[o]
if(!add)plot(0,type="n",ylim=c(y-1,y+2),xlim=range(xdata),axes=F,ylab="",xlab="")
abline(h=1,lwd=4)
dy=0.25
segments(xdata,y-dy,xdata,y+dy)
tpos = seq(min(xdata),max(xdata),len=length(xdata))
text(tpos,y+2*dy,names,srt=90,adj=0)
segments(xdata,y+dy,tpos,y+2*dy)
}
Then using your data:
clpl(mydf$position[lg1:lg2],mydf$mylab[lg1:lg2])
gives:
You could then think about labelling clusters underneath the main line.
I've not given much thought to doing multiple lines in a plot, but I think with a bit of mucking with my code and the add parameter it should be possible. You could also use colour to show clusters. I'm fairly sure these techniques are present in some of the clustering packages for R...
Obviously with a lot of markers even this is going to get smushed, but with a lot of clusters the same thing is going to happen. Maybe you end up labelling clusters with a this technique?
In general, I agree with #Joran that cluster labelling can't be automated but you've said that labelling a group of lines with the first label in the cluster would be OK, so it is possible to automate some of the process.
Putting the following code after the line lg2 = lng*2 gives the result shown in the image below:
clust <- cutree(hclust(dist(mydf$position[1:lng])),h=0.75)
u <- rep(T,length(unique(clust)))
clust.labels <- sapply(c(1:lng),function (i)
{
if (u[clust[i]])
{
u[clust[i]] <<- F
as.character(mydf$mylab)[i]
}
else
{
""
}
})
segments(mydf$position[1:lng],mydf$y.start[1:lng],y1=mydf$y.end[1:lng])
segments(mydf$position[lg1:lg2],mydf$y.start[lg1:lg2],y1=mydf$y.end[lg1:lg2])
text(mydf$position[1:lng],mydf$y.start[1:lng]+0.65, clust.labels, srt = 90)
text(mydf$position[lg1:lg2],mydf$y.start[lg1:lg2]+0.65, mydf$mylab[lg1:lg2], srt = 90)
(I've only labelled the clusters on the lower line -- the same principle could be applied to the upper line too). The parameter h of cutree() might have to be adjusted case-by-case to give the resolution of labels that you want, but this approach is at least easier than labelling every cluster by hand.
library(gplots)
shades= c(seq(-1,0.8,length=64),seq(0.8,1.2,length=64),seq(1.2,3,length=64))
heatmap.2(cor_mat, dendrogram='none', Rowv=FALSE, Colv=FALSE, col=redblue(64),
breaks=shades, key=TRUE, cexCol=0.7, cexRow=1, keysize=1)
There is some problem with breaks. Wish to receive help on it.
After running the code I get this error message
Error in image.default(1:nc, 1:nr, x, xlim = 0.5 + c(0, nc), ylim = 0.5 + : must have one more break than colour
Thank you for your time and consideration.
Well, we don't have cor_mat so we can't try this ourselves, but the problem seems to be what it says on the tin, isn't it? The way heatmap (and generally all functions based on image) works with breaks and a vector of colours, is that the breaks define the points where changes in the value of your data matrix means the colour changes. In short, if break = c(1,2,3), and your col = c("red", "blue"):
values < 1 will be transparent
values >= 1, <= 2 will be plotted as red
values > 2, <= 3 will be plotted as blue
values > 3 will be transparent
What's going on in your code is that with 'shade' you've supplied a length 3*64 vector to break, while redblue(64) only gives you 64 colours. Try replacing redblue(64) with, say, redblue(3*64-1).