R: Christmas Tree - r

For an assignment, we need to draw a Christmas tree in R.
I've searched the internet and found some helpful pieces of advice, but at the end of the day, I don't know how to proceed and hope someone can help me.
This is my code so far.
#ctree: prints a Christmas tree on screen with size N
ctree <- function(N){
for (i in 1:N){
width = sample("*",i,replace=T)
cat(width,sep="-","\n")
}
cat(width[1],"\n")
}
This leaves me with the middle and right side of my tree (with N=4), which is great, but not enough.
*-
*-*-
*-*-*-
*-*-*-*-
*
I planned on reversing what I had (basically right-aligning the product of the function) to create the left side, subsequently delete the rightmost column of the left side and glue it together with the right side of the tree, creating a Christmas tree.
I really hope that someone can help me achieve this! Looking forward to your advice.
Thanks in advance.

For anyone interested: this is what I ended up doing in R to create a Christmas tree.
#ctree: prints a Christmas tree on screen with amount of branch levels N
ctree <- function(N){
filler = "*"
blank = ""
for (i in 1:N){
row = c(sample(blank,N-i,replace=T),sample(filler,i,replace=T),sample(blank,N-i,replace=T))
cat(row,"\n")
}
cat(c(sample(blank,(N-1),replace=T),sample(filler,1,replace=T),sample(blank,(N-1),replace=T)),"\n")
} #ctree
This being the result! My own happy little (or big, whatever floats your boat) tree.

Here is a more succinct version:
ctree <- function(N=10){
for (i in 1:N) cat(rep("",N-i+1),rep("*",i),"\n")
cat(rep("",N),"*\n")
}
ctree()

This code came from someone else. I wish I could credit them but I have lost the source. The tree it produces is beautiful, and perhaps you could modify it for your purposes.
part <- list(x0=0,y0=0,x1=0,y1=1,
branch1=NULL,branch2=NULL,extend=NULL,
lwd=1,depth=0,col='springgreen')
par(mfrow=c(1,1),mar=c(5, 4, 4, 2) + 0.1)
segplot <- function(tree) {
if (is.null(tree)) return()
segments(tree$x0,tree$y0,tree$x1,tree$y1,
col=tree$col,
lwd=tree$lwd)
segplot(tree$branch1)
segplot(tree$branch2)
segplot(tree$extend)
}
#segplot(part)
grow <- function(tree) {
if (is.null(tree) ) return(NULL)
tree$lwd=tree$lwd*1.2
if (tree$lwd>2.5) tree$col <- 'brown'
if (is.null(tree$extend)) {
tree$extend <- list(
x0=tree$x1,
y0=tree$y1,
x1=rnorm(1,1,.03)*(2*tree$x1-tree$x0),
y1=(rnorm(1,.98,.02)+.02*(tree$x1==tree$x0))*(2*tree$y1-tree$y0),
branch1=NULL,
branch2=NULL,
extend=NULL,
lwd=1,
depth=tree$depth,
col=tree$col
)
length=sqrt((tree$x1-tree$x0)^2 + (tree$y1-tree$y0)^2)
angle <- asin((tree$x1-tree$x0)/length)
branch <- list(
x0=(tree$x1+tree$x0)/2,
y0=(tree$y1+tree$y0)/2,
branch1=NULL,
branch2=NULL,
extend=NULL,
lwd=1,
depth=tree$depth,
col=tree$col
)
shift <- rnorm(2,.5,.1)
branch$x0 <- shift[1]*tree$x1+(1-shift[1])*tree$x0
branch$y0 <- shift[1]*tree$y1+(1-shift[1])*tree$y0
length=length*rnorm(1,.5,.05)
co <- runif(1,.35,.45)
branch$x1 <- branch$x0+sin(angle+co)*length
branch$y1 <- branch$y0+cos(angle+co)*length
tree$branch1 <- branch
branch$x0 <- shift[2]*tree$x1+(1-shift[2])*tree$x0
branch$y0 <- shift[2]*tree$y1+(1-shift[2])*tree$y0
co <- runif(1,.35,.45)
branch$x1 <- branch$x0+sin(angle-co)*length
branch$y1 <- branch$y0+cos(angle-co)*length
tree$branch2 <- branch
} else {
tree$branch1 <- grow(tree$branch1)
tree$branch2 <- grow(tree$branch2)
tree$extend <- grow(tree$extend)
}
tree$depth <- tree$depth+1
if (tree$depth>2) tree$col <- 'green'
if (tree$depth>4) tree$col <- 'darkgreen'
if (tree$depth>6) tree$col <- 'brown'
tree
}
tree <- part
for (i in 1:9) tree <- grow(tree)
par(mar=c(0,0,0,0))
plot(x=c(-3,3),y=c(0,9),type='n',axes=FALSE,xlab='',ylab='')
segplot(tree)

Related

iteration of a loop function in a list

I deleted the old question since it was not clear.
I would like to ask how we can interate a loop function for a list
I created one example by using the phytools package
# a set of trees
List <- list(tree1= pbtree(n=3, tip.label = c("Pycnonotus_simplex", "Pycnonotus_brunneus", "Blythipicus_rubiginosus")),
tree2 = pbtree(n=3, tip.label = c("Blythipicus_rubiginosus", "Pycnonotus_erythropthalmos", "Orthotomus_atrogularis")))
class(List) <- "multiPhylo"
# a vector of species would be added
spp <- c("Pycnonotus_sp.02", "Pycnonotus_sp.08")
I will add randomly spp to one tree by add.species.to.genus
for (i in 1:length(spp)){
tree1 <- add.species.to.genus(tree1, spp [i], where = "random")
}
I hope now my question is clear. Any help/suggestion would be appreciated.
Updated
Hi guys,
I already solved my problem since when I use the fuction add.species.to.genus that results in the limited precision in the edge lengths of the tree.
By using force.ultrametric fucntion will deal with
for (i in 1:length(List)){
tree[[i]] <- List[[i]]
for (j in 1:length(spp)){
tree[[i]] <- force.ultrametric(tree[[i]])
tree[[i]] <- add.species.to.genus(tree[[i]], spp[j], where = "random")
}
}

For>while>for loops slowing down this R code?

I apologize in advance for the elementary question, but thought it may be a quick pointer from someone out there.
I am looking at this publicly-available code and wondering why it runs slow (or stalls completely), when the mu for the negative binomial generation is >1. Is it related to the nested loops?
Thank you.
for(i in 1:runs) {
cases <- seed
t <- rep(0,seed)
times <- t
while(cases > 0) {
secondary <- rnbinom(cases,size=fit.cases$estimate[1],mu=fit.cases$estimate[2])
t.new <- numeric()
for(j in 1:length(secondary)) {
t.new <- c(t.new,t[j] + rgamma(secondary[j],shape=fit.serial$estimate[1],
rate=fit.serial$estimate[2]))
}
cases <- length(t.new)
t <- t.new
times <- c(times,t.new)
}
lines(sort(times),1:length(times),col=cols[i],lwd=1)
points(max(times),length(times),col=cols[i],pch=16)
}
https://github.com/calthaus/Ebola/blob/master/Superspreading%20(Lancet%20Inf%20Dis%202015)/Ebola_superspreading_analysis.R

R - Assigning Plot to Variably Named List

I am trying to assign a plot to a list that is named via variable (snm). My code snippet is all the variations that I tried to do to make it work. What other option am I missing? Thanks.
My goal is to loop over my graph assignments, using an IF statement to change the snm and a few other variables that I will use in the graphs.
for (x in seq(0,1)) {
if (x==0) {
snm="grad"
}
else if (x==1) {
snm="start"
}
assign(snm,list(),envir=.GlobalEnv) #works
assign(snm[[1]],ggplot(data=TDSF, aes(x=Graduation))+geom_histogram()+labs(title="A"),envir=.GlobalEnv) #works
assign(snm[[2]],ggplot(data=TDSF, aes(x=Graduation,weights=Donation))+geom_bar()+labs(title="B"),envir=.GlobalEnv) #fails "subscript out of bonds"
assign(snm[[3]],ggplot(data=TDSF, aes(x=State,weights=Donation))+geom_bar()+labs(title="B")+scale_y_sqrt(),envir=.GlobalEnv) #fails "subscript out of bonds"
grid.arrange(grad[[1]],grad[[2]],grad[[3]])
}
Partial solution based on #MrFlick and #hrbrmstr, but 1) I have to use do.call in the loop or I get the same graphs and 2) seeing mapply I feel that I should be able to use it, but cannot get it to work.
library(ggplot2)
library(gridExtra)
set.seed(1492)
TDSF <- data.frame(Graduation=sample(1950:2010, 30),
Donation=sample(300:10000, 30),
Start.Year=sample(1950:2010,30),
State=sample(state.abb,30,replace=TRUE))
plots <- list()
for (x in seq(0,1)) {
if (x==0) {
nm=quote(Graduation)
snm="grad"
}
else if (x==1) {
nm=quote(Start.Year)
snm="start"
}
plots[[snm]]<-list()
plots[[snm]][[1]] <- ggplot(data=TDSF, aes(x=eval(nm)))+geom_histogram()+labs(title=paste("Number of People per",snm,"Year"))
plots[[snm]][[2]] <- ggplot(data=TDSF, aes(x=eval(nm),weights=Donation))+geom_bar()+labs(title=paste("Donations by",snm,"Year"))
plots[[snm]][[3]] <- ggplot(data=TDSF, aes(x=State,weights=Donation))+geom_bar()+labs(title="Donations by State")+scale_y_sqrt()
}
do.call(grid.arrange,plots[["grad"]])
do.call(grid.arrange,plots[["start"]])
mapply attempt:
plot<-mapply(function(snm,nm) list(
{ggplot(data=TDSF, aes(x=nm))+geom_histogram()+labs(title=paste("Number of People per",snm,"Year"))},
{ggplot(data=TDSF, aes(x=nm,weights=Donation))+geom_bar()+labs(title=paste("Donations by",snm,"Year"))},
{ggplot(data=TDSF, aes(x=State,weights=Donation))+geom_bar()+labs(title="Donations by State")+scale_y_sqrt()}
), c("grad","start"),c("Graduation","Start.Year"),SIMPLIFY = FALSE)
do.call(grid.arrange,plot[["grad"]])
do.call(grid.arrange,plot[["start"]])
Despite a lengthy code snippet, your question really isn't clear. Are you trying to do something like this?
library(ggplot2)
library(gridExtra)
set.seed(1492)
TDSF <- data.frame(Graduation=sample(1950:2010, 30),
Donation=sample(300:10000, 30))
snm <- mapply(function(x, title) {
ggplot(TDSF, aes_(x=as.name(x))) +
geom_histogram() +
labs(title=title)
}, c("Graduation", "Donation"), c("A", "B"), SIMPLIFY=FALSE)
do.call(grid.arrange, snm)
What I wanted to do originally is not possible in that exact manner. However, based on the feedback I was able to create a list of lists of ggplots. This condenses my out down to 1 variable versus the 2 I was targeting. Instead of start[[1]] to plot the first graph I use plot[["start"]][[1]]. Makes sense when you read it, but was not how I expected. I come from VBA and python so R is new format.
Mapply is also incredibly more powerful/simple approach than I was originally doing, so thanks for that input.
library(ggplot2)
library(gridExtra)
set.seed(1492)
TDSF <- data.frame(Graduation=sample(1950:2010, 30),
Donation=sample(300:10000, 30),
Start.Year=sample(1950:2010,30),
State=sample(state.abb,30,replace=TRUE))
plot<-mapply(function(snm,nm) list(
{ggplot(data=TDSF, aes_q(x=as.name(nm)))+geom_histogram()+labs(title=paste("Number of People per",snm,"Year"))},
{ggplot(data=TDSF, aes_q(x=as.name(nm),weights=~Donation))+geom_bar()+labs(title=paste("Donations by",snm,"Year"))},
{ggplot(data=TDSF, aes(x=State,weights=Donation))+geom_bar()+labs(title="Donations by State")+scale_y_sqrt()}
), c("grad","start"),c("Graduation","Start.Year"),SIMPLIFY = FALSE)
do.call(grid.arrange,plot[["grad"]])
do.call(grid.arrange,plot[["start"]])

Get sequence of adjacent cell numbers out of a raster

I am currently working on a script, that loads a TIF file into a raster object, crops it and plots two points (starting point and point of destination; selected via the click-function) into that raster. I then want it to get the cell numbers of those two points. All of that hasn't caused any trouble but now I have tried to write a while-Loop which gets me the number of a random cell (which is adjacent to the current cell; beginning from the starting point) until that cell number equals the cell number of my point of destination. My idea behind that was to "walk" across the raster until I have reached my point of destination or at least the column containing it (to reduce computation time). The numbers of the cells i cross during that walk should be stored in a vector ("Path"). I select the adjacent cell (=choose my next step) by randomly sampling from a vector that contains numbers that, when added to the current cell number, lead to the number of an adjacent cell. I have multiple vectors from which to sample as the number of possible directions in which to "walk" differs depending on the position of the current cell (e.g. I can't "walk" to the cell to my lower rigth (=n + (ncol_dispersal + 1) if I am currently positioned at the bottom of the raster). The script looks like this so far:
library(gdistance)
library(raster)
library(rgdal)
library(sp)
setwd("C:/Users/Giaco/Dropbox/Random Walk")
altdata <- raster("altitude.tif")
plot(altdata)
e <- extent(92760.79,93345.79,204017.5,204242.5)
dispersal_area <- crop(altdata,e)
plot(dispersal_area)
points(92790.79,204137.5,pch=16,cex=1)
points(93300.79,204062.5,pch=16,cex=1)
Pts <- matrix(c(92790.79,204137.5,93300.79,204062.5),nrow=2,ncol=2,byrow=TRUE)
Start <- cellFromXY(dispersal_area,Pts[1,])
End <- cellFromXY(dispersal_area,Pts[2,])
nrow_dispersal <- nrow(dispersal_area)
ncol_dispersal <- ncol(dispersal_area)
col_start <- colFromCell(dispersal_area,Start)
row_start <- rowFromCell(dispersal_area,Start)
col_end <- colFromCell(dispersal_area,End)
row_end <- rowFromCell(dispersal_area,End)
upper_left_corner <- cellFromRowCol(dispersal_area,1,1)
lower_left_corner <- cellFromRowCol(dispersal_area,14,1)
sample_standard <- c(1,(ncol_dispersal+1),(ncol_dispersal*-1+1))
sample_top <- c(1,ncol_dispersal,(ncol_dispersal+1))
sample_bottom <- c(1,(ncol_dispersal*-1+1),(ncol_dispersal*-1))
sample_left <- c(1,(ncol_dispersal+1),(ncol_dispersal*-1+1))
sample_upper_left <- c(1,ncol_dispersal,(ncol_dispersal+1))
sample_lower_left <- c(1,(ncol_dispersal*-1+1),(ncol_dispersal*-1))
Path <- c()
Path[1] <- Start
n <- Start
counter <- 1
while (n != End)
{
n = Start+sample(sample_standard,1)
if (colFromCell(dispersal_area,n)==col_end) {
n=End
break
} else if (n==upper_left_corner) {
n = n+sample(sample_upper_left,1)
} else if(n==lower_left_corner){
n = n+sample(sample_lower_left,1)
} else if(colFromCell(dispersal_area,n)==1) {
n = n+sample(sample_left,1)
} else if(rowFromCell(dispersal_area,n)==1){
n = n+sample(sample_top,1)
} else if(rowFromCell(dispersal_area,n)==nrow_dispersal) {
n = n+sample(sample_bottom,1)
}
counter <- counter+1
Path[counter] <- n
}
When I run the script and print the path vector it returns a veeerryy long vector (I always have to stop it as it never finishes computing) which contains only a few different numbers. Why is that ? I have been staring at this all day but I simply can't figure out where i went wrong. There must be something wrong with the while Loop but I don't see it.
If anyone of you guys could help me out with this I would be really really thankful.
Thanks in advance !
Here is a simple and reproducible example (that also answers your question).
library(gdistance)
r <- raster(system.file("external/maungawhau.grd", package="gdistance"))
r <- aggregate(r, 5)
p <- matrix(c(2667531, 6478843, 2667731, 6479227), ncol=2, byrow=TRUE)
start <- cellFromXY(r, p[1,])
end <- cellFromXY(r, p[2,])
counter <- 1
cell <- start
path <- cell
while (cell != end) {
a <- adjacent(r, cell, pairs=F)
cell <- sample(a, 1)
path <- c(path, cell)
}
xy <- xyFromCell(r, path)
plot(r)
lines(xy)
or
cols <- rainbow(nrow(xy))
for (i in 1:nrow(xy)-1) { lines(xy[i:(i+1), ], col=cols[i]) }
This is pretty fast on this coarse raster, but it could indeed take a very long time to reach a particular cell on a large raster by random walk.
Perhaps there are function in gdistance that are more useful?

Trying to use a for loop for population simulation(2)

Im sorry to say that I have a problem with a for loop, again. I'm trying to save the final number from a population estimate for loop into a new matrix but I am only able to get the population estimate to show up in row 100. I know it relates to breedingPop2 but I cant figure it out. Any help would be much appreciated. Please find the code below:
finalPop=matrix(nrow=102, ncol=1)
for(i in 1:100){
SWWAyears=data.frame(iteration=rep(NA,101),pop=NA)
breedingPop<-90000
fallMig<-.825
springMig<-.825
winterSurvival<-rbeta(100,.95,.05)
npFecund<-rbinom(100, 3.0, .9)
pFecund<-rbeta(100, .85,.25)
breedingSurvival<-rbeta(100,.95,.05)
# Set initial starting condition
SWWAyears[1,2]=breedingPop
for(years in 2:101) {
fallPop<-(SWWAyears[years-1,2]*fallMig)
for (i in 1:100){
winterPop<-(fallPop*winterSurvival[i])}
springPop<-(winterPop*springMig)
for (i in 1:100){
summerPop<-(springPop*breedingSurvival[i])
}
for(i in 1:100){
breedingPop2<-((summerPop*.26)*npFecund[i])+((summerPop*.14)*pFecund[i])+(summerPop*.60)
}
SWWAyears[years,1]=years
SWWAyears[years,2]<-breedingPop2
}
finalPop[i,1]<-breedingPop2
}
I think you have more fundamental issues with your looping structure and you're not getting the correct results you're expecting. However, the reason for your specific question about only the 100th row being updated is:
Your variable i is being updated inside your 'inner' for() loops, so by the time you reach finalPop[i, 1] <- breedingPop2, i always equals 100.
You need to use a different variable, j for example, in your inner for() loops.
finalPop=matrix(nrow=102, ncol=1)
for(i in 1:100){
SWWAyears = data.frame(iteration=rep(NA,101),pop=NA)
breedingPop <- 90000
fallMig <- .825
springMig <- .825
winterSurvival <- rbeta(100,.95,.05)
npFecund <- rbinom(100, 3.0, .9)
pFecund <- rbeta(100, .85,.25)
breedingSurvival <- rbeta(100,.95,.05)
# Set initial starting condition
SWWAyears[1,2] = breedingPop
for(years in 2:101) {
fallPop <- (SWWAyears[years-1,2]*fallMig)
for (j in 1:100){
winterPop <- (fallPop*winterSurvival[j])
}
springPop <- (winterPop*springMig)
for (j in 1:100){
summerPop <- (springPop*breedingSurvival[j])
}
for(j in 1:100){
breedingPop2 <- ((summerPop*.26)*npFecund[j])+((summerPop*.14)*pFecund[j])+(summerPop*.60)
}
SWWAyears[years,1] = years
SWWAyears[years,2] <- breedingPop2
}
finalPop[i,1] <- breedingPop2
}
Having said that, using multiple nested for() loops is generally not recommended in R; you should be able to use matrix multiplication / vectorisation to achieve the same result.
Other Issues
your values of winterPop and summerPop will only ever be fallPop * winterSurvival[100] and springPop * breedingSurvival[100] respectively. Is this what you intended?

Resources