A shiny app to generate creel schedules

Background to the creel schedule

The backbone to a creel survey is the schedule. Schedules often follow a stratified multi-stage probability sampling regime (Malvestuto, 1996) to determine days of interviews. This often means that there are a number of weekend days and weekday days chosen each month to sample and then these are then randomly selected from those that are available. During any day sampled, a shift chosen. For our needs here in Nebraska, we use two periods (a morning shift and an afternoon shift). The morning shift will go from sunrise (based on sunrise times in Kearney, Nebraska) to 1330 and an afternoon shift that goes from 1330 until sunset (also based on sunset times in Kearney).It is during this time, that the creel clerk will conduct interviews with anglers to estimate the catch rate of the anglers. In addition, a creel clerk is also required to conduct an instantaneous (or as close as possible) count of the number of anglers on the waterbody. The count is used to estimate the number of anglers using the waterbody during that day. These two values are ultimately multiplied together to estimate the total number of fish caught and harvested.

The creel schedule app

There are a few options to change parts of the creel schedules using these apps, keeping within the two period, sunrise to sunset framework I mentioned earlier.

If changes are made in the parameters, there will be no changes made to the schedule to the right until you press Submit.

Download the schedule as a *csv file. The filename should be in the format “Lake XXXXXXschedule-2015.csv”

There are still a few bugs that I am working on but if you find any please send me a note. I would be happy to incorporate any bugs or ideas that you might have to better improve the scheduler.

How to use

If you want to use the app there are several ways you can run the app:

library(shiny)
runGitHub("creelr", "chrischizinski", subdir = "shiny/schedule", launch.browser =TRUE)

Some people were having trouble getting the app to run through GitHub, although it works on my computer fine.

library(shiny)

runUrl("https://github.com/chrischizinski/creelr/archive/master.zip",
       subdir = "shiny/schedule", launch.browser =TRUE)

runUrl("https://github.com/chrischizinski/creelr/archive/master.tar.gz",
       subdir = "shiny/schedule", launch.browser =TRUE)

Or you can clone the git repository, then use runApp():

# First clone the repository with git. If you have cloned it into
# ~/schedule, first go to that directory, then use runApp().
setwd("~/schedule")
runApp()

If you are using any of the options above with RStudio, make sure that you have launch.browser =TRUE indicated or you will not be able to download the schedule.

Or and perhaps easiest of all (particularly if you are not using RStudio) you can follow this link: chrischizinski.shinyapps.io/scheduleR

References

Malvestuto, S.P., 1996. Sampling the recreational fishery. In: Murphy, B.R., Willis, D.M. (Eds.), Fisheries Techniques. (second ed.). American Fisheries Society, Bethesda, MD, pp. 591–623.

Creating the data

First lets create some data. We will create three sets of sites (30 sites, 10 species) for each of three treatments. The number of individuals for each species in a site will be drawn from a negative binomial distribution using rnbinom() using the a similar mean number of species but allowing the dispersion parameter to be different. Note: This data was created just to illustrate this post and I am sure it could be done better to illustrate actual ecological data and provide better NMDS fits.

set.seed(123456789)
num<-30
disp.a<-5
sites.a<-data.frame(sp.a=rnbinom(num,mu = 40, size = disp.a),
                    sp.b=rnbinom(num,mu = 60, size = disp.a),
                    sp.c=rnbinom(num,mu = 50, size = disp.a),
                    sp.d=rnbinom(num,mu = 70, size = disp.a),
                    sp.e=rnbinom(num,mu = 10, size = disp.a),
                    sp.f=rnbinom(num,mu = 180, size = disp.a),
                    sp.g=rnbinom(num,mu = 100, size = disp.a),
                    sp.h=rnbinom(num,mu = 80, size = disp.a),
                    sp.i=rnbinom(num,mu = 40, size = disp.a),
                    sp.j=rnbinom(num,mu = 50, size = disp.a))

disp.b<-50
sites.b<-data.frame(sp.a=rnbinom(num,mu = 40, size = disp.a),
                    sp.b=rnbinom(num,mu = 60, size = disp.b),
                    sp.c=rnbinom(num,mu = 50, size = disp.a),
                    sp.d=rnbinom(num,mu = 70, size = disp.b),
                    sp.e=rnbinom(num,mu = 10, size = disp.a),
                    sp.f=rnbinom(num,mu = 180, size = disp.a),
                    sp.g=rnbinom(num,mu = 100, size = disp.b),
                    sp.h=rnbinom(num,mu = 80, size = disp.a),
                    sp.i=rnbinom(num,mu = 40, size = disp.b),
                    sp.j=rnbinom(num,mu = 50, size = disp.a))

disp.c<-200
sites.c<-data.frame(sp.a=rnbinom(num,mu = 40, size = disp.a),
                    sp.b=rnbinom(num,mu = 60, size = disp.b),
                    sp.c=rnbinom(num,mu = 50, size = disp.c),
                    sp.d=rnbinom(num,mu = 70, size = disp.b),
                    sp.e=rnbinom(num,mu = 10, size = disp.c),
                    sp.f=rnbinom(num,mu = 180, size = disp.a),
                    sp.g=rnbinom(num,mu = 100, size = disp.b),
                    sp.h=rnbinom(num,mu = 80, size = disp.c),
                    sp.i=rnbinom(num,mu = 40, size = disp.b),
                    sp.j=rnbinom(num,mu = 50, size = disp.c))

all.sites<-rbind(sites.a,sites.b,sites.c)


trt<-rep(c("C","H","L"),each=nrow(sites.a))

Running an NMDS

Then we can run this through metaMDS and plot it in ggplot using stat_ellipse to generate the confidence ellipses.

library(vegan)
library(ggplot2)
library(grid)

all.mds <- metaMDS(all.sites)  #using all the defaults

## Square root transformation
## Wisconsin double standardization
## Run 0 stress 0.2650943 
## Run 1 stress 0.2680585 
## Run 2 stress 0.2648514 
## ... New best solution
## ... procrustes: rmse 0.06298445  max resid 0.244192 
## Run 3 stress 0.2640097 
## ... New best solution
## ... procrustes: rmse 0.07531341  max resid 0.2861196 
## Run 4 stress 0.2646814 
## Run 5 stress 0.2675274 
## Run 6 stress 0.2773219 
## Run 7 stress 0.2663498 
## Run 8 stress 0.2674223 
## Run 9 stress 0.2776589 
## Run 10 stress 0.2650576 
## Run 11 stress 0.2832777 
## Run 12 stress 0.2738943 
## Run 13 stress 0.2797539 
## Run 14 stress 0.2705419 
## Run 15 stress 0.2705508 
## Run 16 stress 0.2881442 
## Run 17 stress 0.2640104 
## ... procrustes: rmse 0.001211731  max resid 0.008448712 
## *** Solution reached

data.scores <- as.data.frame(scores(all.mds))  
data.scores$site <- rownames(data.scores)  
data.scores$grp<-trt

ggplot(data=data.scores) + 
  stat_ellipse(aes(x=NMDS1,y=NMDS2,colour=trt),level = 0.50) +
  geom_point(aes(x=NMDS1,y=NMDS2,shape=trt,colour=trt),size=4) + 
  theme_mine()

adonis

In the above plot, we can see a lot of overlap in the 50% ellipses and the centroids are not that different suggesting that the groups are not that different. But, running the same data in adonis indicates that there are significant differences in the treatments.

adon.results<-adonis(all.sites ~ trt, method="bray",perm=999)
print(adon.results)

## 
## Call:
## adonis(formula = all.sites ~ trt, permutations = 999, method = "bray") 
## 
## Terms added sequentially (first to last)
## 
##           Df SumsOfSqs  MeanSqs F.Model      R2 Pr(>F)  
## trt        2   0.08327 0.041635  1.9988 0.04393  0.018 *
## Residuals 87   1.81222 0.020830         0.95607         
## Total     89   1.89549                  1.00000         
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

So why do we get a significant value from adonis? adonis works by first finding the centroids for each group and then calculates the squared deviations of each of site to that centroid. Then significance tests are performed using F-tests based on sequential sums of squares from permutations of the raw data.

A good way to see why we are getting differences by plotting this out. The process is to calculate this distance matrix for the data using the vegdist function and then calculate the multivariate homogeneity of group dispersions (variances) using betadisper. For more information on the process behind this read the Details from help(betadisper).

## Bray-Curtis distances between samples
dis <- vegdist(all.sites)

## Calculate multivariate dispersions
mod <- betadisper(dis, trt)
mod

## 
##  Homogeneity of multivariate dispersions
## 
## Call: betadisper(d = dis, group = trt)
## 
## No. of Positive Eigenvalues: 36
## No. of Negative Eigenvalues: 53
## 
## Average distance to median:
##      C      H      L 
## 0.1635 0.1395 0.1050 
## 
## Eigenvalues for PCoA axes:
##  PCoA1  PCoA2  PCoA3  PCoA4  PCoA5  PCoA6  PCoA7  PCoA8 
## 0.7084 0.2641 0.1971 0.1648 0.1464 0.1401 0.1301 0.1257

Visualizing the multivariate homogeneity of group dispersions

We can then plot this out in steps so it is easier to visualize. First, I will extract the data and get it in a forma that ggplot2 can use.

# extract the centroids and the site points in multivariate space.  
centroids<-data.frame(grps=rownames(mod$centroids),data.frame(mod$centroids))
vectors<-data.frame(group=mod$group,data.frame(mod$vectors))

# to create the lines from the centroids to each point we will put it in a format that ggplot can handle
seg.data<-cbind(vectors[,1:3],centroids[rep(1:nrow(centroids),as.data.frame(table(vectors$group))$Freq),2:3])
names(seg.data)<-c("group","v.PCoA1","v.PCoA2","PCoA1","PCoA2")

# create the convex hulls of the outermost points
grp1.hull<-seg.data[seg.data$group=="C",1:3][chull(seg.data[seg.data$group=="C",2:3]),]
grp2.hull<-seg.data[seg.data$group=="H",1:3][chull(seg.data[seg.data$group=="H",2:3]),]
grp3.hull<-seg.data[seg.data$group=="L",1:3][chull(seg.data[seg.data$group=="L",2:3]),]
all.hull<-rbind(grp1.hull,grp2.hull,grp3.hull)

I will use grid.arrange from gridExtra to create display each treatment seperately and then have a combined panel.

First points (black symbols) and the centroids (red symbols).

library(gridExtra)

panel.a<-ggplot() + 
  geom_point(data=centroids[1,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=16) + 
  geom_point(data=seg.data[1:30,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=16) +
  labs(title="Control",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.b<-ggplot() + 
  geom_point(data=centroids[2,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=17) + 
  geom_point(data=seg.data[31:60,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=17) +
  labs(title="High",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.c<-ggplot() + 
  geom_point(data=centroids[3,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=15) + 
  geom_point(data=seg.data[61:90,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=15) +
  labs(title="Low",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.d<-ggplot() + 
  geom_point(data=centroids[,1:3], aes(x=PCoA1,y=PCoA2,shape=grps),size=4,colour="red") + 
  geom_point(data=seg.data, aes(x=v.PCoA1,y=v.PCoA2,shape=group),size=2) +
  labs(title="All",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

grid.arrange(panel.a,panel.b,panel.c,panel.d,nrow=1)

Then the vector segments

panel.a<-ggplot() +
  geom_segment(data=seg.data[1:30,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[1,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=16) + 
  geom_point(data=seg.data[1:30,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=16) +
  labs(title="Control",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.b<-ggplot() + 
  geom_segment(data=seg.data[31:60,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[2,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=17) + 
  geom_point(data=seg.data[31:60,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=17) +
  labs(title="High",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.c<-ggplot() + 
  geom_segment(data=seg.data[61:90,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) +
  geom_point(data=centroids[3,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=15) + 
  geom_point(data=seg.data[61:90,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=15) + 
  labs(title="Low",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.d<-ggplot() + 
  geom_segment(data=seg.data,aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[,1:3], aes(x=PCoA1,y=PCoA2,shape=grps),size=4,colour="red") + 
  geom_point(data=seg.data, aes(x=v.PCoA1,y=v.PCoA2,shape=group),size=2) +
  labs(title="All",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

grid.arrange(panel.a,panel.b,panel.c,panel.d,nrow=1)

Then the hulls

panel.a<-ggplot() +
  geom_polygon(data=all.hull[all.hull=="C",],aes(x=v.PCoA1,y=v.PCoA2),colour="black",alpha=0,linetype="dashed") +
  geom_segment(data=seg.data[1:30,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[1,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=16) + 
  geom_point(data=seg.data[1:30,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=16) +
  labs(title="Control",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.b<-ggplot() + 
  geom_polygon(data=all.hull[all.hull=="H",],aes(x=v.PCoA1,y=v.PCoA2),colour="black",alpha=0,linetype="dashed") +
  geom_segment(data=seg.data[31:60,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[2,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=17) + 
  geom_point(data=seg.data[31:60,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=17) +
  labs(title="High",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.c<-ggplot() + 
  geom_polygon(data=all.hull[all.hull=="L",],aes(x=v.PCoA1,y=v.PCoA2),colour="black",alpha=0,linetype="dashed") +
  geom_segment(data=seg.data[61:90,],aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) +
  geom_point(data=centroids[3,1:3], aes(x=PCoA1,y=PCoA2),size=4,colour="red",shape=15) + 
  geom_point(data=seg.data[61:90,], aes(x=v.PCoA1,y=v.PCoA2),size=2,shape=15) + 
  labs(title="Low",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

panel.d<-ggplot() + 
  geom_polygon(data=all.hull,aes(x=v.PCoA1,y=v.PCoA2),colour="black",alpha=0,linetype="dashed") +
  geom_segment(data=seg.data,aes(x=v.PCoA1,xend=PCoA1,y=v.PCoA2,yend=PCoA2),alpha=0.30) + 
  geom_point(data=centroids[,1:3], aes(x=PCoA1,y=PCoA2,shape=grps),size=4,colour="red") + 
  geom_point(data=seg.data, aes(x=v.PCoA1,y=v.PCoA2,shape=group),size=2) +
  labs(title="All",x="",y="") +
  coord_cartesian(xlim = c(-0.2,0.2), ylim = c(-0.25,0.2)) +
  theme_mine() + 
  theme(legend.position="none")

grid.arrange(panel.a,panel.b,panel.c,panel.d,nrow=1)

In the above data, we can see that the control data has the greatest variance (i.e., differences between each black point and the red centroid) in the data, followed by the high treatment, and then the low treatment. The significance shown by adonis, in the case of this data, is due to the variation associated with the treatment groups. This should not surprising given that when we created data at the beginning, we used the same mean number of individuals and just differed the size argument in rnbinom().

Plot as is

set.seed(20140824)

library(ggplot2)

## Use suppressPackageStartupMessages to eliminate package startup messages.

# First make up some data with different values for y with different scales
foo.dat<-rbind(data.frame(group="A", x = runif(50), y=rnorm(50,mean=5)),
                data.frame(group="B", x = runif(50), y=rnorm(50,mean=5,sd=3)+20),
                data.frame(group="C", x = runif(50), y=rnorm(50,mean=5,sd=5)+30))

## Plot it in ggplot
ggplot() + 
  geom_point(data=foo.dat,aes(x=x,y=y,colour=group),size=4) + 
  facet_wrap(~group,scales="free_y") + ## using scales="free_y" allows the y-axis to vary while keeping x-axis constant among plots
  theme_bw()

ggplot() + geom_point(data = foo.dat, aes(x = x, y = y, colour = group), size = 4) + 
    facet_wrap(~group, scales = "free_y") + coord_cartesian(ylim = c(0, 50)) + 
    theme_bw()

## Plot it in ggplot
ggplot() + geom_point(data = foo.dat, aes(x = x, y = y, colour = group), size = 4) + 
    facet_wrap(~group, scales = "free_y") + expand_limits(y = 0) + scale_y_continuous(expand = c(0, 
    0)) + theme_bw()

blank_data <- data.frame(group = c("A", "A", "B", "B", "C", "C"), x = 0, y = c(0, 
    8, 0, 40, 0, 50))

## Plot it in ggplot
ggplot() + geom_point(data = foo.dat, aes(x = x, y = y, colour = group), size = 4) + 
    geom_blank(data = blank_data, aes(x = x, y = y)) + facet_wrap(~group, scales = "free_y") + 
    expand_limits(y = 0) + scale_y_continuous(expand = c(0, 0)) + theme_bw()

makeanglers()

makeanglers <- function(nanglers = 50) {
    # This function generates a simulated angler population with a set location,
    # starting time , and trip length.
    anglers <- data.frame(angl.id = 1:nanglers)
    start.pos <- 0.004
    spacing <- (1 - start.pos)/nanglers
    
    anglers$loc <- seq(from = start.pos, by = spacing, length = nanglers)
    
    # Give all the anglers a start time representing 1.0 hour into the fishing
    # day
    anglers$starttime <- rep(1, nanglers)
    
    # Assign each angler a triplength, where the duration of the trip will
    # alternate between 3 and 6 hours as the anglers alternate .
    anglers$triplength <- c(rep(c(3, 6), nanglers/2))
    
    # NOTE : nanglers/2 = 25 . If the value of nanglers is an odd number, the
    # number of repetions given by rep() would be one number short . For our
    # purposes only even numbers were used .
    
    return(anglers)
}

Run the function with the 50 anglers to generate the data

anglers <- makeanglers(nanglers = 50)
anglers

##    angl.id     loc starttime triplength
## 1        1 0.00400         1          3
## 2        2 0.02392         1          6
## 3        3 0.04384         1          3
## 4        4 0.06376         1          6
## 5        5 0.08368         1          3
## 6        6 0.10360         1          6
## 7        7 0.12352         1          3
## 8        8 0.14344         1          6
## 9        9 0.16336         1          3
## 10      10 0.18328         1          6
## 11      11 0.20320         1          3
## 12      12 0.22312         1          6
## 13      13 0.24304         1          3
## 14      14 0.26296         1          6
## 15      15 0.28288         1          3
## 16      16 0.30280         1          6
## 17      17 0.32272         1          3
## 18      18 0.34264         1          6
## 19      19 0.36256         1          3
## 20      20 0.38248         1          6
## 21      21 0.40240         1          3
## 22      22 0.42232         1          6
## 23      23 0.44224         1          3
## 24      24 0.46216         1          6
## 25      25 0.48208         1          3
## 26      26 0.50200         1          6
## 27      27 0.52192         1          3
## 28      28 0.54184         1          6
## 29      29 0.56176         1          3
## 30      30 0.58168         1          6
## 31      31 0.60160         1          3
## 32      32 0.62152         1          6
## 33      33 0.64144         1          3
## 34      34 0.66136         1          6
## 35      35 0.68128         1          3
## 36      36 0.70120         1          6
## 37      37 0.72112         1          3
## 38      38 0.74104         1          6
## 39      39 0.76096         1          3
## 40      40 0.78088         1          6
## 41      41 0.80080         1          3
## 42      42 0.82072         1          6
## 43      43 0.84064         1          3
## 44      44 0.86056         1          6
## 45      45 0.88048         1          3
## 46      46 0.90040         1          6
## 47      47 0.92032         1          3
## 48      48 0.94024         1          6
## 49      49 0.96016         1          3
## 50      50 0.98008         1          6

We can calculate the total effort by the 50 anglers.

trueeffort = sum(anglers$triplength)
trueeffort

## [1] 225

We can visualize where the anglers are using ggplot2 and drawing on some geometry from days past.

library(ggplot2)
library(grid)
# source('W:/CreelProject/RFiles/themes.r') source for theme_map
radius <- 1/(2 * pi)  # calculate the radius from a circumfrence of 1 (given in the makeanglers() code)

# Create a function to generate the points on a circle Found at
# http://stackoverflow.com/questions/6862742/draw-a-circle-with-ggplot2

circleFun <- function(center = c(0, 0), diameter = 1, npoints = 100) {
    r = diameter/2
    tt <- seq(0, 2 * pi, length.out = npoints)
    xx <- center[1] + r * cos(tt)
    yy <- center[2] + r * sin(tt)
    return(data.frame(x = xx, y = yy))
}

nanglers <- 50  # Use same number of anglers as above
dat <- circleFun(c(0, 0), diameter = radius * 2, npoints = 100)  # run the code to generate circle
points2 <- data.frame(angl.id = 1:nanglers, dist = NA, x = NA, y = NA)
points2$dist[1] <- 0.004  # first angler distance from makeanglers() code
points2$dist[2:length(points2$dist)] <- 0.004 + 0.02 * (points2$angl.id[2:length(points2$dist)] - 
    1)  # add another angler an equidistant point from the initial anglers
points2$angle <- (360 * (points2$dist/(2 * pi * radius))) * (pi/180)  #  convert that distance along the circumfrence to an angle in radians

# calculate cartesian coordinate using the standard equations
points2$x <- radius * sin(points2$angle) + 0
points2$y <- radius * cos(points2$angle) + 0



lake.map <- ggplot() + geom_polygon(data = dat, aes(x, y), fill = "lightblue") + 
    geom_point(data = points2, aes(x, y), size = 4, colour = "red") + coord_equal() + 
    theme_map()

print(lake.map)

gettotalvalues()

This function was originally written to simulate a creel survey and compute estimates of total catch. I modified the code and therefore changed the name to output the interview data, thus changing the function to makeinterview() The basic process of this code is to simulate each anglers fishing day by determining simulating if and when fish are caught during the duration of each fishing trip. Using length() on the times that fish were caught will give you the number caught.

The next step is to simulate a starting position of a creel clerk (or as in the below code, a survey agent) and the speed that the creel clerk will make it around the lake. If the time that a clerk gets to a position is during the duration of the anglers fishing trip then the effort and catch is recorded at the time of the interview. If the trip duration does not fall within the encounter time, then no interview is recorded.

makeinterview <- function(ang = anglers, teffort = trueeffort, nanglers = length(anglers$loc)) {
    # Generate a catch history for each angler .  Start by obtaining a random
    # catch rate parameter for each angler following a Poisson process
    
    lambda <- rgamma(nanglers, 1) * 2
    catch <- vector("list", nanglers)
    for (i in 1:nanglers) {
        # Do this for each angler .  Time of day when the angler arrives .
        time <- ang$starttime[i]
        # If the time calculated below falls within the trip duration, this time
        # will be recorded as the instant when the first fish was caught .
        time <- time + rexp(1, rate = lambda[i])
        # At the beginning of each loop through the while statement, check to see if
        # the current fish capture time falls within the duration of the trip .
        while (time <= ang$starttime[i] + ang$triplength[i]) {
            ### NOTE : the number of fish caught is given by length(catch[[i]]) .
            catch[[i]] <- c(catch[[i]], time)
            # Calculate the time when the next fish is to be caught .
            time <- time + rexp(1, rate = lambda[i])
        }  # end of while loop
    }  # end of i for loop
    
    ################################################# Obtain a starting postion for the survey agent .
    
    startloc <- runif(1)  # Start postion of surveyor
    agentspeed <- 0.125  # Speed of the surveyor in circuits per hour (i.e., 1/8)
    
    # This time switch is nesseccary for the simulation of the circular lake,
    # with a perimeter of 1.0, where the positions 0.0 and 1.0 are equivalent on
    # the lake representation . At this point a'jump' must be made, which is
    # accomplished by our timeswitch .
    timeswitch <- (1 - startloc)/agentspeed
    
    
    inteffort <- intcatch <- cr <- vector("numeric", length = length(catch))
    # For each sample of anglers
    for (i in 1:nanglers) {
        # Calculate the time of each interview
        if ((startloc < ang$loc[i]) & (ang$loc[i] < 1)) {
            timeint <- (ang$loc[i] - startloc) * 8
        } else if ((0 < ang$loc[i]) & (ang$loc[i] < startloc)) {
            timeint <- ang$loc[i] * 8 + timeswitch
        }
        
        # Calculate the fishing effort at the time of each interview
        inteffort[i] <- 0
        if ((ang$starttime[i] < timeint) & (timeint < ang$starttime[i] + ang$triplength[i])) 
            {
                inteffort[i] <- timeint - ang$starttime[i]
            }  # else if no interview took place leave inteffort at default 0
        
        
        # Determine the number caught by the time of the interview
        intcatch[i] <- 0
        if (length(catch[[i]]) > 0) 
            {
                for (k in 1:length(catch[[i]])) {
                  
                  if ((catch[[i]][k] < timeint) & (timeint < ang$starttime[i] + 
                    ang$triplength[i])) {
                    intcatch[i] <- intcatch[i] + 1
                  }
                }
            }  # else if no fish were caught leave intcatch at default 0
        # Calculate catch rate
        if (inteffort[i] > 0) 
            cr[i] <- intcatch[i]/inteffort[i] else cr[i] <- NA
    }  # end of i for loop
    
    interview.dat <- data.frame(angl.id = ang$angl.id, intcatch = intcatch, 
        inteffort = inteffort, catchrate = cr)
    dat <- list(Actual.catches = catch, interview.data = interview.dat)
    return(dat)
}

angler.data <- makeinterview(ang = anglers, teffort = trueeffort, nanglers = length(anglers$loc))
angler.data$interview.dat

##    angl.id intcatch inteffort catchrate
## 1        1        0   0.00000        NA
## 2        2       15   5.96671    2.5139
## 3        3        0   0.00000        NA
## 4        4        0   0.00000        NA
## 5        5        0   0.00000        NA
## 6        6        0   0.00000        NA
## 7        7        0   0.00000        NA
## 8        8        0   0.00000        NA
## 9        9        0   0.00000        NA
## 10      10        0   0.00000        NA
## 11      11        0   0.00000        NA
## 12      12        0   0.00000        NA
## 13      13        0   0.00000        NA
## 14      14        0   0.00000        NA
## 15      15        0   0.03839    0.0000
## 16      16        0   0.19775    0.0000
## 17      17        1   0.35711    2.8003
## 18      18        0   0.51647    0.0000
## 19      19        4   0.67583    5.9186
## 20      20        3   0.83519    3.5920
## 21      21        1   0.99455    1.0055
## 22      22        0   1.15391    0.0000
## 23      23        2   1.31327    1.5229
## 24      24       14   1.47263    9.5068
## 25      25        0   1.63199    0.0000
## 26      26        1   1.79135    0.5582
## 27      27        1   1.95071    0.5126
## 28      28        2   2.11007    0.9478
## 29      29        9   2.26943    3.9658
## 30      30        6   2.42879    2.4704
## 31      31        2   2.58815    0.7728
## 32      32        2   2.74751    0.7279
## 33      33        0   2.90687    0.0000
## 34      34        1   3.06623    0.3261
## 35      35        0   0.00000        NA
## 36      36        0   3.38495    0.0000
## 37      37        0   0.00000        NA
## 38      38        1   3.70367    0.2700
## 39      39        0   0.00000        NA
## 40      40        0   4.02239    0.0000
## 41      41        0   0.00000        NA
## 42      42       37   4.34111    8.5232
## 43      43        0   0.00000        NA
## 44      44        3   4.65983    0.6438
## 45      45        0   0.00000        NA
## 46      46        7   4.97855    1.4060
## 47      47        0   0.00000        NA
## 48      48        2   5.29727    0.3776
## 49      49        0   0.00000        NA
## 50      50        1   5.61599    0.1781

In the above angler data, anglers with inteffort = 0 were not interviewed.

We can represent this in ggplot showing all the anglers and anglers not surveyed during that day. Note, that I did not set a seed so your figures may look a little different than this one based on the randomized nature of the catches and starting position.

points3 <- merge(points2, angler.data$interview.dat, by = "angl.id", all = TRUE)
points3$interviewed <- as.factor(ifelse(points3$inteffort > 0, 1, 0))

interview.map <- ggplot() + geom_polygon(data = dat, aes(x, y), fill = "lightblue") + 
    geom_point(data = points3, aes(x, y, colour = interviewed), size = 4) + 
    coord_equal() + theme_map()

print(interview.map)

catchrate.map <- ggplot() + geom_polygon(data = dat, aes(x, y), fill = "lightblue") + 
    geom_point(data = points3, aes(x, y, size = catchrate), colour = "red") + 
    coord_equal() + theme_map()

print(catchrate.map)

## Warning: Removed 21 rows containing missing values (geom_point).

I hope to come back and revist these code frequently in future blog posts. The authors of the report provide several different scenarios which include an effort dependent models, a learner model, and a bag limit model but there are so many more modifications that we can add.

ordisurf plots using base plots

Load the required libraries. For this demonstration I will use the dune dataset within the vegan package. The analysis I am showing here is based on information presented in the Vegan: an introduction to ordination vignette by Jari Oksanen

library(ggplot2)
library(vegan)
library(grid)
set.seed(123456)

data(dune)
head(dune)

##    Belper Empnig Junbuf Junart Airpra Elepal Rumace Viclat Brarut Ranfla
## 2       3      0      0      0      0      0      0      0      0      0
## 13      0      0      3      0      0      0      0      0      0      2
## 4       2      0      0      0      0      0      0      0      2      0
## 16      0      0      0      3      0      8      0      0      4      2
## 6       0      0      0      0      0      0      6      0      6      0
## 1       0      0      0      0      0      0      0      0      0      0
##    Cirarv Hyprad Leoaut Potpal Poapra Calcus Tripra Trirep Antodo Salrep
## 2       0      0      5      0      4      0      0      5      0      0
## 13      0      0      2      0      2      0      0      2      0      0
## 4       2      0      2      0      4      0      0      1      0      0
## 16      0      0      0      0      0      3      0      0      0      0
## 6       0      0      3      0      3      0      5      5      3      0
## 1       0      0      0      0      4      0      0      0      0      0
##    Achmil Poatri Chealb Elyrep Sagpro Plalan Agrsto Lolper Alogen Brohor
## 2       3      7      0      4      0      0      0      5      2      4
## 13      0      9      1      0      2      0      5      0      5      0
## 4       0      5      0      4      5      0      8      5      2      3
## 16      0      2      0      0      0      0      7      0      4      0
## 6       2      4      0      0      0      5      0      6      0      0
## 1       1      2      0      4      0      0      0      7      0      0

Run the ordination on the dune dataset and plot the result with base graphics

ord <- metaMDS(dune)

## Run 0 stress 0.1193 
## Run 1 stress 0.1183 
## ... New best solution
## ... procrustes: rmse 0.02027  max resid 0.06494 
## Run 2 stress 0.1183 
## ... procrustes: rmse 2.269e-05  max resid 7.575e-05 
## *** Solution reached

ord

## 
## Call:
## metaMDS(comm = dune) 
## 
## global Multidimensional Scaling using monoMDS
## 
## Data:     dune 
## Distance: bray 
## 
## Dimensions: 2 
## Stress:     0.1183 
## Stress type 1, weak ties
## Two convergent solutions found after 2 tries
## Scaling: centring, PC rotation, halfchange scaling 
## Species: expanded scores based on 'dune'

plot(ord, type = "n")
points(ord, display = "sites", cex = 1, pch = 16, col = "red")
text(ord, display = "species", cex = 1, col = "blue")

Now fit continuous environmental factors from the dune.env dataset using ordisurf.

data(dune.env)
head(dune.env)

##     A1 Moisture Management      Use Manure
## 2  3.5        1         BF Haypastu      2
## 13 6.0        5         SF Haypastu      3
## 4  4.2        2         SF Haypastu      4
## 16 5.7        5         SF  Pasture      3
## 6  4.3        1         HF Haypastu      2
## 1  2.8        1         SF Haypastu      4

plot(ord, type = "n")
points(ord, display = "sites", cex = 1, pch = 16, col = "red")
text(ord, display = "species", cex = 1, col = "blue")
ordisurf(ord, dune.env$A1, add = TRUE)

## 
## Family: gaussian 
## Link function: identity 
## 
## Formula:
## y ~ s(x1, x2, k = 10, bs = "tp", fx = FALSE)
## <environment: 0x0000000015c7dac0>
## 
## Estimated degrees of freedom:
## 1.59  total = 2.59 
## 
## REML score: 41.59

ordisurf plots using ggplot

The first step is to extract the data from the ord object and put it into a dataframe. For the purpose of this demonstration, I am going to just focus on the species scores.

Notice that I add a ‘z’ column filled with NAs, which allows the score data sets to be combined with the contour dataset.

species.scores <- as.data.frame(scores(ord, "species"))
species.scores$species <- rownames(species.scores)
names(species.scores)[c(1, 2)] <- c("x", "y")
species.scores$z <- NA

head(species.scores)

##               x        y species  z
## Belper -0.47834 -0.24453  Belper NA
## Empnig -0.08858  1.69637  Empnig NA
## Junbuf  0.26483 -0.60750  Junbuf NA
## Junart  0.91148 -0.08299  Junart NA
## Airpra -0.52855  1.67980  Airpra NA
## Elepal  1.24505  0.16158  Elepal NA

Next step is to run the ordisurf function as above.

dune.sf <- ordisurf(ord ~ dune.env$A1, plot = FALSE, scaling = 3)
head(dune.sf)

## $coefficients
## (Intercept)  s(x1,x2).1  s(x1,x2).2  s(x1,x2).3  s(x1,x2).4  s(x1,x2).5 
##   4.850e+00  -4.962e-06   1.084e-07   4.976e-06   1.178e-05  -1.745e-07 
##  s(x1,x2).6  s(x1,x2).7  s(x1,x2).8  s(x1,x2).9 
##   2.924e-06  -2.379e-05   9.978e-01   2.136e-01 
## 
## $residuals
##       1       2       3       4       5       6       7       8       9 
## -0.3474  0.7280 -0.2302 -0.8285  0.2823 -0.3654 -1.0333  2.5075  0.1111 
##      10      11      12      13      14      15      16      17      18 
##  5.0940 -0.7213 -0.9555 -1.1335 -0.1942 -0.2218 -3.1576  2.7045 -1.4852 
##      19      20 
##  0.3919 -1.1455 
## 
## $fitted.values
##     1     2     3     4     5     6     7     8     9    10    11    12 
## 3.847 5.272 4.430 6.528 4.018 3.165 5.233 3.793 3.889 6.406 4.021 4.456 
##    13    14    15    16    17    18    19    20 
## 4.833 4.794 4.522 6.658 6.596 5.185 5.408 3.945 
## 
## $family
## 
## Family: gaussian 
## Link function: identity 
## 
## 
## $linear.predictors
##     1     2     3     4     5     6     7     8     9    10    11    12 
## 3.847 5.272 4.430 6.528 4.018 3.165 5.233 3.793 3.889 6.406 4.021 4.456 
##    13    14    15    16    17    18    19    20 
## 4.833 4.794 4.522 6.658 6.596 5.185 5.408 3.945 
## 
## $deviance
## [1] 58.68

We need to extract the contour information from dune.sf object. This is in the $grid. I wrote a function that will pull out this information and put it into a dataframe with the column headers ‘x’, ‘y’, and ‘z’.

extract.xyz <- function(obj) {
    xy <- expand.grid(x = obj$grid$x, y = obj$grid$y)
    xyz <- cbind(xy, c(obj$grid$z))
    names(xyz) <- c("x", "y", "z")
    return(xyz)
}

contour.vals <- extract.xyz(obj = dune.sf)
head(contour.vals)

##         x      y     z
## 1 -0.8603 -0.716 3.133
## 2 -0.7956 -0.716 3.238
## 3 -0.7309 -0.716 3.343
## 4 -0.6662 -0.716 3.449
## 5 -0.6015 -0.716 3.554
## 6 -0.5368 -0.716 3.659

We now have the required information to reproduce the plot from ordisurf in ggplot2. The first step is the lay down the contours in the plot.

p <- ggplot(data = contour.vals, aes(x, y, z = z)) + stat_contour(aes(colour = ..level..)) + 
    coord_cartesian(xlim = c(-2, 2), ylim = c(-1, 1.5)) + theme_mine()

print(p)

## Warning: Removed 156 rows containing non-finite values (stat_contour).

Then add the species scores. Note that I am using theme_mine which can be sourced from my themes.r file

p <- p + geom_text(data = species.scores, aes(x = x, y = y, label = species), 
    colour = "red") + coord_equal() + theme_mine() + labs(x = "NMDS1", y = "NMDS2") + 
    theme(panel.border = element_rect(fill = NA), axis.text.x = element_blank(), 
        axis.text.y = element_blank(), legend.position = "none")

print(p)

## Warning: Removed 156 rows containing non-finite values (stat_contour).

labelz <- data.frame(x = c(-0.85, -0.8, -0.45, -0.15, 0.15, 0.5, 0.85), y = c(0.05, 
    1.1, 1.1, 1.1, 1, 0.75, 0.65), z = NA, labels = c("3.5", "4.0", "4.5", "5.0", 
    "5.5", "6.0", "6.5"))

p + geom_text(data = labelz, aes(x = x, y = y, label = labels), angle = -80, 
    size = 6)

## Warning: Removed 156 rows containing non-finite values (stat_contour).

library(directlabels)
direct.label(p)

## Loading required package: proto

## Warning: Removed 156 rows containing non-finite values (stat_contour).
## Warning: Removed 156 rows containing non-finite values (stat_contour).

default ggplot themes

One of my favorite aspects of ggplot2 is the use of themes. Not including a theme, the default ggplots theme is the theme_grey which has a dark grey background with white grid lines. See the example below

library(ggplot2)
library(grid)  # Needed for some aspects of the themes
library(scales)  # Needed for some aspects of the themes

ggplot(diamonds, ) + geom_point(aes(x = carat, y = price, colour = cut))

You see these plots all over the place now and you can recognize the ggplot2 style. The problem with the default theme in ggplot is that these do not work for presentation formats (e.g., publication in a journal or presentation).

There are a couple of “canned” themes that come with ggplot that offer themes do change the way the plot looks without having to edit every aspect of the visual presentation of the plot and these are theme_bw() and theme_grey

Here is an example of both plots using each theme side by side (for this presentation I turned “off” the legend).

library(gridExtra)

a <- ggplot(diamonds, ) + geom_point(aes(x = carat, y = price, colour = cut)) + 
    labs(title = "theme_grey") + theme(legend.position = "none")

b <- ggplot(diamonds, ) + geom_point(aes(x = carat, y = price, colour = cut)) + 
    labs(title = "theme_bw") + theme_bw() + theme(legend.position = "none")

grid.arrange(a, b, nrow = 2)

While the theme_bw() is an improvment it still does not meet publication quality figures (atleast in my field) or my typical presentation format. So I generated a few other themese that I use on a regular basis to make inclusion of these figures easier. The basic process is fairly straight forward. You start with the theme_bw and modify using %+replace% the aspects you wish to change.

theme_mine

theme_mine is the theme I use most often and is what I generally use for pubs.

theme_mine <- function(base_size = 12, base_family = "") {
  # Starts with theme_grey and then modify some parts
  theme_bw(base_size = base_size, base_family = base_family) %+replace%
    theme(
      strip.background = element_blank(),
      strip.text.x = element_text(size = 18),
      strip.text.y = element_text(size = 18),
      axis.text.x = element_text(size=14),
      axis.text.y = element_text(size=14,hjust=1),
      axis.ticks =  element_line(colour = "black"), 
      axis.title.x= element_text(size=16),
      axis.title.y= element_text(size=16,angle=90),
      #legend.position = "none", 
      panel.background = element_blank(), 
      panel.border =element_blank(), 
      panel.grid.major = element_blank(), 
      panel.grid.minor = element_blank(), 
      panel.margin = unit(1.0, "lines"), 
      plot.background = element_blank(), 
      plot.margin = unit(c(0.5,  0.5, 0.5, 0.5), "lines"),
      axis.line = element_line(colour = "black")
    )
}


ggplot(diamonds, ) +
  geom_point(aes(x=carat, y = price,colour=cut)) +
  labs(title="theme_mine") +
  theme_mine()

theme_presentation

My general format in presentations is to have a black background with white, yellow, and green text. I therefore created a theme (theme_presentation)that would work with the required black background and white text.

theme_presentation<- function(base_size = 28, base_family = "") {
  # Starts with theme_grey and then modify some parts
  theme_bw(base_size = base_size, base_family = base_family) %+replace%
    theme(
      strip.background = element_blank(),
      strip.text.x = element_text(size = 18,colour="white"),
      strip.text.y = element_text(size = 18,colour="white"),
      axis.text.x = element_text(size=28,colour="white"),
      axis.text.y = element_text(size=28,colour="white",hjust=1),
      axis.ticks =  element_line(colour = "white"), 
      axis.title.x= element_text(size=42,colour="white"),
      axis.title.y= element_text(size=42,angle=90,colour="white"),
      #legend.position = "none", 
      panel.background = element_rect(fill="black"), 
      panel.border =element_blank(),  
      panel.grid.major = element_blank(), 
      panel.grid.minor = element_blank(), 
      panel.margin = unit(1.0, "lines"), 
      plot.background = element_rect(fill="black"), 
      plot.title =element_text(size=28,colour="white"), 
      plot.margin = unit(c(1,  1, 1, 1), "lines"),
      axis.line = element_line(colour = "white"),
      legend.background=element_rect(fill='black'),
      legend.title=element_text(size=28,colour="white"),
      legend.text=element_text(size=28,colour="white"),
      legend.key = element_rect( fill = 'black'),
      legend.key.size = unit(c(1, 1), "lines")
    )
}


ggplot(diamonds, ) +
  geom_point(aes(x=carat, y = price,colour=cut)) +
  labs(title="theme_presentation") +
  theme_presentation() + 
  theme(legend.position=c(1,0.25))

## Warning: an argument will be fractionally recycled

theme_map

I do a lot of map creation using ggplot and therefore the canned themes and the previous themes I discussed do not really fit. So I created a theme (theme_map).

library(maps)
library(reshape2)

theme_map <- function(base_size = 12, base_family = "") {
    # Starts with theme_grey and then modify some parts
    theme_bw(base_size = base_size, base_family = base_family) %+replace% theme(strip.background = element_blank(), 
        strip.text.x = element_text(size = 18), strip.text.y = element_text(size = 18), 
        axis.text.x = element_blank(), axis.text.y = element_blank(), axis.ticks = element_blank(), 
        axis.title.x = element_blank(), axis.title.y = element_blank(), panel.background = element_blank(), 
        panel.border = element_blank(), panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), panel.margin = unit(1, "lines"), 
        plot.background = element_blank(), plot.margin = unit(c(0.25, 0.5, 0, 
            0), "lines"), axis.line = element_blank(), legend.background = element_blank(), 
        legend.margin = unit(0.1, "line"), legend.title = element_text(size = 16, 
            colour = "black"), legend.text = element_text(size = 16, colour = "black", 
            hjust = 0.2), legend.key = element_blank(), legend.key.width = unit(2, 
            "line"), legend.key.height = unit(2, "line"))
    
}

crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
states_map <- map_data("state")

d <- ggplot(crimes, aes(map_id = state)) + geom_map(aes(fill = Murder), map = states_map) + 
    labs(title = "default") + expand_limits(x = states_map$long, y = states_map$lat) + 
    coord_map()
e <- ggplot(crimes, aes(map_id = state)) + geom_map(aes(fill = Murder), map = states_map) + 
    labs(title = "theme_map") + expand_limits(x = states_map$long, y = states_map$lat) + 
    coord_map() + theme_map()

grid.arrange(d, e, ncol = 1)

These files are included in a single file I call themes.r which I load as a source file in the housekeeping section of my R code. I included this file here, which includes a theme_transparent and a theme_map_presentation that were not discussed above but ones that I use every once in a while. If anyone has another theme or theme ideas I would love to hear about them.

ggplot2 and facet_wrap

Within ggplot2 there is facet_wrap which will allow you to create multiple panels by a variable with a single line of code.

As an example:

library(ggplot2)

ggplot(diamonds, ) + geom_point(aes(x = carat, y = price)) + facet_wrap(~color, 
    ncol = 4) + theme(aspect.ratio = 1)

The facet_wrap command allows you to wrap panels by a single variable using the ~x command, where x is your by variable. You can specify the number of columns via ncol. One thing thing to notice that the x and y axis are equal among the facets. You can allow these to be vary among the different facets using scales command. You can set it to scales = 'free_x to allow the x-axis to be variable but constant y, scales = 'free_y to allow the y-axis to be variable but constant x, and scales = 'free for both to vary.

Now this works pretty well when you have a dataset up already like this, but what if you have data from two different datasets?

Lets load some data used to generate plot of angling effort and the surface area of a reservoir.

# load(url('https://github.com/chrischizinski/chrischizinski.github.com/raw/master/datasets/press_elev.RData'))
# You can not load this through knitr, which is why this is commented out
head(elev)

##     Year Month Day Elev ElevSI       Date Area Area_ha type elev_press
## 745 2005     1   1   NA     NA 2005-01-01   NA      NA elev         NA
## 746 2005     1   2   NA     NA 2005-01-02   NA      NA elev         NA
## 747 2005     1   3   NA     NA 2005-01-03   NA      NA elev         NA
## 748 2005     1   4   NA     NA 2005-01-04   NA      NA elev         NA
## 749 2005     1   5   NA     NA 2005-01-05   NA      NA elev         NA
## 750 2005     1   6   NA     NA 2005-01-06   NA      NA elev         NA

head(monthly_pressure)

##         Date Month Year mmon.all mmon.bnk semon.all semon.bnk  type
## 1 2007-01-15   Jan 2007       NA       NA        NA        NA    NA
## 2 2007-02-15   Feb 2007       NA       NA        NA        NA    NA
## 3 2007-03-15   Mar 2007       NA       NA        NA        NA    NA
## 4 2007-10-15   Oct 2007    408.8    42.17       168     36.25 408.8
## 5 2007-11-15   Nov 2007       NA       NA        NA        NA    NA
## 6 2007-12-15   Dec 2007       NA       NA        NA        NA    NA

For you to be able to use ggplot you will need to get the data into a single dataset and as you can tell from above that the column headers do no align (except for date). To get this into single dataset to be used in ggplot takes a couple of steps.

elev.2$type <- "elev"
monthly_pressure.2$type <- "effort"

elev.2$elev_press <- elev.2$Area_ha  #  we will need to have the variable to plot (our y) in a single column
monthly_pressure.2$elev_press <- monthly_pressure.2$mmon.all

library(plyr)

combined.data <- rbind.fill(elev.2, monthly_pressure.2)

head(combined.data)

##   Year Month Day Elev ElevSI       Date Area Area_ha type elev_press
## 1 2009     1  15 2575  785.0 2009-01-15 1414   572.2 elev      572.2
## 2 2009     2  15 2576  785.1 2009-02-15 1430   578.7 elev      578.7
## 3 2009     3  15 2576  785.1 2009-03-15 1433   579.9 elev      579.9
## 4 2009     4  15 2576  785.2 2009-04-15 1406   569.0 elev      569.0
## 5 2009     5  15 2577  785.4 2009-05-15 1426   577.1 elev      577.1
## 6 2009     6  15 2577  785.5 2009-06-15 1437   581.5 elev      581.5
##   mmon.all mmon.bnk semon.all semon.bnk
## 1       NA       NA        NA        NA
## 2       NA       NA        NA        NA
## 3       NA       NA        NA        NA
## 4       NA       NA        NA        NA
## 5       NA       NA        NA        NA
## 6       NA       NA        NA        NA

tail(combined.data)

##    Year Month Day Elev ElevSI       Date Area Area_ha   type elev_press
## 43 2010   Apr  NA   NA     NA 2010-04-15   NA      NA effort       1348
## 44 2010   May  NA   NA     NA 2010-05-15   NA      NA effort       4874
## 45 2010   Jun  NA   NA     NA 2010-06-15   NA      NA effort       3606
## 46 2010   Jul  NA   NA     NA 2010-07-15   NA      NA effort       3794
## 47 2010   Aug  NA   NA     NA 2010-08-15   NA      NA effort       2136
## 48 2010   Sep  NA   NA     NA 2010-09-15   NA      NA effort        442
##    mmon.all mmon.bnk semon.all semon.bnk
## 43     1348   1200.3     430.1    355.49
## 44     4874   3040.3    1105.5    415.82
## 45     3606   1476.0    1350.5    593.52
## 46     3794    903.8     619.8    254.15
## 47     2136   1449.7    1033.4   1062.06
## 48      442    149.5     136.3     88.41

and lets plot the data using ggplot

ggplot(data = combined.data) + geom_line(aes(x = Date, y = elev_press, group = type, 
    colour = type), size = 1) + facet_wrap(~type, ncol = 1, scales = "free_y") + 
    theme_bw() + theme(legend.position = "none")

## Warning: Removed 5 rows containing missing values (geom_path).

As you might be able to tell from the above figure, there is a problem with the above figure as the y-axis label is not appropriate and probably should not be included. The option in this case is to remove it and add it in with another program.

ggplot(data = combined.data) + geom_line(aes(x = Date, y = elev_press, group = type, 
    colour = type), size = 1) + facet_wrap(~type, ncol = 1, scales = "free_y") + 
    labs(y = "") + theme_bw() + theme(legend.position = "none")

## Warning: Removed 5 rows containing missing values (geom_path).

Another issue with this figure is that tehre are no ticks in the upper figure of effort. You could do do scales = 'free' but this would add in all the dates again along the x-axis. The other option is to use create to seperate ggplot objects and align them with grid.arrange in the gridExtra package.

grid.arrange

library(gridExtra)

effort.plot <- ggplot(data = monthly_pressure.2) + geom_line(aes(x = Date, y = mmon.all), 
    colour = "red", size = 1) + labs(y = "Effort") + theme_bw() + theme(axis.text.x = element_blank(), 
    axis.title.x = element_blank(), panel.margin = unit(0, "lines"), plot.margin = unit(c(1, 
        1, 0, 1), "lines"))  # set the plot margins to pull figures in closer.  order is clockwise starting with top

elev.plot <- ggplot(data = elev.2) + geom_line(aes(x = Date, y = Area_ha), colour = "blue", 
    size = 1) + labs(y = "Surface area") + theme_bw() + theme(panel.margin = unit(0, 
    "lines"), plot.margin = unit(c(0.25, 1, 1, 1), "lines"))

grid.arrange(effort.plot, elev.plot)

## Warning: Removed 5 rows containing missing values (geom_path).

Now as you can see in the above figure that this is much closer to what I would normally like in a figure, except that because effort and surface area have a differing number of digits, the figures do not fully align.

You can work around this using the gtable package.

library(gtable)

# Get the widths
gA <- ggplot_gtable(ggplot_build(effort.plot))  # effort plot

## Warning: Removed 5 rows containing missing values (geom_path).

gB <- ggplot_gtable(ggplot_build(elev.plot))  # elev plot


maxWidth = unit.pmax(gA$widths[2:3], gB$widths[2:3])  # find the maximum widths among the plots.  
maxWidth

## [1] max(1grobwidth+0.5lines, 1grobwidth+0.5lines)                    
## [2] max(sum(1grobwidth, 0.15cm+0.1cm), sum(1grobwidth, 0.15cm+0.1cm))

# Set the widths with the maximum width
gA$widths[2:3] <- maxWidth
gB$widths[2:3] <- maxWidth

# Arrange the four charts
grid.arrange(gA, gB, ncol = 1)

The above figure then no longer needs another program to add the axis labels and the top facet has tick marks.

Load the libraries and get the data

library(vegan)  #load the vegan package

## Loading required package: permute
## This is vegan 2.0-7

library(ggplot2)  #load the ggplot2 package

## Use suppressPackageStartupMessages to eliminate package startup messages.

data(varespec)  #load the vegan package
head(varespec)  # look at the first 6 rows of the data

##    Cal.vul Emp.nig Led.pal Vac.myr Vac.vit Pin.syl Des.fle Bet.pub Vac.uli
## 18    0.55   11.13    0.00    0.00   17.80    0.07    0.00       0    1.60
## 15    0.67    0.17    0.00    0.35   12.13    0.12    0.00       0    0.00
## 24    0.10    1.55    0.00    0.00   13.47    0.25    0.00       0    0.00
## 27    0.00   15.13    2.42    5.92   15.97    0.00    3.70       0    1.12
## 23    0.00   12.68    0.00    0.00   23.73    0.03    0.00       0    0.00
## 19    0.00    8.92    0.00    2.42   10.28    0.12    0.02       0    0.00
##    Dip.mon Dic.sp Dic.fus Dic.pol Hyl.spl Ple.sch Pol.pil Pol.jun Pol.com
## 18    2.07   0.00    1.62    0.00     0.0    4.67    0.02    0.13    0.00
## 15    0.00   0.33   10.92    0.02     0.0   37.75    0.02    0.23    0.00
## 24    0.00  23.43    0.00    1.68     0.0   32.92    0.00    0.23    0.00
## 27    0.00   0.00    3.63    0.00     6.7   58.07    0.00    0.00    0.13
## 23    0.00   0.00    3.42    0.02     0.0   19.42    0.02    2.12    0.00
## 19    0.00   0.00    0.32    0.02     0.0   21.03    0.02    1.58    0.18
##    Poh.nut Pti.cil Bar.lyc Cla.arb Cla.ran Cla.ste Cla.unc Cla.coc Cla.cor
## 18    0.13    0.12    0.00   21.73   21.47    3.50    0.30    0.18    0.23
## 15    0.03    0.02    0.00   12.05    8.13    0.18    2.65    0.13    0.18
## 24    0.32    0.03    0.00    3.58    5.52    0.07    8.93    0.00    0.20
## 27    0.02    0.08    0.08    1.42    7.63    2.55    0.15    0.00    0.38
## 23    0.17    1.80    0.02    9.08    9.22    0.05    0.73    0.08    1.42
## 19    0.07    0.27    0.02    7.23    4.95   22.08    0.25    0.10    0.25
##    Cla.gra Cla.fim Cla.cri Cla.chl Cla.bot Cla.ama Cla.sp Cet.eri Cet.isl
## 18    0.25    0.25    0.23    0.00    0.00    0.08   0.02    0.02    0.00
## 15    0.23    0.25    1.23    0.00    0.00    0.00   0.00    0.15    0.03
## 24    0.48    0.00    0.07    0.10    0.02    0.00   0.00    0.78    0.12
## 27    0.12    0.10    0.03    0.00    0.02    0.00   0.02    0.00    0.00
## 23    0.50    0.17    1.78    0.05    0.05    0.00   0.00    0.00    0.00
## 19    0.18    0.10    0.12    0.05    0.02    0.00   0.00    0.00    0.00
##    Cet.niv Nep.arc Ste.sp Pel.aph Ich.eri Cla.cer Cla.def Cla.phy
## 18    0.12    0.02   0.62    0.02       0       0    0.25       0
## 15    0.00    0.00   0.85    0.00       0       0    1.00       0
## 24    0.00    0.00   0.03    0.00       0       0    0.33       0
## 27    0.00    0.00   0.00    0.07       0       0    0.15       0
## 23    0.02    0.00   1.58    0.33       0       0    1.97       0
## 19    0.02    0.00   0.28    0.00       0       0    0.37       0

For this walkthrough I would like to assign a “group” to the each row of the data for illustration purposes. Normally, your data will already belong to a grp and this next step will not be necessary.

The basic process I will use to assign these groups is to to find the number of rows of the varespec data and then randomly sample half rows to group ‘A’ and the other half will be group ‘B’.

set.seed(123456)  #this will set the seed so that the random draw will be the same
nrow(varespec)

## [1] 24

# create a grouping variable that has a length of 24, the same # of rows of
# varespec using the rep function
grp <- rep(NA, 24)

# randomly sample 12 of those rows to belong in grp A
ind <- sample(1:nrow(varespec), 12)

# assign those in ind to grp A
grp[ind] <- "A"
grp

##  [1] NA  "A" "A" "A" NA  NA  NA  "A" "A" "A" NA  "A" NA  NA  NA  "A" NA 
## [18] "A" NA  "A" "A" NA  NA  "A"

# assign the NAs to grp B
grp[is.na(grp)] <- "B"

# Then take a look at the results
grp

##  [1] "B" "A" "A" "A" "B" "B" "B" "A" "A" "A" "B" "A" "B" "B" "B" "A" "B"
## [18] "A" "B" "A" "A" "B" "B" "A"

Run the NMDS using the vegan package

vare.mds <- metaMDS(varespec)  #using all the defaults

## Square root transformation
## Wisconsin double standardization
## Run 0 stress 0.1843 
## Run 1 stress 0.2353 
## Run 2 stress 0.2045 
## Run 3 stress 0.2219 
## Run 4 stress 0.2066 
## Run 5 stress 0.1948 
## Run 6 stress 0.1846 
## ... procrustes: rmse 0.04942  max resid 0.1578 
## Run 7 stress 0.226 
## Run 8 stress 0.1852 
## Run 9 stress 0.1858 
## Run 10 stress 0.1843 
## ... New best solution
## ... procrustes: rmse 0.0001229  max resid 5e-04 
## *** Solution reached

vare.mds  #display the results

## 
## Call:
## metaMDS(comm = varespec) 
## 
## global Multidimensional Scaling using monoMDS
## 
## Data:     wisconsin(sqrt(varespec)) 
## Distance: bray 
## 
## Dimensions: 2 
## Stress:     0.1843 
## Stress type 1, weak ties
## Two convergent solutions found after 10 tries
## Scaling: centring, PC rotation, halfchange scaling 
## Species: expanded scores based on 'wisconsin(sqrt(varespec))'

I am not a fan of using base R for graphics. When you are in a pinch, they are ok to call but never hand in an assignment or attempt to submit for a publication the default plots.

plot(vare.mds, type = "t")

Using ggplot for the NMDS plot

The first step is to extract the scores (the x and y coordinates of the site (rows) and species and add the grp variable we created before. Once again the grp variable is not needed, I am just using it for illustration purposes. For the data.scores, the result will be a 26 row x 4 column data.frame with the NMDS1 (x location) and NMDS2 (y location), designated by the site number and the group (grp). The species.scores will be a 44 row by 3 column data.frame with the NMDS1 (x location), NMDS2 (y location), and species.

data.scores <- as.data.frame(scores(vare.mds))  #Using the scores function from vegan to extract the site scores and convert to a data.frame
data.scores$site <- rownames(data.scores)  # create a column of site names, from the rownames of data.scores
data.scores$grp <- grp  #  add the grp variable created earlier
head(data.scores)  #look at the data

##       NMDS1    NMDS2 site grp
## 18 -0.12983 -0.12169   18   B
## 15 -0.01377 -0.11541   15   A
## 24  0.25603  0.41941   24   A
## 27  0.58918 -0.15769   27   A
## 23  0.14003  0.01794   23   B
## 19  0.09844  0.04796   19   B

species.scores <- as.data.frame(scores(vare.mds, "species"))  #Using the scores function from vegan to extract the species scores and convert to a data.frame
species.scores$species <- rownames(species.scores)  # create a column of species, from the rownames of species.scores
head(species.scores)  #look at the data

##            NMDS1    NMDS2 species
## Cal.vul -0.16683 -0.07432 Cal.vul
## Emp.nig  0.05842  0.10667 Emp.nig
## Led.pal  0.88647 -0.10071 Led.pal
## Vac.myr  0.71151 -0.10910 Vac.myr
## Vac.vit  0.04376  0.09994 Vac.vit
## Pin.syl -0.02586  0.29633 Pin.syl

Now that we have the site and species scores, we can begin plotting with ggplot2. First we will produce a plot like the base plot function.

ggplot() + 
  geom_text(data=species.scores,aes(x=NMDS1,y=NMDS2,label=species),alpha=0.5) +  # add the species labels
  geom_point(data=data.scores,aes(x=NMDS1,y=NMDS2,shape=grp,colour=grp),size=3) + # add the point markers
  geom_text(data=data.scores,aes(x=NMDS1,y=NMDS2,label=site),size=6,vjust=0) +  # add the site labels
  scale_colour_manual(values=c("A" = "red", "B" = "blue")) +
  coord_equal() +
  theme_bw()

There are a couple of changes I like to make in the themes to make these a little nicer.

ggplot() + 
  geom_text(data=species.scores,aes(x=NMDS1,y=NMDS2,label=species),alpha=0.5) +  # add the species labels
  geom_point(data=data.scores,aes(x=NMDS1,y=NMDS2,shape=grp,colour=grp),size=4) + # add the point markers
  geom_text(data=data.scores,aes(x=NMDS1,y=NMDS2,label=site),size=8,vjust=0,hjust=0) +  # add the site labels
  scale_colour_manual(values=c("A" = "red", "B" = "blue")) +
  coord_equal() +
  theme_bw() + 
  theme(axis.text.x = element_blank(),  # remove x-axis text
        axis.text.y = element_blank(), # remove y-axis text
        axis.ticks = element_blank(),  # remove axis ticks
        axis.title.x = element_text(size=18), # remove x-axis labels
        axis.title.y = element_text(size=18), # remove y-axis labels
        panel.background = element_blank(), 
        panel.grid.major = element_blank(),  #remove major-grid labels
        panel.grid.minor = element_blank(),  #remove minor-grid labels
        plot.background = element_blank())

Another way to look at these is to plot a hull around each of the groups. To accomplish this, you can utilize the chull function. In the below plot I dropped the site score labels.

grp.a <- data.scores[data.scores$grp == "A", ][chull(data.scores[data.scores$grp == 
    "A", c("NMDS1", "NMDS2")]), ]  # hull values for grp A
grp.b <- data.scores[data.scores$grp == "B", ][chull(data.scores[data.scores$grp == 
    "B", c("NMDS1", "NMDS2")]), ]  # hull values for grp B

hull.data <- rbind(grp.a, grp.b)  #combine grp.a and grp.b
hull.data

##       NMDS1    NMDS2 site grp
## 27  0.58918 -0.15769   27   A
## 16  0.02939 -0.15007   16   A
## 4  -0.37538  0.01663    4   A
## 12  0.02425  0.30475   12   A
## 24  0.25603  0.41941   24   A
## 21  0.55793  0.22927   21   A
## 22  0.18416 -0.15261   22   B
## 25  0.21868 -0.46169   25   B
## 5  -0.49165 -0.29143    5   B
## 2  -0.22988  0.53244    2   B
## 23  0.14003  0.01794   23   B

and plot it out There are a couple of changes I like to make in the themes to make these a little nicer.

ggplot() + 
  geom_polygon(data=hull.data,aes(x=NMDS1,y=NMDS2,fill=grp,group=grp),alpha=0.30) + # add the convex hulls
  geom_text(data=species.scores,aes(x=NMDS1,y=NMDS2,label=species),alpha=0.5) +  # add the species labels
  geom_point(data=data.scores,aes(x=NMDS1,y=NMDS2,shape=grp,colour=grp),size=4) + # add the point markers
  scale_colour_manual(values=c("A" = "red", "B" = "blue")) +
  coord_equal() +
  theme_bw() + 
  theme(axis.text.x = element_blank(),  # remove x-axis text
        axis.text.y = element_blank(), # remove y-axis text
        axis.ticks = element_blank(),  # remove axis ticks
        axis.title.x = element_text(size=18), # remove x-axis labels
        axis.title.y = element_text(size=18), # remove y-axis labels
        panel.background = element_blank(), 
        panel.grid.major = element_blank(),  #remove major-grid labels
        panel.grid.minor = element_blank(),  #remove minor-grid labels
        plot.background = element_blank())

ggplot2 gives you a lot of flexibility in developing plots. Whenever you are thinking of plotting with ggplot2 you need to first get the data in a data.frame format. Additionally, because ggplot2 is based on the “Grammar of Graphics” by Leland Wilkinson, you can only have two-axis. Given that, each layer must have the same x and y colummn names. In addition, the plots are built in layers. If in the above plot, if you were to put the geom_polygon below the geom_point line then the hulls would cover up the points and text.

Load and display the data

library(plyr)  #load the plyr package
data(baseball)  #load the baseball dataset that comes with plyr
head(baseball)  # display the first six lines of the data.frame

##            id year stint team lg  g  ab  r  h X2b X3b hr rbi sb cs bb so
## 4   ansonca01 1871     1  RC1    25 120 29 39  11   3  0  16  6  2  2  1
## 44  forceda01 1871     1  WS3    32 162 45 45   9   4  0  29  8  0  4  0
## 68  mathebo01 1871     1  FW1    19  89 15 24   3   1  0  10  2  1  2  0
## 99  startjo01 1871     1  NY2    33 161 35 58   5   1  1  34  4  2  3  0
## 102 suttoez01 1871     1  CL1    29 128 35 45   3   7  3  23  3  1  1  0
## 106 whitede01 1871     1  CL1    29 146 40 47   6   5  1  21  2  2  4  1
##     ibb hbp sh sf gidp
## 4    NA  NA NA NA   NA
## 44   NA  NA NA NA   NA
## 68   NA  NA NA NA   NA
## 99   NA  NA NA NA   NA
## 102  NA  NA NA NA   NA
## 106  NA  NA NA NA   NA

To look at the year-team combinations in the data, use the ddply function

baseball$team <- as.character(baseball$team)  #convert team from a factor to a character

# For the purpose of this excercise we will reduce the dataset to just a few
# teams
baseball.red <- baseball[baseball$team %in% c("BOS", "CHN", "CIN"), ]

# Use ddply again to create a variable called c_year, which is the number of
# years since the first year
baseball.red <- ddply(baseball.red, .(id), transform, c_year = year - min(year))

So the basic idea for the process I am going to use, is that I am going to use a Poisson regression using the glm function in R to look at the hits as a function of year since the first year of data was included in the dataset. Is the model 100% valid? No but for this the actual model is not important.

Further, the approaches I am describing below, are runnign the same model with same dependent and independent variables across different subsets of data. If you were interested in running different subsets of independent variables there are also many different approaches that could be considered, but I will not go into that at this time.

1. Subsetting and running each model seperate

The basic process is to run each model seperately by providing a different subset of the data. Not very difficult to do, but if you had a bunch of models to run, it can very quickly add up. The nice thing about this process though is that you have very clear model outputs (i.e., a specific output for BOS, CHN, and CIN).

mod.BOS <- glm(h ~ c_year, data = baseball.red[baseball.red$team == "BOS", ], 
    family = "poisson")  # run the model using only team BOS
summary(mod.BOS)  #  Display the model summary

## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     "BOS", ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -14.29  -10.16   -5.28    6.82   17.97  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 3.943280   0.005922   665.9   <2e-16 ***
## c_year      0.034136   0.000884    38.6   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 72809  on 900  degrees of freedom
## Residual deviance: 71420  on 899  degrees of freedom
## AIC: 75179
## 
## Number of Fisher Scoring iterations: 6

mod.CHN <- glm(h ~ c_year, data = baseball.red[baseball.red$team == "CHN", ], 
    family = "poisson")
summary(mod.CHN)

## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     "CHN", ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -13.94   -9.17   -2.72    6.21   16.82  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 4.071993   0.005087   800.5   <2e-16 ***
## c_year      0.033453   0.000737    45.4   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 80354  on 1178  degrees of freedom
## Residual deviance: 78403  on 1177  degrees of freedom
## AIC: 84317
## 
## Number of Fisher Scoring iterations: 5

mod.CIN <- glm(h ~ c_year, data = baseball.red[baseball.red$team == "CIN", ], 
    family = "poisson")
summary(mod.CIN)

## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     "CIN", ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -12.40   -9.48   -2.03    6.35   14.83  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  4.21200    0.00528  797.57  < 2e-16 ***
## c_year       0.00589    0.00082    7.19  6.6e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 70036  on 1029  degrees of freedom
## Residual deviance: 69984  on 1028  degrees of freedom
## AIC: 75122
## 
## Number of Fisher Scoring iterations: 5

2. Subsetting and running through a loop

This process first identifies all the uniqe teams listed in the dataset and then will loop through those teams and store the output in a list. The summary for all the models can be provided by running lapply on that list or running summary on an extracted element of the list. Problem with this method is just the inherent complication of using lists in R and running loops can take quite a long time especially on large datasets. If it is speed you are after there are quicker options.

uniq.teams <- unique(baseball.red$team)  # find all the unique teams in the dataset
model.out <- list()  # create a list to store each model

for (i in 1:length(uniq.teams)) {
    model.out[[paste(uniq.teams[i])]] <- glm(h ~ c_year, data = baseball.red[baseball.red$team == 
        paste(uniq.teams[i]), ], family = "poisson")
}

lapply(model.out, summary)  # look at all the model outputs, this could be used with outputs on 3 and 5 as well.  

## $CHN
## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     paste(uniq.teams[i]), ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -13.94   -9.17   -2.72    6.21   16.82  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 4.071993   0.005087   800.5   <2e-16 ***
## c_year      0.033453   0.000737    45.4   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 80354  on 1178  degrees of freedom
## Residual deviance: 78403  on 1177  degrees of freedom
## AIC: 84317
## 
## Number of Fisher Scoring iterations: 5
## 
## 
## $CIN
## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     paste(uniq.teams[i]), ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -12.40   -9.48   -2.03    6.35   14.83  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  4.21200    0.00528  797.57  < 2e-16 ***
## c_year       0.00589    0.00082    7.19  6.6e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 70036  on 1029  degrees of freedom
## Residual deviance: 69984  on 1028  degrees of freedom
## AIC: 75122
## 
## Number of Fisher Scoring iterations: 5
## 
## 
## $BOS
## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     paste(uniq.teams[i]), ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -14.29  -10.16   -5.28    6.82   17.97  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 3.943280   0.005922   665.9   <2e-16 ***
## c_year      0.034136   0.000884    38.6   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 72809  on 900  degrees of freedom
## Residual deviance: 71420  on 899  degrees of freedom
## AIC: 75179
## 
## Number of Fisher Scoring iterations: 6

summary(model.out[["CIN"]])  # or look at a specific model

## 
## Call:
## glm(formula = h ~ c_year, family = "poisson", data = baseball.red[baseball.red$team == 
##     paste(uniq.teams[i]), ])
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -12.40   -9.48   -2.03    6.35   14.83  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  4.21200    0.00528  797.57  < 2e-16 ***
## c_year       0.00589    0.00082    7.19  6.6e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 70036  on 1029  degrees of freedom
## Residual deviance: 69984  on 1028  degrees of freedom
## AIC: 75122
## 
## Number of Fisher Scoring iterations: 5

3. Using split and lapply

This process splits the dataset into seperate lists by a variable and then uses lapply to run the glm model across those different datasets.

datasets <- split(baseball.red, baseball.red$team)  # splits the dataset into a list by team
str(datasets)  # look at the structure of the dataset

## List of 3
##  $ BOS:'data.frame': 901 obs. of  23 variables:
##   ..$ id    : chr [1:901] "adairje01" "adairje01" "aguilri01" "altroni01" ...
##   ..$ year  : int [1:901] 1967 1968 1995 1902 1903 1988 1990 1971 1972 1973 ...
##   ..$ stint : int [1:901] 2 1 2 1 1 1 2 1 1 1 ...
##   ..$ team  : chr [1:901] "BOS" "BOS" "BOS" "BOS" ...
##   ..$ lg    : chr [1:901] "AL" "AL" "AL" "AL" ...
##   ..$ g     : int [1:901] 89 74 30 3 1 41 15 125 110 132 ...
##   ..$ ab    : int [1:901] 316 208 0 8 3 148 0 491 436 499 ...
##   ..$ r     : int [1:901] 41 18 0 0 0 14 0 56 47 56 ...
##   ..$ h     : int [1:901] 92 45 0 0 2 34 0 114 112 135 ...
##   ..$ X2b   : int [1:901] 13 1 0 0 0 5 0 23 26 17 ...
##   ..$ X3b   : int [1:901] 1 0 0 0 0 3 0 0 3 1 ...
##   ..$ hr    : int [1:901] 3 2 0 0 0 0 0 4 3 0 ...
##   ..$ rbi   : int [1:901] 26 12 0 0 0 12 0 45 39 49 ...
##   ..$ sb    : int [1:901] 1 0 0 0 0 4 0 6 3 13 ...
##   ..$ cs    : int [1:901] 4 0 0 NA NA 2 0 4 3 1 ...
##   ..$ bb    : int [1:901] 13 9 0 0 1 15 0 35 26 43 ...
##   ..$ so    : int [1:901] 35 28 0 NA NA 35 0 43 28 33 ...
##   ..$ ibb   : int [1:901] 0 2 0 NA NA 0 0 0 0 1 ...
##   ..$ hbp   : int [1:901] 2 1 0 0 0 4 0 2 2 0 ...
##   ..$ sh    : int [1:901] 4 6 0 0 0 4 0 9 5 12 ...
##   ..$ sf    : int [1:901] 2 0 0 NA NA 1 0 4 5 7 ...
##   ..$ gidp  : int [1:901] 10 10 0 NA NA 2 0 7 8 12 ...
##   ..$ c_year: int [1:901] 0 1 0 0 1 0 0 0 1 2 ...
##  $ CHN:'data.frame': 1179 obs. of  23 variables:
##   ..$ id    : chr [1:1179] "abernte02" "abernte02" "abernte02" "abernte02" ...
##   ..$ year  : int [1:1179] 1965 1966 1969 1970 1957 1958 1959 1999 2000 1969 ...
##   ..$ stint : int [1:1179] 1 1 1 1 1 1 1 2 1 1 ...
##   ..$ team  : chr [1:1179] "CHN" "CHN" "CHN" "CHN" ...
##   ..$ lg    : chr [1:1179] "NL" "NL" "NL" "NL" ...
##   ..$ g     : int [1:1179] 84 20 56 11 60 62 3 41 50 41 ...
##   ..$ ab    : int [1:1179] 18 4 8 0 187 96 2 1 0 5 ...
##   ..$ r     : int [1:1179] 1 0 1 0 21 14 0 0 0 2 ...
##   ..$ h     : int [1:1179] 3 0 2 0 47 27 0 0 0 2 ...
##   ..$ X2b   : int [1:1179] 0 0 1 0 10 4 0 0 0 0 ...
##   ..$ X3b   : int [1:1179] 0 0 0 0 2 4 0 0 0 0 ...
##   ..$ hr    : int [1:1179] 0 0 0 0 1 0 0 0 0 0 ...
##   ..$ rbi   : int [1:1179] 2 0 1 0 10 4 0 0 0 0 ...
##   ..$ sb    : int [1:1179] 0 0 0 0 0 2 0 0 0 0 ...
##   ..$ cs    : int [1:1179] 0 0 0 0 3 0 0 0 0 0 ...
##   ..$ bb    : int [1:1179] 0 0 0 0 17 6 0 0 0 0 ...
##   ..$ so    : int [1:1179] 7 2 2 0 28 15 1 0 0 1 ...
##   ..$ ibb   : int [1:1179] 0 0 0 0 0 0 0 0 0 0 ...
##   ..$ hbp   : int [1:1179] 1 0 0 0 2 0 0 0 0 0 ...
##   ..$ sh    : int [1:1179] 3 0 0 0 5 3 0 0 0 0 ...
##   ..$ sf    : int [1:1179] 0 0 0 0 0 0 0 0 0 0 ...
##   ..$ gidp  : int [1:1179] 0 0 0 0 2 2 0 0 0 0 ...
##   ..$ c_year: int [1:1179] 0 1 4 5 11 12 13 4 5 0 ...
##  $ CIN:'data.frame': 1030 obs. of  23 variables:
##   ..$ id    : chr [1:1030] "abernte02" "abernte02" "adamsbo03" "adamsbo03" ...
##   ..$ year  : int [1:1030] 1967 1968 1946 1947 1948 1949 1950 1951 1952 1953 ...
##   ..$ stint : int [1:1030] 1 1 1 1 1 1 1 1 1 1 ...
##   ..$ team  : chr [1:1030] "CIN" "CIN" "CIN" "CIN" ...
##   ..$ lg    : chr [1:1030] "NL" "NL" "NL" "NL" ...
##   ..$ g     : int [1:1030] 70 78 94 81 87 107 115 125 154 150 ...
##   ..$ ab    : int [1:1030] 17 17 311 217 262 277 348 403 637 607 ...
##   ..$ r     : int [1:1030] 0 2 35 39 33 32 57 57 85 99 ...
##   ..$ h     : int [1:1030] 1 0 76 59 78 70 98 107 180 167 ...
##   ..$ X2b   : int [1:1030] 0 0 13 11 20 16 21 12 25 14 ...
##   ..$ X3b   : int [1:1030] 0 0 3 2 3 2 8 5 4 6 ...
##   ..$ hr    : int [1:1030] 0 0 4 4 1 0 3 5 6 8 ...
##   ..$ rbi   : int [1:1030] 2 0 24 20 21 25 25 24 48 49 ...
##   ..$ sb    : int [1:1030] 0 0 16 9 6 4 7 4 11 3 ...
##   ..$ cs    : int [1:1030] 0 0 NA NA NA NA NA 10 9 2 ...
##   ..$ bb    : int [1:1030] 0 3 18 25 25 26 43 43 49 58 ...
##   ..$ so    : int [1:1030] 10 12 32 23 23 36 29 40 67 67 ...
##   ..$ ibb   : int [1:1030] 0 0 NA NA NA NA NA NA NA NA ...
##   ..$ hbp   : int [1:1030] 0 0 3 4 1 0 0 1 0 0 ...
##   ..$ sh    : int [1:1030] 0 0 14 7 7 5 3 3 8 12 ...
##   ..$ sf    : int [1:1030] 0 0 NA NA NA NA NA NA NA NA ...
##   ..$ gidp  : int [1:1030] 1 0 7 2 5 6 2 6 15 7 ...
##   ..$ c_year: int [1:1030] 2 3 0 1 2 3 4 5 6 7 ...

model.out <- lapply(datasets, function(x) glm(h ~ c_year, family = "poisson", 
    data = x))  # apply the glm function across the dataset list

# lapply(model.out,summary), # Not run because output is the same as above

4. Using by

This process is similar to the one directly above but will do it in a single line of code. Essentially what by does is the “data frame is split by row into data frames subsetted by the values of one or more factors, and function FUN is applied to each subset in turn”

model.out <- by(data = baseball.red, baseball.red$team, function(x) glm(h ~ 
    c_year, family = "poisson", data = x))
model.out

## baseball.red$team: BOS
## 
## Call:  glm(formula = h ~ c_year, family = "poisson", data = x)
## 
## Coefficients:
## (Intercept)       c_year  
##      3.9433       0.0341  
## 
## Degrees of Freedom: 900 Total (i.e. Null);  899 Residual
## Null Deviance:       72800 
## Residual Deviance: 71400     AIC: 75200
## -------------------------------------------------------- 
## baseball.red$team: CHN
## 
## Call:  glm(formula = h ~ c_year, family = "poisson", data = x)
## 
## Coefficients:
## (Intercept)       c_year  
##      4.0720       0.0335  
## 
## Degrees of Freedom: 1178 Total (i.e. Null);  1177 Residual
## Null Deviance:       80400 
## Residual Deviance: 78400     AIC: 84300
## -------------------------------------------------------- 
## baseball.red$team: CIN
## 
## Call:  glm(formula = h ~ c_year, family = "poisson", data = x)
## 
## Coefficients:
## (Intercept)       c_year  
##     4.21200      0.00589  
## 
## Degrees of Freedom: 1029 Total (i.e. Null);  1028 Residual
## Null Deviance:       70000 
## Residual Deviance: 70000     AIC: 75100

5. Using dlply

One package I use in alot of my analyses is the plyr package created by Hadley Wickham (author of ggplot2, another package I use daily). This packages make subsetting and applying functions incredibly easy and are relatively fast.

library(plyr)
model.out <- dlply(baseball.red, .(team), glm, formula = h ~ c_year, family = poisson)  #dlply takes the data as a dataframe and returns the output as a list
llply(model.out, summary)  #uses llply (list input - list output) to display the summary (instead of lapply, but lapply works as well)

## $BOS
## 
## Call:
## .fun(formula = ..1, family = ..2, data = piece)
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -14.29  -10.16   -5.28    6.82   17.97  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 3.943280   0.005922   665.9   <2e-16 ***
## c_year      0.034136   0.000884    38.6   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 72809  on 900  degrees of freedom
## Residual deviance: 71420  on 899  degrees of freedom
## AIC: 75179
## 
## Number of Fisher Scoring iterations: 6
## 
## 
## $CHN
## 
## Call:
## .fun(formula = ..1, family = ..2, data = piece)
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -13.94   -9.17   -2.72    6.21   16.82  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 4.071993   0.005087   800.5   <2e-16 ***
## c_year      0.033453   0.000737    45.4   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 80354  on 1178  degrees of freedom
## Residual deviance: 78403  on 1177  degrees of freedom
## AIC: 84317
## 
## Number of Fisher Scoring iterations: 5
## 
## 
## $CIN
## 
## Call:
## .fun(formula = ..1, family = ..2, data = piece)
## 
## Deviance Residuals: 
##    Min      1Q  Median      3Q     Max  
## -12.40   -9.48   -2.03    6.35   14.83  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  4.21200    0.00528  797.57  < 2e-16 ***
## c_year       0.00589    0.00082    7.19  6.6e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 70036  on 1029  degrees of freedom
## Residual deviance: 69984  on 1028  degrees of freedom
## AIC: 75122
## 
## Number of Fisher Scoring iterations: 5

As in a lot of things in R, there are many different approaches to the same problem. I personally tend to shy away from the use of the lapply, mapply, and tapply approaches but use the plyr package in most analysis.

igraph plots

First, I will bring in the data, which is a matrix of species relative abundances. Columns are the species and each row is an observation. Here is a snapshot of what the data looks like

head(caught.wide.2)

##                    BLG    CCF COC CRP FHC FWD     HSB LMB NOP WAE WHB
## 6915.2009-04-07.8    0 0.2222   0   0   0   0 0.00000   0   0 0.0   0
## 6915.2009-04-11.14   0 0.0000   0   0   0   0 0.00000   0   0 0.4   0
## 6915.2009-04-11.17   0 0.0000   0   0   0   0 0.09091   0   0 0.0   0
## 6915.2009-04-13.22   0 0.2500   0   0   0   0 0.00000   0   0 0.0   0
## 6915.2009-04-14.26   0 0.5000   0   0   0   0 0.00000   0   0 0.0   0
## 6915.2009-04-14.30   0 0.1429   0   0   0   0 0.00000   0   0 0.0   0

Load the igraph library and run through the first few steps of generating the network

library(igraph)
caught.inc <- graph.incidence(caught.wide.2, weighted = TRUE)  #make data into a bipartite graph object
obs.parties.all <- bipartite.projection(caught.inc)[[1]]
obs.spp.all <- bipartite.projection(caught.inc)[[2]]

Plotting these two plots produces okay graphs, but as I mentioned earlier, they are not great.

op <- par(mfrow = c(1, 2))
fr.all <- layout.fruchterman.reingold(obs.spp.all)
plot(obs.spp.all, layout = fr.all, edge.color = "black", edge.width = E(obs.spp.all)$weight * 
    0.1, vertex.label = V(obs.spp.all)$name)
obs.sg.all <- fastgreedy.community(obs.spp.all, weights = E(obs.spp.all)$weight)
plot(obs.sg.all, obs.spp.all, layout = fr.all, edge.width = E(obs.spp.all)$weight * 
    0.25, vertex.label = V(obs.spp.all)$name, vertex.label.color = "blue")
par(op)

Create graphs in ggplot

Okay first lets extract the data to produce the basic graph of the network on the left. ggplot needs the data as a data.frame so extract the data and coerce it to a data.frame

fr.all.df <- as.data.frame(fr.all)  ## convert the layout to a data.frame
fr.all.df$species <- colnames(caught.wide.2)  ## add in the species codes

fr.all.df  ## display the x (V1) and y (V2) coordinates for each of the nodes.

##         V1      V2 species
## 1   2.3192 -3.0746     BLG
## 2  -2.4960 -3.3497     CCF
## 3   0.2719 -5.7700     COC
## 4  -0.7398 -2.6457     CRP
## 5  -1.1411  0.4478     FHC
## 6   0.7329 -3.7887     FWD
## 7  -3.2541 -5.7682     HSB
## 8   0.3530 -1.2192     LMB
## 9  -4.6923 -2.4240     NOP
## 10 -1.3122 -4.3867     WAE
## 11 -2.0786 -1.7555     WHB

Now we have all the coordinates for the nodes in the plot, we can display it in ggplot

library(ggplot2)

ggplot() +
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=21,colour="black") +  # adds a black border around the nodes
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=20,colour="lightgrey") +
    geom_text(data=fr.all.df,aes(x=V1,y=V2,label=species)) + # add the node labels
    scale_x_continuous(expand=c(0,1))+  # expand the x limits 
    scale_y_continuous(expand=c(0,1))+ # expand the y limits
    theme_bw()  # use the ggplot black and white theme

Now that we have the nodes in the right place, lets draw the connections between the nodes

g <- get.data.frame(obs.spp.all)  # get the edge information using the get.data.frame function

head(g)

##   from  to weight
## 1  BLG CCF     20
## 2  BLG COC      6
## 3  BLG WHB      4
## 4  BLG WAE      8
## 5  BLG LMB      7
## 6  BLG CRP      6

g$from.x <- fr.all.df$V1[match(g$from, fr.all.df$species)]  #  match the from locations from the node data.frame we previously connected
g$from.y <- fr.all.df$V2[match(g$from, fr.all.df$species)]
g$to.x <- fr.all.df$V1[match(g$to, fr.all.df$species)]  #  match the to locations from the node data.frame we previously connected
g$to.y <- fr.all.df$V2[match(g$to, fr.all.df$species)]

g

##    from  to weight  from.x  from.y    to.x    to.y
## 1   BLG CCF     20  2.3192 -3.0746 -2.4960 -3.3497
## 2   BLG COC      6  2.3192 -3.0746  0.2719 -5.7700
## 3   BLG WHB      4  2.3192 -3.0746 -2.0786 -1.7555
## 4   BLG WAE      8  2.3192 -3.0746 -1.3122 -4.3867
## 5   BLG LMB      7  2.3192 -3.0746  0.3530 -1.2192
## 6   BLG CRP      6  2.3192 -3.0746 -0.7398 -2.6457
## 7   BLG FWD     13  2.3192 -3.0746  0.7329 -3.7887
## 8   CCF FWD    117 -2.4960 -3.3497  0.7329 -3.7887
## 9   CCF COC      9 -2.4960 -3.3497  0.2719 -5.7700
## 10  CCF WHB    211 -2.4960 -3.3497 -2.0786 -1.7555
## 11  CCF CRP     15 -2.4960 -3.3497 -0.7398 -2.6457
## 12  CCF LMB      7 -2.4960 -3.3497  0.3530 -1.2192
## 13  CCF WAE     55 -2.4960 -3.3497 -1.3122 -4.3867
## 14  CCF HSB     11 -2.4960 -3.3497 -3.2541 -5.7682
## 15  CCF NOP      3 -2.4960 -3.3497 -4.6923 -2.4240
## 16  CCF FHC      6 -2.4960 -3.3497 -1.1411  0.4478
## 17  COC FWD     12  0.2719 -5.7700  0.7329 -3.7887
## 18  COC WHB      4  0.2719 -5.7700 -2.0786 -1.7555
## 19  COC HSB      2  0.2719 -5.7700 -3.2541 -5.7682
## 20  COC LMB      3  0.2719 -5.7700  0.3530 -1.2192
## 21  COC WAE      2  0.2719 -5.7700 -1.3122 -4.3867
## 22  COC CRP      1  0.2719 -5.7700 -0.7398 -2.6457
## 23  CRP WHB     41 -0.7398 -2.6457 -2.0786 -1.7555
## 24  CRP LMB      3 -0.7398 -2.6457  0.3530 -1.2192
## 25  CRP WAE      9 -0.7398 -2.6457 -1.3122 -4.3867
## 26  CRP FWD      7 -0.7398 -2.6457  0.7329 -3.7887
## 27  CRP NOP      3 -0.7398 -2.6457 -4.6923 -2.4240
## 28  CRP HSB      2 -0.7398 -2.6457 -3.2541 -5.7682
## 29  CRP FHC      1 -0.7398 -2.6457 -1.1411  0.4478
## 30  FHC FWD      4 -1.1411  0.4478  0.7329 -3.7887
## 31  FHC WAE      1 -1.1411  0.4478 -1.3122 -4.3867
## 32  FHC WHB      2 -1.1411  0.4478 -2.0786 -1.7555
## 33  FHC LMB      1 -1.1411  0.4478  0.3530 -1.2192
## 34  FWD HSB      6  0.7329 -3.7887 -3.2541 -5.7682
## 35  FWD WHB    161  0.7329 -3.7887 -2.0786 -1.7555
## 36  FWD WAE     49  0.7329 -3.7887 -1.3122 -4.3867
## 37  FWD LMB      4  0.7329 -3.7887  0.3530 -1.2192
## 38  HSB WAE      8 -3.2541 -5.7682 -1.3122 -4.3867
## 39  HSB WHB     46 -3.2541 -5.7682 -2.0786 -1.7555
## 40  HSB NOP      1 -3.2541 -5.7682 -4.6923 -2.4240
## 41  LMB WAE      6  0.3530 -1.2192 -1.3122 -4.3867
## 42  LMB WHB      6  0.3530 -1.2192 -2.0786 -1.7555
## 43  LMB NOP      1  0.3530 -1.2192 -4.6923 -2.4240
## 44  NOP WHB      5 -4.6923 -2.4240 -2.0786 -1.7555
## 45  NOP WAE      1 -4.6923 -2.4240 -1.3122 -4.3867
## 46  WAE WHB    120 -1.3122 -4.3867 -2.0786 -1.7555

and plot it out.

ggplot() +
    geom_segment(data=g,aes(x=from.x,xend = to.x, y=from.y,yend = to.y,size=weight),colour="black") +
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=21,colour="black") +  # adds a black border around the nodes
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=20,colour="lightgrey") +
    geom_text(data=fr.all.df,aes(x=V1,y=V2,label=species)) + # add the node labels
    scale_x_continuous(expand=c(0,1))+  # expand the x limits 
    scale_y_continuous(expand=c(0,1))+ # expand the y limits
    theme_bw()  # use the ggplot black and white theme

Lets mess with the themes and remove the grid lines and axis labels etc.

ggplot() +
    geom_segment(data=g,aes(x=from.x,xend = to.x, y=from.y,yend = to.y,size=weight),colour="black") +
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=21,colour="black") +  # adds a black border around the nodes
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=20,colour="lightgrey") +
    geom_text(data=fr.all.df,aes(x=V1,y=V2,label=species)) + # add the node labels
    scale_x_continuous(expand=c(0,1))+  # expand the x limits 
    scale_y_continuous(expand=c(0,1))+ # expand the y limits
    theme_bw()+  # use the ggplot black and white theme
    theme(
      axis.text.x = element_blank(),  # remove x-axis text
      axis.text.y = element_blank(), # remove y-axis text
      axis.ticks = element_blank(),  # remove axis ticks
      axis.title.x = element_blank(), # remove x-axis labels
      axis.title.y = element_blank(), # remove y-axis labels
      panel.background = element_blank(), 
      panel.border =element_blank(), 
      panel.grid.major = element_blank(),  #remove major-grid labels
      panel.grid.minor = element_blank(),  #remove minor-grid labels
      plot.background = element_blank())

If we wanted to incorporate some of the elements of the community detection algorithms present in the igraph on the right. We can make elements in the one group red and the other blue. Connections within a group will be a solid line and between groups a dashed line.

grouping <- data.frame(species = obs.sg.all$names, group = obs.sg.all$membership)  #create a data.frame of species and group membership
g$grp.from <- grouping$group[match(g$from, grouping$species)]  # match group membership within the g data.frame for from and to nodes
g$grp.to <- grouping$group[match(g$to, grouping$species)]
g$grp.type <- ifelse(g$grp.from == g$grp.to, 1, 0)  # if from and to nodes are the in same group then type is 1 else 0
g  # display the additions

##    from  to weight  from.x  from.y    to.x    to.y grp.from grp.to
## 1   BLG CCF     20  2.3192 -3.0746 -2.4960 -3.3497        1      2
## 2   BLG COC      6  2.3192 -3.0746  0.2719 -5.7700        1      1
## 3   BLG WHB      4  2.3192 -3.0746 -2.0786 -1.7555        1      2
## 4   BLG WAE      8  2.3192 -3.0746 -1.3122 -4.3867        1      2
## 5   BLG LMB      7  2.3192 -3.0746  0.3530 -1.2192        1      1
## 6   BLG CRP      6  2.3192 -3.0746 -0.7398 -2.6457        1      1
## 7   BLG FWD     13  2.3192 -3.0746  0.7329 -3.7887        1      2
## 8   CCF FWD    117 -2.4960 -3.3497  0.7329 -3.7887        2      2
## 9   CCF COC      9 -2.4960 -3.3497  0.2719 -5.7700        2      1
## 10  CCF WHB    211 -2.4960 -3.3497 -2.0786 -1.7555        2      2
## 11  CCF CRP     15 -2.4960 -3.3497 -0.7398 -2.6457        2      1
## 12  CCF LMB      7 -2.4960 -3.3497  0.3530 -1.2192        2      1
## 13  CCF WAE     55 -2.4960 -3.3497 -1.3122 -4.3867        2      2
## 14  CCF HSB     11 -2.4960 -3.3497 -3.2541 -5.7682        2      2
## 15  CCF NOP      3 -2.4960 -3.3497 -4.6923 -2.4240        2      1
## 16  CCF FHC      6 -2.4960 -3.3497 -1.1411  0.4478        2      1
## 17  COC FWD     12  0.2719 -5.7700  0.7329 -3.7887        1      2
## 18  COC WHB      4  0.2719 -5.7700 -2.0786 -1.7555        1      2
## 19  COC HSB      2  0.2719 -5.7700 -3.2541 -5.7682        1      2
## 20  COC LMB      3  0.2719 -5.7700  0.3530 -1.2192        1      1
## 21  COC WAE      2  0.2719 -5.7700 -1.3122 -4.3867        1      2
## 22  COC CRP      1  0.2719 -5.7700 -0.7398 -2.6457        1      1
## 23  CRP WHB     41 -0.7398 -2.6457 -2.0786 -1.7555        1      2
## 24  CRP LMB      3 -0.7398 -2.6457  0.3530 -1.2192        1      1
## 25  CRP WAE      9 -0.7398 -2.6457 -1.3122 -4.3867        1      2
## 26  CRP FWD      7 -0.7398 -2.6457  0.7329 -3.7887        1      2
## 27  CRP NOP      3 -0.7398 -2.6457 -4.6923 -2.4240        1      1
## 28  CRP HSB      2 -0.7398 -2.6457 -3.2541 -5.7682        1      2
## 29  CRP FHC      1 -0.7398 -2.6457 -1.1411  0.4478        1      1
## 30  FHC FWD      4 -1.1411  0.4478  0.7329 -3.7887        1      2
## 31  FHC WAE      1 -1.1411  0.4478 -1.3122 -4.3867        1      2
## 32  FHC WHB      2 -1.1411  0.4478 -2.0786 -1.7555        1      2
## 33  FHC LMB      1 -1.1411  0.4478  0.3530 -1.2192        1      1
## 34  FWD HSB      6  0.7329 -3.7887 -3.2541 -5.7682        2      2
## 35  FWD WHB    161  0.7329 -3.7887 -2.0786 -1.7555        2      2
## 36  FWD WAE     49  0.7329 -3.7887 -1.3122 -4.3867        2      2
## 37  FWD LMB      4  0.7329 -3.7887  0.3530 -1.2192        2      1
## 38  HSB WAE      8 -3.2541 -5.7682 -1.3122 -4.3867        2      2
## 39  HSB WHB     46 -3.2541 -5.7682 -2.0786 -1.7555        2      2
## 40  HSB NOP      1 -3.2541 -5.7682 -4.6923 -2.4240        2      1
## 41  LMB WAE      6  0.3530 -1.2192 -1.3122 -4.3867        1      2
## 42  LMB WHB      6  0.3530 -1.2192 -2.0786 -1.7555        1      2
## 43  LMB NOP      1  0.3530 -1.2192 -4.6923 -2.4240        1      1
## 44  NOP WHB      5 -4.6923 -2.4240 -2.0786 -1.7555        1      2
## 45  NOP WAE      1 -4.6923 -2.4240 -1.3122 -4.3867        1      2
## 46  WAE WHB    120 -1.3122 -4.3867 -2.0786 -1.7555        2      2
##    grp.type
## 1         0
## 2         1
## 3         0
## 4         0
## 5         1
## 6         1
## 7         0
## 8         1
## 9         0
## 10        1
## 11        0
## 12        0
## 13        1
## 14        1
## 15        0
## 16        0
## 17        0
## 18        0
## 19        0
## 20        1
## 21        0
## 22        1
## 23        0
## 24        1
## 25        0
## 26        0
## 27        1
## 28        0
## 29        1
## 30        0
## 31        0
## 32        0
## 33        1
## 34        1
## 35        1
## 36        1
## 37        0
## 38        1
## 39        1
## 40        0
## 41        0
## 42        0
## 43        1
## 44        0
## 45        0
## 46        1

fr.all.df$grp <- grouping$group[match(fr.all.df$species, grouping$species)]  # add group type to node data.frame

ggplot() +
    geom_segment(data=g,aes(x=from.x,xend = to.x, y=from.y,yend = to.y,size=weight,linetype=as.factor(grp.type)),colour="black") + # add line type
    geom_point(data=fr.all.df,aes(x=V1,y=V2),size=21,colour="black") +  # adds a black border around the nodes
    geom_point(data=fr.all.df,aes(x=V1,y=V2,colour=as.factor(grp)),size=20,show_guide=FALSE) +
    geom_text(data=fr.all.df,aes(x=V1,y=V2,label=species)) + # add the node labels
    scale_colour_manual(values=c("1"="red","2"="lightblue"))+  # add colour scaling for group membership
    scale_linetype_manual(values=c("0"="dashed","1"="solid"))+ # add linteyp scaling for within and between groups
    scale_x_continuous(expand=c(0,1))+  # expand the x limits 
    scale_y_continuous(expand=c(0,1))+ # expand the y limits
    theme_bw()+  # use the ggplot black and white theme
    theme(
      axis.text.x = element_blank(),  # remove x-axis text
      axis.text.y = element_blank(), # remove y-axis text
      axis.ticks = element_blank(),  # remove axis ticks
      axis.title.x = element_blank(), # remove x-axis labels
      axis.title.y = element_blank(), # remove y-axis labels
      panel.background = element_blank(), 
      panel.border =element_blank(), 
      panel.grid.major = element_blank(),  #remove major-grid labels
      panel.grid.minor = element_blank(),  #remove minor-grid labels
      plot.background = element_blank())