├── tests ├── test-all.R └── testthat │ ├── test-fitRF.R │ ├── test-fitIMC.R │ ├── test-alienData.R │ ├── test-fitGLM.R │ └── test-fitKNN.R ├── data ├── galPara.rda └── salixGal.rda ├── vignettes ├── adat_gp.RDS ├── adat_sg.RDS └── Ex_salix_galler_parasitoids.Rmd ├── R ├── alien.R ├── print.alienFit.R ├── data.R ├── tjur.R ├── rsquare.R ├── logLik.alienFit.R ├── PEM.build.alienData.R ├── RcppExports.R ├── fitRF.R ├── polyTrait.R ├── fitGLM.R ├── fitPNB.R ├── fitIMC.R ├── alienData.R └── fitKNN.R ├── man ├── alien.Rd ├── salixGal.Rd ├── tjur.Rd ├── logLik.alienFit.Rd ├── rsquare.Rd ├── getNull.Rd ├── fitRF.Rd ├── PEM.build.alienData.Rd ├── polyTrait.Rd ├── alienData.Rd ├── fitGLM.Rd ├── fitPNB.Rd ├── fitIMC.Rd ├── webFromNicheModel.Rd └── fitKNN.Rd ├── .Rbuildignore ├── src ├── Makevars ├── Makevars.win ├── getNull.cpp ├── webFromNicheModel.cpp └── RcppExports.cpp ├── .travis.yml ├── .gitignore ├── NAMESPACE ├── Makefile ├── LICENSE ├── appveyor.yml ├── CONTRIBUTING ├── DESCRIPTION └── README.md /tests/test-all.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library("alien") 3 | test_check("alien") 4 | -------------------------------------------------------------------------------- /data/galPara.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheoreticalEcosystemEcology/alien/HEAD/data/galPara.rda -------------------------------------------------------------------------------- /data/salixGal.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheoreticalEcosystemEcology/alien/HEAD/data/salixGal.rda -------------------------------------------------------------------------------- /vignettes/adat_gp.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheoreticalEcosystemEcology/alien/HEAD/vignettes/adat_gp.RDS -------------------------------------------------------------------------------- /vignettes/adat_sg.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheoreticalEcosystemEcology/alien/HEAD/vignettes/adat_sg.RDS -------------------------------------------------------------------------------- /R/alien.R: -------------------------------------------------------------------------------- 1 | #' alien 2 | #' 3 | #' @name alien 4 | #' @docType package 5 | #' @description This should predict interactions! 6 | #' @useDynLib alien 7 | #' @importFrom stats runif predict 8 | NULL 9 | -------------------------------------------------------------------------------- /man/alien.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/alien.R 3 | \docType{package} 4 | \name{alien} 5 | \alias{alien} 6 | \title{alien} 7 | \description{ 8 | This should predict interactions! 9 | } 10 | -------------------------------------------------------------------------------- /R/print.alienFit.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | print.alienFit <- function(x, ...){ 3 | baseAttr <- attributes(x) 4 | attributes(x) <- NULL 5 | 6 | attributes(x) <- list(dim = baseAttr$dim, 7 | dimnames = baseAttr$dimnames) 8 | 9 | print(x) 10 | } 11 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^.*\.Rproj$ 4 | ^appveyor\.yml$ 5 | ^\.travis\.yml$ 6 | ^\.gitignore 7 | ^Makefile 8 | ^src/Makevars\.local$ 9 | ^pkg2date\.R 10 | ^README\.rmd 11 | ^record* 12 | ^inst/*.R 13 | ^CONTRIBUTING 14 | ^\.DS_Store 15 | ^beforeInstall.sh 16 | ^tmp -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Salix - Galler - parasitoids data 2 | #' 3 | #' The Salix - galler - parasitoids data was originally published by Kopelke et al. (2017) for which additional information on phylogeny was added. The full data was used to perform the analysis in Wooton et al. (2021). 4 | #' 5 | #' @docType data 6 | #' @keywords datasets 7 | #' @name salixGal 8 | #' @usage data(salixGal) 9 | #' @usage data(galPara) 10 | #' 11 | #' @format an object of class alienData 12 | #' 13 | #' @references 14 | #' 15 | NULL -------------------------------------------------------------------------------- /man/salixGal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{salixGal} 5 | \alias{salixGal} 6 | \title{Salix - Galler - parasitoids data} 7 | \format{ 8 | an object of class alienData 9 | } 10 | \usage{ 11 | data(salixGal) 12 | 13 | data(galPara) 14 | } 15 | \description{ 16 | The Salix - galler - parasitoids data was originally published by Kopelke et al. (2017) for which additional information on phylogeny was added. The full data was used to perform the analysis in Wooton et al. (2021). 17 | } 18 | \references{ 19 | 20 | } 21 | \keyword{datasets} 22 | -------------------------------------------------------------------------------- /man/tjur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tjur.R 3 | \name{tjur} 4 | \alias{tjur} 5 | \title{Calculate Tjur's D} 6 | \usage{ 7 | tjur(object) 8 | } 9 | \arguments{ 10 | \item{object}{An object of class \code{alienfit}.} 11 | } 12 | \value{ 13 | A numerical value presenting a Tjur's D. 14 | } 15 | \description{ 16 | Calculate Tjur's D for an object of class \code{alienfit}. 17 | } 18 | \details{ 19 | This function is designed for presence-absence data and will send an error when other data type are used. 20 | } 21 | \author{ 22 | F. Guillaume Blanchet and Kate Wootton 23 | } 24 | \keyword{univar} 25 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | 2 | ## With R 3.1.0 or later, you can uncomment the following line to tell R to 3 | ## enable compilation with C++11 (where available) 4 | ## 5 | ## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider 6 | ## availability of the package we do not yet enforce this here. It is however 7 | ## recommended for client packages to set it. 8 | ## 9 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 10 | ## support within Armadillo prefers / requires it 11 | CXX_STD = CXX11 12 | 13 | PKG_CXXFLAGS = $(SHLIB_CXXFLAGS) 14 | PKG_LIBS = $(SHLIB_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 15 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | 2 | ## With R 3.1.0 or later, you can uncomment the following line to tell R to 3 | ## enable compilation with C++11 (where available) 4 | ## 5 | ## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider 6 | ## availability of the package we do not yet enforce this here. It is however 7 | ## recommended for client packages to set it. 8 | ## 9 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 10 | ## support within Armadillo prefers / requires it 11 | CXX_STD = CXX11 12 | 13 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 14 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | warnings_are_errors: false 3 | sudo: required 4 | cache: packages 5 | notifications: 6 | email: 7 | recipients: 8 | - Guillaume.Blanchet@USherbrooke.ca 9 | on_success: never 10 | 11 | matrix: 12 | include: 13 | - os: osx 14 | osx_image: xcode12.2 15 | r: release 16 | env: NOT_CRAN=true 17 | - os: linux 18 | dist: bionic 19 | r: devel 20 | env: NOT_CRAN=false 21 | addons: 22 | apt: 23 | packages: 24 | - libgsl-dev 25 | r_github_packages: 26 | - r-lib/covr 27 | after_success: 28 | - Rscript -e 'covr::codecov()' 29 | -------------------------------------------------------------------------------- /man/logLik.alienFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/logLik.alienFit.R 3 | \name{logLik.alienFit} 4 | \alias{logLik.alienFit} 5 | \title{Extract Log-Likelihood for \code{alienfit} object} 6 | \usage{ 7 | \method{logLik}{alienFit}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{an object of class \code{alienfit}.} 11 | 12 | \item{\dots}{Some methods for this function require additional arguments.} 13 | } 14 | \value{ 15 | A numerical value presenting a log-likelihood. 16 | } 17 | \description{ 18 | Calculate a Log-Likelihood for and object class \code{alienfit} 19 | } 20 | \details{ 21 | For objects of class \code{fitKNN}, log-likelihoods are only available for presence-absence data. An error will be sent otherwise. 22 | } 23 | \author{ 24 | F. Guillaume Blanchet and Dominique Gravel 25 | } 26 | \keyword{univar} 27 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | Makefile 3 | .Rhistory 4 | .Rapp.history 5 | # Session Data files 6 | .RData 7 | # Example code in package build process 8 | *-Ex.R 9 | # Output files from R CMD build 10 | /*.tar.gz 11 | # Output files from R CMD check 12 | /*.Rcheck/ 13 | # RStudio files 14 | .Rproj.user/ 15 | # produced vignettes 16 | vignettes/*.html 17 | vignettes/*.pdf 18 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 19 | .httr-oauth 20 | # knitr and R markdown default cache directories 21 | /*_cache/ 22 | /cache/ 23 | *.Rproj 24 | # tmp files 25 | tmp/ 26 | 27 | # Rcpp files 28 | src/*.o 29 | src/*.so 30 | src/*.dll 31 | src/*.rds 32 | 33 | 34 | # Temporary files created by R markdown 35 | *.utf8.md 36 | *.knit.md 37 | 38 | 39 | ## MacOs store files 40 | .DS_Store 41 | 42 | ## for the makefiles 43 | record_updates.txt 44 | .Rproj.user 45 | inst/doc 46 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(logLik,alienFit) 4 | S3method(print,alienFit) 5 | export(alienData) 6 | export(fitGLM) 7 | export(fitIMC) 8 | export(fitKNN) 9 | export(fitPNB) 10 | export(fitRF) 11 | export(getNull) 12 | export(getNullOne) 13 | export(polyTrait) 14 | export(prodNorm) 15 | export(rsquare) 16 | export(tjur) 17 | export(webFromNicheModel) 18 | importFrom(GenSA,GenSA) 19 | importFrom(MPSEM,PEM.build) 20 | importFrom(Rcpp,evalCpp) 21 | importFrom(ape,cophenetic.phylo) 22 | importFrom(lme4,glmer) 23 | importFrom(picante,pblm) 24 | importFrom(randomForest,randomForest) 25 | importFrom(stats,as.dist) 26 | importFrom(stats,glm) 27 | importFrom(stats,model.matrix) 28 | importFrom(stats,na.omit) 29 | importFrom(stats,predict) 30 | importFrom(stats,runif) 31 | importFrom(stats,terms) 32 | importFrom(stats,update) 33 | importFrom(utils,tail) 34 | importFrom(vegan,vegdist) 35 | useDynLib(alien) 36 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | rfun := $(wildcard R/*.R) 2 | rman := $(wildcard man/) 3 | rcpp := $(wildcard src/*.cpp) 4 | rtes := $(wildcard tests/testthat/*.R) 5 | 6 | regular: 7 | Rscript --no-init-file $(rscr) 1 8 | 9 | check: 10 | Rscript --no-init-file -e "devtools::check('.')" 11 | 12 | vignet: 13 | Rscript --no-init-file -e "devtools::load_all(); devtools::build_vignettes('.')" 14 | 15 | formatR: 16 | Rscript -e 'formatR::tidy_dir("./R", width.cutoff = 70)' 17 | Rscript -e 'formatR::tidy_dir("./tests/test_that", width.cutoff = 70)' 18 | 19 | paper: 20 | Rscript -e "render('paper/paper.md', 'pdf_document')" 21 | 22 | winbuild: 23 | Rscript --no-init-file -e "devtools::build_win()" 24 | 25 | goodpractice: 26 | Rscript --no-init-file -e "goodpractice::gp()" 27 | 28 | website: 29 | Rscript --no-init-file -e "pkgdown::build_site()" 30 | 31 | everything: 32 | Rscript --no-init-file $(rscr) 2 33 | 34 | clean: 35 | rm -rf man/* src/*.o src/*.so R/RcppExports.R src/RcppExports.cpp 36 | -------------------------------------------------------------------------------- /R/tjur.R: -------------------------------------------------------------------------------- 1 | #' @title Calculate Tjur's D 2 | #' 3 | #' @description Calculate Tjur's D for an object of class \code{alienfit}. 4 | #' 5 | #' @param object An object of class \code{alienfit}. 6 | #' 7 | #' @details 8 | #' 9 | #' This function is designed for presence-absence data and will send an error when other data type are used. 10 | #' 11 | #' @return 12 | #' 13 | #' A numerical value presenting a Tjur's D. 14 | #' 15 | #' @author F. Guillaume Blanchet and Kate Wootton 16 | #' 17 | #' @keywords univar 18 | #' @export 19 | tjur <- function(object) { 20 | # Extract model and data 21 | model <- object 22 | dat <- attributes(object)$alienData$adjMat 23 | 24 | # Check 25 | if(!all(is.na(dat) | dat == 0 | dat == 1)){ 26 | stop("For this model, only presence-absence data should be used") 27 | } 28 | 29 | # Calculate Tjur's D 30 | pos0 <- which(dat==0) 31 | pos1 <- which(dat==1) 32 | 33 | res <- mean(model[pos1]) - mean(model[pos0]) 34 | 35 | # Return result 36 | return(res) 37 | } 38 | -------------------------------------------------------------------------------- /man/rsquare.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rsquare.R 3 | \name{rsquare} 4 | \alias{rsquare} 5 | \title{Pseudo-\eqn{R^2}{R2}} 6 | \usage{ 7 | rsquare(alienFit) 8 | } 9 | \arguments{ 10 | \item{alienFit}{An object of class \code{alienFit}.} 11 | } 12 | \description{ 13 | Calculates Efron's pseudo-\eqn{R^2}{R2} for \code{alienFit} objects 14 | } 15 | \details{ 16 | Efron's pseudo-\eqn{R^2}{R2} is calculated as: 17 | 18 | \deqn{R^2 = 1 - \frac{(y_i-\hat{\pi})^2}{(y_i-\bar{y})^2}{R2=1-((y-pihat)^2)/((y-ybar)^2)}}. 19 | 20 | where \eqn{\hat{\pi}}{pihat} is the model predicted values calculated on the scale of the response variable. 21 | 22 | This version of pseudo-\eqn{R^2}{R2} was chosen over the others because it can be calculated for all types of models implemented in this package. 23 | } 24 | \references{ 25 | Efron, B. (1978) Regression and ANOVA with Zero-One Data: Measures of Residual Variation., \emph{Journal of the American Statistical Association} \strong{73}, 113-121. 26 | } 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 IELab research group 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /man/getNull.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{getNull} 4 | \alias{getNull} 5 | \alias{getNullOne} 6 | \alias{prodNorm} 7 | \title{getNull} 8 | \usage{ 9 | getNull(A) 10 | 11 | getNullOne(nbsp) 12 | 13 | prodNorm(nbsp, B, V) 14 | } 15 | \arguments{ 16 | \item{A}{a matrix.} 17 | 18 | \item{nbsp}{an integer (from an ecological standpoint, a number 19 | of species).} 20 | 21 | \item{B}{a matrix (an orthogonal basis of A).} 22 | 23 | \item{V}{a vector.} 24 | } 25 | \value{ 26 | The null basis of \code{A}. 27 | } 28 | \description{ 29 | Wrapper around the \code{null} function of Armadillo library 30 | that finds the orthonormal basis of the null space of matrix A. Note that 31 | this wrapper do not allow the user to use any other parameters the 32 | original function can. 33 | } 34 | \section{Functions}{ 35 | \itemize{ 36 | \item \code{getNullOne}: Special case of \code{getNull} for which the orthonormal 37 | basis of the unit vector is required. 38 | 39 | \item \code{prodNorm}: Matrix product that requires to normalise one vector 40 | (see \code{\link[=fitIMC]{fitIMC()}}). 41 | }} 42 | 43 | \author{ 44 | Kevin Cazelles 45 | } 46 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | notifications: 4 | - provider: Email 5 | to: 6 | - Guillaume.Blanchet@USherbrooke.ca 7 | on_build_success: true 8 | on_build_failure: true 9 | on_build_status_changed: true 10 | 11 | # Download script file from GitHub 12 | init: 13 | ps: | 14 | $ErrorActionPreference = "Stop" 15 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 16 | Import-Module '..\appveyor-tool.ps1' 17 | 18 | install: 19 | ps: Bootstrap 20 | 21 | # Adapt as necessary starting from here 22 | 23 | build_script: 24 | - travis-tool.sh install_deps 25 | 26 | test_script: 27 | - travis-tool.sh run_tests 28 | 29 | on_failure: 30 | - 7z a failure.zip *.Rcheck\* 31 | - appveyor PushArtifact failure.zip 32 | 33 | artifacts: 34 | - path: '*.Rcheck\**\*.log' 35 | name: Logs 36 | 37 | - path: '*.Rcheck\**\*.out' 38 | name: Logs 39 | 40 | - path: '*.Rcheck\**\*.fail' 41 | name: Logs 42 | 43 | - path: '*.Rcheck\**\*.Rout' 44 | name: Logs 45 | 46 | - path: '\*_*.tar.gz' 47 | name: Bits 48 | 49 | - path: '\*_*.zip' 50 | name: Bits 51 | 52 | environment: 53 | global: 54 | USE_RTOOLS: true # For remotes install purpose -------------------------------------------------------------------------------- /man/fitRF.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitRF.R 3 | \name{fitRF} 4 | \alias{fitRF} 5 | \title{Fit direct matching centrality using Random Forest} 6 | \usage{ 7 | fitRF(data, formula, ...) 8 | } 9 | \arguments{ 10 | \item{data}{an object of the class \code{\link{alienData}}} 11 | 12 | \item{formula}{A one-sided formula specifying how the different traits from both sets of species should be used to estimate species interactions.} 13 | 14 | \item{\dots}{Other parameters passed to \link[randomForest]{randomForest}.} 15 | } 16 | \value{ 17 | An object with a class alienFit and a class fitRF. 18 | } 19 | \description{ 20 | Fit direct matching centrality model using Random Forest 21 | } 22 | \details{ 23 | The Random Forest model is designed to be used on bipartite network where traits are available for both sets of species interacting in the network. It should not be used otherwise. 24 | 25 | This function unfold the adjacency matrix and uses it as the response variable. As explanatory variables, the traits for each sets of species are repeated to match the length of the unfolded adjacency matrix but also the position. 26 | 27 | If there are NAs in the adjacency matrix, the function will omit these values in the estimation of the model. 28 | } 29 | \author{ 30 | F. Guillaume Blanchet, Dominique Gravel, Steve Vissault 31 | } 32 | -------------------------------------------------------------------------------- /CONTRIBUTING: -------------------------------------------------------------------------------- 1 | ### Development practices 2 | 3 | - the `master` branch is protected -- code can only make the master branch after a pull request, that has must be apporved by @SteveViss @KevCaz @guiblanchet 4 | - everyone work on branches in this repo 5 | - `git fetch` / `git pull` before you do anything else 6 | - good commit messages are 72 chars max on the first line and explain what has been done in the imperative tone. A good rule of thumb is that if you say "If merged, this commit will" before the commit message, it should be a sentence. For the sake of example, a good commit message is: "*add information about development practices*" while a bad one could be "*CONTRIBUTING changes*" 7 | - if the branching complexity of your function is > 3 (number of nested for / if / while), rewrite 8 | 9 | 10 | ### Style Guide 11 | 12 | - function names are explicit and with `CamelCased` verbs, *e.g.* `SimulatesNicheModel`. 13 | - objects are declared with lowercase, underscores and small caps, *e.g.* `trophic_level` 14 | - namespaces with `::` (e.g `reshape2::acast`) 15 | - Packages dependencies are declared in the `DESCRIPTION` (import section) 16 | - all `roxygen2` flags (e.g. @param etc.) are to be set up. 17 | - R extension file has to be written in capital letter (e.g `fitBayesReg.R`) 18 | 19 | Have a look at [http://adv-r.had.co.nz/Style.html](http://adv-r.had.co.nz/Style.html) 20 | For further details on namespace: [http://r-pkgs.had.co.nz/namespace.html](http://r-pkgs.had.co.nz/namespace.html) 21 | -------------------------------------------------------------------------------- /man/PEM.build.alienData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PEM.build.alienData.R 3 | \name{PEM.build.alienData} 4 | \alias{PEM.build.alienData} 5 | \title{Construct Phylogenetic Eigenvector Maps with \code{\link{alienData}}} 6 | \usage{ 7 | \method{PEM.build}{alienData}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{an object of class \code{\link{alienData}}. See details.} 11 | 12 | \item{\dots}{Arguments passed to \code{\link[MPSEM]{PEM.build}}. See details.} 13 | } 14 | \value{ 15 | An object of class \code{\link{alienData}}. 16 | } 17 | \description{ 18 | This function is essentially a wrapper around \code{\link[MPSEM]{PEM.build}}. It is designed to use the phylogenetic information in an \code{\link{alienData}} object to construct phylogenetic eigenvector maps and replace (or add) them as traits in a new \code{\link{alienData}} object. 19 | } 20 | \details{ 21 | For this function it is essential that the \code{\link{alienData}} object includes phylogenetic information, otherwise the function will send an error message. However, it is not necessary for the \code{\link{alienData}} object to include traits. 22 | 23 | The arguments passed to \code{\link[MPSEM]{PEM.build}} are typically that ones used for tunning when constructing the phylogenetic eigenvector maps. 24 | } 25 | \references{ 26 | Guénard, G., Legendre, P., and Peres-Neto, P. 2013. Phylogenetic eigenvector maps (PEM): a framework to model and predict species traits. \emph{Methods in Ecology and Evolution} \strong{4} 1120-1131. 27 | } 28 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: alien 2 | Title: Comparative analysis of interaction inference methods 3 | Version: 1.0-0 4 | Date: 2021-04-27 5 | Authors@R: c(person("F. Guillaume", "Blanchet", email = "guillaume.blanchet@usherbrooke.ca" , role = c("aut","cre"), comment = c(ORCID = "0000-0001-5149-2488")), 6 | person("Ignasi", "Bartomeus", role = c("ctb"), comment = c(ORCID = "0000-0001-7893-4389")), 7 | person("David", "Beauchesne", role = c("ctb")), 8 | person("Kevin", "Cazelles", role = c("aut"), comment = c(ORCID = "0000-0001-6619-9874")), 9 | person("Dominique", "Gravel", role = c("aut"), comment = c(ORCID = "0000-0002-4498-7076")), 10 | person("Steve", "Vissault", role = c("aut"), comment = c(ORCID = "0000-0001-6619-9874"))) 11 | Depends: 12 | R (>= 3.1.0) 13 | Maintainer: F. Guillaume Blanchet 14 | Description: Comparative analysis of interaction inference methods. 15 | Suggests: 16 | testthat (>= 0.8.0), 17 | knitr, 18 | rmarkdown 19 | Imports: 20 | Rcpp (>= 0.12.9), 21 | RcppArmadillo, 22 | randomForest, 23 | reshape2, 24 | utils, 25 | stats, 26 | GenSA, 27 | mvabund, 28 | vegan, 29 | lme4, 30 | ape, 31 | MPSEM, 32 | picante 33 | LinkingTo: Rcpp, RcppArmadillo 34 | NeedsCompilation: yes 35 | License: MIT + file LICENSE 36 | BugReports: https://github.com/TheoreticalEcosystemEcology/alien/issues 37 | VignetteBuilder: knitr 38 | Encoding: UTF-8 39 | LazyData: true 40 | RoxygenNote: 7.1.2 41 | Roxygen: list(markdown = TRUE) 42 | -------------------------------------------------------------------------------- /R/rsquare.R: -------------------------------------------------------------------------------- 1 | #' @name rsquare 2 | #' 3 | #' @title Pseudo-\eqn{R^2}{R2} 4 | #' 5 | #' @description 6 | #' Calculates Efron's pseudo-\eqn{R^2}{R2} for `alienFit` objects 7 | #' 8 | #' @param alienFit An object of class `alienFit`. 9 | #' 10 | #' @details 11 | #' 12 | #' Efron's pseudo-\eqn{R^2}{R2} is calculated as: 13 | #' 14 | #' \deqn{R^2 = 1 - \frac{(y_i-\hat{\pi})^2}{(y_i-\bar{y})^2}{R2=1-((y-pihat)^2)/((y-ybar)^2)}}. 15 | #' 16 | #' where \eqn{\hat{\pi}}{pihat} is the model predicted values calculated on the scale of the response variable. 17 | #' 18 | #' This version of pseudo-\eqn{R^2}{R2} was chosen over the others because it can be calculated for all types of models implemented in this package. 19 | #' 20 | #' 21 | #' @references 22 | #' Efron, B. (1978) Regression and ANOVA with Zero-One Data: Measures of Residual Variation., \emph{Journal of the American Statistical Association} \strong{73}, 113-121. 23 | #' 24 | #' @export 25 | rsquare <- function(alienFit) { 26 | # General check 27 | stopifnot(class(alienFit) == "alienFit") 28 | 29 | # Extract response (adjacency) matrix 30 | Y <- attributes(alienFit)$adjMat 31 | 32 | # Extract prediction matrix 33 | Ypred <- alienFit 34 | 35 | #------------------------ 36 | # Calculate the pseudo-R2 37 | #------------------------ 38 | # Total sums of squares per species 39 | ssY <- colSums(sweep(Y,2,colMeans(Y),FUN="-")^2) 40 | 41 | # Residual sums of squares per species 42 | ssRes <- colSums((Y-Ypred)^2) 43 | 44 | # Calculate R2 45 | R2 <- 1 - ssRes/ssY 46 | R2 <- mean(R2) 47 | 48 | # Return result 49 | return(R2) 50 | 51 | } -------------------------------------------------------------------------------- /man/polyTrait.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/polyTrait.R 3 | \name{polyTrait} 4 | \alias{polyTrait} 5 | \title{Construct second degree polynomial of traits} 6 | \usage{ 7 | polyTrait(data) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{\link{alienData}}.} 11 | } 12 | \value{ 13 | An object of class \code{\link{alienData}} with all numerical traits squared. 14 | The squared variables all end with "_Sq". 15 | } 16 | \description{ 17 | Construct second degree orthogonal polynomial of numerical 18 | traits while keeping the factors and binary traits as is. 19 | } 20 | \details{ 21 | This function calculates the second degree polynomials of each variable 22 | independently. The second degree polynomial of each variable are orthogonal 23 | to one another. 24 | 25 | In the process of calculating the second degree polynomials of each variable, 26 | the resulting two variables were rescaled by multiplying each value by the 27 | square root of the number of species (observations). The calculation will 28 | result in the non-squared variable to present slightly different values from 29 | the values of the original variable (even after rescaling). This is expected 30 | and the non-squared variable still presents the same information. 31 | 32 | The function will automatically transform all binary (0-1) variable to a 33 | factor. 34 | 35 | In addition, all factors are designed to have a sum to zero contrast 36 | (\code{\link[stats]{contr.sum}}). 37 | } 38 | \note{ 39 | Many aspect of this function were inspired from an internal function of the 40 | mvabund R package. 41 | } 42 | -------------------------------------------------------------------------------- /man/alienData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/alienData.R 3 | \name{alienData} 4 | \alias{alienData} 5 | \title{Formatting data and return an \code{alienData} object} 6 | \usage{ 7 | alienData( 8 | adjMat, 9 | traitFrom = NULL, 10 | traitTo = NULL, 11 | traitDistFrom = NULL, 12 | traitDistTo = NULL, 13 | phyloDistFrom = NULL, 14 | phyloDistTo = NULL 15 | ) 16 | } 17 | \arguments{ 18 | \item{adjMat}{An adjancency matrix. The rows (From) species are influencing the column (To) species.} 19 | 20 | \item{traitFrom}{A data.frame containing the traits of the row (From) species.} 21 | 22 | \item{traitTo}{A data.frame containing the traits of the column (To) species.} 23 | 24 | \item{traitDistFrom}{A dist object containing the distance between pairs of traits of the row (From) species.} 25 | 26 | \item{traitDistTo}{A dist object containing the distance between pairs of traits of the column (To) species.} 27 | 28 | \item{phyloDistFrom}{A dist object containing phylogenetic distance between pairs of row (From) species.} 29 | 30 | \item{phyloDistTo}{A dist object containing phylogenetic distance between pairs of column (To) species.} 31 | } 32 | \value{ 33 | An object of class \code{alienData} is returned. 34 | } 35 | \description{ 36 | \code{alienData} is used to check the data, if correct 37 | it returns an object of class \code{alienData}. 38 | } 39 | \details{ 40 | This function is essentially designed to make sure the names of all components match in the right order. The output of this function is at the basis of all the analyses implemented in the alien package. 41 | } 42 | \author{ 43 | F. Guillaume Blanchet, Kevin Cazelles & Steve Vissault 44 | } 45 | \keyword{classes} 46 | \keyword{manip} 47 | -------------------------------------------------------------------------------- /man/fitGLM.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitGLM.R 3 | \name{fitGLM} 4 | \alias{fitGLM} 5 | \title{Fit direct matching centrality using generalized linear model} 6 | \usage{ 7 | fitGLM(data, formula, family = NULL, spRandom = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{data}{an object of the class \code{\link{alienData}}} 11 | 12 | \item{formula}{A one-sided formula specifying how the different traits from both sets of species should be used to estimate species interactions.} 13 | 14 | \item{family}{The family of the response variable. See \link[stats]{family}, or the choices available.} 15 | 16 | \item{spRandom}{Logical. Whether species are used as a random effect. Default is FALSE.} 17 | 18 | \item{\dots}{Other parameters passed to \link[stats]{glm}.} 19 | } 20 | \value{ 21 | An object with a class alienFit and a class fitGLM. 22 | } 23 | \description{ 24 | Fit direct matching centrality model using generalized linear model 25 | } 26 | \details{ 27 | This function unfold the adjacency matrix and uses it as the response variable. As explanatory variables, the traits for each sets of species are repeated to match the length of the unfolded adjacency matrix but also the position. 28 | 29 | If there are NAs in the adjacency matrix, the function will omit these values in the estimation of the model. 30 | 31 | Although not specified by default formula is proposed here, in the ecological literature focusing on modeling species interactions, all variables are considered additively. In addition, quadratic relations are included for quantitative terms. Lastly, interactions between traits are considered across all traits within and across trophic levels. This is different than from the fourth corner approach where interactions is considered solely between traits of different trophic levels. 32 | } 33 | \author{ 34 | F. Guillaume Blanchet, Dominique Gravel, Steve Vissault 35 | } 36 | -------------------------------------------------------------------------------- /man/fitPNB.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitPNB.R 3 | \name{fitPNB} 4 | \alias{fitPNB} 5 | \title{Fit using Probabilistic niche model} 6 | \usage{ 7 | fitPNB( 8 | data, 9 | type, 10 | optimum, 11 | optimumMin, 12 | optimumMax, 13 | range, 14 | rangeMin, 15 | rangeMax, 16 | verbose = TRUE 17 | ) 18 | } 19 | \arguments{ 20 | \item{data}{An object of the class alienData, see \code{\link{alienData}}.} 21 | 22 | \item{type}{Method to be used to estimate the model. Either 'P' (presence-only) or 'PA' (presence-absence), respectively.} 23 | 24 | \item{optimum}{A vector of two values defining the optimum intercept (first value) and slope (second value).} 25 | 26 | \item{optimumMin}{A vector of two values giving the minimum values the optimum intercept and slope can have, respectively.} 27 | 28 | \item{optimumMax}{A vector of two values giving the maximum values the optimum intercept and slope can have, respectively.} 29 | 30 | \item{range}{A vector of two values defining the range intercept (first value) and slope (second value).} 31 | 32 | \item{rangeMin}{A vector of two values giving the minimum values the range intercept and slope can have, respectively.} 33 | 34 | \item{rangeMax}{A vector of two values giving the maximum values the range intercept and slope can have, respectively.} 35 | 36 | \item{verbose}{Logical. Whether messages from the algorithm are shown (TRUE) or not (FALSE). Default is TRUE.} 37 | } 38 | \value{ 39 | An object with a class alienFit and a class fitPNB. 40 | } 41 | \description{ 42 | Model adegency matrix using probabilistic niche model 43 | } 44 | \details{ 45 | This function is only designed to handle presence-only and presence-absence data. In addition, the function can only handle a single continuous trait for each species. 46 | 47 | If there are any NAs in the species interaction data (the adjacency matrix), they will be automatically removed to estimate the presence-absence (PA) model parameters. If there are NAs in the traits, an error message will be sent. 48 | } 49 | \author{ 50 | Dominique Gravel and F. Guillaume Blanchet 51 | } 52 | -------------------------------------------------------------------------------- /man/fitIMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitIMC.R 3 | \name{fitIMC} 4 | \alias{fitIMC} 5 | \title{Fit indirect matching centrality model} 6 | \usage{ 7 | fitIMC(data, d = 2, verbose = TRUE, control = list()) 8 | } 9 | \arguments{ 10 | \item{data}{An object of the class \code{\link{alienData}}.} 11 | 12 | \item{d}{Numeric. The dimension of the latent traits. Default is 2.} 13 | 14 | \item{verbose}{Logical. Whether information on the progress of the analysis is reported in the console.} 15 | 16 | \item{control}{List passed to \code{\link[GenSA]{GenSA}} to control the behavior of the algorithm.} 17 | } 18 | \value{ 19 | An object with a class alienFit and a class fitIMC. 20 | } 21 | \description{ 22 | This method estimate matching and centrality latent traits to model the interactions in an adjacency matrix. 23 | } 24 | \details{ 25 | As can be hinted by the name of the method, there are two types of latent traits. : (1) matching latent traits that are designed to quantify the strength of the interaction between two species and (2) centrality latent traits, which quantify the number of relations a species has with other species. Mathematically, these latent traits (both matching and centrality) are all orthonormal with each other, within and outside of their category. 26 | 27 | When deciding on the dimension of the lantent traits, aside from technical issues (i.e. the number of parameters to estimate and the size of the data) it is important to also consider what is gained (or loss) from increasing (or decreasing) the dimension of the latent traits. The default was set to 2 because it is often of interest to study latent traits in pairs in an ordination-type graphic. 28 | } 29 | \references{ 30 | Rohr, R. P. & Bascompte, J. (2014) Components of Phylogenetic Signal in Antagonistic and Mutualistic Networks. Am. Nat. 184, 556--564. 31 | 32 | Rohr, R. P., Naisbit, R. E., Mazza, C. & Bersier, L.-F. (2016) Matching-centrality decomposition and the forecasting of new links in networks. Proc. R. Soc. B Biol. Sci. 283, 20152702. 33 | } 34 | \author{ 35 | Kevin Cazelles, Dominique Gravel and F. Guillaume Blanchet 36 | } 37 | -------------------------------------------------------------------------------- /man/webFromNicheModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{webFromNicheModel} 4 | \alias{webFromNicheModel} 5 | \title{Generate a web using the niche model.} 6 | \arguments{ 7 | \item{nbsp}{An integer giving the number of species considered.} 8 | 9 | \item{connec}{A real positive between 0 and .5 indicating the connectance 10 | of the network to be generated.} 11 | 12 | \item{connect_all}{Logical. If TRUE, then all species in the network have a 13 | least one prey (but the niche with the lowest niche value).} 14 | 15 | \item{unbias}{Logical. If TRUE, then the first species may not be a basal species.} 16 | 17 | \item{niche}{A vector real positive between 0 and 1 standing for the niche axis. 18 | Default is set to \code{NULL}, in such case the niche axis is automatically generated.} 19 | } 20 | \value{ 21 | A logical matrix describing pairwise interactions. A given line 22 | describes the diet of a given species while a column decribes the set of 23 | predator associated to a particular species. 24 | } 25 | \description{ 26 | This function is an implementation of the niche model which generates 27 | food webs based on 1- a number of species, 2- a niche axis and 3- a value of 28 | comnectance. 29 | } 30 | \details{ 31 | Three remarks. First, according to Williams and Martinez (2000), 32 | the species with the lowest niche value is considered as a basal species and 33 | therefore cannot feed upon another species. This introduces a slight bias (\emph{e.g} the 34 | expected connectance is lower than the expected values \code{connec}). Second, 35 | forcing all the species to be connected introduces another biais (on 36 | connectance values) as they tends to be more connected than expected. 37 | Third, if one uses its own customed niche axis, values should be between 0 and 38 | and 1 and the expected connectance (\code{connec}) can vary significantly if the 39 | distribution of niche values differ from the uniform distribution used in 40 | Williams and Martinez (2000). 41 | } 42 | \references{ 43 | Williams, R.J. and Martinez, N.D. (2000) Simple rules yield complex food webs. 44 | \emph{Nature}, 404:180–183. 45 | } 46 | \author{ 47 | Kevin Cazelles 48 | } 49 | -------------------------------------------------------------------------------- /tests/testthat/test-fitRF.R: -------------------------------------------------------------------------------- 1 | # Set seed 2 | set.seed(43) 3 | 4 | ####################### 5 | # Generate bogus adjMat 6 | ####################### 7 | bipart <- matrix(rbinom(n = 20, prob = 0.6, size = 1), 8 | nrow = 5, ncol = 4) 9 | 10 | # Add row an column names 11 | rownames(bipart) <- letters[1:5] 12 | colnames(bipart) <- LETTERS[1:4] 13 | 14 | ########################## 15 | # Generate bogus traitFrom 16 | ########################## 17 | # Convert TraitF to data.frame 18 | TraitFDF <- data.frame(tr1 = rnorm(5), 19 | tr2 = rnorm(5), 20 | tr3 = as.factor(c("red", "red", 21 | "blue", "green", 22 | "green"))) 23 | 24 | rownames(TraitFDF) <- letters[1:5] 25 | 26 | ######################## 27 | # Generate bogus traitTo 28 | ######################## 29 | # Convert TraitT to data.frame 30 | TraitTDF <- data.frame(Tr1 = rnorm(4), 31 | Tr2 = as.factor(c("red", "red", 32 | "blue","blue")), 33 | Tr3 = rnorm(4)) 34 | 35 | rownames(TraitTDF) <- LETTERS[1:4] 36 | 37 | ################# 38 | # Build alienData 39 | ################# 40 | AllData <- alienData(adjMat = bipart, 41 | traitFrom = TraitFDF, 42 | traitTo = TraitTDF) 43 | 44 | ######################### 45 | # Test randomForest model 46 | ######################### 47 | # Function 48 | fitRFComplexRes <- fitRF(data = AllData, 49 | formula = ~ tr1 + tr2 + tr3 + Tr1 + Tr2 + Tr3, 50 | ntree = 500, 51 | nodesize = 3) 52 | 53 | 54 | fitRFSimpleRes <- fitRF(data = AllData, 55 | formula = ~ -1 + tr1, 56 | ntree = 500, 57 | nodesize = 3) 58 | 59 | # Trick to compare the result obtained from fit 60 | fitRFComplexResMat <- matrix(NA, nrow = 5, ncol = 4) 61 | fitRFComplexResMat[,1:4] <- fitRFComplexRes[,1:4] 62 | 63 | fitRFSimpleResMat <- matrix(NA, nrow = 5, ncol = 4) 64 | fitRFSimpleResMat[,1:4] <- fitRFSimpleRes[,1:4] 65 | 66 | # Test 67 | test_that("fitRF expected output", 68 | expect_false(isTRUE(all.equal(fitRFSimpleResMat, 69 | fitRFComplexResMat)))) 70 | 71 | -------------------------------------------------------------------------------- /R/logLik.alienFit.R: -------------------------------------------------------------------------------- 1 | #' @title Extract Log-Likelihood for \code{alienfit} object 2 | #' 3 | #' @description Calculate a Log-Likelihood for and object class \code{alienfit} 4 | #' 5 | #' @param object An object of class \code{alienfit}. 6 | #' @param error a numeric value defining the level of uncertainty in the data. It needs to be between 0 and 1 and is usually small. 7 | #' @param \dots Some methods for this function require additional arguments. 8 | #' 9 | #' @details 10 | #' 11 | #' Currently, the function only calculates log-likelihood for presence-absence data. An error will be sent otherwise. 12 | #' 13 | #' When defining \code{error}, the value given should represent how much uncertainty there is in the probability obtained from the model. In other words, below which probability value is there a lost of confidence in the results. The threshold value given in \code{error} will be used for all probability values obtained from the model that are smaller than \code{error} or larger than 1 - \code{error. 14 | #' 15 | #' @return 16 | #' 17 | #' A numerical value presenting a log-likelihood. 18 | #' 19 | #' @author F. Guillaume Blanchet and Dominique Gravel 20 | #' 21 | #' @keywords univar 22 | #' @export 23 | logLik.alienFit <- function(object, error, ...) { 24 | if(min(object) < 0 | max(object) > 1){ 25 | stop("The values in 'object' should range between 0 and 1") 26 | } 27 | 28 | if(error > 1 | error < 0){ 29 | stop("The error value should range between 0 and 1") 30 | } 31 | 32 | # Extract model and data 33 | model <- object 34 | dat <- attributes(object)$alienData$adjMat 35 | 36 | # Check 37 | if(!all(is.na(dat) | dat == 0 | dat == 1)){ 38 | stop("For this model, only presence-absence data should be used") 39 | } 40 | 41 | # Replace model values below error threshold by error value 42 | model[which(model < error)] <- error 43 | model[which(model > (1 - error))] <- 1 - error 44 | 45 | # Result object 46 | mat <- matrix(NA, nrow = nrow(dat), ncol = ncol(dat)) 47 | 48 | # Calculate loglikelihood for presences and absences 49 | pos1 <- which(dat == 1) 50 | pos0 <- which(dat == 0) 51 | 52 | mat[pos1] <- log(model[pos1]) 53 | mat[pos0] <- log(1-model[pos0]) 54 | 55 | # Return result 56 | res <- sum(mat, na.rm=TRUE) 57 | return(res) 58 | } 59 | -------------------------------------------------------------------------------- /R/PEM.build.alienData.R: -------------------------------------------------------------------------------- 1 | #' @title Construct Phylogenetic Eigenvector Maps with \code{\link{alienData}} 2 | #' 3 | #' @description This function is essentially a wrapper around \code{\link[MPSEM]{PEM.build}}. It is designed to use the phylogenetic information in an \code{\link{alienData}} object to construct phylogenetic eigenvector maps and replace (or add) them as traits in a new \code{\link{alienData}} object. 4 | #' 5 | #' @param x an object of class \code{\link{alienData}}. See details. 6 | #' @param \dots Arguments passed to \code{\link[MPSEM]{PEM.build}}. See details. 7 | #' 8 | #' @details 9 | #' 10 | #' For this function it is essential that the \code{\link{alienData}} object includes phylogenetic information, otherwise the function will send an error message. However, it is not necessary for the \code{\link{alienData}} object to include traits. 11 | #' 12 | #' The arguments passed to \code{\link[MPSEM]{PEM.build}} are typically that ones used for tunning when constructing the phylogenetic eigenvector maps. 13 | #' 14 | #' @return 15 | #' 16 | #' An object of class \code{\link{alienData}}. 17 | #' 18 | #' @references 19 | #' 20 | #' Guénard, G., Legendre, P., and Peres-Neto, P. 2013. Phylogenetic eigenvector maps (PEM): a framework to model and predict species traits. \emph{Methods in Ecology and Evolution} \strong{4} 1120-1131. 21 | #' 22 | #' @method PEM.build alienData 23 | # @export 24 | #' @importFrom MPSEM PEM.build 25 | #' 26 | PEM.build.alienData <- function(x, ...){ 27 | # General check 28 | if(is.null(x$phylo)){ 29 | stop("There is no phylogenetic information in 'x'") 30 | } 31 | 32 | nphylo <- length(x$phylo) 33 | PEM <- vector("list", length = nphylo) 34 | PEMLong <- data.frame(idInd = NULL, trait = NULL,value = NULL) 35 | 36 | # Convert phylogenies to PEM 37 | for(i in 1:nphylo){ 38 | graph <- MPSEM::Phylo2DirectedGraph(x$phylo[[1]]) 39 | PEM[[i]] <- as.data.frame(MPSEM::PEM.build(graph, ...)) 40 | colnames(PEM[[i]]) <- paste0("PEM_",names(x$phylo)[i],"_",1:ncol(PEM[[i]])) 41 | PEMLong <- rbind(PEMLong, reshape2::melt(as.matrix(PEM[[i]]))) 42 | } 43 | 44 | # Format data 45 | colnames(PEMLong) <- c("idInd", "trait", "value") 46 | PEMLong$value <- as.character(PEMLong$value) 47 | 48 | if(is.null(x$trait)){ 49 | x$trait <- PEMLong 50 | }else{ 51 | x$trait <- rbind(x$trait,PEMLong) 52 | } 53 | 54 | # return new alienData 55 | return(x) 56 | } 57 | -------------------------------------------------------------------------------- /tests/testthat/test-fitIMC.R: -------------------------------------------------------------------------------- 1 | # Set seed 2 | set.seed(43) 3 | 4 | ####################### 5 | # Generate bogus adjMat 6 | ####################### 7 | #------ 8 | # Small 9 | #------ 10 | bipart <- matrix(rbinom(n = 20, prob = 0.6, size = 1), 11 | nrow = 5, ncol = 4) 12 | 13 | # Add row an column names 14 | rownames(bipart) <- letters[1:5] 15 | colnames(bipart) <- LETTERS[1:4] 16 | 17 | #------- 18 | # Larger 19 | #------- 20 | bipartLarger <- matrix(rbinom(n = 50, prob = 0.6, size = 1), 21 | nrow = 10, ncol = 5) 22 | 23 | # Add row an column names 24 | rownames(bipartLarger) <- letters[1:nrow(bipartLarger)] 25 | colnames(bipartLarger) <- LETTERS[1:ncol(bipartLarger)] 26 | 27 | ################# 28 | # Build alienData 29 | ################# 30 | AllData <- alienData(adjMat = bipart) 31 | AllDataLarger <- alienData(adjMat = bipartLarger) 32 | 33 | ############################# 34 | # Test fitIMC - overfit check 35 | ############################# 36 | test_that("fitIMC check overfit", 37 | expect_error(fitIMC(AllData, 38 | d = 2, 39 | verbose = FALSE, 40 | control = list(maxit = 1)))) 41 | 42 | ################# 43 | # Test fitIMC - d 44 | ################# 45 | fitIMCBad <- fitIMC(AllDataLarger, 46 | d = 1, 47 | verbose = FALSE, 48 | control = list(maxit = 100, seed = 42)) 49 | 50 | fitIMCBetter <- fitIMC(AllDataLarger, 51 | d = 2, 52 | verbose = FALSE, 53 | control = list(maxit = 100, seed = 42)) 54 | 55 | # Calculate sums of squares 56 | SSBad <- sum((bipartLarger - fitIMCBad)^2) 57 | SSBetter <- sum((bipartLarger - fitIMCBetter)^2) 58 | 59 | # Test 60 | test_that("fitIMC d", 61 | expect_gt(SSBad ,SSBetter)) 62 | 63 | ####################### 64 | # Test fitIMC - control 65 | ####################### 66 | fitIMCBad <- fitIMC(AllData, 67 | d = 1, 68 | verbose = FALSE, 69 | control = list(maxit = 1)) 70 | 71 | fitIMCBetter <- fitIMC(AllData, 72 | d = 1, 73 | verbose = FALSE, 74 | control = list(maxit = 10)) 75 | 76 | # Calculate sums of squares 77 | SSBad <- sum((bipart - fitIMCBad)^2) 78 | SSBetter <- sum((bipart - fitIMCBetter)^2) 79 | 80 | # Test 81 | test_that("fitIMC control", 82 | expect_gt(SSBad ,SSBetter)) 83 | -------------------------------------------------------------------------------- /src/getNull.cpp: -------------------------------------------------------------------------------- 1 | // [[Rcpp::depends(RcppArmadillo)]] 2 | #include 3 | #include 4 | using namespace Rcpp; 5 | //' @name getNull 6 | //' @title getNull 7 | //' 8 | //' @author 9 | //' Kevin Cazelles 10 | //' 11 | //' @description Wrapper around the `null` function of Armadillo library 12 | //' that finds the orthonormal basis of the null space of matrix A. Note that 13 | //' this wrapper do not allow the user to use any other parameters the 14 | //' original function can. 15 | //' 16 | //' @param A a matrix. 17 | //' @param B a matrix (an orthogonal basis of A). 18 | //' @param V a vector. 19 | //' @param nbsp an integer (from an ecological standpoint, a number 20 | //' of species). 21 | //' 22 | //' @return The null basis of `A`. 23 | //' 24 | //' @importFrom Rcpp evalCpp 25 | //' @export 26 | // [[Rcpp::export]] 27 | 28 | arma::mat getNull(arma::mat A) { 29 | return arma::null(A); 30 | } 31 | 32 | //' @describeIn getNull Special case of `getNull` for which the orthonormal 33 | //' basis of the unit vector is required. 34 | //' @export 35 | // [[Rcpp::export]] 36 | arma::mat getNullOne(int nbsp) { 37 | // column vectors of 1 38 | arma::mat vecU1 = arma::ones(1, nbsp); 39 | return arma::null(vecU1); 40 | } 41 | 42 | //' @describeIn getNull Matrix product that requires to normalise one vector 43 | //' (see [fitIMC()]). 44 | //' @export 45 | // [[Rcpp::export]] 46 | arma::vec prodNorm(int nbsp, arma::mat B, arma::vec V) { 47 | return sqrt(nbsp)*B*arma::normalise(V); 48 | } 49 | 50 | // @export 51 | // [[Rcpp::export]] 52 | double interaction_proba(NumericVector M1_i, NumericVector M2_j, double cent1_i, double cent2_j, NumericVector Lambda, double m) { 53 | int k; 54 | double val = cent1_i + cent2_j + m; 55 | double tmp; 56 | for (k=0; k do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #' @name getNull 5 | #' @title getNull 6 | #' 7 | #' @author 8 | #' Kevin Cazelles 9 | #' 10 | #' @description Wrapper around the `null` function of Armadillo library 11 | #' that finds the orthonormal basis of the null space of matrix A. Note that 12 | #' this wrapper do not allow the user to use any other parameters the 13 | #' original function can. 14 | #' 15 | #' @param A a matrix. 16 | #' @param B a matrix (an orthogonal basis of A). 17 | #' @param V a vector. 18 | #' @param nbsp an integer (from an ecological standpoint, a number 19 | #' of species). 20 | #' 21 | #' @return The null basis of `A`. 22 | #' 23 | #' @importFrom Rcpp evalCpp 24 | #' @export 25 | getNull <- function(A) { 26 | .Call('_alien_getNull', PACKAGE = 'alien', A) 27 | } 28 | 29 | #' @describeIn getNull Special case of `getNull` for which the orthonormal 30 | #' basis of the unit vector is required. 31 | #' @export 32 | getNullOne <- function(nbsp) { 33 | .Call('_alien_getNullOne', PACKAGE = 'alien', nbsp) 34 | } 35 | 36 | #' @describeIn getNull Matrix product that requires to normalise one vector 37 | #' (see [fitIMC()]). 38 | #' @export 39 | prodNorm <- function(nbsp, B, V) { 40 | .Call('_alien_prodNorm', PACKAGE = 'alien', nbsp, B, V) 41 | } 42 | 43 | interaction_proba <- function(M1_i, M2_j, cent1_i, cent2_j, Lambda, m) { 44 | .Call('_alien_interaction_proba', PACKAGE = 'alien', M1_i, M2_j, cent1_i, cent2_j, Lambda, m) 45 | } 46 | 47 | likelihoodMC_core <- function(netObs, M1, M2, cent1, cent2, Lambda, m) { 48 | .Call('_alien_likelihoodMC_core', PACKAGE = 'alien', netObs, M1, M2, cent1, cent2, Lambda, m) 49 | } 50 | 51 | #' @name webFromNicheModel 52 | #' 53 | #' @title Generate a web using the niche model. 54 | #' 55 | #' @description 56 | #' This function is an implementation of the niche model which generates 57 | #' food webs based on 1- a number of species, 2- a niche axis and 3- a value of 58 | #' comnectance. 59 | #' 60 | #' @author 61 | #' Kevin Cazelles 62 | #' 63 | #' @param nbsp An integer giving the number of species considered. 64 | #' @param connec A real positive between 0 and .5 indicating the connectance 65 | #' of the network to be generated. 66 | #' @param connect_all Logical. If TRUE, then all species in the network have a 67 | #' least one prey (but the niche with the lowest niche value). 68 | #' @param unbias Logical. If TRUE, then the first species may not be a basal species. 69 | #' @param niche A vector real positive between 0 and 1 standing for the niche axis. 70 | #' Default is set to \code{NULL}, in such case the niche axis is automatically generated. 71 | #' 72 | #' @return A logical matrix describing pairwise interactions. A given line 73 | #' describes the diet of a given species while a column decribes the set of 74 | #' predator associated to a particular species. 75 | #' 76 | #' @details 77 | #' Three remarks. First, according to Williams and Martinez (2000), 78 | #' the species with the lowest niche value is considered as a basal species and 79 | #' therefore cannot feed upon another species. This introduces a slight bias (\emph{e.g} the 80 | #' expected connectance is lower than the expected values \code{connec}). Second, 81 | #' forcing all the species to be connected introduces another biais (on 82 | #' connectance values) as they tends to be more connected than expected. 83 | #' Third, if one uses its own customed niche axis, values should be between 0 and 84 | #' and 1 and the expected connectance (\code{connec}) can vary significantly if the 85 | #' distribution of niche values differ from the uniform distribution used in 86 | #' Williams and Martinez (2000). 87 | #' 88 | #' @references 89 | #' Williams, R.J. and Martinez, N.D. (2000) Simple rules yield complex food webs. 90 | #' \emph{Nature}, 404:180–183. 91 | #' 92 | #' @export 93 | NULL 94 | 95 | #' @importFrom Rcpp evalCpp 96 | #' 97 | webFromNicheModel <- function(nbsp, connec, connect_all = FALSE, unbias = FALSE, niche = NULL) { 98 | .Call('_alien_webFromNicheModel', PACKAGE = 'alien', nbsp, connec, connect_all, unbias, niche) 99 | } 100 | 101 | -------------------------------------------------------------------------------- /src/webFromNicheModel.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | 5 | //' @name webFromNicheModel 6 | //' 7 | //' @title Generate a web using the niche model. 8 | //' 9 | //' @description 10 | //' This function is an implementation of the niche model which generates 11 | //' food webs based on 1- a number of species, 2- a niche axis and 3- a value of 12 | //' comnectance. 13 | //' 14 | //' @author 15 | //' Kevin Cazelles 16 | //' 17 | //' @param nbsp An integer giving the number of species considered. 18 | //' @param connec A real positive between 0 and .5 indicating the connectance 19 | //' of the network to be generated. 20 | //' @param connect_all Logical. If TRUE, then all species in the network have a 21 | //' least one prey (but the niche with the lowest niche value). 22 | //' @param unbias Logical. If TRUE, then the first species may not be a basal species. 23 | //' @param niche A vector real positive between 0 and 1 standing for the niche axis. 24 | //' Default is set to \code{NULL}, in such case the niche axis is automatically generated. 25 | //' 26 | //' @return A logical matrix describing pairwise interactions. A given line 27 | //' describes the diet of a given species while a column decribes the set of 28 | //' predator associated to a particular species. 29 | //' 30 | //' @details 31 | //' Three remarks. First, according to Williams and Martinez (2000), 32 | //' the species with the lowest niche value is considered as a basal species and 33 | //' therefore cannot feed upon another species. This introduces a slight bias (\emph{e.g} the 34 | //' expected connectance is lower than the expected values \code{connec}). Second, 35 | //' forcing all the species to be connected introduces another biais (on 36 | //' connectance values) as they tends to be more connected than expected. 37 | //' Third, if one uses its own customed niche axis, values should be between 0 and 38 | //' and 1 and the expected connectance (\code{connec}) can vary significantly if the 39 | //' distribution of niche values differ from the uniform distribution used in 40 | //' Williams and Martinez (2000). 41 | //' 42 | //' @references 43 | //' Williams, R.J. and Martinez, N.D. (2000) Simple rules yield complex food webs. 44 | //' \emph{Nature}, 404:180–183. 45 | //' 46 | //' @export 47 | // 48 | //' @importFrom Rcpp evalCpp 49 | //' 50 | // [[Rcpp::export]] 51 | LogicalMatrix webFromNicheModel(int nbsp, double connec, bool connect_all = false, 52 | bool unbias = false, Nullable niche = R_NilValue){ 53 | if ( (connec < 0) || (connec > 0.5) ) { 54 | stop("Inadmissible value for connectance"); 55 | } 56 | LogicalMatrix metaweb(nbsp, nbsp); 57 | NumericVector vec_tmp(nbsp); 58 | double c, r, rg1, rg2, beta; 59 | int i, j, k, l, m, count; 60 | // 61 | if (unbias) { 62 | m = 0; 63 | } else { 64 | m = 1; 65 | } 66 | // 67 | if (niche.isNotNull()) { 68 | NumericVector vec_tmp0(niche); 69 | vec_tmp = clone(vec_tmp0); 70 | if (vec_tmp.size() != nbsp){ 71 | stop("Niche axis dimension is not equal to the number of species."); 72 | } 73 | for (i = 1; i 1) ){ 75 | stop("Inadmissible value for the niche axis"); 76 | } 77 | } 78 | } else { 79 | vec_tmp = runif(nbsp, 0, 1); 80 | } 81 | // 82 | NumericVector niche_sorted = clone(vec_tmp); 83 | // Sorting the niche axis (using standard library) 84 | std::sort(niche_sorted.begin(), niche_sorted.end()); 85 | // 86 | beta = .5/connec - 1; 87 | count = 0; 88 | k = 0; 89 | while (k == 0) { 90 | if (count>100000){ 91 | stop("100,000 unsucessful attempts."); 92 | } 93 | // if unbias, then the first species is a basal species 94 | for (i = m; irg1) && (niche_sorted[j] 84 | 85 | For further details on namespaces: 86 | 87 | 88 | License 89 | ------- 90 | 91 | Copyright (c) 2016-2020 IELab research group 92 | 93 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 94 | 95 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 96 | 97 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 98 | -------------------------------------------------------------------------------- /R/fitRF.R: -------------------------------------------------------------------------------- 1 | #' @name fitRF 2 | #' 3 | #' @title Fit direct matching centrality using Random Forest 4 | #' 5 | #' @description Fit direct matching centrality model using Random Forest 6 | #' 7 | #' @param data an object of the class \code{\link{alienData}} 8 | #' @param formula A one-sided formula specifying how the different traits from both sets of species should be used to estimate species interactions. 9 | #' @param \dots Other parameters passed to \link[randomForest]{randomForest}. 10 | #' 11 | #' @details 12 | #' 13 | #' The Random Forest model is designed to be used on bipartite network where traits are available for both sets of species interacting in the network. It should not be used otherwise. 14 | #' 15 | #' This function unfold the adjacency matrix and uses it as the response variable. As explanatory variables, the traits for each sets of species are repeated to match the length of the unfolded adjacency matrix but also the position. 16 | #' 17 | #' If there are NAs in the adjacency matrix, the function will omit these values in the estimation of the model. 18 | #' 19 | #' @return 20 | #' 21 | #' An object with a class alienFit and a class fitRF. 22 | #' 23 | #' @author 24 | #' 25 | #' F. Guillaume Blanchet, Dominique Gravel, Steve Vissault 26 | #' 27 | # @importFrom mvabund get.polys 28 | #' @importFrom stats terms update predict na.omit 29 | #' @importFrom randomForest randomForest 30 | #' 31 | #' @export 32 | fitRF <- function(data, formula, ...) { 33 | 34 | stopifnot(class(data) == "alienData") 35 | 36 | # Adjacency matrix 37 | adjMat <- data$adjMat 38 | nFromSp <- nrow(adjMat) 39 | nToSp <- ncol(adjMat) 40 | 41 | # Check if adjMat is a binary or not 42 | adjMatUnique <- unique(as.vector(adjMat)) 43 | if(any(is.na(adjMatUnique))){ 44 | # Remove NAs for check 45 | adjMatUnique <- adjMatUnique[-which(is.na(adjMatUnique))] 46 | } 47 | 48 | # Check if binary 49 | if(all(adjMatUnique %in% c(0,1))){ 50 | binary <- TRUE 51 | }else{ 52 | binary <- FALSE 53 | } 54 | 55 | # Trait matrix 56 | traitFromBase <- data$traitFrom 57 | traitToBase <- data$traitTo 58 | 59 | # Check for NAs in traits 60 | if(any(is.na(traitFromBase))){ 61 | stop("There is at least one NA in the data$traitFrom.") 62 | } 63 | 64 | if(any(is.na(traitToBase))){ 65 | stop("There is at least one NA in the data$traitTo.") 66 | } 67 | 68 | # Unfold adjMat into a vector 69 | adjVec <- as.vector(adjMat) 70 | 71 | # Organize trait$from to match the size and organization of adjMat 72 | traitFrom <- as.data.frame(traitFromBase[rep(seq_len(nFromSp), 73 | nToSp),]) 74 | colnames(traitFrom) <- colnames(traitFromBase) 75 | 76 | # Organize trait$to to match the size and organization of adjMat 77 | traitTo <- as.data.frame(traitToBase[rep(seq_len(nToSp), 78 | each = nFromSp),]) 79 | colnames(traitTo) <- colnames(traitToBase) 80 | 81 | # Organize data into a single object 82 | dat <- cbind(adjVec, traitTo, traitFrom) 83 | 84 | # Row names for dat 85 | nameBase <- expand.grid(colnames(adjMat), rownames(adjMat)) 86 | rNames <- paste(nameBase[,1], nameBase[,2],sep = "_") 87 | rownames(dat) <- rNames 88 | 89 | # Column names for dat 90 | colnames(dat)[1] <- c("adj") 91 | 92 | # Organize formula 93 | formulaBase <- update(formula, adj ~ ., data = dat) 94 | 95 | # Terms 96 | formTerm <- terms(formulaBase, data = dat) 97 | 98 | # formula 99 | Formula <- update(formTerm, ~ .) 100 | 101 | # Random forest 102 | if(binary){ 103 | dat$adj <- as.factor(dat$adj) 104 | } 105 | 106 | model <- randomForest::randomForest(formula = Formula, 107 | data = dat, 108 | na.action = na.omit, 109 | ...) 110 | 111 | # Prediction 112 | if(binary){ 113 | pred <- predict(model, newdata = dat, type = "prob") 114 | 115 | # Organise result into a matrix 116 | res <- matrix(pred[,2], 117 | nrow = nFromSp, 118 | ncol = nToSp) # Focuses only on 1s 119 | }else{ 120 | pred <- predict(model, newdata = dat, type = "response") 121 | 122 | # Organise result into a matrix 123 | res <- matrix(pred, 124 | nrow = nFromSp, 125 | ncol = nToSp) 126 | } 127 | 128 | rownames(res) <- rownames(adjMat) 129 | colnames(res) <- colnames(adjMat) 130 | 131 | # Add model as attribute 132 | baseAttr <- attributes(res) 133 | attributes(res) <- list(dim = baseAttr$dim, 134 | dimnames = baseAttr$dimnames, 135 | alienData = data, 136 | model = model, 137 | formula = Formula) 138 | 139 | # Define object class 140 | class(res) <- c("alienFit", "fitRF") 141 | 142 | # Return results 143 | return(res) 144 | } 145 | -------------------------------------------------------------------------------- /R/polyTrait.R: -------------------------------------------------------------------------------- 1 | #' @title Construct second degree polynomial of traits 2 | #' 3 | #' @description Construct second degree orthogonal polynomial of numerical 4 | #' traits while keeping the factors and binary traits as is. 5 | #' 6 | #' @param data An object of class \code{\link{alienData}}. 7 | #' 8 | #' @details 9 | #' 10 | #' This function calculates the second degree polynomials of each variable 11 | #' independently. The second degree polynomial of each variable are orthogonal 12 | #' to one another. 13 | #' 14 | #' In the process of calculating the second degree polynomials of each variable, 15 | #' the resulting two variables were rescaled by multiplying each value by the 16 | #' square root of the number of species (observations). The calculation will 17 | #' result in the non-squared variable to present slightly different values from 18 | #' the values of the original variable (even after rescaling). This is expected 19 | #' and the non-squared variable still presents the same information. 20 | #' 21 | #' The function will automatically transform all binary (0-1) variable to a 22 | #' factor. 23 | #' 24 | #' In addition, all factors are designed to have a sum to zero contrast 25 | #' (\code{\link[stats]{contr.sum}}). 26 | #' 27 | #' @return 28 | #' 29 | #' An object of class \code{\link{alienData}} with all numerical traits squared. 30 | #' The squared variables all end with "_Sq". 31 | #' 32 | #' @note 33 | #' 34 | #' Many aspect of this function were inspired from an internal function of the 35 | #' mvabund R package. 36 | #' 37 | #' @export 38 | #' 39 | polyTrait <- function(data){ 40 | 41 | # Build data object 42 | traits <- vector("list", length = 2) 43 | names(traits) <- c("from", "to") 44 | 45 | traits$from <- data$traitFrom 46 | traits$to <- data$traitTo 47 | 48 | for(j in 1:2){ 49 | # Check NA 50 | if(any(is.na(traits[[j]]))){ 51 | stop("There should not be any NAs in the traits") 52 | } 53 | 54 | # Basic object 55 | nRows <- nrow(traits[[j]]) 56 | nCols <- ncol(traits[[j]]) 57 | 58 | #==================== 59 | # Check variable type 60 | #==================== 61 | varType <- sapply(traits[[j]], class) 62 | 63 | #==================================== 64 | # Convert binary variable to a factor 65 | #==================================== 66 | varInteger <- which(varType == "integer") 67 | for(i in varInteger){ 68 | # Find unique values 69 | varUniqueVal <- unique(traits[[j]][,i]) 70 | if(all(varUniqueVal %in% c(0,1))){ 71 | # Convert to factor 72 | traits[[j]][,i] <- as.factor(traits[[j]][,i]) 73 | varType[i] <- "factor" 74 | } 75 | } 76 | 77 | #==================================== 78 | # Convert integer to numeric for ease 79 | #==================================== 80 | varType[which(varType == "integer")] <- "numeric" 81 | 82 | # Build result object 83 | res <- data.frame(NA) 84 | resName <- character() 85 | 86 | #================================================================ 87 | # Calculate second order polynomial of each quantitative variable 88 | #================================================================ 89 | for(i in 1:nCols){ 90 | if(is.factor(traits[[j]][,i])){ 91 | res <- cbind(res, traits[[j]][,i]) 92 | resName <- c(resName, colnames(traits[[j]])[i]) 93 | }else{ 94 | res <- cbind(res,poly(traits[[j]][,i], degree = 2)) # sqrt(nRows) is for Rescaling 95 | resName <- c(resName, colnames(traits[[j]])[i], 96 | paste0(colnames(traits[[j]])[i],"_Sq")) 97 | } 98 | } 99 | 100 | # Add names and remove bogus NA variable 101 | res <- res[,-1] 102 | if(nCols == 1){ 103 | res <- data.frame("test" = res) 104 | } 105 | 106 | colnames(res) <- resName 107 | 108 | #=============================================== 109 | # Convert all binary factors to a 1, -1 variable 110 | #=============================================== 111 | varType <- sapply(res, class) 112 | facPointer <- which(varType == "factor") 113 | 114 | # If there is 1 factor 115 | if(length(facPointer) == 1){ 116 | facLength <- nlevels(res[,facPointer]) 117 | # If there is more than one factor 118 | }else{ 119 | facLength <- lapply(res[,facPointer],nlevels) 120 | } 121 | 122 | # If there is more than one factor 123 | if(length(facLength) > 0){ 124 | for(i in 1:length(facLength)){ 125 | if(facLength[i] == 2){ 126 | fac <- res[,facPointer[i]] 127 | res[,facPointer[i]] <- model.matrix(~fac, 128 | contrasts = list(fac = "contr.sum"))[,-1] 129 | }else{ 130 | contrasts(res[,facPointer[i]])[contrasts(res[,facPointer[i]]) == 0] <- -1 131 | } 132 | } 133 | } 134 | 135 | # Replace old traits with new ones 136 | if(j == 1){ 137 | data$traitFrom <- res 138 | } 139 | if(j == 2){ 140 | data$traitTo <- res 141 | } 142 | } 143 | 144 | # Return results 145 | return(data) 146 | } 147 | 148 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | // getNull 10 | arma::mat getNull(arma::mat A); 11 | RcppExport SEXP _alien_getNull(SEXP ASEXP) { 12 | BEGIN_RCPP 13 | Rcpp::RObject rcpp_result_gen; 14 | Rcpp::RNGScope rcpp_rngScope_gen; 15 | Rcpp::traits::input_parameter< arma::mat >::type A(ASEXP); 16 | rcpp_result_gen = Rcpp::wrap(getNull(A)); 17 | return rcpp_result_gen; 18 | END_RCPP 19 | } 20 | // getNullOne 21 | arma::mat getNullOne(int nbsp); 22 | RcppExport SEXP _alien_getNullOne(SEXP nbspSEXP) { 23 | BEGIN_RCPP 24 | Rcpp::RObject rcpp_result_gen; 25 | Rcpp::RNGScope rcpp_rngScope_gen; 26 | Rcpp::traits::input_parameter< int >::type nbsp(nbspSEXP); 27 | rcpp_result_gen = Rcpp::wrap(getNullOne(nbsp)); 28 | return rcpp_result_gen; 29 | END_RCPP 30 | } 31 | // prodNorm 32 | arma::vec prodNorm(int nbsp, arma::mat B, arma::vec V); 33 | RcppExport SEXP _alien_prodNorm(SEXP nbspSEXP, SEXP BSEXP, SEXP VSEXP) { 34 | BEGIN_RCPP 35 | Rcpp::RObject rcpp_result_gen; 36 | Rcpp::RNGScope rcpp_rngScope_gen; 37 | Rcpp::traits::input_parameter< int >::type nbsp(nbspSEXP); 38 | Rcpp::traits::input_parameter< arma::mat >::type B(BSEXP); 39 | Rcpp::traits::input_parameter< arma::vec >::type V(VSEXP); 40 | rcpp_result_gen = Rcpp::wrap(prodNorm(nbsp, B, V)); 41 | return rcpp_result_gen; 42 | END_RCPP 43 | } 44 | // interaction_proba 45 | double interaction_proba(NumericVector M1_i, NumericVector M2_j, double cent1_i, double cent2_j, NumericVector Lambda, double m); 46 | RcppExport SEXP _alien_interaction_proba(SEXP M1_iSEXP, SEXP M2_jSEXP, SEXP cent1_iSEXP, SEXP cent2_jSEXP, SEXP LambdaSEXP, SEXP mSEXP) { 47 | BEGIN_RCPP 48 | Rcpp::RObject rcpp_result_gen; 49 | Rcpp::RNGScope rcpp_rngScope_gen; 50 | Rcpp::traits::input_parameter< NumericVector >::type M1_i(M1_iSEXP); 51 | Rcpp::traits::input_parameter< NumericVector >::type M2_j(M2_jSEXP); 52 | Rcpp::traits::input_parameter< double >::type cent1_i(cent1_iSEXP); 53 | Rcpp::traits::input_parameter< double >::type cent2_j(cent2_jSEXP); 54 | Rcpp::traits::input_parameter< NumericVector >::type Lambda(LambdaSEXP); 55 | Rcpp::traits::input_parameter< double >::type m(mSEXP); 56 | rcpp_result_gen = Rcpp::wrap(interaction_proba(M1_i, M2_j, cent1_i, cent2_j, Lambda, m)); 57 | return rcpp_result_gen; 58 | END_RCPP 59 | } 60 | // likelihoodMC_core 61 | double likelihoodMC_core(NumericMatrix netObs, NumericMatrix M1, NumericMatrix M2, NumericVector cent1, NumericVector cent2, NumericVector Lambda, double m); 62 | RcppExport SEXP _alien_likelihoodMC_core(SEXP netObsSEXP, SEXP M1SEXP, SEXP M2SEXP, SEXP cent1SEXP, SEXP cent2SEXP, SEXP LambdaSEXP, SEXP mSEXP) { 63 | BEGIN_RCPP 64 | Rcpp::RObject rcpp_result_gen; 65 | Rcpp::RNGScope rcpp_rngScope_gen; 66 | Rcpp::traits::input_parameter< NumericMatrix >::type netObs(netObsSEXP); 67 | Rcpp::traits::input_parameter< NumericMatrix >::type M1(M1SEXP); 68 | Rcpp::traits::input_parameter< NumericMatrix >::type M2(M2SEXP); 69 | Rcpp::traits::input_parameter< NumericVector >::type cent1(cent1SEXP); 70 | Rcpp::traits::input_parameter< NumericVector >::type cent2(cent2SEXP); 71 | Rcpp::traits::input_parameter< NumericVector >::type Lambda(LambdaSEXP); 72 | Rcpp::traits::input_parameter< double >::type m(mSEXP); 73 | rcpp_result_gen = Rcpp::wrap(likelihoodMC_core(netObs, M1, M2, cent1, cent2, Lambda, m)); 74 | return rcpp_result_gen; 75 | END_RCPP 76 | } 77 | // webFromNicheModel 78 | LogicalMatrix webFromNicheModel(int nbsp, double connec, bool connect_all, bool unbias, Nullable niche); 79 | RcppExport SEXP _alien_webFromNicheModel(SEXP nbspSEXP, SEXP connecSEXP, SEXP connect_allSEXP, SEXP unbiasSEXP, SEXP nicheSEXP) { 80 | BEGIN_RCPP 81 | Rcpp::RObject rcpp_result_gen; 82 | Rcpp::RNGScope rcpp_rngScope_gen; 83 | Rcpp::traits::input_parameter< int >::type nbsp(nbspSEXP); 84 | Rcpp::traits::input_parameter< double >::type connec(connecSEXP); 85 | Rcpp::traits::input_parameter< bool >::type connect_all(connect_allSEXP); 86 | Rcpp::traits::input_parameter< bool >::type unbias(unbiasSEXP); 87 | Rcpp::traits::input_parameter< Nullable >::type niche(nicheSEXP); 88 | rcpp_result_gen = Rcpp::wrap(webFromNicheModel(nbsp, connec, connect_all, unbias, niche)); 89 | return rcpp_result_gen; 90 | END_RCPP 91 | } 92 | 93 | static const R_CallMethodDef CallEntries[] = { 94 | {"_alien_getNull", (DL_FUNC) &_alien_getNull, 1}, 95 | {"_alien_getNullOne", (DL_FUNC) &_alien_getNullOne, 1}, 96 | {"_alien_prodNorm", (DL_FUNC) &_alien_prodNorm, 3}, 97 | {"_alien_interaction_proba", (DL_FUNC) &_alien_interaction_proba, 6}, 98 | {"_alien_likelihoodMC_core", (DL_FUNC) &_alien_likelihoodMC_core, 7}, 99 | {"_alien_webFromNicheModel", (DL_FUNC) &_alien_webFromNicheModel, 5}, 100 | {NULL, NULL, 0} 101 | }; 102 | 103 | RcppExport void R_init_alien(DllInfo *dll) { 104 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 105 | R_useDynamicSymbols(dll, FALSE); 106 | } 107 | -------------------------------------------------------------------------------- /R/fitGLM.R: -------------------------------------------------------------------------------- 1 | #' @name fitGLM 2 | #' 3 | #' @title Fit direct matching centrality using generalized linear model 4 | #' 5 | #' @description Fit direct matching centrality model using generalized linear model 6 | #' 7 | #' @param data an object of the class \code{\link{alienData}} 8 | #' @param formula A one-sided formula specifying how the different traits from both sets of species should be used to estimate species interactions. 9 | #' @param family The family of the response variable. See \link[stats]{family}, or the choices available. 10 | #' @param spRandom Logical. Whether species are used as a random effect. Default is FALSE. 11 | #' @param \dots Other parameters passed to \link[stats]{glm}. 12 | #' 13 | #' @details 14 | #' 15 | #' This function unfold the adjacency matrix and uses it as the response variable. As explanatory variables, the traits for each sets of species are repeated to match the length of the unfolded adjacency matrix but also the position. 16 | #' 17 | #' If there are NAs in the adjacency matrix, the function will omit these values in the estimation of the model. 18 | #' 19 | #' Although not specified by default formula is proposed here, in the ecological literature focusing on modeling species interactions, all variables are considered additively. In addition, quadratic relations are included for quantitative terms. Lastly, interactions between traits are considered across all traits within and across trophic levels. This is different than from the fourth corner approach where interactions is considered solely between traits of different trophic levels. 20 | #' 21 | #' @return 22 | #' 23 | #' An object with a class alienFit and a class fitGLM. 24 | #' 25 | #' @author 26 | #' 27 | #' F. Guillaume Blanchet, Dominique Gravel, Steve Vissault 28 | #' 29 | #' @importFrom stats terms update glm predict na.omit 30 | #' @importFrom lme4 glmer 31 | #' 32 | #' @export 33 | 34 | fitGLM <- function(data, formula, 35 | family = NULL, spRandom = FALSE, ...) { 36 | 37 | stopifnot(class(data) == "alienData") 38 | 39 | # Adjacency matrix 40 | adjMat <- data$adjMat 41 | nFromSp <- nrow(adjMat) 42 | nToSp <- ncol(adjMat) 43 | 44 | # Trait matrix 45 | traitFromBase <- data$traitFrom 46 | traitToBase <- data$traitTo 47 | 48 | # Check for NAs in traits 49 | if(any(is.na(traitFromBase))){ 50 | stop("There is at least one NA in the data$traitFrom.") 51 | } 52 | 53 | if(any(is.na(traitToBase))){ 54 | stop("There is at least one NA in the data$traitTo.") 55 | } 56 | 57 | # Unfold adjMat into a vector 58 | adjVec <- as.vector(adjMat) 59 | 60 | # Organize trait$from to match the size and organization of adjMat 61 | traitFrom <- as.data.frame(traitFromBase[rep(seq_len(nFromSp), 62 | nToSp),]) 63 | colnames(traitFrom) <- colnames(traitFromBase) 64 | 65 | # Organize trait$to to match the size and organization of adjMat 66 | traitTo <- as.data.frame(traitToBase[rep(seq_len(nToSp), 67 | each = nFromSp),]) 68 | colnames(traitTo) <- colnames(traitToBase) 69 | 70 | # Reorganize data for the formula 71 | # if(is.null(formula)){ 72 | # traitFromGP <- mvabund:::get.polys(traitFrom) 73 | # traitFrom <- cbind(traitFromGP$X, traitFromGP$X.squ) 74 | # 75 | # traitToGP <- mvabund:::get.polys(traitTo) 76 | # traitTo <- cbind(traitToGP$X, traitToGP$X.squ) 77 | # } 78 | 79 | # Organize data into a single object 80 | dat <- cbind(adjVec, traitTo, traitFrom) 81 | 82 | # Row names for dat 83 | nameBase <- expand.grid(colnames(adjMat), rownames(adjMat)) 84 | rNames <- paste(nameBase[,1], nameBase[,2],sep = "_") 85 | rownames(dat) <- rNames 86 | 87 | # Column names for dat 88 | colnames(dat)[1] <- c("adj") 89 | 90 | # Organize formula 91 | # if(is.null(formula)){ 92 | # # Terms 93 | # formTerm <- terms(adj ~ .*., data = dat) 94 | 95 | # # formula 96 | # Formula <- update(formTerm, ~ .) 97 | # }else{ 98 | formulaBase <- update(formula, adj ~ .) 99 | 100 | # Terms 101 | formTerm <- terms(formulaBase, data = dat) 102 | 103 | # formula 104 | Formula <- update(formTerm, ~ .) 105 | # } 106 | 107 | # GLM 108 | if(spRandom){ 109 | # Add species to dat 110 | dat <- cbind(dat, sp = as.factor(rNames)) 111 | 112 | # Terms 113 | formTerm <- terms(Formula, data = dat) 114 | 115 | # Update formula 116 | Formula <- update(formTerm, ~ . + (1|sp)) 117 | 118 | model <- lme4::glmer(Formula, data = dat, family = family, 119 | na.action = na.omit, ...) 120 | }else{ 121 | # Without random effect 122 | model <- stats::glm(Formula, data = dat, family = family, 123 | na.action = na.omit, ...) 124 | } 125 | 126 | # Prediction 127 | pred <- predict(model, newdata = dat, type = "response") 128 | 129 | # Organise result into a matrix 130 | res <- matrix(pred, nrow = nFromSp, ncol = nToSp) 131 | 132 | rownames(res) <- rownames(adjMat) 133 | colnames(res) <- colnames(adjMat) 134 | 135 | # Add model as attribute 136 | baseAttr <- attributes(res) 137 | attributes(res) <- list(dim = baseAttr$dim, 138 | dimnames = baseAttr$dimnames, 139 | alienData = data, 140 | model = model, 141 | formula = Formula) 142 | 143 | # Define object class 144 | class(res) <- c("alienFit", "fitGLM") 145 | 146 | # Return results 147 | return(res) 148 | } 149 | -------------------------------------------------------------------------------- /R/fitPNB.R: -------------------------------------------------------------------------------- 1 | #' @name fitPNB 2 | #' 3 | #' @title Fit using Probabilistic niche model 4 | #' 5 | #' @description Model adegency matrix using probabilistic niche model 6 | #' 7 | #' @param data An object of the class alienData, see \code{\link{alienData}}. 8 | #' @param type Method to be used to estimate the model. Either 'P' (presence-only) or 'PA' (presence-absence), respectively. 9 | #' @param optimum A vector of two values defining the optimum intercept (first value) and slope (second value). 10 | #' @param optimumMin A vector of two values giving the minimum values the optimum intercept and slope can have, respectively. 11 | #' @param optimumMax A vector of two values giving the maximum values the optimum intercept and slope can have, respectively. 12 | #' @param range A vector of two values defining the range intercept (first value) and slope (second value). 13 | #' @param rangeMin A vector of two values giving the minimum values the range intercept and slope can have, respectively. 14 | #' @param rangeMax A vector of two values giving the maximum values the range intercept and slope can have, respectively. 15 | #' @param verbose Logical. Whether messages from the algorithm are shown (TRUE) or not (FALSE). Default is TRUE. 16 | #' 17 | #' @details 18 | #' 19 | #' This function is only designed to handle presence-only and presence-absence data. In addition, the function can only handle a single continuous trait for each species. 20 | #' 21 | #' If there are any NAs in the species interaction data (the adjacency matrix), they will be automatically removed to estimate the presence-absence (PA) model parameters. If there are NAs in the traits, an error message will be sent. 22 | #' 23 | #' @author 24 | #' 25 | #' Dominique Gravel and F. Guillaume Blanchet 26 | #' 27 | #' @return 28 | #' 29 | #' An object with a class alienFit and a class fitPNB. 30 | #' 31 | #' @importFrom GenSA GenSA 32 | #' 33 | #' @export 34 | fitPNB <- function(data, type, optimum, optimumMin, optimumMax, 35 | range, rangeMin, rangeMax, verbose = TRUE){ 36 | 37 | stopifnot(class(data) == "alienData") 38 | 39 | # Construct adjencency matrix 40 | adjMat <- data$adjMat 41 | nFromSp <- ncol(adjMat) 42 | nToSp <- nrow(adjMat) 43 | 44 | # Trait matrix 45 | traitFromBase <- data$traitFrom 46 | traitToBase <- data$traitTo 47 | 48 | # Check for NAs in traits 49 | if(any(is.na(traitFromBase))){ 50 | stop("There is at least one NA in the data$traitFrom.") 51 | } 52 | 53 | if(any(is.na(traitToBase))){ 54 | stop("There is at least one NA in the data$traitTo.") 55 | } 56 | 57 | # Unfold adjMat into a vector 58 | adjVec <- as.vector(adjMat) 59 | 60 | # Organize trait$from to match the size and organization of adjMat 61 | traitFrom <- as.data.frame(traitFromBase[rep(seq_len(nFromSp), 62 | each = nToSp),]) 63 | colnames(traitFrom) <- colnames(traitFromBase) 64 | 65 | # Organize trait$to to match the size and organization of adjMat 66 | traitTo <- as.data.frame(traitToBase[rep(seq_len(nToSp), 67 | nFromSp),]) 68 | colnames(traitTo) <- colnames(traitToBase) 69 | 70 | # Check number of traits for From and To 71 | if(ncol(traitsTo) > 1){ 72 | stop("For this analysis there should be only a single 'To' trait") 73 | } 74 | colnames(traitsTo) <- "To" 75 | 76 | if(ncol(traitsFrom) > 1){ 77 | stop("For this analysis there should be only a single 'From' trait") 78 | } 79 | colnames(traitsFrom) <- "From" 80 | 81 | # Choose the probabilitic model to use 82 | if(type == "P"){ 83 | # Organize data into a single object 84 | dat <- data.frame(To = traitsTo, From = traitsFrom) 85 | 86 | # Keep only the data on where an interaction was found 87 | dat <- dat[adjVec == 1,] 88 | 89 | minFunc <- nicheFuncPres 90 | 91 | # Estimate parameters using simulated annealing 92 | estimPars <- GenSA::GenSA(par = c(optimum, range), fn = minFunc, 93 | lower = c(optimumMin, rangeMin), 94 | upper = c(optimumMax, rangeMax), 95 | control = list(verbose = verbose, smooth=FALSE), 96 | traitsFrom = dat$From, traitsTo = dat$To) 97 | } 98 | if(type == "PA"){ 99 | # Remove NAs in adjVec and the associated trait data 100 | noNALoc <- which(!is.na(adjVec)) 101 | adjVecNoNA <- adjVec[noNALoc] 102 | 103 | # Define the function to use 104 | minFunc <- nicheFuncPresAbs 105 | 106 | # Estimate parameters using simulated annealing 107 | estimPars <- GenSA::GenSA(par = c(optimum, range), fn = minFunc, 108 | lower = c(optimumMin, rangeMin), 109 | upper = c(optimumMax, rangeMax), 110 | control = list(verbose = verbose, smooth=FALSE), 111 | traitsFrom = traitsFrom, traitsTo = traitsTo, 112 | adjVec = adjVecNoNA) 113 | } 114 | 115 | # Prediction 116 | optimumPred <- estimPars[1] + estimPars[2] * traitsTo 117 | rangePred <- estimPars[3] + estimPars[4] * traitsTo 118 | 119 | res <- exp(-(optimumPred - traitsFrom)^2 / (2 * rangePred^2)) 120 | 121 | # Add model as attribute 122 | baseAttr <- attributes(res) 123 | attributes(res) <- list(dim = baseAttr$dim, 124 | dimnames = baseAttr$dimnames, 125 | adjMat = adjMat) 126 | 127 | # Define object class 128 | class(res) <- c("alienFit", "fitPNB") 129 | 130 | # Return result 131 | return(res) 132 | } 133 | 134 | # Presence-only data 135 | nicheFuncPres <- function(pars, traitsFrom, traitsTo) { 136 | 137 | # Optimum and range 138 | Optimum <- pars[1] + pars[2] * traitsTo 139 | Range <- pars[3] + pars[4] * traitsTo 140 | 141 | # Compute the conditional 142 | pLM <- exp(-(Optimum - traitsFrom)^2 /( 2 * Range^2)) 143 | 144 | # Compute the marginal 145 | pM <- 1/(max(traitsFrom) - min(traitsFrom)) 146 | 147 | # Integrate the denominator 148 | pL <- Range / sqrt(pi) 149 | 150 | # Compute the posterior probability 151 | pML <- pLM * pM / pL 152 | pML[pML <= 0] <- .Machine$double.xmin # Control to avoid computing issues 153 | 154 | return(-sum(log(pML))) 155 | } 156 | 157 | # Presence-absence data 158 | nicheFuncPresAbs <- function(pars, traitsFrom, traitsTo, adjVec, na.rm = TRUE) { 159 | 160 | # Optimum and range 161 | Optimum <- pars[1] + pars[2] * traitsTo 162 | Range <- pars[3] + pars[4] * traitsTo 163 | 164 | # Compute the interaction probility 165 | pL <- exp(-(Optimum - traitsFrom)^2 / ( 2 * Range^2)) 166 | 167 | # Compute the log-likelihood 168 | ll <- adjVec*0 169 | ll[adjVec == 1] <- log(pL[adjVec == 1]) 170 | ll[adjVec == 0] <- log(1 - pL[adjVec == 0]) 171 | 172 | return(-sum(ll)) 173 | } 174 | -------------------------------------------------------------------------------- /R/fitIMC.R: -------------------------------------------------------------------------------- 1 | #' @name fitIMC 2 | #' 3 | #' @title Fit indirect matching centrality model 4 | #' 5 | #' @description This method estimate matching and centrality latent traits to model the interactions in an adjacency matrix. 6 | #' 7 | #' @param data An object of the class \code{\link{alienData}}. 8 | #' @param d Numeric. The dimension of the latent traits. Default is 2. 9 | #' @param verbose Logical. Whether information on the progress of the analysis is reported in the console. 10 | #' @param control List passed to \code{\link[GenSA]{GenSA}} to control the behavior of the algorithm. 11 | #' 12 | #' @author 13 | #' Kevin Cazelles, Dominique Gravel and F. Guillaume Blanchet 14 | #' 15 | #' @details 16 | #' 17 | #' As can be hinted by the name of the method, there are two types of latent traits. : (1) matching latent traits that are designed to quantify the strength of the interaction between two species and (2) centrality latent traits, which quantify the number of relations a species has with other species. Mathematically, these latent traits (both matching and centrality) are all orthonormal with each other, within and outside of their category. 18 | #' 19 | #' When deciding on the dimension of the lantent traits, aside from technical issues (i.e. the number of parameters to estimate and the size of the data) it is important to also consider what is gained (or loss) from increasing (or decreasing) the dimension of the latent traits. The default was set to 2 because it is often of interest to study latent traits in pairs in an ordination-type graphic. 20 | #' 21 | #' @return 22 | #' An object with a class alienFit and a class fitIMC. 23 | #' 24 | #' @references 25 | #' Rohr, R. P. & Bascompte, J. (2014) Components of Phylogenetic Signal in Antagonistic and Mutualistic Networks. Am. Nat. 184, 556--564. 26 | #' 27 | #' Rohr, R. P., Naisbit, R. E., Mazza, C. & Bersier, L.-F. (2016) Matching-centrality decomposition and the forecasting of new links in networks. Proc. R. Soc. B Biol. Sci. 283, 20152702. 28 | #' 29 | #' @importFrom GenSA GenSA 30 | #' 31 | #' @export 32 | fitIMC <- function(data, d = 2, verbose = TRUE, control = list()){ 33 | 34 | # General check 35 | stopifnot(d >= 1) 36 | stopifnot(class(data) == "alienData") 37 | 38 | # Adjacency matrix 39 | adjMat <- data$adjMat 40 | 41 | # Check if the data is presence-absence 42 | adjMatUnique <- unique(as.vector(adjMat)) 43 | if(any(is.na(adjMatUnique))){ 44 | # Remove NAs for check 45 | adjMatUnique <- adjMatUnique[-which(is.na(adjMatUnique))] 46 | } 47 | 48 | if(!all(adjMatUnique %in% c(0,1))){ 49 | stop("'fitIMC is only developped for presence-absence data'") 50 | } 51 | 52 | # Number of species per sets and in total (predator and prey together) 53 | nset1 <- nrow(adjMat) 54 | nset2 <- ncol(adjMat) 55 | 56 | nsp <- nset1 + nset2 57 | 58 | # Verbose 59 | if (verbose) { 60 | print(paste(nset1, "'From' species -",nset2, "'To' species")) 61 | } 62 | 63 | # Parameters 64 | ## Centrality latent traits: 1 per species 65 | ## IIRC - 2 => because we can set 1 value and adjust the other values 66 | nbc <- nsp - 2 67 | 68 | ## Matching latent traits 69 | ## Given the constrains on vector's orthogonality, dimension of the linear 70 | ## subspace where a new vector is drawn decreases. 71 | nbm <- d * nsp - 2 * sum(seq_len(d)) 72 | 73 | ## number of 'fixed' parameters (d lambda(s), delta1, delta2 and m), 74 | ## Equation 2.1 in Rohr et al. (2016) for more details 75 | npr <- 3 + d 76 | 77 | ## Total number of paramters 78 | npar <- nbc + nbm + npr 79 | 80 | ## overfit check 81 | stopifnot(npar < prod(dim(adjMat))) 82 | 83 | # If verbose ON 84 | if (verbose){ 85 | print(paste(npar, "parameters need to be fitted")) 86 | } 87 | 88 | ## parameters order: m, delta1 (>0), delta2(>0), d lambda values (>0), 89 | ## latent traits for centrality and matching 90 | 91 | ## lower boundary of paramter values 92 | low_bound <- c(-2.5, rep(-2.5, 2+d), rep(-2.5, nbm + nbc)) 93 | 94 | ## upper boundary 95 | upp_bound <- c(2.5, rep(2.5, 2+d), rep(2.5, nbm + nbc)) 96 | 97 | ## Get orthogonal basis (needs to be calculated only once). 98 | B1 <- getNullOne(nset1) 99 | B2 <- getNullOne(nset2) 100 | 101 | ## Simulated Annealing 102 | genSARes <- GenSA::GenSA(lower = low_bound, upper = upp_bound, 103 | fn = coreMC, adjMat = adjMat, nset1 = nset1, 104 | nset2 = nset2, B1 = B1, B2 = B2, d = d, 105 | control = control) 106 | 107 | # 108 | params <- tidyParamMC(nset1, nset2, B1, B2, d, genSARes$par) 109 | out <- IMCPredict(-genSARes$value, estimateMC(adjMat, params), 110 | adjMat = adjMat, params = params) 111 | 112 | # Standardize results 113 | res <- out$netEstim 114 | 115 | # Format results attributes 116 | baseAttr <- attributes(res) 117 | 118 | # Define object class 119 | attributes(res) <- list(dim = baseAttr$dim, 120 | dimnames = baseAttr$dimnames, 121 | model = out$methodsSpecific$params, 122 | alienData = data, 123 | logLike = -genSARes$value) 124 | 125 | class(res) <- c("alienFit", "fitIMC") 126 | res 127 | } 128 | 129 | ## tidy parameters and return the likelihood 130 | coreMC <- function(adjMat, nset1, nset2, B1, B2, d, ...) { 131 | ## parsing parameters (values passed as ...) 132 | tmp <- tidyParamMC(nset1, nset2, B1, B2, d, ...) 133 | 134 | # compute -log(likelihood) 135 | likelihoodMC(adjMat, tmp$M1, tmp$M2, tmp$c1, tmp$c2, tmp$Lambda, 136 | tmp$delta1, tmp$delta2, tmp$m) 137 | } 138 | 139 | 140 | ## tidy parameters 141 | #' @importFrom utils tail 142 | tidyParamMC <- function(nset1, nset2, B1, B2, d, ...) { 143 | args <- list(...)[[1L]] # vector of latent parameter 144 | tmp <- list() 145 | ## number of parameter 146 | nsp <- nset1 + nset2 147 | nbc <- nsp - 2 148 | nbm <- d * nsp - 2 * sum(seq_len(d)) 149 | npr <- 3 + d 150 | ##-- 'fixed parameters' 151 | tmp$m <- args[1L] 152 | tmp$delta1 <- args[2L] 153 | tmp$delta2 <- args[3L] 154 | tmp$Lambda <- args[4:npr] 155 | ##-- get c1 and c2 using the nbc centrality traits 156 | args2 <- args[npr + seq_len(nbc)] 157 | tmp$c1 <- prodNorm(nset1, B1, args2[seq_len(nset1 - 1)]) 158 | tmp$c2 <- prodNorm(nset2, B2, tail(args2, nset2 - 1)) 159 | # ## get Matching vectors using the ncm macting traits 160 | args3 <- tail(args, nbm) 161 | tmp$M1 <- getMiMC(B1, nset1, d, args3[seq_len(d * nset1 - sum(seq_len(d)))]) 162 | tmp$M2 <- getMiMC(B2, nset2, d, tail(args3, d * nset2 - sum(seq_len(d)))) 163 | ## 164 | tmp 165 | } 166 | 167 | 168 | ## get Matching parameters 169 | getMiMC <- function(B, nset, d, args) { 170 | ## 171 | M <- matrix(0, d, nset) 172 | ls_vec <- list() 173 | k <- 0 174 | for (i in seq_len(d)) { 175 | inc <- nset - i 176 | ls_vec[[i]] <- args[k + seq_len(inc)] 177 | k <- k + inc 178 | } 179 | ## 180 | Ba <- B 181 | M[1L, ] <- prodNorm(nset, Ba, ls_vec[[1L]]) 182 | ## 183 | if (d >= 2) { 184 | ## keep track of vectors to which the next one should be orthogonal to 185 | K <- matrix(0, d, nset) 186 | K[1L, ] <- rep(1, nset) 187 | for (i in 2:d) { 188 | K[i, ] <- M[i - 1, ] 189 | Ba <- getNull(K[seq_len(i), ]) 190 | M[i, ] <- prodNorm(nset, Ba, ls_vec[[i]]) 191 | } 192 | } 193 | M 194 | } 195 | 196 | ## Compute likelihood 197 | likelihoodMC <- function(adjMat, M1, M2, c1, c2, Lambda, delta1, delta2, m) { 198 | #### test size ensures M1, M2 and Lambda use the same dimension d) 199 | stopifnot(nrow(M1) == length(Lambda)) 200 | stopifnot(nrow(M2) == length(Lambda)) 201 | stopifnot(ncol(M1) == length(c1)) 202 | stopifnot(ncol(M2) == length(c2)) 203 | stopifnot(nrow(adjMat) == length(c1)) 204 | stopifnot(ncol(adjMat) == length(c2)) 205 | ## 206 | cent1 <- c1 * delta1 207 | cent2 <- c2 * delta2 208 | 209 | ## We look for max(likelihood) so max(log(likelihood)) 210 | ## so we look for min(-log(likelihood)) and that's what we use cause 211 | # GenSA minimizes the objectif function. 212 | -likelihoodMC_core(adjMat, M1, M2, cent1, cent2, Lambda, m) 213 | } 214 | 215 | ## return a network of probabilities 216 | estimateMC <- function(adjMat, lsArgs) { 217 | out <- adjMat * 0 218 | cent1 <- lsArgs$c1 * lsArgs$delta1 219 | cent2 <- lsArgs$c2 * lsArgs$delta2 220 | ## logit values 221 | for (i in seq_len(nrow(adjMat))) { 222 | for (j in seq_len(ncol(adjMat))) { 223 | out[i, j] <- interaction_proba(lsArgs$M1[, i], lsArgs$M2[, j], 224 | cent1[i], cent2[j], lsArgs$Lambda, lsArgs$m) 225 | } 226 | } 227 | out 228 | } 229 | 230 | IMCPredict <- function(logLik, netEstim, ...) { 231 | out <- list() 232 | out$logLik <- logLik 233 | ##-- 234 | stopifnot(all(netEstim <= 1) & all(netEstim >= 0)) 235 | out$netEstim <- netEstim 236 | out$connec <- list(expectation = sum(netEstim), 237 | variance = sum(netEstim * (1 - netEstim))) 238 | ##-- 239 | out$methodsSpecific <- list(...) 240 | ##-- 241 | class(out) <- "IMCPredict" 242 | out 243 | } 244 | -------------------------------------------------------------------------------- /R/alienData.R: -------------------------------------------------------------------------------- 1 | #' @title Formatting data and return an \code{alienData} object 2 | #' 3 | #' @description \code{alienData} is used to check the data, if correct 4 | #' it returns an object of class \code{alienData}. 5 | #' 6 | #' @param adjMat An adjancency matrix. The rows (From) species are influencing the column (To) species. 7 | #' @param traitFrom A data.frame containing the traits of the row (From) species. 8 | #' @param traitTo A data.frame containing the traits of the column (To) species. 9 | #' @param traitDistFrom A dist object containing the distance between pairs of traits of the row (From) species. 10 | #' @param traitDistTo A dist object containing the distance between pairs of traits of the column (To) species. 11 | #' @param phyloDistFrom A dist object containing phylogenetic distance between pairs of row (From) species. 12 | #' @param phyloDistTo A dist object containing phylogenetic distance between pairs of column (To) species. 13 | #' 14 | #' @details 15 | #' 16 | #' This function is essentially designed to make sure the names of all components match in the right order. The output of this function is at the basis of all the analyses implemented in the alien package. 17 | #' 18 | #' @return 19 | #' An object of class \code{alienData} is returned. 20 | #' 21 | #' @author F. Guillaume Blanchet, Kevin Cazelles & Steve Vissault 22 | #' 23 | #' @keywords manip 24 | #' @keywords classes 25 | #' @export 26 | alienData <- function(adjMat, traitFrom = NULL, traitTo = NULL, 27 | traitDistFrom = NULL, traitDistTo = NULL, 28 | phyloDistFrom = NULL, phyloDistTo = NULL) { 29 | 30 | ################## 31 | # Adjacency matrix 32 | ################## 33 | if(!is.matrix(adjMat)){ 34 | stop("'adjMat' should be a matrix") 35 | } 36 | 37 | # row names adjMat 38 | adjMatFromNames <- rownames(adjMat) 39 | 40 | if(is.null(adjMatFromNames)){ 41 | stop("'adjMat' needs to have row names") 42 | } 43 | 44 | # column names adjMat 45 | adjMatToNames <- colnames(adjMat) 46 | 47 | if(is.null(adjMatToNames)){ 48 | stop("'adjMat' needs to have column names") 49 | } 50 | 51 | #-#-#-#-#- 52 | # Raw data 53 | #-#-#-#-#- 54 | ####### 55 | # Trait 56 | ####### 57 | #----------- 58 | # Trait from 59 | #----------- 60 | if(!is.null(traitFrom)){ 61 | # Check object class 62 | if(!is.data.frame(traitFrom)){ 63 | stop("'traitFrom' should be a data.frame") 64 | } 65 | 66 | # Names 67 | traitFromNames <- rownames(traitFrom) 68 | 69 | # Check variable class 70 | traitFromVarClass <- sapply(traitFrom, 71 | function(x) is.numeric(x) | is.factor(x)) 72 | 73 | if(!all(traitFromVarClass)){ 74 | stop("Variables in 'traitFrom' need to be a 'numeric' or a 'factor'") 75 | } 76 | 77 | # Check if species name match 78 | if(!all(adjMatFromNames %in% traitFromNames)){ 79 | stop("traitFrom and the rows of adjMat do not have the same labels") 80 | } 81 | 82 | expOrd <- match(adjMatFromNames, traitFromNames) 83 | if(!all(expOrd == 1:length(adjMatFromNames))){ 84 | stop("The row names of traitFrom and the row names of adjMat needs to have the same order") 85 | } 86 | } 87 | 88 | #--------- 89 | # Trait to 90 | #--------- 91 | if(!is.null(traitTo)){ 92 | # Check object class 93 | if(!is.data.frame(traitTo)){ 94 | stop("'traitTo' should be a data.frame") 95 | } 96 | 97 | # Names 98 | traitToNames <- rownames(traitTo) 99 | 100 | # Check variable class 101 | traitToVarClass <- sapply(traitTo, 102 | function(x) is.numeric(x) | is.factor(x)) 103 | 104 | if(!all(traitToVarClass)){ 105 | stop("Variables in 'traitTo' need to be a 'numeric' or a 'factor'") 106 | } 107 | 108 | # Check if species name match 109 | if(!all(adjMatToNames %in% traitToNames)){ 110 | stop("traitTo and the columns of adjMat do not have the same labels") 111 | } 112 | 113 | # Check if the order of the species names match between the adjacency matrix and the cophenetic matrix 114 | expOrd <- match(adjMatToNames, traitToNames) 115 | if(!all(expOrd == 1:length(adjMatToNames))){ 116 | stop("The rownames of traitTo and the column names of adjMat needs to have the same order") 117 | } 118 | } 119 | 120 | #-#-#-#-#-#-#-# 121 | # Distance data 122 | #-#-#-#-#-#-#-# 123 | ######## 124 | # Traits 125 | ######## 126 | #-------------- 127 | # traitDistFrom 128 | #-------------- 129 | if(!is.null(traitDistFrom)){ 130 | # Check object class 131 | if(class(traitDistFrom) != "dist"){ 132 | stop("'traitDistFrom' needs to be of class dist") 133 | } 134 | 135 | # Extract labels 136 | traitDistFromNames <- attributes(traitDistFrom)$Labels 137 | 138 | # Check if species name match 139 | if(!all(adjMatFromNames %in% traitDistFromNames)){ 140 | stop("Labels of traitDistFrom and the column of adjMat do not match") 141 | } 142 | 143 | # Check if the order of the species names match between the adjacency matrix and the cophenetic matrix 144 | expOrd <- match(adjMatFromNames,traitDistFromNames) 145 | if(!all(expOrd == 1:length(adjMatFromNames))){ 146 | stop("The labels of traitDistFrom and the row names of adjMat needs to have the same order") 147 | } 148 | } 149 | 150 | #------------ 151 | # traitDistTo 152 | #------------ 153 | if(!is.null(traitDistTo)){ 154 | # Check object class 155 | if(class(traitDistTo) != "dist"){ 156 | stop("'traitDistTo' needs to be of class dist") 157 | } 158 | 159 | # Extract labels 160 | traitDistToNames <- attributes(traitDistTo)$Labels 161 | 162 | # Check if species name match 163 | if(!all(adjMatToNames %in% traitDistToNames)){ 164 | stop("Labels of traitDistTo and the column of adjMat do not match") 165 | } 166 | 167 | # Check if the order of the species names match between the adjacency matrix and the trait distance matrix 168 | expOrd <- match(adjMatToNames,traitDistToNames) 169 | if(!all(expOrd == 1:length(adjMatToNames))){ 170 | stop("The labels of traitDistTo and the column names of adjMat needs to have the same order") 171 | } 172 | } 173 | 174 | ########### 175 | # Phylogeny 176 | ########### 177 | #-------------- 178 | # phyloDistFrom 179 | #-------------- 180 | if(!is.null(phyloDistFrom)){ 181 | # Check object class 182 | if(class(phyloDistFrom) != "dist"){ 183 | stop("'phyloDistFrom' needs to be of class dist") 184 | } 185 | 186 | # Extract labels 187 | phyloDistFromNames <- attributes(phyloDistFrom)$Labels 188 | 189 | # Check if species name match 190 | if(!all(adjMatFromNames %in% phyloDistFromNames)){ 191 | stop("Labels of phyloDistFrom and the column of adjMat do not match") 192 | } 193 | 194 | # Check if the order of the species names match between the adjacency matrix and the cophenetic matrix 195 | expOrd <- match(adjMatFromNames,phyloDistFromNames) 196 | if(!all(expOrd == 1:length(adjMatFromNames))){ 197 | stop("The labels of phyloDistFrom and the row names of adjMat needs to have the same order") 198 | } 199 | } 200 | 201 | #------------ 202 | # phyloDistTo 203 | #------------ 204 | if(!is.null(phyloDistTo)){ 205 | # Check object class 206 | if(class(phyloDistTo) != "dist"){ 207 | stop("'phyloDistTo' needs to be of class dist") 208 | } 209 | 210 | # Extract labels 211 | phyloDistToNames <- attributes(phyloDistTo)$Labels 212 | 213 | # Check if species name match 214 | if(!all(adjMatToNames %in% phyloDistToNames)){ 215 | stop("Labels of phyloDistTo and the column of adjMat do not match") 216 | } 217 | 218 | # Check if the order of the species names match between the adjacency matrix and the cophenetic matrix 219 | expOrd <- match(adjMatToNames,phyloDistToNames) 220 | if(!all(expOrd == 1:length(adjMatToNames))){ 221 | stop("The labels of phyloDistTo and the column names of adjMat needs to have the same order") 222 | } 223 | } 224 | 225 | ######################################### 226 | # Check to ensure number of species match 227 | ######################################### 228 | # traitFrom 229 | if(!is.null(traitFrom)){ 230 | if(nrow(adjMat) != nrow(traitFrom)){ 231 | stop("The number of rows in adjMat should match the number of rows in traitFrom") 232 | } 233 | } 234 | 235 | # traitTo 236 | if(!is.null(traitTo)){ 237 | if(ncol(adjMat) != nrow(traitTo)){ 238 | stop("The number of columns in adjMat should match the number of rows in traitTo") 239 | } 240 | } 241 | 242 | # traitDistFrom 243 | if(!is.null(traitDistFrom)){ 244 | if(nrow(adjMat) != attributes(traitDistFrom)$Size){ 245 | stop("The number of rows in adjMat should match the size of traitDistFrom") 246 | } 247 | } 248 | 249 | # traitDistTo 250 | if(!is.null(traitDistTo)){ 251 | if(ncol(adjMat) != attributes(traitDistTo)$Size){ 252 | stop("The number of columns in adjMat should match the size of traitDistTo") 253 | } 254 | } 255 | 256 | # phyloDistFrom 257 | if(!is.null(phyloDistFrom)){ 258 | if(nrow(adjMat) != attributes(phyloDistFrom)$Size){ 259 | stop("The number of rows in adjMat should match the size of phyloDistFrom") 260 | } 261 | } 262 | 263 | # phyloDistTo 264 | if(!is.null(phyloDistTo)){ 265 | if(ncol(adjMat) != attributes(phyloDistTo)$Size){ 266 | stop("The number of columns in adjMat should match the size of phyloDistTo") 267 | } 268 | } 269 | 270 | # Results 271 | res <- list(adjMat = adjMat, 272 | traitFrom = traitFrom, 273 | traitTo = traitTo, 274 | traitDistFrom = traitDistFrom, 275 | traitDistTo = traitDistTo, 276 | phyloDistFrom = phyloDistFrom, 277 | phyloDistTo = phyloDistTo) 278 | 279 | class(res) <- "alienData" 280 | 281 | return(res) 282 | } 283 | -------------------------------------------------------------------------------- /R/fitKNN.R: -------------------------------------------------------------------------------- 1 | #' @name fitKNN 2 | #' 3 | #' @title Fit using K-nearest neighbour 4 | #' 5 | #' @description Model adegency matrix using K-nearest neighbour approach 6 | #' 7 | #' @param data An object of the class alienData, see \code{\link{alienData}}. 8 | #' @param distFrom Character string defining which distance (or dissimilarity) to apply on the "From" species. Check \code{\link[vegan]{vegdist}} for the distances to choose from. Default is "jaccard". 9 | #' @param distTo Character string defining which distance (or dissimilarity) to apply on the "To" species. Check \code{\link[vegan]{vegdist}} for the distances to choose from. Default is "jaccard". 10 | #' @param distTraitFrom Character string defining which distance (or dissimilarity) to apply on the traits of the "From" species. Check \code{\link[vegan]{vegdist}} for the distances to choose from. If the value is left to NULL, \code{traitDistFrom} (or \code{phyloDistFrom}) in the data (\code{\link{alienData}}) is used directly. Default is NULL. 11 | #' @param distTraitTo Character string defining which distance (or dissimilarity) to apply on the "To" species. Check \code{\link[vegan]{vegdist}} for the distances to choose from. If the value is left to NULL, \code{traitDistTo} (or \code{phyloDistTo}) in the data (\code{\link{alienData}}) is used directly. Default is NULL. 12 | #' @param weight Numeric. Defines the contribution of the traits (or phylogeny) in the analysis. Must be between 0 and 1. Default is 0.5. 13 | #' @param nNeig Integer defining how many neighbours to consider. 14 | #' @param phylo Logical. Whether phylogenetic information should be used instead of traits to measure neighbourhood. Default is FALSE. 15 | #' 16 | #' @details 17 | #' 18 | #' This function should only be used for bipartite adjacency matrices. 19 | #' 20 | #' The function is designed in such a way that if the argument \code{distTraitFrom} is defined it will build a distance matrix using \code{traitFrom} in the \code{\link{alienData}} object even if \code{distTraitFrom} is available in \code{\link{alienData}} object. The same is true for the argument \code{distTraitTo}. 21 | #' 22 | #' The argument \code{weight} defines the important of traits (or phylogeny) in the analysis. If a weight of 0 is given, the traits (or phylogeny) are assumed to have no importance. Conversely, if \code{weight} is 1 the traits (or phylogeny) are given their full importance in the analysis. 23 | #' 24 | #' If \code{phylo} is TRUE, the cophenetic distance is used to calculate the distance between pairs of species. 25 | #' 26 | #' When ranking the species to find the \code{nNeig} nearest neighbour, in case of ties the argument \code{tie.method} in the \code{\link{rank}} function is set to "first". Also, when ranking the species, it is assumed that the species is not a neighbour of itself. 27 | #' 28 | #' NAs were removed in the calculation of the distances whenever they were present, but also in the calculation of the interaction probability. For species where all distance values are NAs, the returned interactions probability will be 0. 29 | #' 30 | #' @author 31 | #' 32 | #' F. Guillaume Blanchet and Dominique Gravel 33 | #' 34 | #' @return 35 | #' 36 | #' An object with a class alienFit and a class fitKNN. 37 | #' 38 | #' @importFrom vegan vegdist 39 | #' @importFrom stats model.matrix as.dist 40 | #' @importFrom ape cophenetic.phylo 41 | #' 42 | #' @export 43 | 44 | fitKNN <- function(data, distFrom = "jaccard", 45 | distTo = "jaccard", 46 | distTraitFrom = NULL, 47 | distTraitTo = NULL, 48 | weight = 0.5, nNeig, phylo = FALSE){ 49 | 50 | # Check 51 | stopifnot(class(data) == "alienData") 52 | 53 | if(weight > 1 | weight < 0){ 54 | stop("'weight' needs to be between 0 and 1") 55 | } 56 | 57 | if(weight < 0){ 58 | if(is.null(distTraitFrom) | is.null(distTraitTo)){ 59 | stop("distTraitFrom and distTraitTo cannot be NULL if weight is < 0") 60 | } 61 | } 62 | 63 | # Get adjacency matrix 64 | adjMat <- data$adjMat 65 | 66 | # Basic information 67 | nFromSp <- nrow(adjMat) 68 | nToSp <- ncol(adjMat) 69 | 70 | # Distance species 71 | distFromSp <- as.matrix(vegan::vegdist(adjMat, 72 | method = distFrom, na.rm = TRUE)) 73 | distToSp <- as.matrix(vegan::vegdist(t(adjMat), 74 | method = distTo, na.rm = TRUE)) 75 | 76 | #================ 77 | # Distance traits 78 | #================ 79 | if(!phylo){ 80 | # From traits 81 | if(is.null(distTraitFrom)){ 82 | if(is.null(data$traitDistFrom)){ 83 | distFromTr <- matrix(0, nrow = nFromSp, ncol = nFromSp) 84 | rownames(distFromTr) <- rownames(distFromSp) 85 | colnames(distFromTr) <- colnames(distFromSp) 86 | }else{ 87 | distFromTr <- data$traitDistFrom 88 | } 89 | }else{ 90 | # Get trait matrix 91 | traitFrom <- stats::model.matrix(~ -1 +., 92 | data = data$traitFrom) 93 | 94 | # Distance traits 95 | distFromTr <- as.matrix(vegan::vegdist(traitFrom, 96 | method = distTraitFrom, 97 | na.rm = TRUE)) 98 | } 99 | 100 | # To traits 101 | if(is.null(distTraitTo)){ 102 | if(is.null(data$traitDistTo)){ 103 | distToTr <- matrix(0, nrow = nToSp, ncol = nToSp) 104 | rownames(distToTr) <- rownames(distToSp) 105 | colnames(distToTr) <- colnames(distToSp) 106 | }else{ 107 | distToTr <- data$traitDistTo 108 | } 109 | }else{ 110 | # Get trait matrix 111 | traitTo <- stats::model.matrix(~ -1 +., 112 | data = data$traitTo) 113 | 114 | # Distance traits 115 | distToTr <- as.matrix(vegan::vegdist(traitTo, 116 | method = distTraitTo, 117 | na.rm = TRUE)) 118 | } 119 | #=============== 120 | # Distance phylo 121 | #=============== 122 | }else{ 123 | # From phylo 124 | if(is.null(data$phyloDistFrom)){ 125 | distFromTr <- matrix(0, nrow = nFromSp, ncol = nFromSp) 126 | rownames(distFromTr) <- rownames(distFromSp) 127 | colnames(distFromTr) <- colnames(distFromSp) 128 | }else{ 129 | # Cophenetic phylogenetic distance 130 | distFromTr <- data$phyloDistFrom 131 | } 132 | 133 | # To phylo 134 | if(is.null(data$phyloDistTo)){ 135 | distToTr <- matrix(0, nrow = nToSp, ncol = nToSp) 136 | rownames(distToTr) <- rownames(distToSp) 137 | colnames(distToTr) <- colnames(distToSp) 138 | }else{ 139 | # Cophenetic phylogenetic distance 140 | distToTr <- data$phyloDistTo 141 | } 142 | } 143 | 144 | # Make sure distFromTr is a matrix 145 | distFromTr <- as.matrix(distFromTr) 146 | 147 | # Make sure distToTr is a matrix 148 | distToTr <- as.matrix(distToTr) 149 | 150 | distFromTrUnique <- unique(as.vector(distFromTr)) 151 | distToTrUnique <- unique(as.vector(distToTr)) 152 | if((length(distFromTrUnique) == 1 && distFromTrUnique == 0) | (length(distToTrUnique) == 1 && distToTrUnique == 0)) { 153 | weight <- 0 154 | print("weight was set to 0 because no trait information is available for at least one group of species") 155 | } 156 | 157 | # Trait weighted distance 158 | wDistFromSp <- (1 - weight) * distFromSp + weight * distFromTr 159 | wDistToSp <- (1 - weight) * distToSp + weight * distToTr 160 | 161 | # Result object 162 | res <- matrix(NA, nrow = nFromSp, ncol = nToSp) 163 | dimnames(res) <- list(rownames(data$adjMat), 164 | colnames(data$adjMat)) 165 | 166 | # For a warning at the end 167 | countWrongNeigFrom <- 0 168 | countWrongNeigTo <- 0 169 | 170 | for(i in 1:nFromSp) { 171 | for(j in 1:nToSp) { 172 | # Order distance for the focal species 173 | FromSpOrder <- order(wDistFromSp[,i], na.last = TRUE) 174 | ToSpOrder <- order(wDistToSp[,j], na.last = TRUE) 175 | 176 | # Find duplicate values and their order for the "From" species 177 | FromSpOrderDup <- numeric() 178 | for(k in 1:nFromSp){ 179 | if(!is.na(FromSpOrder[k])){ 180 | FromSel <- which(wDistFromSp[FromSpOrder[k],i] == wDistFromSp[,i]) 181 | FromSpOrderDup[FromSel] <- k 182 | } 183 | } 184 | 185 | # Find duplicate values and their order for the "To" species 186 | ToSpOrderDup <- numeric() 187 | for(k in 1:nToSp){ 188 | if(!is.na(ToSpOrder[k])){ 189 | ToSel <- which(wDistToSp[ToSpOrder[k],j] == wDistToSp[,j]) 190 | ToSpOrderDup[ToSel] <- k 191 | } 192 | } 193 | 194 | # Remove NA in order 195 | FromSpOrderNoNA <- FromSpOrderDup[which(!is.na(FromSpOrderDup))] 196 | ToSpOrderNoNA <- ToSpOrderDup[which(!is.na(ToSpOrderDup))] 197 | 198 | # Unique rank values (and remove focal species) 199 | FromSpOrderUnique <- sort(unique(FromSpOrderNoNA))[-1] 200 | ToSpOrderUnique <- sort(unique(ToSpOrderNoNA))[-1] 201 | 202 | # Find the interaction for the "To" focal species to all the "From" species 203 | interTo <- numeric() 204 | for(k in FromSpOrderUnique){ 205 | if(k == min(FromSpOrderDup, na.rm = TRUE)){ 206 | interTo[k] <- mean(adjMat[which(FromSpOrderDup == k)[-1],j], na.rm = TRUE) 207 | }else{ 208 | interTo[k] <- mean(adjMat[which(FromSpOrderDup == k),j], na.rm = TRUE) 209 | } 210 | } 211 | 212 | # Find the interaction for the "From" focal species to all the "To" species 213 | interFrom <- numeric() 214 | for(k in ToSpOrderUnique){ 215 | if(k == min(FromSpOrderDup, na.rm = TRUE)){ 216 | interFrom[k] <- mean(adjMat[i,which(ToSpOrderDup == k)[-1]], na.rm = TRUE) 217 | }else{ 218 | interFrom[k] <- mean(adjMat[i,which(ToSpOrderDup == k)], na.rm = TRUE) 219 | } 220 | } 221 | 222 | # Remove NAs in the interaction found 223 | interToNoNA <- interTo[which(!is.na(interTo))] 224 | interFromNoNA <- interFrom[which(!is.na(interFrom))] 225 | 226 | # Calculate KNN values for To to From interactions 227 | if(length(interToNoNA) < nNeig){ 228 | countWrongNeigTo <- countWrongNeigTo + 1 229 | KNNTo <- sum(interToNoNA) / length(interToNoNA) / 2 230 | }else{ 231 | interToNoNA <- interToNoNA[1:nNeig] 232 | KNNTo <- sum(interToNoNA) / nNeig / 2 233 | } 234 | 235 | # Calculate KNN values for From to To interactions 236 | if(length(interFromNoNA) < nNeig){ 237 | countWrongNeigTo <- countWrongNeigTo + 1 238 | KNNFrom <- sum(interFromNoNA) / length(interFromNoNA) / 2 239 | }else{ 240 | interFromNoNA <- interFromNoNA[1:nNeig] 241 | KNNFrom <- sum(interFromNoNA) / nNeig / 2 242 | } 243 | 244 | # Calculate KNN values 245 | res[i, j] <- sum(c(KNNTo, KNNFrom), na.rm = TRUE) 246 | } 247 | } 248 | 249 | if((countWrongNeigTo + countWrongNeigFrom) > 0){ 250 | warning(paste("There are", countWrongNeigTo + countWrongNeigFrom, 251 | "interactions that were calculated with less than", 252 | nNeig, "neighbours")) 253 | } 254 | 255 | # Add model as attribute 256 | baseAttr <- attributes(res) 257 | attributes(res) <- list(dim = baseAttr$dim, 258 | dimnames = baseAttr$dimnames, 259 | alienData = data, 260 | distFrom = distFrom, 261 | distTo = distTo, 262 | distTraitFrom = as.dist(distFromTr), 263 | distTraitTo = as.dist(distToTr), 264 | nNeig = nNeig, 265 | phylo = phylo) 266 | 267 | # Define object class 268 | class(res) <- c("alienFit", "fitKNN") 269 | 270 | # Return result 271 | return(res) 272 | } 273 | -------------------------------------------------------------------------------- /tests/testthat/test-fitKNN.R: -------------------------------------------------------------------------------- 1 | # Set seed 2 | set.seed(43) 3 | 4 | ####################### 5 | # Generate bogus adjMat 6 | ####################### 7 | bipart <- matrix(rbinom(n = 20, prob = 0.6, size = 1), 8 | nrow = 5, ncol = 4) 9 | 10 | # Add row an column names 11 | rownames(bipart) <- letters[1:5] 12 | colnames(bipart) <- LETTERS[1:4] 13 | 14 | ########################## 15 | # Generate bogus traitFrom 16 | ########################## 17 | # Convert TraitF to data.frame 18 | TraitFDF <- data.frame(tr1 = rnorm(5), 19 | tr2 = rnorm(5), 20 | tr3 = as.factor(c("red", "red", 21 | "blue", "green", 22 | "green"))) 23 | 24 | rownames(TraitFDF) <- letters[1:5] 25 | 26 | ######################## 27 | # Generate bogus traitTo 28 | ######################## 29 | # Convert TraitT to data.frame 30 | TraitTDF <- data.frame(Tr1 = rnorm(4), 31 | Tr2 = as.factor(c("red", "red", 32 | "blue","blue")), 33 | Tr3 = rnorm(4)) 34 | 35 | rownames(TraitTDF) <- LETTERS[1:4] 36 | 37 | ############################## 38 | # Generate bogus traitDistFrom 39 | ############################## 40 | TraitFDist <- dist(rnorm(5)) 41 | attributes(TraitFDist)$Labels <- letters[1:5] 42 | 43 | ############################ 44 | # Generate bogus traitDistTo 45 | ############################ 46 | TraitTDist <- dist(rnorm(4)) 47 | attributes(TraitTDist)$Labels <- LETTERS[1:4] 48 | 49 | ############################## 50 | # Generate bogus phyloDistFrom 51 | ############################## 52 | phyloFDist <- dist(rnorm(5)) 53 | attributes(phyloFDist)$Labels <- letters[1:5] 54 | 55 | ############################ 56 | # Generate bogus phyloDistTo 57 | ############################ 58 | phyloTDist <- dist(rnorm(4)) 59 | attributes(phyloTDist)$Labels <- LETTERS[1:4] 60 | 61 | ################# 62 | # Build alienData 63 | ################# 64 | AllData <- alienData(adjMat = bipart, 65 | traitFrom = TraitFDF, 66 | traitTo = TraitTDF, 67 | traitDistFrom = TraitFDist, 68 | traitDistTo = TraitTDist, 69 | phyloDistFrom = phyloFDist, 70 | phyloDistTo = phyloTDist) 71 | 72 | 73 | ################### 74 | # Test fitKNN trait 75 | ################### 76 | # Use traits distance matrices in AllData 77 | fitKNNDistRes <-fitKNN(AllData, 78 | distFrom = "jaccard", 79 | distTo = "bray", 80 | distTraitFrom = NULL, 81 | distTraitTo = NULL, 82 | weight = 0.5, 83 | nNeig = 3, 84 | phylo = FALSE) 85 | 86 | # Construct distance matrices from raw traits in AllData 87 | fitKNNnoDistRes <-fitKNN(AllData, 88 | distFrom = "jaccard", 89 | distTo = "bray", 90 | distTraitFrom = "manhattan", 91 | distTraitTo = "euclidean", 92 | weight = 0.5, 93 | nNeig = 3, 94 | phylo = FALSE) 95 | 96 | # Build numeric trait matrix 97 | traitFromNum <- model.matrix(~ -1 +., 98 | data = AllData$traitFrom) 99 | traitToNum <- model.matrix(~ -1 +., 100 | data = AllData$traitTo) 101 | 102 | # Construct distance matrix 103 | traitDistFromNum <- vegan::vegdist(traitFromNum, 104 | method = "manhattan") 105 | traitDistToNum <- vegan::vegdist(traitToNum, 106 | method = "euclidean") 107 | 108 | #----- 109 | # Test 110 | #----- 111 | test_that("fitKNN - trait expected output", { 112 | # Check From traits distance 113 | expect_equivalent(AllData$traitDistFrom, 114 | attributes(fitKNNDistRes)$distTraitFrom) 115 | 116 | expect_equivalent(traitDistFromNum, 117 | attributes(fitKNNnoDistRes)$distTraitFrom) 118 | 119 | # Check To traits distance 120 | expect_equivalent(AllData$traitDistTo, 121 | attributes(fitKNNDistRes)$distTraitTo) 122 | 123 | expect_equivalent(traitDistToNum, 124 | attributes(fitKNNnoDistRes)$distTraitTo) 125 | }) 126 | 127 | ################################### 128 | # Test fitKNN with permuted species 129 | ################################### 130 | bipartData <- alienData(adjMat = bipart, 131 | traitFrom = NULL, 132 | traitTo = NULL, 133 | traitDistFrom = NULL, 134 | traitDistTo = NULL, 135 | phyloDistFrom = NULL, 136 | phyloDistTo = NULL) 137 | 138 | smplFrom <- sample(1:5) 139 | bipartDataPermFrom <- alienData(adjMat = bipart[smplFrom,], 140 | traitFrom = NULL, 141 | traitTo = NULL, 142 | traitDistFrom = NULL, 143 | traitDistTo = NULL, 144 | phyloDistFrom = NULL, 145 | phyloDistTo = NULL) 146 | 147 | smplTo <- sample(1:4) 148 | bipartDataPermTo <- alienData(adjMat = bipart[,smplTo], 149 | traitFrom = NULL, 150 | traitTo = NULL, 151 | traitDistFrom = NULL, 152 | traitDistTo = NULL, 153 | phyloDistFrom = NULL, 154 | phyloDistTo = NULL) 155 | 156 | # Use traits distance matrices in AllData 157 | fitKNNDistRes <-fitKNN(bipartData, 158 | distFrom = "jaccard", 159 | distTo = "jaccard", 160 | distTraitFrom = NULL, 161 | distTraitTo = NULL, 162 | weight = 0, 163 | nNeig = 3, 164 | phylo = FALSE) 165 | 166 | fitKNNDistResPermFrom <-fitKNN(bipartDataPermFrom, 167 | distFrom = "jaccard", 168 | distTo = "jaccard", 169 | distTraitFrom = NULL, 170 | distTraitTo = NULL, 171 | weight = 0, 172 | nNeig = 3, 173 | phylo = FALSE) 174 | 175 | fitKNNDistResPermTo <-fitKNN(bipartDataPermTo, 176 | distFrom = "jaccard", 177 | distTo = "jaccard", 178 | distTraitFrom = NULL, 179 | distTraitTo = NULL, 180 | weight = 0, 181 | nNeig = 3, 182 | phylo = FALSE) 183 | 184 | #----- 185 | # Test 186 | #----- 187 | test_that("fitKNN - permuted species", { 188 | # Compare non-permuted with From permuted 189 | expect_equivalent(fitKNNDistRes[smplFrom,], 190 | fitKNNDistResPermFrom[1:length(smplFrom),]) 191 | 192 | # Compare non-permuted with To permuted 193 | expect_equivalent(fitKNNDistRes[,smplTo], 194 | fitKNNDistResPermTo[,1:length(smplTo)]) 195 | 196 | # Compare non-permuted with To permuted 197 | expect_equivalent(fitKNNDistResPermFrom[,smplTo], 198 | fitKNNDistResPermTo[smplFrom,]) 199 | 200 | }) 201 | 202 | ################### 203 | # Test fitKNN phylo 204 | ################### 205 | # Use phylogenetic distance matrices 206 | phyloDistData <- alienData(adjMat = bipart, 207 | traitFrom = TraitFDF, 208 | traitTo = TraitTDF, 209 | traitDistFrom = TraitFDist, 210 | traitDistTo = TraitTDist, 211 | phyloDistFrom = phyloFDist, 212 | phyloDistTo = phyloTDist) 213 | 214 | # Use phylogenetic distance matrices in AllData 215 | fitKNNDistPhyloRes <-fitKNN(phyloDistData, 216 | distFrom = "jaccard", 217 | distTo = "bray", 218 | distTraitFrom = NULL, 219 | distTraitTo = NULL, 220 | weight = 0.5, 221 | nNeig = 3, 222 | phylo = TRUE) 223 | 224 | #----- 225 | # Test 226 | #----- 227 | test_that("fitKNN - phylo expected output", { 228 | # Check From traits distance 229 | expect_equivalent(AllData$phyloDistFrom, 230 | attributes(fitKNNDistPhyloRes)$distTraitFrom) 231 | 232 | # Check To traits distance 233 | expect_equivalent(AllData$phyloDistTo, 234 | attributes(fitKNNDistPhyloRes)$distTraitTo) 235 | }) 236 | 237 | ################################ 238 | # Test KNN calculations - no NAs 239 | ################################ 240 | # Use traits distance matrices in AllData 241 | fitKNNRes <-fitKNN(AllData, 242 | distFrom = "jaccard", 243 | distTo = "bray", 244 | distTraitFrom = NULL, 245 | distTraitTo = NULL, 246 | weight = 0.4, 247 | nNeig = 3, 248 | phylo = FALSE) 249 | 250 | #---------------------- 251 | # Calculate KNN by hand 252 | #---------------------- 253 | # Distance matrix 254 | fromDist <- as.matrix(vegan::vegdist(AllData$adjMat, method = "jaccard")) 255 | toDist <- as.matrix(vegan::vegdist(t(AllData$adjMat), method = "bray")) 256 | 257 | # Weight 258 | weight <- 0.4 259 | 260 | # Weighted distance matrix 261 | fromDistw <- fromDist * 0.6 + 0.4 * as.matrix(AllData$traitDistFrom) 262 | toDistw <- toDist * 0.6 + 0.4 * as.matrix(AllData$traitDistTo) 263 | 264 | # Result object 265 | KNNres <- matrix(NA, nrow = 5, ncol = 4) 266 | 267 | # Estimation 268 | for(i in 1:5){ 269 | for(j in 1:4){ 270 | ordFrom <- order(fromDistw[i,])[-1] 271 | ordTo <- order(toDistw[j,])[-1] 272 | 273 | dataSelFrom <- AllData$adjMat[i,ordTo][1:3] 274 | dataSelTo <- AllData$adjMat[ordFrom,j][1:3] 275 | 276 | KNNres[i,j] <- sum(c(dataSelFrom,dataSelTo)) / (3 * 2) 277 | } 278 | } 279 | 280 | # Trick to compare the result obtained from fitKNN 281 | fitKNNResMat <- matrix(NA, nrow = 5, ncol = 4) 282 | fitKNNResMat[,1:4] <- fitKNNRes[,1:4] 283 | 284 | expect_equivalent(KNNres, fitKNNResMat) 285 | 286 | #----- 287 | # Test 288 | #----- 289 | test_that("fitKNN no NA expected output", 290 | expect_equivalent(KNNres, fitKNNResMat)) 291 | 292 | 293 | ################################## 294 | # Test KNN calculations - with NAs 295 | ################################## 296 | ################# 297 | # Build alienData 298 | ################# 299 | # Add NA 300 | bipartNA <- bipart 301 | bipartNA[3,2]<-NA 302 | bipartNA[2,1]<-NA 303 | 304 | AllDataNA <- alienData(adjMat = bipartNA, 305 | traitFrom = TraitFDF, 306 | traitTo = TraitTDF, 307 | traitDistFrom = TraitFDist, 308 | traitDistTo = TraitTDist, 309 | phyloDistFrom = phyloFDist, 310 | phyloDistTo = phyloTDist) 311 | 312 | 313 | # Use traits distance matrices in AllData 314 | fitKNNNARes <-fitKNN(AllDataNA, 315 | distFrom = "jaccard", 316 | distTo = "bray", 317 | distTraitFrom = NULL, 318 | distTraitTo = NULL, 319 | weight = 0.4, 320 | nNeig = 3, 321 | phylo = FALSE) 322 | 323 | # *Warnings are OK 324 | 325 | #---------------------- 326 | # Calculate KNN by hand 327 | #---------------------- 328 | # Distance matrix 329 | fromDistNA <- as.matrix(vegan::vegdist(AllDataNA$adjMat, 330 | method = "jaccard", 331 | na.rm = TRUE)) 332 | toDistNA <- as.matrix(vegan::vegdist(t(AllDataNA$adjMat), 333 | method = "bray", 334 | na.rm = TRUE)) 335 | 336 | # Weight 337 | weight <- 0.4 338 | 339 | # Weighted distance matrix 340 | fromDistNAw <- fromDistNA * 0.6 + 0.4 * as.matrix(AllData$traitDistFrom) 341 | toDistNAw <- toDistNA * 0.6 + 0.4 * as.matrix(AllData$traitDistTo) 342 | 343 | # Result object 344 | KNNNAres <- matrix(NA, nrow = 5, ncol = 4) 345 | 346 | # Estimation 347 | for(i in 1:5){ 348 | for(j in 1:4){ 349 | ordFrom <- order(fromDistNAw[i,])[-1] 350 | ordTo <- order(toDistNAw[j,])[-1] 351 | 352 | dataSelFrom <- AllDataNA$adjMat[i,ordTo][1:3] 353 | dataSelTo <- AllDataNA$adjMat[ordFrom,j][1:3] 354 | 355 | KNNNAres[i,j] <- sum(c(dataSelFrom,dataSelTo)) / (3 * 2) 356 | } 357 | } 358 | 359 | # Trick to compare the result obtained from fitKNN 360 | fitKNNResMat <- matrix(NA, nrow = 5, ncol = 4) 361 | fitKNNResMat[,1:4] <- fitKNNRes[,1:4] 362 | 363 | expect_equal(KNNres, fitKNNResMat) 364 | 365 | ###### 366 | # Test 367 | ###### 368 | test_that("fitKNN NA expected output", 369 | expect_equivalent(KNNres, fitKNNResMat)) 370 | -------------------------------------------------------------------------------- /vignettes/Ex_salix_galler_parasitoids.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Salix_Galler_Parasitoids" 3 | author: "Guillaume Blanchet" 4 | date: "14/05/2021" 5 | output: html_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo = TRUE) 10 | ``` 11 | 12 | This vignette was made to be an example of how the package can be applied to real-world data. As such, we focused on the *Salix*-galler-parasitoid data published by Kopelke et al. (2017) for which additional information on phylogeny was added. The full data was used to perform the analysis in Wooton et al. (2021). 13 | 14 | # Data 15 | 16 | The data is part of the `alien` R package and has already been formatted. 17 | 18 | ```{r} 19 | library(alien) 20 | 21 | data(salixGal) 22 | data(galPara) 23 | 24 | #treeGal <- read.nexus("./Tree_with_added_taxa_with_short_codes_from_Mesquite.nex") 25 | 26 | #cophGal <- cophenetic(treeGal) 27 | #phyloGal <- as.matrix(salixGal$phyloDistTo) 28 | #sel <- which(rownames(cophGal) %in% rownames(phyloGal)) 29 | #cophGalSel <- cophGal[sel,sel] 30 | #cophGalOrd <- cophGalSel[sort(rownames(cophGalSel)),sort(rownames(cophGalSel))] 31 | 32 | #salixGal$phyloDistTo <- as.dist(cophGalOrd) 33 | #galPara$phyloDistFrom <- as.dist(cophGalOrd) 34 | ``` 35 | 36 | # `fitKNN` 37 | 38 | ## Interaction data only 39 | ```{r, warning=FALSE} 40 | # Salix-galler 41 | salixGalKNNInter <- fitKNN(salixGal, 42 | distFrom = "jaccard", 43 | distTo = "jaccard", 44 | nNeig = 3, 45 | weight = 0) 46 | 47 | logLik(salixGalKNNInter, error = 0.001) 48 | tjur(salixGalKNNInter) 49 | 50 | # Galler-parasitoid 51 | galParaKNNInter <- fitKNN(galPara, 52 | distFrom = "jaccard", 53 | distTo = "jaccard", 54 | nNeig = 3, 55 | weight = 0) 56 | 57 | logLik(galParaKNNInter, error = 0.001) 58 | tjur(galParaKNNInter) 59 | ``` 60 | 61 | ## Interaction data with traits 62 | ```{r, warning=FALSE} 63 | # Salix-galler 64 | salixGalKNNInterTrait <- fitKNN(salixGal, 65 | distFrom = "jaccard", 66 | distTo = "jaccard", 67 | distTraitFrom = "euclidean", 68 | distTraitTo = "euclidean", 69 | nNeig = 3, 70 | weight = 1) 71 | 72 | logLik(salixGalKNNInterTrait, error = 0.001) 73 | tjur(salixGalKNNInterTrait) 74 | 75 | # Galler-parasitoid 76 | galParaKNNInterTrait <- fitKNN(galPara, 77 | distFrom = "jaccard", 78 | distTo = "jaccard", 79 | distTraitFrom = "euclidean", 80 | distTraitTo = "euclidean", 81 | nNeig = 3, 82 | weight = 1) 83 | 84 | logLik(galParaKNNInterTrait, error = 0.001) 85 | tjur(galParaKNNInterTrait) 86 | ``` 87 | 88 | ## Interaction data with phylogeny 89 | ```{r, warning=FALSE} 90 | # Salix-galler 91 | salixGalKNNInterPhylo <- fitKNN(salixGal, 92 | distFrom = "jaccard", 93 | distTo = "jaccard", 94 | nNeig = 3, 95 | weight = 1, 96 | phylo=TRUE) 97 | 98 | logLik(salixGalKNNInterPhylo, error = 0.001) 99 | tjur(salixGalKNNInterPhylo) 100 | 101 | # Galler-parasitoid 102 | galParaKNNInterPhylo <- fitKNN(galPara, 103 | distFrom = "jaccard", 104 | distTo = "jaccard", 105 | nNeig = 3, 106 | weight = 1, 107 | phylo = TRUE) 108 | 109 | logLik(galParaKNNInterPhylo, error = 0.001) 110 | tjur(galParaKNNInterPhylo) 111 | ``` 112 | 113 | # `fitRF` 114 | 115 | ## Traits 116 | ```{r} 117 | ############## 118 | # Salix-galler 119 | ############## 120 | 121 | # Base of formula 122 | salTraits <- paste(colnames(salixGal$traitFrom), collapse = "+") 123 | galTraits <- paste(colnames(salixGal$traitTo), collapse = "+") 124 | 125 | # Formula 126 | FormulaSalGal <- as.formula(paste("~", salTraits, "+", galTraits)) 127 | 128 | # Model 129 | salixGalRFTrait <- fitRF(salixGal, 130 | formula = FormulaSalGal, 131 | ntree = 2000, 132 | nodesize = 1) 133 | 134 | # Loglikelihood and Tjur's D 135 | logLik(salixGalRFTrait, error = 0.001) 136 | tjur(salixGalRFTrait) 137 | 138 | ################### 139 | # Galler-parasitoid 140 | ################### 141 | # Base of formula 142 | galTraits <- paste(colnames(galPara$traitFrom), collapse = "+") 143 | parTraits <- paste(colnames(galPara$traitTo), collapse = "+") 144 | 145 | # Formula 146 | FormulaGalPara <- as.formula(paste("~", galTraits, "+", parTraits)) 147 | 148 | # Model 149 | galParaRFTrait <- fitRF(galPara, 150 | formula = FormulaGalPara, 151 | ntree=2000, 152 | nodesize = 1) 153 | 154 | # Loglikelihood and Tjur's D 155 | logLik(galParaRFTrait, error = 0.001) 156 | tjur(galParaRFTrait) 157 | ``` 158 | 159 | ## Phylo 160 | ```{r} 161 | library(vegan) 162 | salPhylo <- wcmdscale(salixGal$phyloDistFrom, add = TRUE) 163 | colnames(salPhylo) <- paste0("salPhylo", 1:ncol(salPhylo)) 164 | 165 | galPhylo <- wcmdscale(salixGal$phyloDistTo, add = TRUE) 166 | colnames(galPhylo) <- paste0("galPhylo", 1:ncol(galPhylo)) 167 | 168 | paraPhylo <- wcmdscale(galPara$phyloDistTo, add = TRUE) 169 | colnames(paraPhylo) <- paste0("paraPhylo", 1:ncol(paraPhylo)) 170 | 171 | ############## 172 | # Salix-galler 173 | ############## 174 | salixGalPhylo <- alienData(adjMat = salixGal$adjMat, 175 | traitFrom = as.data.frame(salPhylo), 176 | traitTo = as.data.frame(galPhylo)) 177 | 178 | # Base of formula 179 | salPhyloTraits <- paste(colnames(salixGalPhylo$traitFrom), collapse = "+") 180 | galPhyloTraits <- paste(colnames(salixGalPhylo$traitTo), collapse = "+") 181 | 182 | # Formula 183 | FormulaSalGalPhylo <- as.formula(paste("~", salPhyloTraits, "+", galPhyloTraits)) 184 | 185 | # Model 186 | salixGalRFPhylo <- fitRF(salixGalPhylo, 187 | formula = FormulaSalGalPhylo, 188 | ntree = 2000, 189 | nodesize = 1) 190 | 191 | # Loglikelihood and Tjur's D 192 | logLik(salixGalRFPhylo, error = 0.001) 193 | tjur(salixGalRFPhylo) 194 | 195 | ################### 196 | # Galler-parasitoid 197 | ################### 198 | galParaPhylo <- alienData(adjMat = galPara$adjMat, 199 | traitFrom = as.data.frame(galPhylo), 200 | traitTo = as.data.frame(paraPhylo)) 201 | 202 | # Base of formula 203 | galPhyloTraits <- paste(colnames(galParaPhylo$traitFrom), collapse = "+") 204 | paraPhyloTraits <- paste(colnames(galParaPhylo$traitTo), collapse = "+") 205 | 206 | # Formula 207 | FormulaGalParaPhylo <- as.formula(paste("~", galPhyloTraits, "+", paraPhyloTraits)) 208 | 209 | # Model 210 | galParaRFPhylo <- fitRF(galParaPhylo, 211 | formula = FormulaGalParaPhylo, 212 | ntree=2000, 213 | nodesize = 1) 214 | 215 | # Loglikelihood and Tjur's D 216 | logLik(galParaRFPhylo, error = 0.001) 217 | tjur(galParaRFPhylo) 218 | ``` 219 | 220 | # `fitGLM` 221 | 222 | ```{r} 223 | ################ 224 | # Salix - Galler 225 | ################ 226 | # Construct squared traits for numerical traits 227 | salixGalSq <- polyTrait(salixGal) 228 | 229 | #============== 230 | # Build formula 231 | #============== 232 | # Select traits 233 | salixTr <- c("TREE.VOLUME", 234 | "TREE.VOLUME_Sq", 235 | "LEAF.THICKNESS", 236 | "GLUCOSIDES", 237 | "GLUCOSIDES_Sq", 238 | "TREE.HEIGHT", 239 | "TREE.HEIGHT_Sq", 240 | "LEAF.HAIRINESS") 241 | 242 | gallTr <- "GALLTYPE" 243 | 244 | # Independent term 245 | indep <- paste(c(salixTr, gallTr), collapse = "+") 246 | 247 | # Interaction term (without Square) 248 | salixTrNoSq <- c("TREE.VOLUME", 249 | "LEAF.THICKNESS", 250 | "GLUCOSIDES", 251 | "TREE.HEIGHT", 252 | "LEAF.HAIRINESS") 253 | 254 | gallTrNoSq <- c("GALLTYPE") 255 | 256 | combTr <- combn(c(salixTrNoSq, gallTrNoSq), 2) 257 | inter <- paste(combTr[1,], ":", combTr[2,], collapse = "+") 258 | 259 | # Build formula 260 | FormulaSalGal <- as.formula(paste("~", indep, "+", inter)) 261 | 262 | #========== 263 | # Run model 264 | #========== 265 | salixGalGLMTrait <- fitGLM(salixGalSq, 266 | formula = FormulaSalGal, 267 | family = binomial(link = "logit")) 268 | 269 | #============================ 270 | # Log-likelihood and Tjur's D 271 | #============================ 272 | logLik(salixGalGLMTrait, error = 0.001) 273 | tjur(salixGalGLMTrait) 274 | 275 | ##################### 276 | # Galler - Parasitoid 277 | ##################### 278 | # Construct squared traits for numerical traits 279 | galParaSq <- polyTrait(galPara) 280 | 281 | #============== 282 | # Build formula 283 | #============== 284 | # Select traits 285 | gallTr <- c("GALLTYPE", 286 | "BODYLENGTH.GAL", 287 | "BODYLENGTH.GAL_Sq", 288 | "PHENOLOGY.GAL", 289 | "OVIPOS.STRATEGY", 290 | "GALL.WALL", 291 | "GALL.WALL_Sq") 292 | 293 | paraTr <- c("P.I", 294 | "OVIPOS.LNTH", 295 | "OVIPOS.LNTH_Sq", 296 | "ATTACK.STAGE", 297 | "PHENOLOGY.PAR", 298 | "BODYLENGTH.PAR", 299 | "BODYLENGTH.PAR_Sq", 300 | "ENDO.ECTO") 301 | 302 | # Independent term 303 | indep <- paste(c(gallTr, paraTr), collapse = "+") 304 | 305 | # Interaction term (without Square) 306 | gallTrNoSq <- c("GALLTYPE", 307 | "BODYLENGTH.GAL", 308 | "PHENOLOGY.GAL", 309 | "OVIPOS.STRATEGY", 310 | "GALL.WALL") 311 | 312 | paraTrNoSq <- c("P.I", 313 | "OVIPOS.LNTH", 314 | "ATTACK.STAGE", 315 | "PHENOLOGY.PAR", 316 | "BODYLENGTH.PAR", 317 | "ENDO.ECTO") 318 | 319 | combTr <- combn(c(gallTrNoSq, paraTrNoSq), 2) 320 | inter <- paste(combTr[1,], ":", combTr[2,], collapse = "+") 321 | 322 | # Build formula 323 | FormulaGalPara <- as.formula(paste("~", indep, "+", inter)) 324 | 325 | #========== 326 | # Run model 327 | #========== 328 | galParaGLMTrait <- fitGLM(galParaSq, 329 | formula = FormulaGalPara, 330 | family = binomial(link = "logit")) 331 | 332 | #============================ 333 | # Log-likelihood and Tjur's D 334 | #============================ 335 | logLik(galParaGLMTrait, error = 0.001) 336 | tjur(galParaGLMTrait) 337 | ``` 338 | 339 | # `fit4corner` 340 | 341 | ```{r} 342 | # Construct squared traits for numerical traits 343 | salixGalSq <- polyTrait(salixGal) 344 | 345 | #============== 346 | # Build formula 347 | #============== 348 | # Select traits 349 | salixTr <- c("TREE.VOLUME", 350 | "TREE.VOLUME_Sq", 351 | "LEAF.THICKNESS", 352 | "GLUCOSIDES", 353 | "GLUCOSIDES_Sq", 354 | "TREE.HEIGHT", 355 | "TREE.HEIGHT_Sq", 356 | "LEAF.HAIRINESS") 357 | 358 | gallTr <- "GALLTYPE" 359 | 360 | # Independent term 361 | indep <- paste(c(salixTr, gallTr), collapse = "+") 362 | 363 | # Interaction term (without Square) 364 | salixTrNoSq <- c("TREE.VOLUME", 365 | "LEAF.THICKNESS", 366 | "GLUCOSIDES", 367 | "TREE.HEIGHT", 368 | "LEAF.HAIRINESS") 369 | 370 | gallTrNoSq <- c("GALLTYPE") 371 | 372 | combTr <- expand.grid(salixTrNoSq, gallTrNoSq) 373 | inter <- paste(combTr[,1], ":", combTr[,2], collapse = "+") 374 | 375 | # Build formula 376 | FormulaSalGal <- as.formula(paste("~", indep, "+", inter)) 377 | 378 | #========== 379 | # Run model 380 | #========== 381 | salixGal4cornerTrait <- fitGLM(salixGalSq, 382 | formula = FormulaSalGal, 383 | family = binomial(link = "logit")) 384 | 385 | #============================ 386 | # Log-likelihood and Tjur's D 387 | #============================ 388 | logLik(salixGal4cornerTrait, error = 0.001) 389 | tjur(salixGal4cornerTrait) 390 | 391 | 392 | ##################### 393 | # Galler - Parasitoid 394 | ##################### 395 | # Construct squared traits for numerical traits 396 | galParaSq <- polyTrait(galPara) 397 | 398 | #============== 399 | # Build formula 400 | #============== 401 | # Select traits 402 | gallTr <- c("GALLTYPE", 403 | "BODYLENGTH.GAL", 404 | "BODYLENGTH.GAL_Sq", 405 | "PHENOLOGY.GAL", 406 | "OVIPOS.STRATEGY", 407 | "GALL.WALL", 408 | "GALL.WALL_Sq") 409 | 410 | paraTr <- c("P.I", 411 | "OVIPOS.LNTH", 412 | "OVIPOS.LNTH_Sq", 413 | "ATTACK.STAGE", 414 | "PHENOLOGY.PAR", 415 | "BODYLENGTH.PAR", 416 | "BODYLENGTH.PAR_Sq", 417 | "ENDO.ECTO") 418 | 419 | # Independent term 420 | indep <- paste(c(gallTr, paraTr), collapse = "+") 421 | 422 | # Interaction term (without Square) 423 | gallTrNoSq <- c("GALLTYPE", 424 | "BODYLENGTH.GAL", 425 | "PHENOLOGY.GAL", 426 | "OVIPOS.STRATEGY", 427 | "GALL.WALL") 428 | 429 | paraTrNoSq <- c("P.I", 430 | "OVIPOS.LNTH", 431 | "ATTACK.STAGE", 432 | "PHENOLOGY.PAR", 433 | "BODYLENGTH.PAR", 434 | "ENDO.ECTO") 435 | 436 | combTr <- expand.grid(gallTrNoSq, paraTrNoSq) 437 | inter <- paste(combTr[,1], ":", combTr[,2], collapse = "+") 438 | 439 | # Build formula 440 | FormulaGalPara <- as.formula(paste("~", indep, "+", inter)) 441 | 442 | #========== 443 | # Run model 444 | #========== 445 | galParaGLMTrait <- fitGLM(galParaSq, 446 | formula = FormulaGalPara, 447 | family = binomial(link = "logit")) 448 | 449 | #============================ 450 | # Log-likelihood and Tjur's D 451 | #============================ 452 | logLik(galParaGLMTrait, error = 0.001) 453 | tjur(galParaGLMTrait) 454 | ``` 455 | 456 | # `fitIMC` 457 | 458 | ```{r, eval=TRUE, echo = FALSE} 459 | # Salix-galler 460 | salixGalIMC <- readRDS("salixGalIMC.RDS") 461 | 462 | logLik(salixGalIMC, error = 0.001) # -137.0956 463 | tjur(salixGalIMC) # 0.526749 464 | 465 | # Galler-parasitoids 466 | galParaIMC <- readRDS("galParaIMC.RDS") 467 | 468 | logLik(galParaIMC, error = 0.001) # -690.649 469 | tjur(galParaIMC) # 0.5714072 470 | 471 | ``` 472 | This function take a long time to run. 473 | 474 | ```{r, eval=FALSE} 475 | # Salix-galler 476 | salixGalIMC <- fitIMC(salixGal, 477 | d = 1) 478 | 479 | logLik(salixGalIMC, error = 0.001) # -137.0956 480 | tjur(salixGalIMC) # 0.526749 481 | 482 | # Galler-parasitoids 483 | galParaIMC <- fitIMC(galPara, 484 | d = 1) 485 | 486 | logLik(galParaIMC, error = 0.001) # -690.649 487 | tjur(galParaIMC) # 0.5714072 488 | 489 | ``` 490 | 491 | --------------------------------------------------------------------------------