Martin Hinz

14C Calibration with JAGS

Sun, 19 Dec 2021 00:00:00 +0000

Intro

In this post I would like to continue what I have published already 4 years ago. This time I want to show how to calibrate a ¹⁴C-date using well-known Bayesian tools, specifically JAGS. JAGS stands for Just Another Gibbs Sampler, and is a program for analysing ‘Bayesian hierarchical models using Markov Chain Monte Carlo (MCMC) simulation’. This makes it clearly overqualified for our simple task, but it nicely shows a different perspective on the problem and also makes obvious the possibilities of how to extend this task even further.

Formulation of the problem

In the last post, I realised the bottom-up procedure and wrote an MCMC algorithm and a Gibbs sampler from scratch, or rather explained the method for doing so. Using the example of estimating pi, I showed how an MC method can be used to estimate unknown quantities that cannot be determined analytically. Based on this, I transferred the whole approach to radiocarbon calibration.

Prior

We can therefore dispense with all this here; we start by defining the problem from the other side. I had explained that (apart from technical things like the loop and a variable for collecting results) we need above all a prior and a likelihood function. The prior has not been explicitly specified by us, but it is implicit: Some calendar date, where all calendar dates per se have the same probability. This remains the same. However, for technical reasons, because we can only perform a calibration within the calibration curve, we have to restrict our prior somewhat: we can perform up to a maximum of the range of the calibration curve, which currently goes back to 55000 BP.

This poses a problem mathematically for the basic justification of the correctness of the procedure, but not practically. We simply have to be aware that the procedure will not work correctly for older data (or data that touches this fringe).

In formulaic language, we can express this prior as follows:

\[calDate ∼ U(0,55000)\]

We pretend to know nothing per se about the possible temporal position of the calibrated date. This is not true, of course, we have the calibration curve and we will use it later to set the starting values for our analysis. But this is how we indicate the objectively available knowledge about it, namely that the calibrated date should be somewhere between today and the beginning of the calibration curve.

Likelihood

Next, let’s look at the definition of the likelihood of our calibrated date. Last time I expressed it like this:

likelihood <- function(proposal){dnorm(calf(proposal),bp,std)}

This is R-code, which says that the probability of a proposal is determined by how well the recalibrated 14C age (i.e. not calendar years) fits the measured value, which we have present. We randomly made suggestions from the whole range of the prior, and then looked to see how plausible this calendar year is, given our measurement. This has a normal distribution around the BP value with a certain standard deviation, which results from the measurement and the measurement inaccuracies.

The function calf() was a little help here, making a linear approximation for the area between two calendar dates occupied in the calibration curve. The R code was as follows:

calf<-approxfun(intcal13[,1],intcal13[,2])

Intuitively, this is what happens:

We have given two points. Between these we can determine the slope. If we now want to estimate another point for which the x-value lies between these points, we assume that it will behave in exactly the same way as the process we know through the two points and interpolate the y-value of the estimated point accordingly by sticking to these first two points.

The likelihood therefore consists of two elements: the normal distribution around the measured value, and the back-calibration of the estimated value, which we create using the linear approximation of the measured values of the calibration curve. In the first step, we assume for simplicity that the calibration curve is only a line and not a probability band. But we will incorporate this fact again later.

Let’s write it down roughly, then it could look like this:

\[uncalDate = linearApproximation(calDate, CalibrationCurveBP_{uncal},CalibrationCurveBP_{cal}) \\ uncalDate \sim N(MeasurementBP, MeasurementSigma)\]

Let’s take a look at the following illustration:

It does not matter whether I determine from the probability of the (red) recalibrated proposal with respect to the normal distribution of the measured value, or from the (black) measured value the probability with respect to the normal distribution around the recalibrated proposal: the result will be the same. Therefore, in the last line we can swap our uncalibrated proposal date with the measurement without changing anything in the probabilities:

\[MeasurementBP \sim N(uncalDate, MeasurementSigma)\]

This gives us everything we need for a Bayesian model using JAGS, the prior and the likelihood. The programme takes care of all the other technical details. In return, however, we have to work some magic to persuade JAGS to cooperate. Before we get to that, let’s briefly write up the inside of our model:

\[calDate \sim U(0,55000)\\ \hspace{-2em}\\ uncalDate = linearApproximation(calDate, CalibrationCurveBP_{uncal},CalibrationCurveBP_{cal}) \\ MeasurementBP \sim N(uncalDate, MeasurementSigma)\]

Putting JAGS to work

There are several packages for R to persuade JAGS to cooperate. The prerequisite, however, is that JAGS is installed at all on the operating system level. I will not discuss how to do this, as there are already too many operating systems to consider. But you can find your way around quite well via the project page and the internet help, I hope.

Rather, I would like to outline the R side of the task a little more closely.

We will use the package rjags, which is developed by Martyn Plummer, who is also behind JAGS itself. This has to be installed (I have commented it out for myself, for the first time the part behind the hash has to be executed):

# install.packages("rjags")

And then be loaded

require(rjags)

## Loading required package: rjags

## Loading required package: coda

## Linked to JAGS 4.3.0

## Loaded modules: basemod,bugs

This puts the power of the programme at our disposal. In order to achieve a result quickly, I will put the simplest possible use at the beginning, we will also specify this in more detail later. So let’s turn to the implementation of our model in JAGS code. You remember the model from above, don’t you?

\[calDate \sim U(0,55000)\\ \hspace{-2em}\\ uncalDate = linearApproximation(calDate, CalibrationCurveBP_{uncal},CalibrationCurveBP_{cal}) \\ MeasurementBP \sim N(uncalDate, MeasurementSigma)\]

First to the prior. We express this uniform distribution in JAGS language as follows:

# Prior
calDate ~ dunif(0,55000);

Here, dunif stands for the uniform distribution, the values given behind it for the limits of the uniform distribution. That was easy. Now for the likelihood. This consisted of two parts, the normal distribution around the uncalibrated date and the recalibration of our proposal to obtain this uncalibrated date. For this we want to use a linear approximation. Fortunately, there is a function in JAGS that looks pretty much like our formulaic proposal.

uncalDate <- interp.lin(calDate,calBP,C14BP);

Here are two variables (calBP, C14BP) that we have not yet added. This represents the calibrated and the uncalibrated values of the calibration curve, and we will give these values to the model as data (or better as constants) later.

Regarding the normal distribution, there is one small thing to note: JAGS, for historical reasons, does not expect the standard deviation as a parameter, but something called precision (and commonly abbreviated as τ or tau). This is nothing other than the inverse of the variance, or in terms of the standard deviation:

\[\tau = \frac{1}{\sigma^2}\]

We have to add this small conversion to the model of the likelihood so that JAGS then understands it correctly. Therefore, the whole block for the normal distribution looks like this:

MeasurementBP ~ dnorm(uncalDate, tau)

tau <- 1/(pow(sigma,2)

With this we have the whole naive model (it does not yet take into account the standard deviation of the calibration curve itself) together:

# Prior
calDate ~ dunif(0,55000);

# Likelihood
uncalDate <- interp.lin(calDate,calBP,C14BP);

MeasurementBP ~ dnorm(uncalDate, tau)
tau <- 1/(pow(sigma,2)

By the way, the order does not matter, the main thing is that all elements are named and specified correctly. In order to make this usable for JAGS, we still have to transfer it into a variable and within it mark the actual model as a model by placing it in curly brackets with the word ‘model’ in front of it:

calibration_model <- "
  model{
    # Prior
    calDate ~ dunif(0,55000)

    # Likelihood
    uncalDate <- interp.lin(calDate,calBP,C14BP)

    MeasurementBP ~ dnorm(uncalDate, tau)
    tau <- 1/pow(sigma,2)
  }
"

The indentations are just for us to make it easier to read.

Wonderful, the model is ready, now we need the data. Firstly, there is the calibration curve. We want to take IntCal20, which is the latest version at the time of writing. We can download this from the net:

CalCurve <- read.csv(
  url("http://intcal.org/curves/intcal20.14c"),
  header=F, skip = 11)
colnames(CalCurve) <- c("calBP", "C14BP", "Sigma", "Delta_14C", "Sigma_Delta")

Furthermore, we need our measurement and its standard deviation. Let’s take a nice dating from the Neolithic:

MeasurementBP <- 5640
sigma <- 31

JAGS (or rjags) expects our data as a list, let’s put it together. A small insertion nevertheless: interp.lin expects the values in ascending order, the calibration curve delivers them in descending order. We have to reverse this quickly using the R command rev():

data <- list(
  MeasurementBP = MeasurementBP,
  sigma = sigma,
  calBP = rev(CalCurve$calBP),
  C14BP = rev(CalCurve$C14BP)
)

With this we are basically done (we are not, we will see in a moment). To run jags now, we initialise the model:

m_init <- jags.model(textConnection(calibration_model), data=data)

## Compiling model graph
##    Resolving undeclared variables
##    Allocating nodes
## Graph information:
##    Observed stochastic nodes: 1
##    Unobserved stochastic nodes: 1
##    Total graph size: 19014
## 
## Initializing model

Voila, we have an initialised model. Now, similar to our example by hand, we can start the MCMC algorithm and have samples drawn. To do this, we use the command coda.samples and specify from which variable we want to get them, namely from calDate, as well as the number. Let’s stay with 10000, as in the example by hand:

samples <- coda.samples(m_init, c('calDate'), 10000)

If we now have a summary of the sampled values, it is a rather unconvincing surprise:

summary(samples)

## 
## Iterations = 1001:11000
## Thinning interval = 1 
## Number of chains = 1 
## Sample size per chain = 10000 
## 
## 1. Empirical mean and standard deviation for each variable,
##    plus standard error of the mean:
## 
##           Mean             SD       Naive SE Time-series SE 
##      2.678e+04      7.064e-01      7.064e-03      1.056e-02 
## 
## 2. Quantiles for each variable:
## 
##  2.5%   25%   50%   75% 97.5% 
## 26779 26780 26780 26781 26782

All samples, with few deviations, took place around the year 26780. We expected that to be better. This can also be better if we let the algorithm start at the right place.

Another way to see that something is going wrong here is to have the sampling process itself displayed graphically. To do this, you can simply apply the plot command to the result of the sampling:

plot(samples)

On the left we see the so-called trace plot. Generally, this should look like “a hairy caterpillar”. Which it does here. However, the values only jump back and forth between 26784 and 26778. The density plot on the right also looks quite wrong, with a very pronounced peak and a steep slope on both sides. This is not how a calibrated datum should look!

We do not specify a frame within which the date can lie, but very small probabilities over the entire span of the 50,000 years mean that the algorithm cannot navigate reasonably along the suggestions, and therefore always remains at the starting point. Therefore, we roughly estimate the position of the calibrated date on the basis of the calibration curve:

naive_cal <- approx(CalCurve$C14BP, CalCurve$calBP, data$MeasurementBP)$y

## Warning in regularize.values(x, y, ties, missing(ties), na.rm = na.rm):
## collapsing to unique 'x' values

There is the linear approximation again, but this time in reverse. We estimate the calibrated date from the uncalibrated date. Of course, this is not allowed for a real calibration, but it gives us a good starting point to run through the whole probability range of the calibration. Accordingly, we get a warning that several places would fit, and only one is selected. However, this is sufficient as a starting value, which we give via another variable (which I call inits):

inits <- list(calDate = naive_cal)
m_init <- jags.model(textConnection(calibration_model), data=data, inits = inits)

## Compiling model graph
##    Resolving undeclared variables
##    Allocating nodes
## Graph information:
##    Observed stochastic nodes: 1
##    Unobserved stochastic nodes: 1
##    Total graph size: 19014
## 
## Initializing model

samples <- coda.samples(m_init, c('calDate'), 10000)
summary(samples)

## 
## Iterations = 1001:11000
## Thinning interval = 1 
## Number of chains = 1 
## Sample size per chain = 10000 
## 
## 1. Empirical mean and standard deviation for each variable,
##    plus standard error of the mean:
## 
##           Mean             SD       Naive SE Time-series SE 
##      6417.5136        39.6977         0.3970         0.9805 
## 
## 2. Quantiles for each variable:
## 
##  2.5%   25%   50%   75% 97.5% 
##  6325  6401  6423  6441  6484

That is already more credible! The calibrated results range between 6325 and 6484 with a 95% confidence interval. Let’s look at the plot of the samples:

plot(samples)

That’s better. The “caterpillar” has more legs than hair - less deviation into the lower than into the higher range, but the density plot is already far more credible.

And then compare the result with a calibration using another method, e.g. rcarbon:

if (!require(rcarbon)) install.packages("rcarbon") # Install, if not already present

## Loading required package: rcarbon

require(rcarbon) # Load in any case
rcarbon_result <- calibrate(data$MeasurementBP, data$sigma)

## [1] "Calibrating radiocarbon ages..."
##   |                                                                              |                                                                      |   0%  |                                                                              |======================================================================| 100%[1] "Done."

plot(rcarbon_result)

The similarities are clearly visible!

Now there is one more thing we have not taken into account: The calibration curve itself also has a range of uncertainty, as is clear from the data from IntCal20 itself:

head(CalCurve)

##   calBP C14BP Sigma Delta_14C Sigma_Delta
## 1 55000 50100  1024     528.5       193.9
## 2 54980 50081  1018     528.3       192.7
## 3 54960 50063  1013     527.9       191.7
## 4 54940 50043  1007     527.8       190.6
## 5 54920 50027  1003     527.0       189.5
## 6 54900 50009   997     526.6       188.4

It clearly says sigma! However, this is not a problem, we can interpolate this sigma for each proposed date as well and then insert it into the variation range of the normal distribution just like the sigma of the measurement itself:

better_calibration_model <- "
  model{
    # Prior
    calDate ~ dunif(0,55000)

    # Likelihood
    uncalDate <- interp.lin(calDate,calBP,C14BP)
    sigmaCalCurve <- interp.lin(calDate,calBP,C14Sigma) # Here we now interpolate the Uncertainity of the CalCurve itself

    MeasurementBP ~ dnorm(uncalDate, tau)
    
    tau <- 1/(pow(sigma,2)+pow(sigmaCalCurve,2)) # Here comes the CalCurve uncertainity into the Model
  }
"

We need to add the source for the uncertainity to the data

data$C14Sigma <- CalCurve$Sigma

And now we do the same as before:

m_init <- jags.model(textConnection(better_calibration_model), data=data, inits = inits)

## Compiling model graph
##    Resolving undeclared variables
##    Allocating nodes
## Graph information:
##    Observed stochastic nodes: 1
##    Unobserved stochastic nodes: 1
##    Total graph size: 28519
## 
## Initializing model

samples_better <- coda.samples(m_init, c('calDate'), 10000)

Let’s have a look at the summary of the samples:

summary(samples_better)

## 
## Iterations = 1001:11000
## Thinning interval = 1 
## Number of chains = 1 
## Sample size per chain = 10000 
## 
## 1. Empirical mean and standard deviation for each variable,
##    plus standard error of the mean:
## 
##           Mean             SD       Naive SE Time-series SE 
##      6413.7099        45.2159         0.4522         0.9311 
## 
## 2. Quantiles for each variable:
## 
##  2.5%   25%   50%   75% 97.5% 
##  6321  6393  6420  6443  6486

And compare that with the previous run:

summary(samples)

## 
## Iterations = 1001:11000
## Thinning interval = 1 
## Number of chains = 1 
## Sample size per chain = 10000 
## 
## 1. Empirical mean and standard deviation for each variable,
##    plus standard error of the mean:
## 
##           Mean             SD       Naive SE Time-series SE 
##      6417.5136        39.6977         0.3970         0.9805 
## 
## 2. Quantiles for each variable:
## 
##  2.5%   25%   50%   75% 97.5% 
##  6325  6401  6423  6441  6484

Actually, not that much has changed. Let’s plot this over the date calibrated by rcarbon:

plot(rcarbon_result$grids$`1`$calBP, rcarbon_result$grids$`1`$PrDens, type = "l")
lines(density(samples[[1]]), col="red")
lines(density(samples_better[[1]]), col="green")

Especially in the marginal areas, the green curve (our samples_better) should provide more reliable results.

Convergence

Now we go one step further. We have arbitrarily set 10000 repetitions for our result. But is that enough? Or too much? And is the result reliable? There is a way to estimate this by running several estimates in parallel. If all of them come to the same result, then this should also be consistent.

To do this, we simply specify that more than one chain is to be computed. To illustrate the effect, I shorten the adaptation time of the model, which is set to 1000 iterations by default and ensures that the sampler works more effectively. I also set the start value for one of the chains to something less optimal:

diff_inits <- list(inits,
                   list( calDate = inits$calDate + 300))

m_init <- jags.model(textConnection(better_calibration_model),
                     data=data,
                     inits = diff_inits,
                     n.chains = 2, # two chains
                     n.adapt=50
                    )

## Compiling model graph
##    Resolving undeclared variables
##    Allocating nodes
## Graph information:
##    Observed stochastic nodes: 1
##    Unobserved stochastic nodes: 1
##    Total graph size: 28519
## 
## Initializing model

## Warning in jags.model(textConnection(better_calibration_model), data = data, :
## Adaptation incomplete

samples_better <- coda.samples(model = m_init,
                               variable.names = c('calDate'),
                               n.iter = 10000)

## NOTE: Stopping adaptation

plot(samples_better)

The first chain is rendered in black, the second in red. We can see that the chains differ from each other. It takes time for them to sample in the same area. This is called that they “converge”. Accordingly, only after a certain point in time do the samples make sense. To determine this, one could perhaps read it from the trace plot. However, it is better to use the generally recognised statistic for this, the Brooks-Gelman-Rubin (BGR) statistic.

gelman.diag(samples_better)

## Potential scale reduction factors:
## 
##         Point est. Upper C.I.
## calDate       1.22       1.75

This value should be close to 1, then we have achieved convergence. Generally, it is said that it should not exceed 1.1. Here it is higher. This is due to the different starting values, but also because our sampler does not work optimally due to lack of adaptation. We can also take a graphical look at the point at which convergence could be achieved:

gelman.plot(samples_better)

At a certain point, both curves may run close to zero. That would be the point at which convergence would be reached. What we can do (we have deliberately made the sampler worse) is to let the chains run longer and throw away the first part. We know that at the beginning of the run of the MCMC, the samples are taken from not very probable areas. It is good practice in Bayesian modelling to ignore the first results. This is also called the burn-in phase.

To make the chains run longer, we can simply repeat the sampling process:

samples_better <- coda.samples(model = m_init,
                               variable.names = c('calDate'),
                               n.iter = 10000)
gelman.plot(samples_better)

That should look better now. Perhaps even complete convergence has been achieved? Let’s have a look:

gelman.diag(samples_better)

## Potential scale reduction factors:
## 
##         Point est. Upper C.I.
## calDate          1          1

You can continue this until you are satisfied with the Gelman-Rubin-Brooks statistics. You can try to optimise the time of the burn-in, as you do not want to sample the computer for an unnecessarily long time.

So, let’s end the whole thing with our model running according to the rules with 4 chains. Since the model can now fully adapt, there is no burn-in at all in this simple case. Therefore, I set extra false start values and used a while loop to first update with 2000 samples until the statistics are sufficient, and then I take the final 10000 samples.

extra_diff_inits <- list(
                   list( calDate = inits$calDate + 100),
                   list( calDate = inits$calDate + 200),
                   list( calDate = inits$calDate + 300),
                   list( calDate = inits$calDate + 385)
                   )

m_init <- jags.model(textConnection(better_calibration_model),
                     data=data,
                     inits = extra_diff_inits,
                     n.chains = 4
                    )

## Compiling model graph
##    Resolving undeclared variables
##    Allocating nodes
## Graph information:
##    Observed stochastic nodes: 1
##    Unobserved stochastic nodes: 1
##    Total graph size: 28519
## 
## Initializing model

it <- 1 # I like to take count of the iteration, not necessary in real world

not_converged <- TRUE

while(not_converged){
samples_better <- coda.samples(model = m_init,
                               variable.names = c('calDate'),
                               n.iter = 2000)
it <- it + 1
not_converged <- gelman.diag(samples_better)$psrf[1,1]>1.1
}

samples_better <- coda.samples(model = m_init,
                               variable.names = c('calDate'),
                               n.iter = 10000)

plot(samples_better)

gelman.diag(samples_better)

## Potential scale reduction factors:
## 
##         Point est. Upper C.I.
## calDate          1          1

It took 39 iterations before convergence was achieved. And now here is our calibrated date, where we may assume a successful convergence of 4 chains.

We can then display the result in a graphically appealing way. For this purpose, I will use the bayesplot package, but there are a large number of packages that can be used for this task.

if (!require(bayesplot)) install.packages("bayesplot") # Install, if not already present

## Loading required package: bayesplot

## This is bayesplot version 1.8.1

## - Online documentation and vignettes at mc-stan.org/bayesplot

## - bayesplot theme set to bayesplot::theme_default()

##    * Does _not_ affect other ggplot2 plots

##    * See ?bayesplot_theme_set for details on theme setting

require(bayesplot) # Load in any case

bayesplot::mcmc_areas(samples_better, prob = 0.95,
                      transformations = function(x) 1950 - x)

For comparison, the rcarbon version again:

plot(rcarbon_result, calendar = "BCAD")

So, by using JAGS, we learned how to set up and implement our model formulaically, and also how to test and improve its reliability. And it wasn’t that hard, was it?

14C Calibration the Bayesian way

Mon, 23 Jan 2017 00:00:00 +0000

Appetizer

With what follows I want to demonstrate that the basic functionality of Oxcal is reflected in this tiny bit of code:

calf<-approxfun(intcal13[,1],intcal13[,2])

likelihood <- function(proposal){dnorm(calf(proposal),bp,std)}

#Setup
collector <- bp <- 3600; std <- 30; last_prob <- likelihood(bp)

for (i in 1:10000) {
  proposal <- rnorm(1, tail(collector,1), 3*std)
  proposal_prob <- likelihood(proposal)
  
  if ((proposal_prob/last_prob) > runif(1))
  {
    last_prob <- proposal_prob
  } else {
    proposal <- tail(collector,1)
  }
  
  collector <- c(collector, proposal)
}

Motivation

The ¹⁴C cycle

¹⁴C is produced in the atmosphere by solar radiation, is than oxidised to CO₂ and than introduced into the foodchain. From than onward, the ¹⁴C decays.

source: http://www.imprs-gbgc.de/uploads/RadiocarbonSchool/Overview/radiocarbon.png

The nonlinear nature of the ¹⁴C curve

The problem is, that the amount of ¹⁴C in the atmosphere was different during different times. This causes that there is no simple linear relationship between ¹⁴C years you get from the lab to the real calendric cal bp or bc date. The expression of this is the wiggly nature of the calibration curve:

This becomes more obvious if we zoom in:

changes in solar activity

The main reason for that might be the fluctuation of the solar activity, that causes different amount of solar radiation and with that also different ¹⁴C values. One fluctuation is a well known 11 year cycle, but there are other, not so well behaving fluctuations, too.

A solar cycle
source: https://upload.wikimedia.org/wikipedia/commons/c/c2/The_Solar_Cycle_XRay_hi.jpg

calibration | using material of known age

To cope with that, we use samples of known age, eg. tree rings. Radiometric dating those gives us a estimation for the amount of ¹⁴C at different times. Since the resulting calibration curve is not linear, there is no linear calculation possible to come up with the real age of things.

Dendrochronology
source: Schweingruber, F.H., 1983: Der Jahrring. Haupt, Bern und Stuttgart

Real world calibration | The problem with the nonlinear nature

In an ideal world, you could use a ruler for translating a radiocarbon age to a calender age. But due to the wiggles of the curve, there are parts where a radiocarbon age could result in two or even more possible calendric ages.

video of chunk calib_anim

Real world calibration | The problem nature of a ¹⁴C date

What makes things worse, is the fact, that you will never get a single radiocarbon age, but always a probability distribution with a ‘most likely’ value (the uncalibrated ¹⁴C age) with a standard deviation (eg. +/- 25). On the pro side is that this distribution behaves statistically well, since it follows a normal distribution. On the con side: this enlarges the possible range where a calibration gives multiple values, and it makes the calculation non-trivial.

There are several approaches for calibration, one I have shown in an earlier post, this time we will deal with the Bayesian way.

The bayesian approach to that problem

Keywords

There are several buzzwords that show up when people talk about Bayesian calibration. Those are eg.

Monte Carlo
Markov Chain
Metropolis–Hastings algorithm

The sound impressive, don’t they. But we will handle them one by one.

Monte Carlo

Monte Carlo methods are just a name for 'doing something including a random aspect', meaning eg. 'roll a dice'.

Markov Chain

Markov Chain means 'Something takes place in respect to the current state'. In this example, we start from a sunny day. There is a 90% chance that the next day will be sunny again, and a 10% chance that it will be raining. If the next day will be one of those 10% where it is rainy, there is a 50% chance that it stays rainy, and a 50% chance that it will be sunny again. So, next day is rainy, again 50/50 chances. If next day is sunny, again 90/10 chances. And so on.

Together it is MCMC

MCMC stands for ‘Monte Carlo Markov Chain’. This is a procedure that can be used for estimating parameter that can not be measured directly, based on an external evaluation.

To demonstrate that and to prepare for the real ¹⁴C calibration, we will estimate the value of Pi.

Excurse Value of Pi using MCMC

Setting

We have a square of 1 m and an circle with radius 1 m.

We throw darts. We count, how many darts are in the circle, and how many are in the surrounding square.

The darts are the random part (Monte Carlo). The amount of darts inside the circle is relative to the area, as it is the amount of darts within the square.

area of circle to area of square is:

\(\frac{\text{area of circle}}{\text{area of square}} = \frac{ r^{2} \cdot \pi }{ (2 \cdot r)^{2} } = \frac{ \pi }{ 4 } = \frac{\text{darts in circle}}{\text{darts in square}} = P\)
\(\pi = P \cdot 4\)

To calculate the value of Pi, we have to count the darts that are inside the circle and those inside the square, and divide their ratio by 4.

Experiment

Now some R code follows:

We make a circle with radius of 0.5 and center it in a square (center = 0.5;0.5). We make a loop, that is repeated 10000 times. We randomly draw from a uniform distribution x and y for the point (we throw the dart). We check if the dart is inside the circle. If so, we memorize it. Afterwards, we divide the amounts of dart inside the circle by the number of trials, divided by 4.

radius <- 0.5
center_x <- center_y <- 0.5
collector <- vector()
for (i in 1:10000) {
x <- runif(1)
y <- runif(1)
inside <- (x-center_x)^2 + (y - center_y)^2 < radius^2
collector <- c(collector,inside)
}

sum(collector==TRUE)/length(collector)*4

The result:

## [1] 3.1208

is close to Pi:

pi
## [1] 3.141593

Experiment Live

Here you can see the experiment running live:

video of chunk pi_2

Anatomy of the algorithm

The algorithm we have used can be divided into several parts:

# Setup
radius <- 0.5
center_x <- center_y <- 0.5
collector <- vector()

# Loop
for (i in 1:10000) {
  
  # Proposal (function)
  x <- runif(1)
  y <- runif(1)
  
  # Likelihood (function)
  inside <- (x-center_x)^2 + (y - center_y)^2 < radius^2
  
  collector <- c(collector,inside)
}

A setup, where we define start values
A loop, within which things are repeated for some time
A proposal function, that proposes candidates for our ‘desired’ result (darts in the circle).
A likelihood function that determinates how likely it is that we archived a ‘desired’ result. In this case it is either in or out, so likelihood is either 0 or 1.
At last, a collector, that collects our results.

Pi vs ¹⁴C Date

In this experiment, there are already several aspects that are similar to the ¹⁴C calibration that we intend to produce, but also some differences that we have to cope with:

Pi	¹⁴C Date
unknown value of Pi	unknown distribution of calibrated date
choosing a random point	choosing a random date
evaluation against the circle (inside/outside)	evaluation against the uncalibrated date
deterministic evaluation criterion (inside/outside)	probabalistic criterion (prob. distribution of uncalibrated date)

With some little effort we will be able to proceed from here to Bayesian calibration.

Toward the Bayesian calibration

Lets start with things that are similar:

Setup

Setup looks rather similar. We only need different things, like uncalibrated date and its standard deviation.

# Pi
radius <- 0.5
center_x <- center_y <- 0.5
collector <- vector()

# Calibration
bp <- 3600
std <- 30
collector <- vector()
collector[1] <- bp

Loop

Also the loop is rather similar:

# Pi
for (i in 1:10000) {
  # Actions that are repeated
  # 10000 times
}

# Calibration
for (i in 1:10000) {
  # Actions that are repeated
  # 10000 times
}

Proposal function

In case of Pi, we propose random x and y coordinates. For the calibration, we propose a calendric date. But we do not propose any random date, but one that depends on our previous proposal. This is a Markov Chain, remember? We make a new proposal near to our previous one, and we make it more likely that it is nearer than that it is farther away. For that we use a normal distribution (rnorm).

# Pi

x <- runif(1)
y <- runif(1)

# Calibration
proposal <- rnorm(
  1,
  tail(collector,1),
  3*std)

video of chunk proposal_function_live

Putting together what we have now:

bp <- 3600
std <- 30
collector <- vector()
collector[1] <- bp
 
for (i in 1:10000) {
  proposal <- rnorm(1, tail(collector,1), 3*std)
  
  # What is missing is the likelihood function!
  
  collector <- c(collector, proposal)
}

Differences to the Pi example

From now on, things are a bit different due to the differences of our examples:

Pi	¹⁴C Date
unknown value of Pi	unknown distribution of calibrated date
choosing a random point	choosing a random date
evaluation against the circle (inside/outside)	evaluation against the uncalibrated date
deterministic evaluation criterion (inside/outside)	probabalistic criterion (prob. distribution of uncalibrated date)

We cannot directly evaluate, if the date fits our calibrated date, because we do not know it yet. But we know the uncalibrated date, and will use that instead. Also, we do not have a inside/outside of the circle criterion (0/1), but one that has a certain probability, so values between 0 and 1 are possible. We will cope with that.

Differences to the Pi example

Problem One

We evaluate against the uncalibrated date:

-> We have to backcalibrate the proposal

Problem Two

We have a probabilistic criterion, we only get a probability back if the proposal fits our uncalibrated date

-> We have to introduce some probabilistic (random) decision

Solution One: Backward calibration

In contrast to forward calibration, backward calibration is straight forward. We can use the ‘ruler approach’, since every calibrated date only reflects one uncalibrated one. The wiggles only go up and down, luckily not left and right!

video of chunk backcalib_anim

intcal13 <- read.csv(
  "http://www.radiocarbon.org/IntCal13%20files/intcal13.14c",
  skip = 11, header=F)[,1:2]
colnames(intcal13) <- c("CAL BP", "14C age")

calf <- function(this_bp) {
  approx(intcal13$`CAL BP`,
         intcal13$`14C age`,
         this_bp)$y
}
calf(3600)

## [1] 3364

Likelihood function

For the likelyhood function, we need the shape of the uncalibrated date. With that we can now check how good a proposed date would fit our uncalibrated one. We can determine, how likely a proposal would be given our uncalibrated date.

likelihood <- function(proposal){
 pred = calf(proposal)
 dnorm(pred,bp,std)
}

likelihood(3600)

## [1] 4.85012e-16

With that, we have a likelihood function!

Solution Two: Evaluation with a random component

We take the last proposal, resp. its likelihood
We compute the likelihood of the new proposal
If the new proposal fits better to the uncalibrated date, we keep it
If not: We still keep it with a probability equal to how worse the new proposal is compared to the prior one

p(new)/p(old)

-> Metropolis-Hastings algorithm

Solution Two: Evaluation with a random component

We start with the bp value of the uncalibrated date as our first proposal. Than we make a second proposal, in relation to the first one.

first_proposal <- bp
second_proposal <- rnorm(1, first_proposal, 3*std)
second_proposal

Our second proposal is:

## [1] 3555.349

With our likelihood function, we check how likely this second proposal is:

ratio <- likelihood(second_proposal)/likelihood(first_proposal)
ratio

## [1] 3.353998e-10

The second proposal is 3.3539984 * 10^-10 times likely compared to the first.

Solution Two: Evaluation with a random component

If the ratio is more than 1 (second proposal is better), we keep it.

If it is less than one (second proposal is worse), we keep it with a probability equal to the ratio. Meaning, we roll a dice…

alpha <- runif(1)
alpha

## [1] 0.2552167

Check if our random value is smaller than our ratio.

alpha < ratio

## [1] FALSE

That is false. So our second proposal will not be recorded, and will not be part of the Markov chain.

Everything together

The final code

calf<-approxfun(intcal13[,1],intcal13[,2])

likelihood <- function(proposal){dnorm(calf(proposal),bp,std)}

#Setup
collector <- bp <- 3600; std <- 30; last_prob <- likelihood(bp)

for (i in 1:10000) {
  proposal <- rnorm(1, tail(collector,1), 3*std)
  proposal_prob <- likelihood(proposal)
  
  if ((proposal_prob/last_prob) > runif(1))
  {
    last_prob <- proposal_prob
  } else {
    proposal <- tail(collector,1)
  }
  
  collector <- c(collector, proposal)
}

With every loop, our collector records those proposals that were accepted, either because they were better, or because the were choosen in the relegation round… due to the random factor.

The result

If we make a histogramm from the collected proposals, we get something that is essentially already the calibrated date:

hist(collector,probability=TRUE, breaks = 100)

Compare the result

We can compare the resulting histogram with a calibration from Oxcal: looks similar!

See it run

video of chunk algorithm_live

Adding stratigraphical informations

The Scenario

We have two samples, S_1 (3600, 30) and S_2 (3550, 40). We know from the stratigraphy, that S_1 must be younger than S_2.

We can easily introduce this information into our calibration with a little extra code.

The new code

First step: Calibrate multiple dates at once. For this, we add another dimension to our variables (bp, std, collector, last_prob), to reflect the fact that we now deal with multiple data:

#Setup
bp <- c(3600, 3550); std <- c(30,40)
collector <- list(date1=bp[1], date2=bp[2])
last_prob <- c(likelihood(bp[1]), likelihood(bp[2]))

for (i in 1:20000) {
  curr_date <- (i-1)%%2+1 # alter between 1 and 2
  proposal <- rnorm(1, tail(collector[[curr_date]],1), 3*std[curr_date])
  proposal_prob <- likelihood(proposal)[curr_date]
  
  if ((proposal_prob/last_prob[curr_date]) > runif(1))
  {
    last_prob[curr_date] <- proposal_prob
  } else {
    proposal <- tail(collector[[curr_date]],1)
  }
  
  collector[[curr_date]] <- c(collector[[curr_date]], proposal)
}

The result

If we now let the code run, we can calibrate two dates at once:

The new code

Second step: Alter the Metropolis-Hastings -> Gibbs Sampling We add another condition:

If calibrating for the first date (S_1), every proposal must be younger than the last proposal for the second date (S_2), and vice versa,

If calibrating for the second date (S_2), every proposal must be older than the last proposal for the second date (S_1)

#Setup
bp <- c(3600, 3550); std <- c(30,40)
collector <- list(date1=bp[1], date2=bp[2])
last_prob <- c(likelihood(bp[1]), likelihood(bp[2]))

for (i in 1:20000) {
  curr_date <- (i-1)%%2+1 # alter between 1 and 2
  proposal <- rnorm(1, tail(collector[[curr_date]],1), 3*std[curr_date])
  proposal_prob <- likelihood(proposal)[curr_date]
  
# This is the new bit!
#####################################################
  if (curr_date == 1 & proposal > tail(collector[[2]],1)) proposal_prob = 0
  if (curr_date == 2 & proposal < tail(collector[[1]],1)) proposal_prob = 0
#####################################################
  
  if ((proposal_prob/last_prob[curr_date]) > runif(1))
  {
    last_prob[curr_date] <- proposal_prob
  } else {
    proposal <- tail(collector[[curr_date]],1)
  }
  
  collector[[curr_date]] <- c(collector[[curr_date]], proposal)
}

The result

Now we can see the modeled date according to our stratigraphic information:

Both dates can again be compared against the Oxcal output:

Compare to Oxcal unmodeled

Compare to Oxcal modeled

Result

Voila, Oxcal reverse engineered!

14C Calibration 1

Fri, 03 Jun 2016 00:00:00 +0000

Calibration of ¹⁴C dates is one of the more common tasks an archaeologists has to do. I will not go into the details of the details why calibration is necessary here (maybe in another post), but I want to give in this post and in some follow ups hands on instruction how a calibration can be archieved using R. This series will be published also at the ISAAKiel-Repository.

The short story

Everything, what follows, is an explanation of these 5 lines of code:

cal_curve <- read.csv(
  url("http://www.radiocarbon.org/IntCal13%20files/intcal13.14c"),
  skip=11, 
  header=F)
cal_matrix <- sapply(cal_curve[,1],function(x) {
  dnorm(x,mean = cal_curve[,2],sd = cal_curve[,3])
  })
my_prob_date <- dnorm(cal_curve[,1], mean = 4000, sd = 25)
my_cal_date <- as.vector(cal_matrix %*% my_prob_date)
plot(cal_curve[,1],my_cal_date,type="l",xlim=c(4350,4600))

Got it? Fine! If not, continue reading…

Getting the Calibration Curve

For calibration we need two things: A date and the calibration curve.

Starting with the latter, you can obtain it at Radiocarbon. You can download it or access it directly from inside R, like I did in the upper code snippet. I will now go for the first alternative.

If you have downloaded it, you may like to inspect the file. It is essentially a csv file, with a header spanning 11 rows. To load it into your R, you can use the read.csv function, with skipping the first 11 rows, like this:

cal_curve <- read.csv("/path/to/your/calcurve",
                      skip=11,
                      header = F)

The data set contains several columns that are named in the header in a style not very conveniently for R users. We therefor name the columns manually:

colnames(cal_curve) <- c("CAL BP", 
                         "14C age",
                         "Error",
                         "Delta 14C",
                         "Sigma")

Having the first component at hand, we proceed to arranging a date.

Making a date

What follows will be very simple: A ¹⁴C date consists of two components, a BP (before present in ¹⁴C years) and a standard deviation of the measurement. I will make a simple vector reflecting this structure, and since I am overly enthusiastic, I will also name the vector.

my_date <- c(4000, 25)
names(my_date) <- c("bp", "std")

Transforming the ‘curve’ to a matrix

Probably one of the most easy ways to calibrate a date is to use the calibration curve as transformation matrix. In the curve file we have information on the calibrated bp dates, the related ¹⁴C age and the error in years. Each of these value groups can be understood as probability distribution. Eg. for:

cal_curve[4500,]

##      CAL BP 14C age Error Delta 14C Sigma
## 4500   3205    3002    10      14.1   1.3

the calibrated bp year of 3205 results from a 14C age of 3002 with an error of 10, or from a normal distribution with a mean of 3002 and a standard deviation of 10 years:

years_to_show <- seq(2950,3050,by=5)
cal_curve_entry<-dnorm(years_to_show,3002,10)
plot(years_to_show,cal_curve_entry, type="l")

We can proceed with other dates (note: the libraries are only included to enhance the plot):

library(reshape2)
library(ggplot2)

years_to_show <- seq(2800,3050,by=5)
cal_curve_range <- cal_curve[4500:4540,]
cal_curve_entry_range <- apply(cal_curve_range,
                               1,
                               function(x) {
                                 dnorm(years_to_show,x[2],x[3])
                                 }
                               )
rownames(cal_curve_entry_range)<-years_to_show
cal_curve_entry_range[cal_curve_entry_range<1e-3]<-NA
dates_for_ggplot<-melt(t(cal_curve_entry_range))

m <- ggplot(dates_for_ggplot,aes(x=Var2,y=value,group=Var1))
graph <- m + 
         geom_area() + 
         facet_grid(Var1 ~ .) + 
         scale_x_continuous("BP")
show(graph)

## Warning: Removed 1540 rows containing missing values (position_stack).

Compare the calibration curve for the respective time window:

cal_curve_for_ggplot<-data.frame(bp=cal_curve_range[,1],
                                 c14=cal_curve_range[,2])

m <- ggplot(cal_curve_for_ggplot,aes(x=bp,y=c14))
graph <- m + geom_line() + coord_flip()
show(graph)

The message of this is: The calibration curve can be expressed as matrix of probabilities, mapping one ¹⁴C year to one calendric BP year. Such a matrix can be constructed like that:

years <- cal_curve[,'CAL BP']

cal_matrix <- sapply(years,function(x) {
  dnorm(x,mean = cal_curve[,'14C age'],sd = cal_curve[,'Error'])
  })

rownames(cal_matrix)<-colnames(cal_matrix)<-years

Calibration by using the calibration curve as transformation matrix

This matrix we just created can be used to transform a vector of probabilities to a calibrated vector of probabilities. We have our date:

my_date

##   bp  std 
## 4000   25

which represents a normal distributed density function with mean bp and standard deviation std. This can be expressed, with our years vector, as:

my_prob_date <- dnorm(years, 
                      mean = my_date['bp'], 
                      sd = my_date['std'])
plot(years,my_prob_date,type = 'l')

or if we zoom in to only the relevant parts

my_prob_date.window <- cbind(years,my_prob_date)
my_prob_date.window <- my_prob_date.window[my_prob_date.window[,2] > 1e-3,]
plot(my_prob_date.window,type = 'l')

Now we can just multiply our vector with the transformation matrix to get a calibrated result:

my_cal_date <- as.vector(cal_matrix %*% my_prob_date)
# normalize, so that it sums up to 1
my_cal_date <- my_cal_date / sum(my_cal_date)
plot(years, my_cal_date, type = 'l', xlim=c(4350,4600))

Compare this to a ´Bchron´ calibration:

library(Bchron)

## Loading required package: inline

plot(
  Bchron::BchronCalibrate(4000,
                          25,
                          calCurves = 'intcal13'),
  xlim=c(4350,4600)
)

Looks pretty similar, doesn’t it?

Remember: it are essentially 4 steps in total to come from a date to a calibrated one, it is not rocket science. And 1 of them represents getting the curve, two other reshaping the calibration curve and the date, while only in one step you can do the calibration itself. Simple, isn’t it?

Blog Entry Number One

Thu, 02 Jun 2016 13:23:23 +0000

To get my new website finally online, I want to add something to the blog section. Here in the future mostly stuff should be published that is related to archaeology and statistics using R.

To start I want to add a bit that helps to understand the relationship of several items within a collection of data. To be more specific, how can I explore the correlation of lets say pottery types or in this case animal species in the archaeological remains of different sites. Do specific combination occure regularily, so that it might be the case that they are functional related?

As an example I will use the animal remains from sites of the so called Funnelbeaker Culture, on which I recently published an article that is still under review. The data mostly originate from the collection in an article of Jan Steffens (2005), but there are some additions from an [unpublished (?) master thesis of Peter Imperiale] [@Imperiale2001]. You may like to download the data set.

Within this data set the question was/is, how the different animal species do correlate, and how this can be explored/visualised intuitively. The most obvious candidate was a network that display the interdependence of those species. When two species correlate positively and significant, their representation in the network should be linked by a connection.

To start this enterprise, we first load the data into our R environment:

animals <- read.csv2("tbk_animals.csv") #note that it is the "continental" csv version!

library(knitr)
kable(animals)

id	site	Hausrind	Hausschwein	Schaf.Ziege	Hund	Pferd	Rothirsch	Reh	Elch	Ur	Wildschwein	Braunbär	Dachs	Marder	Iltis	Fischotter	Wolf	Fuchs	Luchs	Wildkatze	Biber	Feldhase	Robbe	sonstige	summe
1	Alsleben	46	1	8	0	0	2	0	0	2	1	0	0	0	0	0	0	0	0	0	0	0	0	0	60
2	Basedow	87	26	15	9	29	265	71	10	25	81	2	4	0	0	0	0	0	0	0	10	0	0	0	634
3	Bebensee	43	17	2	11	6	99	20	1	47	27	0	0	0	0	3	0	0	0	2	8	0	0	0	286
4	Bistoft	213	112	209	24	0	363	17	5	22	72	0	0	2	0	43	1	0	0	0	53	1	0	0	1137
5	Dölauer Heide	105	35	44	2	22	2	1	0	0	3	0	1	0	0	0	0	0	0	0	0	0	0	1	216
6	Fuchsberg-Südensee	624	94	44	18	5	45	15	0	20	46	0	0	0	0	0	0	0	0	1	3	0	0	7	922
7	Glasow	37	11	68	0	0	5	10	0	21	3	2	2	0	0	0	1	0	0	1	0	0	0	0	161
8	Großobringen	3064	0	570	161	129	248	28	1	0	0	14	1	0	0	0	0	2	1	0	5	0	0	0	4224
9	Haldensleben	45	5	6	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	57
10	Heidmoor	891	440	139	145	35	1707	336	162	93	515	6	35	17	6	46	35	1	1	46	579	1	29	17	5282
11	Hüde I	75	46	17	35	393	301	237	307	989	793	110	6	29	6	64	12	6	2	23	781	0	0	0	4232
12	Neukirchen-Bostholm	190	148	36	4	0	12	2	0	2	4	1	2	0	0	0	0	0	0	0	1	0	0	0	402
13	Niedergörne	60	29	39	0	0	6	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	135
14	Runstedt	67	7	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	7	0	0	83
15	Schalkenburg	1508	404	792	104	24	37	67	0	12	28	3	3	6	0	0	3	9	0	3	1	1	0	49	3054
16	Siggeneben-Süd	38	41	9	3	0	16	1	0	3	6	1	0	0	0	1	2	0	0	4	0	0	8	2	135
17	Stinthorst	15	18	6	2	8	151	31	13	5	30	5	1	1	0	0	0	1	0	0	3	0	0	0	290
18	Süssau	568	113	97	12	0	18	0	0	0	3	0	0	0	0	0	0	0	0	0	0	0	2	0	813
19	Wangels FN	164	8	57	11	1	65	23	0	13	11	1	0	1	0	1	0	0	0	0	0	0	5	9	370
20	Wangels MN	151	128	32	15	0	113	48	0	9	34	0	0	0	0	0	0	0	0	0	0	0	24	72	626
21	Wolkenwehe	2586	448	168	16	32	2875	416	16	104	288	0	8	1	0	8	2	8	0	8	456	0	8	0	7448
22	Blandebjerg	423	124	37	0	1	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	586
23	Bundsø	1405	1222	359	196	0	142	3	7	7	7	3	0	14	1	3	1	0	0	0	0	0	10	0	3380
24	Fannerup	183	106	149	10	7	46	10	0	13	16	0	1	0	0	3	0	1	0	0	0	0	17	0	562
25	Lidsø	672	66	137	49	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	11	1	938
26	Lindø	1293	659	421	30	1	90	0	0	0	5	3	0	0	0	3	1	0	0	0	0	1	0	1	2508
27	Lyø	297	85	59	0	0	8	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	25	0	474
28	Sølanger	15	1	29	34	0	60	128	0	0	96	0	0	0	0	8	0	9	0	3	0	1	16	1	401
29	Spodsbjerg	1978	891	588	101	4	179	8	0	0	8	1	0	0	0	4	1	4	0	0	1	0	23	101	3892
30	Svaleklint	35	0	0	0	0	126	65	0	0	0	0	0	0	0	0	0	0	0	1	5	0	10	0	242
31	Troldebjerg	10459	11632	2721	25	75	25	25	0	1	5	0	0	0	0	5	0	5	0	1	1	0	5	0	24985
32	Löddesborg	7	0	0	3	0	65	30	0	0	0	0	0	0	0	1	1	0	0	0	2	0	33	22	164
33	Nymölla III	7	0	0	0	0	74	23	0	0	0	1	0	0	0	8	0	3	0	2	0	0	21	6	145
34	Brachnowko	24	76	107	0	0	0	0	0	0	0	0	8	0	1	0	0	80	0	0	0	0	0	0	296
35	Cmielow	1579	566	276	112	57	36	44	3	0	44	3	5	0	0	0	3	3	0	0	5	0	0	0	2736
36	Grodek	1265	453	252	41	15	19	11	6	0	60	2	1	0	0	1	0	2	0	0	0	6	0	0	2134
37	Kamin Lukawski	1675	581	402	66	9	26	28	3	11	11	3	3	0	0	0	0	0	1	0	23	3	0	0	2845
38	Kruska Podlotowa	237	0	1	7	25	8	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	279
39	Ksiaznice Wielkie	150	137	25	31	0	9	26	0	0	5	0	0	0	0	0	1	0	0	50	0	2	0	0	436
40	Mrowino	359	78	93	8	3	29	3	0	0	12	7	0	0	0	0	0	0	2	0	1	0	0	0	595
41	Pikutkowo	103	26	14	69	3	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	217
42	Podgaj	197	19	94	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	312
43	Srem	1040	216	50	17	11	1	1	0	0	4	0	0	0	0	0	0	0	0	0	0	3	0	0	1343
44	Strachow	215	76	119	4	0	0	0	0	15	0	0	0	0	0	0	0	0	0	0	0	22	0	0	451
45	Stryczowice	327	36	48	71	0	0	0	0	8	4	0	0	0	0	0	0	0	0	0	0	3	0	5	502
46	Szlachcin	56	14	11	4	43	30	45	0	0	0	1	0	0	0	0	0	1	0	0	7	0	0	0	212
47	Ustowo	483	267	76	37	46	191	59	0	60	16	4	0	0	0	0	1	1	0	1	114	0	1	0	1357
48	Zawichost-Podgorze	1017	323	214	93	40	10	10	0	0	9	2	3	0	0	0	0	0	2	0	3	2	0	0	1728
49	Makotrasy	1636	373	173	50	14	31	1	0	5	10	2	0	0	0	0	2	0	0	0	2	7	0	2	2308
50	Muldbjerg I	33	0	3	0	0	665	116	0	0	5	0	0	2	0	115	0	0	0	0	179	0	0	4	1122
51	Björnsholm	1	0	2	0	0	6	9	0	0	3	0	0	1	0	0	0	2	0	0	0	0	0	0	24
52	Saxtorp	246	78	90	1	3	4	5	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	1	429
53	Almhov - CT1	157	170	51	0	0	71	2	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	452
54	Hunneberget	85	50	36	16	0	19	27	0	0	0	0	0	1	0	0	0	1	0	1	3	0	7	2	248
55	S.Sallerup 15H	371	52	43	2	4	22	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	495
56	Elinelund 2B	314	59	14	2	0	1	0	0	0	0	0	0	0	0	1	0	0	0	1	0	0	0	1	393
57	Hyllie station	39	41	7	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	89
58	Hyllie vattentorn	40	27	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	68
59	Hotelltomten	79	68	7	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	156
60	Skumparerget	397	68	20	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	1	0	0	1	4	492
61	Anneberg	54	46	4	11	0	0	0	2	0	0	0	1	17	0	17	0	3	0	2	6	0	674	24	861

Displayed are now our sites with the NISP data of the species. For the construction of the network we now need a matrix, consisting of a row and a column for each species, filled with 1 for each situation when there is a positive significant correlation between the occurence of these both species. To archive this I used a modified snippet from the web (originally from Aleksandar Blagotić, function corstar.R), and the function corr.test from the library psych. I constructed this little function:

cornet <- function(x, y = NULL, use = "pairwise", method = "pearson", round = 3, row.labels, col.labels, ...) {
  
  require(psych)
  
  ct <- corr.test(x, y, use, method,adjust="bonferroni")    # calculate correlation
  r <- ct$r                             # get correlation coefs
  p <- ct$p                             # get p-values
  
  sig <- ifelse(p < .05, 1,0) # generate significance stars
  poscorr<-ifelse(r > 0, 1,0)
  
  m <- matrix(NA, nrow = nrow(r) , ncol = ncol(r)) # create empty matrix
  
  rlab <- if(missing(row.labels)) rownames(r) else row.labels # add row labels
  clab <- if(missing(col.labels)) {
    if(is.null(colnames(r)))
      deparse(substitute(y))
    else
      colnames(r)
  } else {
    col.labels # add column labels
  }
  
  rows <- 1:nrow(m)                     # row indices
  cols <- 1:ncol(m)                     # column indices
  
  m[rows, cols] <- sig*poscorr
  
  colnames(m) <- c( clab)           # add colnames
  rownames(m) <- c( rlab)           # add colnames
  m                                     # return matrix
}

With this at hand we can now prepare our data for the network plot:

adj <- cornet(na.omit(animals[,3:25]))

## Lade nötiges Paket: psych

## Warning in abbreviate(colnames(r), minlength = 5): abbreviate mit
## nicht-ASCII Zeichen genutzt

Second thing we need for a nice plot is the function ggnet2 from the library GGally. This library has some dependencies, especially regarding ggplot and sna, so you might have to install them first!

library(GGally)

But then:

ggnet2(adj, mode = "fruchtermanreingold", size = 24, label = rownames(adj), label.size = 3, alpha=0.8)

## Lade nötiges Paket: network

## network: Classes for Relational Data
## Version 1.13.0 created on 2015-08-31.
## copyright (c) 2005, Carter T. Butts, University of California-Irvine
##                     Mark S. Handcock, University of California -- Los Angeles
##                     David R. Hunter, Penn State University
##                     Martina Morris, University of Washington
##                     Skye Bender-deMoll, University of Washington
##  For citation information, type citation("network").
##  Type help("network-package") to get started.

## Lade nötiges Paket: sna

## sna: Tools for Social Network Analysis
## Version 2.3-2 created on 2014-01-13.
## copyright (c) 2005, Carter T. Butts, University of California-Irvine
##  For citation information, type citation("sna").
##  Type help(package="sna") to get started.

## 
## Attache Paket: 'sna'

## Das folgende Objekt ist maskiert 'package:network':
## 
##     %c%

## Lade nötiges Paket: scales

## 
## Attache Paket: 'scales'

## Die folgenden Objekte sind maskiert von 'package:psych':
## 
##     alpha, rescale

Voila! domestic species form one subnet (pig, cattle, sheep/goat), while most wild species form another subnet. There seem to be two separate spheres of interaction with the animals, indicating that there are two types of sites resp. activities: one is hunting, the other husbandry.