ecodist/ 0000755 0001751 0000144 00000000000 13131602130 011710 5 ustar hornik users ecodist/inst/ 0000755 0001751 0000144 00000000000 13131506235 012676 5 ustar hornik users ecodist/inst/CITATION 0000644 0001751 0000144 00000001100 13034761246 014032 0 ustar hornik users citHeader("To cite package ecodist in publications use:")
citEntry(entry="Article",
title = "The ecodist package for dissimilarity-based analysis of ecological data",
author = personList(as.person("Sarah C. Goslee"),
as.person("Dean L. Urban")),
journal = "Journal of Statistical Software",
year = 2007,
volume = 22,
issue = 7,
pages = "1-19",
textVersion =
paste("Goslee, S.C. and Urban, D.L. 2007.",
"The ecodist package for dissimilarity-based analysis of ecological data.",
"Journal of Statistical Software 22(7):1-19.")
)
ecodist/inst/doc/ 0000755 0001751 0000144 00000000000 13131506235 013443 5 ustar hornik users ecodist/inst/doc/dissimilarity.html 0000644 0001751 0000144 00000026523 13131506235 017227 0 ustar hornik users
Dissimilarity Cheat Sheet
Dissimilarity Cheat Sheet
Sarah Goslee
2017-07-12
Things to do with dissimilarity matrices
(ecodist functions are marked in bold)
(untested ideas marked with ?)
Relationship between two matrices |
D1 ~ D2 |
Mantel test |
mantel(D1 ~ D2) |
Relationship between two matrices given more |
D1 ~ D2 | D3 … Dn |
Partial Mantel test |
mantel(D1 ~ D2 + D3 + …) |
|
|
|
Spatial structure in one matrix |
D1 x S |
Mantel correlogram |
mgram(D1, S) |
Spatial structure in one matrix given more |
D1 | D2 … Dn x S |
Partial Mantel correlogram |
?mgram(residuals(lm(D1 ~ D2 + …)), space) |
Spatial structuce in one matrix |
D1 x S |
Multivariate correlogram |
pmgram(D1, S) |
Spatial structure in one matrix given more |
D1 | D2 … Dn x S |
Partial multivariate correlogram |
pmgram(D1, S, D2) |
|
|
|
Spatial structure in the relationship between two matrices |
D1 ~ D2 x S |
Mantel cross-correlogram |
pmgram(cbind(lower(D1), lower(D2)), S) |
Spatial structure in the relationship between two matrices given more |
D1 ~ D2 | D3 … Dn x S |
Partial Mantel cross-correlogram |
pmgram(cbind(lower(D1), lower(D2)), S, D3) |
|
|
|
Ordination of one matrix |
|
(N)MDS |
nmds(y) or pco(y) |
Ordination of one matrix given more |
|
(Partial (N)MDS |
?nmds(residuals(lm(y ~ z1 + …))) |
|
|
|
Grouping of items based on one matrix |
|
Cluster analysis |
hclust(y) |
Grouping of items based on one matrix given more |
|
Partial cluster analysis |
?hclust(residuals(lm(y ~ z1 + …))) |
Grouping of items given space |
|
Spatially-constrained cluster analysis |
NA |
|
|
|
Multiple regression |
D1 ~ D2 | D3 … Dn |
Multiple regression on distance matrices |
MRM(D1 ~ D2 + D3 + …) |
Ways to calculate dissimilarity matrices
From a site by sample matrix |
Symmetric matrix with zero diagonals |
dist(x) or bcdist(x) or distance(x) |
Things to do with cross-dissimilarity matrices
Relationship between two cross-dissimilarity matrices |
D12 ~ D34 |
Cross-Mantel test |
xmantel(D12 ~ D34) |
Relationship between two cross-dissimilarity matrices given more |
D12 ~ D34 | D56 … Dn |
Partial cross-Mantel test |
xmantel(D12 ~ D34 + D56 + …) |
|
|
|
Spatial structure in one cross-dissimilarity matrix |
D12 x S |
Cross-Mantel correlogram |
xmgram(D12, spaceX) |
Spatial structure in one cross-dissimilarity matrix given more |
D12 | D34 … Dn x S |
Partial cross-Mantel correlogram |
?xmgram(residuals(lm(D12 ~ D34 + …)), spaceX) |
Ways to calculate cross-dissimilarity matrices
From 2 site by sample matrixes for the same sites and samples (e.g. different years) |
nonsymmetric matrix with nonzero diagonals |
xdistance(x, y) |
ecodist/inst/doc/dissimilarity.Rmd 0000644 0001751 0000144 00000006216 13131456337 017011 0 ustar hornik users ---
title: "Dissimilarity Cheat Sheet"
author: "Sarah Goslee"
date: "2017-07-12"
output: rmarkdown::html_vignette
vignette: >
%\VignetteIndexEntry{Dissimilarity Cheat Sheet}
%\VignetteEngine{knitr::rmarkdown}
---
**Things to do with dissimilarity matrices**
_(ecodist functions are marked in **bold**)_
_(untested ideas marked with ?)_
Description | Notation | Name | R function
------------|----------|------|-----------
Relationship between two matrices | D1 ~ D2 | Mantel test | **mantel**(D1 ~ D2)
Relationship between two matrices given more | D1 ~ D2 | D3 ... Dn | Partial Mantel test | **mantel**(D1 ~ D2 + D3 + ...)
|||
Spatial structure in one matrix | D1 x S | Mantel correlogram | **mgram**(D1, S)
Spatial structure in one matrix given more | D1 | D2 ... Dn x S | Partial Mantel correlogram | **?mgram**(residuals(lm(D1 ~ D2 + ...)), space)
Spatial structuce in one matrix | D1 x S | Multivariate correlogram | **pmgram**(D1, S)
Spatial structure in one matrix given more | D1 | D2 ... Dn x S | Partial multivariate correlogram | **pmgram**(D1, S, D2)
|||
Spatial structure in the relationship between two matrices | D1 ~ D2 x S | Mantel cross-correlogram | **pmgram**(cbind(lower(D1), lower(D2)), S)
Spatial structure in the relationship between two matrices given more | D1 ~ D2 | D3 ... Dn x S | Partial Mantel cross-correlogram | **pmgram**(cbind(lower(D1), lower(D2)), S, D3)
|||
Ordination of one matrix | | (N)MDS | **nmds**(y) or **pco**(y)
Ordination of one matrix given more | | (Partial (N)MDS | **?nmds**(residuals(lm(y ~ z1 + ...)))
|||
Grouping of items based on one matrix | | Cluster analysis | hclust(y)
Grouping of items based on one matrix given more | | Partial cluster analysis | ?hclust(residuals(lm(y ~ z1 + ...)))
Grouping of items given space | | Spatially-constrained cluster analysis | NA
|||
Multiple regression | D1 ~ D2 | D3 ... Dn | Multiple regression on distance matrices | **MRM**(D1 ~ D2 + D3 + ...)
**Ways to calculate dissimilarity matrices**
Description | Result | R function
------------|--------|-----------
From a site by sample matrix | Symmetric matrix with zero diagonals | dist(x) or **bcdist**(x) or **distance**(x)
-----------------------------
**Things to do with cross-dissimilarity matrices**
Description | Notation | Name | R function
------------|----------|------|-----------
Relationship between two cross-dissimilarity matrices | D12 ~ D34 | Cross-Mantel test | **xmantel**(D12 ~ D34)
Relationship between two cross-dissimilarity matrices given more | D12 ~ D34 | D56 ... Dn | Partial cross-Mantel test | **xmantel**(D12 ~ D34 + D56 + ...)
|||
Spatial structure in one cross-dissimilarity matrix | D12 x S | Cross-Mantel correlogram | **xmgram**(D12, spaceX)
Spatial structure in one cross-dissimilarity matrix given more | D12 | D34 ... Dn x S | Partial cross-Mantel correlogram | **?xmgram**(residuals(lm(D12 ~ D34 + ...)), spaceX)
**Ways to calculate cross-dissimilarity matrices**
Source | Result | R function
-------|--------|-----------
From 2 site by sample matrixes for the same sites and samples (e.g. different years) | nonsymmetric matrix with nonzero diagonals | **xdistance**(x, y)
ecodist/tests/ 0000755 0001751 0000144 00000000000 13127510434 013064 5 ustar hornik users ecodist/tests/testthat.R 0000644 0001751 0000144 00000000050 13122530634 015041 0 ustar hornik users library(testthat)
test_check("ecodist")
ecodist/tests/testthat/ 0000755 0001751 0000144 00000000000 13131602130 014712 5 ustar hornik users ecodist/tests/testthat/test-crosstab.R 0000644 0001751 0000144 00000011514 13122536371 017651 0 ustar hornik users context("crosstab")
test_that("different sizes and shapes of data", {
expect_equal( crosstab(rep(letters[1:3], 4), rep(1:4, each=3)),
structure(list(X1 = c(1, 1, 1), X2 = c(1, 1, 1), X3 = c(1, 1, 1), X4 = c(1, 1, 1)),
.Names = c("X1", "X2", "X3", "X4"), row.names = c("a", "b", "c"), class = "data.frame") )
expect_equal( crosstab(rep(letters[1:3], 4), rep(1:4, each=3), allrows=letters[1:5]),
structure(list(X1 = c(1, 1, 1, 0, 0), X2 = c(1, 1, 1, 0, 0), X3 = c(1, 1, 1, 0, 0),
X4 = c(1, 1, 1, 0, 0)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c", "d", "e"), class = "data.frame") )
expect_equal( crosstab(rep(letters[1:3], 4), rep(1:4, each=3), allrows=letters[1:5], allcols=1:5),
structure(list(X1 = c(1, 1, 1, 0, 0), X2 = c(1, 1, 1, 0, 0), X3 = c(1, 1, 1, 0, 0),
X4 = c(1, 1, 1, 0, 0), X5 = c(0, 0, 0, 0, 0)), .Names = c("X1", "X2", "X3", "X4", "X5"),
row.names = c("a", "b", "c", "d", "e"), class = "data.frame") )
expect_equal( crosstab(rep(letters[1], 12), rep(1:4, each=3), allrows=letters[1:5], allcols=1:5),
structure(list(X1 = c(3, 0, 0, 0, 0), X2 = c(3, 0, 0, 0, 0), X3 = c(3, 0, 0, 0, 0),
X4 = c(3, 0, 0, 0, 0), X5 = c(0, 0, 0, 0, 0)), .Names = c("X1", "X2", "X3", "X4", "X5"),
row.names = c("a", "b", "c", "d", "e"), class = "data.frame") )
expect_equal( crosstab(rep(letters[1], 12), rep(1:4, each=3), allcols=1:5),
structure(list(X1 = 3, X2 = 3, X3 = 3, X4 = 3, X5 = 0),
.Names = c("X1", "X2", "X3", "X4", "X5"), row.names = "a", class = "data.frame") )
expect_equal( crosstab(rep(letters[1:3], 4), rep(1, each=12), allrows=letters[1:5], allcols=1:5),
structure(list(X1 = c(4, 4, 4, 0, 0), X2 = c(0, 0, 0, 0, 0), X3 = c(0, 0, 0, 0, 0),
X4 = c(0, 0, 0, 0, 0), X5 = c(0, 0, 0, 0, 0)),
.Names = c("X1", "X2", "X3", "X4", "X5"), row.names = c("a", "b", "c", "d", "e"), class = "data.frame") )
expect_equal( crosstab(rep(letters[1:3], 4), rep(1, each=12), allrows=letters[1:5]),
structure(list(X1 = c(4, 4, 4, 0, 0)), .Names = "X1",
row.names = c("a", "b", "c", "d", "e"), class = "data.frame") )
expect_equal( crosstab(rep(1, each=12), rep(letters[1:3], 4), allcols=letters[1:5]),
structure(list(a = 4, b = 4, c = 4, d = 0, e = 0),
.Names = c("a", "b", "c", "d", "e"), row.names = "1", class = "data.frame") )
expect_equal( crosstab(rep(letters[1:3], 4), rep(1, each=12), allcols=1:5),
structure(list(X1 = c(4, 4, 4), X2 = c(0, 0, 0), X3 = c(0, 0, 0), X4 = c(0, 0, 0),
X5 = c(0, 0, 0)), .Names = c("X1", "X2", "X3", "X4", "X5"),
row.names = c("a", "b", "c"), class = "data.frame") )
})
test_that("data interface", {
x <- data.frame(a = rep(letters[1:3], 4), b = rep(1:4, each=3), c = seq_len(12))
expect_equal( crosstab(a, b, data=x),
structure(list(X1 = c(1, 1, 1), X2 = c(1, 1, 1), X3 = c(1, 1, 1),
X4 = c(1, 1, 1)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
})
test_that("function options", {
x <- data.frame(a = rep(letters[1:3], 8), b = rep(1:4, each=6), c = rep(1:12, times=2))
expect_equal( crosstab(a, b, c, data=x, type="sum"),
structure(list(X1 = c(5, 7, 9), X2 = c(17, 19, 21), X3 = c(5, 7, 9),
X4 = c(17, 19, 21)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
expect_equal( crosstab(a, b, c, data=x, type="min"),
structure(list(X1 = c(1, 2, 3), X2 = c(7, 8, 9), X3 = c(1, 2, 3),
X4 = c(7, 8, 9)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
expect_equal( crosstab(a, b, c, data=x, type="max"),
structure(list(X1 = c(4, 5, 6), X2 = c(10, 11, 12), X3 = c(4, 5, 6),
X4 = c(10, 11, 12)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
expect_equal( crosstab(a, b, c, data=x, type="mean"),
structure(list(X1 = c(2.5, 3.5, 4.5), X2 = c(8.5, 9.5, 10.5), X3 = c(2.5, 3.5, 4.5),
X4 = c(8.5, 9.5, 10.5)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
expect_equal( crosstab(a, b, c, data=x, type="count"),
structure(list(X1 = c(2, 2, 2), X2 = c(2, 2, 2), X3 = c(2, 2, 2),
X4 = c(2, 2, 2)), .Names = c("X1", "X2", "X3", "X4"),
row.names = c("a", "b", "c"), class = "data.frame") )
})
ecodist/tests/testthat/test-mantel.R 0000644 0001751 0000144 00000000414 13130732366 017307 0 ustar hornik users context("mantel")
test_that("mantel r is the correlation", {
set.seed(888)
x <- runif(110)
y <- runif(110)
x <- dist(x)
y <- dist(y)
expect_equal(as.vector(mantel(y ~ x, nperm=0, nboot=0))[1], cor(x, y))
})
ecodist/tests/testthat/test-MRM.R 0000644 0001751 0000144 00000000432 13130724024 016452 0 ustar hornik users context("MRM")
test_that("MRM coefficients match lm", {
set.seed(888)
y <- runif(11175)
x1 <- runif(11175)
x2 <- runif(11175)
expect_equal(as.vector(MRM(y ~ x1 + x2, nperm=0)$coef[,1]), as.vector(coefficients(lm(y ~ x1 + x2))))
})
ecodist/tests/testthat/test-distance.R 0000644 0001751 0000144 00000001464 13130725007 017621 0 ustar hornik users context("distance")
test_that("Euclidean distance is correct", {
set.seed(888)
x <- matrix(runif(50), ncol=5)
d.ecodist <- distance(x, "euclidean")
d.base <- dist(x)
expect_equal(attributes(d.ecodist), attributes(d.base)[names(attributes(d.base)) != "call"])
expect_equal(as.vector(d.ecodist), as.vector(d.base))
})
test_that("Bray-Curtis distance is correct", {
set.seed(888)
x <- matrix(runif(50), ncol=5)
expect_equal(distance(x, "bray"), bcdist(x))
})
test_that("Mahalanobis icov is correct", {
set.seed(888)
x <- matrix(runif(50), ncol=5)
x.md <- full(distance(x, "mahal"))
sub.md <- full(distance(x[1:5, ], "mahal", icov=cov(x)))
expect_equal(x.md[1:5, 1:5], sub.md)
})
ecodist/tests/testthat/test-mgroup.R 0000644 0001751 0000144 00000001371 13130730236 017335 0 ustar hornik users context("mgroup")
test_that("Mantel r is correct", {
set.seed(888)
x <- runif(110)
groups.char <- sample(letters[1:5], size=length(x), replace=TRUE)
x.d <- dist(x)
groups.factor <- factor(groups.char)
groups.numeric <- as.numeric(groups.factor)
groups.d <- dist(groups.numeric)
groups.d[groups.d > 0] <- 1
expect_equal(as.vector(mantel(x.d ~ groups.d, nperm=0, nboot=0))[1], mgroup(x.d, groups.char, nperm=0)[1, 2])
expect_equal(as.vector(mantel(x.d ~ groups.d, nperm=0, nboot=0))[1], mgroup(x.d, groups.factor, nperm=0)[1, 2])
expect_equal(as.vector(mantel(x.d ~ groups.d, nperm=0, nboot=0))[1], mgroup(x.d, groups.numeric, nperm=0)[1, 2])
})
ecodist/src/ 0000755 0001751 0000144 00000000000 13131506235 012510 5 ustar hornik users ecodist/src/Makevars 0000644 0001751 0000144 00000000040 13131506235 014176 0 ustar hornik users PKG_LIBS=$(BLAS_LIBS) $(FLIBS)
ecodist/src/ecodist.c 0000644 0001751 0000144 00000045243 13131506235 014316 0 ustar hornik users #include
#include
#include /* for dgemm */
#define RANDIN GetRNGstate()
#define RANDOUT PutRNGstate()
#define UNIF unif_rand()
void bootstrap(double *x, double *y, int *n, int *xlen, int *nboot, double *pboot, double *bootcor, int *rarray, int *rmat, double *xdif, double *ydif)
{
int i, j, k, l;
double r;
double nsamp;
double xmean, ymean;
double xsum;
double xxsum, yysum;
/* Set random seed using Splus function */
RANDIN;
for(i = 0; i < *nboot; i++) {
/* Set up rarray. */
for(j = 0; j < *n; j++) {
r = UNIF;
if(r > *pboot)
rarray[j] = 0;
else rarray[j] = 1;
}
/* Turn rarray into a lower-triangular sampling matrix. */
/* 1 means include, 0 means omit. */
l = 0;
for(j = 1; j < *n; j++) {
for(k = 0; k < j; k++) {
if(rarray[j] == 0 || rarray[k] == 0)
rmat[l] = 0;
else rmat[l] = 1;
l++;
}
}
nsamp = 0;
for(j = 0; j < *xlen; j++) {
nsamp += rmat[j];
}
/* Calculate means for x and y. */
xmean = 0;
ymean = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xmean += x[j];
ymean += y[j];
}
}
xmean = xmean/nsamp;
ymean = ymean/nsamp;
/* Calculate deviations for x and y. */
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xdif[j] = x[j] - xmean;
ydif[j] = y[j] - ymean;
}
else {
xdif[j] = 0;
ydif[j] = 0;
}
}
xsum = 0;
xxsum = 0;
yysum = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xsum += (xdif[j] * ydif[j]);
xxsum += (xdif[j] * xdif[j]);
yysum += (ydif[j] * ydif[j]);
}
}
bootcor[i] = (xsum) / sqrt(xxsum * yysum);
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void permute(double *x, double *y, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[0] = cumsum / *xlen;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x and take lower triangle. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[i] = cumsum / *xlen;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void permpart(double *hmat, double *bmat, double *omat, double *y, double *xcor, double *ycor, int *n, int *ncol, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
double bsum;
double w1, w2;
int temp;
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[0] = cumsum / *xlen;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert y to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = y[m];
tmat[l * *n + k] = y[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder y and take lower triangle. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
y[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate residuals for y */
/* Calculate bmat */
for(k = 0; k < *ncol; k++) {
bmat[k] = 0;
}
for(k = 0; k < *ncol; k++) {
for(l = 0; l < *xlen; l++) {
bmat[k] = bmat[k] + hmat[l * *ncol + k] * y[l];
}
}
/* Calculate ycor (residuals) */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
bsum = 0;
for(l = 0; l < *ncol; l++) {
bsum = bsum + bmat[l] * omat[l * *xlen + k];
}
ycor[k] = y[k] - bsum;
}
/* Standardize residuals so z = r */
w1 = 0;
w2 = 0;
for(k = 0; k < *xlen; k++) {
w1 = w1 + ycor[k];
w2 = w2 + ycor[k] * ycor[k];
}
w1 = w1 / *xlen;
w2 = sqrt(w2 / *xlen - w1 * w1);
for(k = 0; k < *xlen; k++) {
ycor[k] = (ycor[k] - w1) / w2;
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[i] = cumsum / *xlen;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void bcdistc(double *x, int *pnrow, int *pncol, double *dist)
{
int i, j, k, l;
int nrow, ncol;
double sumi, sumj;
double minsum;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(i = 0; i < (nrow - 1); i++) {
for(j = (i + 1); j < (nrow); j++) {
minsum = 0;
sumi = 0;
sumj = 0;
for(k = 0; k < ncol; k++) {
if(x[i * ncol + k] < x[j * ncol + k])
minsum += x[i * ncol + k];
else
minsum += x[j * ncol + k];
sumi += x[i * ncol + k];
sumj += x[j * ncol + k];
}
if((sumi + sumj) == 0)
dist[l] = 0;
else
dist[l] = (1 - (2 * minsum) / (sumi + sumj));
l++;
}
}
}
void newpermone(double *x, int *dclass, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(dclass[k] == 0) {
cumsum += x[k];
}
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(dclass[k] == 0) {
cumsum += x[k];
}
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void newpermtwo(double *x, double *y, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
float naval = -9999;
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(x[k] != naval) {
cumsum += x[k] * y[k];
}
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(x[k] != naval) {
cumsum += x[k] * y[k];
}
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void psum(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
dist[l] = thisval + thatval;
l++;
}
}
}
}
void pdiff(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
dist[l] = thisval - thatval;
l++;
}
}
}
}
void jpres(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval > 0) & (thatval > 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jabs(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval == 0) & (thatval == 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jfirst(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval > 0) & (thatval == 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jsec(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval == 0) & (thatval > 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void mrmperm(double *x, double *y, int *p, int *nd, int *n, int *nperm, double *r2all, double *ball, double *fall, double *tmat, int *rarray, double *XX, double *XY, double *YY, double *b)
{
int i, k, l;
int m;
int temp;
double SSE=0.0, SSTO=0.0, SSR=0.0;
double r2=0, f=0;
double btemp=0.0;
int bcount = 0;
char *transt = "T", *transn = "N";
double one = 1.0, zero = 0.0;
int onei = 1;
/* Set random seed using Splus function */
RANDIN;
/* Start permutation routine */
for(i = 0; i < *nperm; i++) {
/* first do the unpermuted values */
/* F77_CALL(dgemm)(transa, transb, &ncx, &ncy, &nrx, &one,
x, &nrx, y, &nry, &zero, z, &ncx); */
/* take crossproduct t(X) %*% Y - WORKS */
F77_CALL(dgemm)(transt, transn,
p, &onei, nd,
&one, x, nd, y, nd,
&zero, XY, p);
/* take crossproduct t(Y) %*% (Y) - WORKS */
F77_CALL(dgemm)(transt, transn,
&onei, &onei, nd,
&one, y, nd, y, nd,
&zero, YY, &onei);
/* calculate regression coefficients XX %*% XY - WORKS */
F77_CALL(dgemm)(transn, transn,
p, &onei, p,
&one, XX, p, XY, p,
&zero, b, p);
/* calculate regression components - WORKS */
F77_CALL(dgemm)(transt, transn,
&onei, &onei, p,
&one, b, p, XY, p,
&zero, &btemp, &onei);
/* SSE - WORKS */
SSE = YY[0] - btemp;
/* SSTO - WORKS */
SSTO = 0;
for(k = 0; k < *nd; k++) {
SSTO = SSTO + y[k];
}
SSTO = YY[0] - (SSTO * SSTO) / *nd;
SSR = SSTO - SSE;
/* calculate R2 - WORKS */
r2 = 1 - SSE / SSTO;
/* calculate F* - WORKS */
f = (SSR / (*p - 1)) / (SSE / (*nd - *p));
r2all[i] = r2;
fall[i] = f;
/* calculate pseudo-t for regression coefficients - WORKS*/
/* b / sqrt(1 - R2) */
for(k=0; k<*p; k++) {
ball[bcount] = b[k] / sqrt(1 - r2);
bcount++;
}
/* permute Y */
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert y to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = y[m];
tmat[l * *n + k] = y[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder y. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
y[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void xpermute(double *x, double *y, int *nrow, int *ncol, int *xlen, int *nperm, double *zstats, double *newx, int *rarray, int *carray)
{
int i, k, l, m;
double cumsum;
int temp;
int newk, newl;
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
cumsum = 0;
/* Set up rarray. */
for(k = 0; k < *nrow; k++) {
rarray[k] = k;
}
/* Set up carray. */
for(k = 0; k < *ncol; k++) {
carray[k] = k;
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*nrow - 1); k++) {
l = *nrow - k - 1;
m = (long)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Randomize carray using an Splus function. */
for(k = 0; k < (*ncol - 1); k++) {
l = *ncol - k - 1;
m = (long)((float)l * UNIF);
if(m > l) m = l;
temp = carray[l];
carray[l] = carray[m];
carray[m] = temp;
}
/* Reorder x. */
/* loop thru the rows
* swapping each value with its replacement */
for(k = 0; k < *nrow; k++) {
}
for(l = 0; l < *nrow; l++) {
newl = rarray[l];
if(newl != l) {
for(k = 0; k < *ncol; k++) {
newx[k*(*nrow) + l] = x[k*(*nrow) + newl];
}
}
}
/* now x has the original info and newx has swapped rows */
/* go thru x and set x identical to newx before swapping columns */
for(k = 0; k < *ncol; k++) {
for(l = 0; l < *nrow; l++) {
x[k*(*nrow) + l] = newx[k*(*nrow) + l];
}
}
/* loop thru the columns
* swapping each value with its replacement */
for(k = 0; k < *ncol; k++) {
}
for(k = 0; k < *ncol; k++) {
newk = carray[k];
if(newk != k) {
for(l = 0; l < *nrow; l++) {
newx[k*(*nrow) + l] = x[newk*(*nrow) + l];
}
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void xpermpart(double *hmat, double *y, double *xcor, double *ycor, int *nrow, int *ncol, int *xlen, int *nperm, double *zstats, double *newy, int *rarray, int *carray)
{
int i, k, l, m;
double cumsum;
int temp;
int newk, newl;
/* Set random seed using Splus function */
RANDIN;
/* Calculate residuals for y */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
for(l = 0; l < *xlen; l++) {
ycor[k] = ycor[k] + hmat[k * *xlen + l] * y[l];
}
}
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *nrow; k++) {
rarray[k] = k;
}
/* Set up carray. */
for(k = 0; k < *ncol; k++) {
carray[k] = k;
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*nrow - 1); k++) {
l = *nrow - k - 1;
m = (long)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Randomize carray using an Splus function. */
for(k = 0; k < (*ncol - 1); k++) {
l = *ncol - k - 1;
m = (long)((float)l * UNIF);
if(m > l) m = l;
temp = carray[l];
carray[l] = carray[m];
carray[m] = temp;
}
/* Reorder y. */
/* loop thru the rows
* swapping each value with its replacement */
for(k = 0; k < *nrow; k++) {
}
for(l = 0; l < *nrow; l++) {
newl = rarray[l];
if(newl != l) {
for(k = 0; k < *ncol; k++) {
newy[k*(*nrow) + l] = y[k*(*nrow) + newl];
}
}
}
/* now y has the original info and newy has swapped rows */
/* go thru y and set y identical to newy before swapping columns */
for(k = 0; k < *ncol; k++) {
for(l = 0; l < *nrow; l++) {
y[k*(*nrow) + l] = newy[k*(*nrow) + l];
}
}
/* loop thru the columns
* swapping each value with its replacement */
for(k = 0; k < *ncol; k++) {
}
for(k = 0; k < *ncol; k++) {
newk = carray[k];
if(newk != k) {
for(l = 0; l < *nrow; l++) {
newy[k*(*nrow) + l] = y[newk*(*nrow) + l];
}
}
}
/* Calculate residuals for y */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
for(l = 0; l < *xlen; l++) {
ycor[k] = ycor[k] + hmat[k * *xlen + l] * y[l];
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
ecodist/src/init.c 0000644 0001751 0000144 00000004224 13131506235 013621 0 ustar hornik users #include // for NULL
#include
/* .C calls */
extern void bcdistc(void *, void *, void *, void *);
extern void bootstrap(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void jabs(void *, void *, void *, void *);
extern void jfirst(void *, void *, void *, void *);
extern void jpres(void *, void *, void *, void *);
extern void jsec(void *, void *, void *, void *);
extern void mrmperm(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void newpermone(void *, void *, void *, void *, void *, void *, void *, void *);
extern void newpermtwo(void *, void *, void *, void *, void *, void *, void *, void *);
extern void pdiff(void *, void *, void *, void *);
extern void permpart(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void permute(void *, void *, void *, void *, void *, void *, void *, void *);
extern void psum(void *, void *, void *, void *);
extern void xpermute(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void xpermpart(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
static const R_CMethodDef CEntries[] = {
{"bcdistc", (DL_FUNC) &bcdistc, 4},
{"bootstrap", (DL_FUNC) &bootstrap, 11},
{"jabs", (DL_FUNC) &jabs, 4},
{"jfirst", (DL_FUNC) &jfirst, 4},
{"jpres", (DL_FUNC) &jpres, 4},
{"jsec", (DL_FUNC) &jsec, 4},
{"mrmperm", (DL_FUNC) &mrmperm, 15},
{"newpermone", (DL_FUNC) &newpermone, 8},
{"newpermtwo", (DL_FUNC) &newpermtwo, 8},
{"pdiff", (DL_FUNC) &pdiff, 4},
{"permpart", (DL_FUNC) &permpart, 13},
{"permute", (DL_FUNC) &permute, 8},
{"psum", (DL_FUNC) &psum, 4},
{"xpermute", (DL_FUNC) &xpermute, 10},
{"xpermpart", (DL_FUNC) &xpermpart, 12},
{NULL, NULL, 0}
};
void R_init_ecodist(DllInfo *dll)
{
R_registerRoutines(dll, CEntries, NULL, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
}
ecodist/NAMESPACE 0000644 0001751 0000144 00000000763 13131451365 013151 0 ustar hornik users ## Functions
export(bcdist, distance, fixdmat)
export(mantel, mgroup, mgram, pmgram, MRM)
export(cor2m, corgen, crosstab, full, lower)
export(pco, nmds, nmds.min, min.nmds, vf, addord)
export(plot.vf, plot.mgram, plot.nmds, residuals.mgram)
export(xdistance, xmantel, xmgram)
## import for S3
import(stats, graphics)
## S3 methods
S3method(min, nmds)
S3method(plot, nmds)
S3method(plot, vf)
S3method(plot, mgram)
S3method(residuals, mgram)
## Compiled code
useDynLib(ecodist, .registration = TRUE)
ecodist/data/ 0000755 0001751 0000144 00000000000 13130732142 012627 5 ustar hornik users ecodist/data/z.no.rda 0000644 0001751 0000144 00000001103 13131506235 014201 0 ustar hornik users r0b```b`f@&`d`aqj 4P!ٿuT:GǁW&*:|=n