├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── R ├── ROBIN.R ├── ROBINFast.R ├── ROBINWeighted.R ├── ROBIN_external_function.R ├── ROBIN_plots.R ├── gpregeFunctions.R ├── gptk_CGoptim.R ├── gptk_SCGoptim.R ├── gptk_boundedTransform.R ├── gptk_cmpndKernCompute.R ├── gptk_cmpndKernExpandParam.R ├── gptk_cmpndKernExtractParam.R ├── gptk_cmpndKernGradient.R ├── gptk_cmpndKernParamInit.R ├── gptk_exhaustivePlot.R ├── gptk_expTransform.R ├── gptk_gpBlockIndices.R ├── gptk_gpComputeAlpha.R ├── gptk_gpComputeM.R ├── gptk_gpCovGrads.R ├── gptk_gpCreate.R ├── gptk_gpDataIndices.R ├── gptk_gpExpandParam.R ├── gptk_gpExtractParam.R ├── gptk_gpGradient.R ├── gptk_gpLogLikeGradients.R ├── gptk_gpLogLikelihood.R ├── gptk_gpMeanFunctionGradient.R ├── gptk_gpObjective.R ├── gptk_gpOptimise.R ├── gptk_gpOptions.R ├── gptk_gpPlot.R ├── gptk_gpPosteriorMeanVar.R ├── gptk_gpScaleBiasGradient.R ├── gptk_gpUpdateAD.R ├── gptk_gpUpdateKernels.R ├── gptk_gptk-internal.R ├── gptk_kernCompute.R ├── gptk_kernCreate.R ├── gptk_kernDiagCompute.R ├── gptk_kernDiagGradX.R ├── gptk_kernDiagGradient.R ├── gptk_kernExpandParam.R ├── gptk_kernExtractParam.R ├── gptk_kernGradX.R ├── gptk_kernGradient.R ├── gptk_kernParamInit.R ├── gptk_localCovarianceGradients.R ├── gptk_localSCovarianceGradients.R ├── gptk_modelExpandParam.R ├── gptk_modelExtractParam.R ├── gptk_modelOut.R ├── gptk_modelOutputGrad.R ├── gptk_optimiDefaultConstraint.R ├── gptk_optimiDefaultOptions.R ├── gptk_rbfKernCompute.R ├── gptk_rbfKernExpandParam.R ├── gptk_rbfKernExtractParam.R ├── gptk_rbfKernGradient.R ├── gptk_rbfKernParamInit.R ├── gptk_sigmoidTransform.R ├── gptk_whiteKernCompute.R ├── gptk_whiteKernExpandParam.R ├── gptk_whiteKernExtractParam.R ├── gptk_whiteKernGradient.R ├── gptk_whiteKernParamInit.R └── gptk_zeroAxes.R ├── README.md ├── inst ├── NEWS └── example │ └── football.gml ├── man ├── createITPSplineResult.Rd ├── img │ └── logoRobin.png ├── membershipCommunities.Rd ├── methodCommunity.Rd ├── plot.robin.Rd ├── plotComm.Rd ├── plotGraph.Rd ├── plotMultiCompare.Rd ├── prepGraph.Rd ├── random.Rd ├── randomNoW.Rd ├── randomWeight.Rd ├── rewireCompl.Rd ├── rewireOnl.Rd ├── rewireWeight.Rd ├── robinAUC.Rd ├── robinCompare.Rd ├── robinCompareFast.Rd ├── robinCompareFastWeight.Rd ├── robinCompareNoParallel.Rd ├── robinFDATest.Rd ├── robinGPTest.Rd ├── robinRobust.Rd ├── robinRobustFast.Rd ├── robinRobustFastWeighted.Rd └── robinRobustNoParallel.Rd ├── robin.Rproj └── vignettes └── robin.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^robin\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^not_really$ 4 | ^.Rshistory$ 5 | ^doc$ 6 | ^Meta$ 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | doc 7 | Meta 8 | .DS_Store 9 | /doc/ 10 | /Meta/ 11 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: robin 2 | Title: ROBustness in Network 3 | Version: 2.1.0 4 | Authors@R: c( 5 | person("Valeria", "Policastro", role=c("aut", "cre"), email="valeria.policastro@gmail.com"), 6 | person("Dario", "Righelli", role=c("aut"), email="dario.righelli@gmail.com"), 7 | person("Luisa", "Cutillo", role=c("aut"), email="l.cutillo@leeds.ac.uk"), 8 | person("Italia", "De Feis", role=c("aut"), email="i.defeis@na.iac.cnr.it"), 9 | person("Annamaria", "Carissimo", role=c("aut"), email="a.carissimo@na.iac.cnr.it")) 10 | Maintainer: Valeria Policastro 11 | Description: Assesses the robustness of the community structure of a network found by one or more community detection algorithm to give indications about their reliability. It detects if the community structure found by a set of algorithms is statistically significant and compares the different selected detection algorithms on the same network. robin helps to choose among different community detection algorithms the one that better fits the network of interest. Reference in Policastro V., Righelli D., Carissimo A., Cutillo L., De Feis I. (2021) . 12 | License: MIT + file LICENSE 13 | Encoding: UTF-8 14 | LazyData: true 15 | RoxygenNote: 7.3.2 16 | URL: https://github.com/ValeriaPolicastro/robin 17 | Depends: 18 | igraph 19 | Imports: 20 | ggplot2, 21 | networkD3, 22 | DescTools, 23 | fdatest, 24 | methods, 25 | gridExtra, 26 | spam, 27 | qpdf, 28 | Matrix, 29 | perturbR, 30 | BiocParallel, 31 | reshape2 32 | VignetteBuilder: knitr 33 | Suggests: 34 | devtools, 35 | knitr, 36 | rmarkdown, 37 | testthat (>= 2.1.0) 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Policastro Valeria -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,robin) 4 | export(membershipCommunities) 5 | export(methodCommunity) 6 | export(plotComm) 7 | export(plotGraph) 8 | export(plotMultiCompare) 9 | export(prepGraph) 10 | export(random) 11 | export(robinAUC) 12 | export(robinCompare) 13 | export(robinFDATest) 14 | export(robinGPTest) 15 | export(robinRobust) 16 | import(fdatest) 17 | import(ggplot2) 18 | import(graphics) 19 | import(igraph) 20 | import(networkD3) 21 | import(parallel) 22 | import(perturbR) 23 | import(qpdf) 24 | importFrom(BiocParallel,bplapply) 25 | importFrom(BiocParallel,bpparam) 26 | importFrom(DescTools,AUC) 27 | importFrom(grDevices,dev.off) 28 | importFrom(grDevices,dev.set) 29 | importFrom(grDevices,gray.colors) 30 | importFrom(grDevices,pdf) 31 | importFrom(grDevices,rgb) 32 | importFrom(graphics,image) 33 | importFrom(igraph,vcount) 34 | importFrom(methods,is) 35 | importFrom(reshape2,melt) 36 | importFrom(stats,optim) 37 | importFrom(stats,optimize) 38 | importFrom(stats,qgamma) 39 | importFrom(stats,qnorm) 40 | importFrom(stats,rnorm) 41 | importFrom(stats,sd) 42 | importFrom(stats,var) 43 | importFrom(utils,read.table) 44 | importFrom(utils,tail) 45 | -------------------------------------------------------------------------------- /R/ROBIN_external_function.R: -------------------------------------------------------------------------------- 1 | ############### COMPARE METHOD ########## 2 | 3 | #' robinCompare 4 | #' 5 | #' @description This function compares the robustness of two community 6 | #' detection algorithms. 7 | #' @param graph The output of prepGraph. 8 | #' @param method1 The first clustering method, one of "walktrap", 9 | #' "edgeBetweenness", "fastGreedy", "louvain", "spinglass", "leadingEigen", 10 | #' "labelProp", "infomap","leiden","optimal","other". 11 | #' @param args1 A \code{list} of arguments to be passed to the \code{method1} 12 | #' (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters). 13 | #' @param method2 The second custering method one of "walktrap", 14 | #' "edgeBetweenness","fastGreedy", "louvain", "spinglass", "leadingEigen", 15 | #' "labelProp", "infomap","leiden","optimal","other". 16 | #' @param args2 A \code{list} of arguments to be passed to the \code{method2} 17 | #' (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters). 18 | #' @param FUN1 personal designed function when \code{method1} is "other". 19 | #' see \code{\link{methodCommunity}}. 20 | #' @param FUN2 personal designed function when \code{method2} is "other". 21 | #' see \code{\link{methodCommunity}}. 22 | #' @param measure The stability measure, one of "vi", "nmi", "split.join", 23 | #' "adjusted.rand" all normalized and used as distances. 24 | #' "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand. 25 | #' @param rewire.w.type for weighted graph. Option to rewire one of "Rewire", 26 | #' "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 27 | #' "Sum" method only for continuous weights. 28 | #' @param type The type of robin construction, dependent or independent. 29 | # @param dist Option to rewire in a manner that retains overall graph weight 30 | # regardless of distribution of edge weights. This option is invoked by putting 31 | # any text into this field. Defaults to "Other". See 32 | # \code{\link[perturbR]{rewireR}} for details. 33 | #' @param BPPARAM the BiocParallel object of class \code{bpparamClass} that 34 | #' specifies the back-end to be used for computations. See 35 | #' \code{\link[BiocParallel]{bpparam}} for details. 36 | #' @param verbose flag for verbose output (default as TRUE). 37 | #' 38 | #' 39 | #' @return A robin object a list with: 40 | #' - "Mean1" and "Mean2" matrices with the means of the procedure for the first 41 | #' and the second method respectively. 42 | #' - "Communities1" and "Communities2" output communities with the first and 43 | #' second method respectively. 44 | #' - "Method1" and "Method2" the two community detection algorithm used 45 | #' - "graph" the input graph. 46 | #' @import igraph 47 | #' @export 48 | #' 49 | #' @examples 50 | #' my_file <- system.file("example/football.gml", package="robin") 51 | #' graph <- prepGraph(file=my_file, file.format="gml") 52 | #' robinCompare(graph=graph, method1="louvain", args1 = list(resolution=0.8), 53 | #' method2="leiden") 54 | ## Weighted example: 55 | # E(graph)$weight <- round(runif(ecount(graph),min=1,max=10)) 56 | # robinCompare(graph=graph, method1="louvain", args1 = list(resolution=0.8), 57 | # method2="leiden") 58 | 59 | robinCompare <- function(graph, 60 | method1=c("walktrap", "edgeBetweenness", "fastGreedy", 61 | "leadingEigen", "louvain", "spinglass", 62 | "labelProp", "infomap", "optimal", "leiden", 63 | "other"), 64 | args1=list(), 65 | method2=c("walktrap", "edgeBetweenness", "fastGreedy", 66 | "leadingEigen", "louvain", "spinglass", 67 | "labelProp", "infomap", "optimal", "leiden", 68 | "other"), 69 | args2=list(), 70 | FUN1=NULL, FUN2=NULL, 71 | measure=c("vi", "nmi","split.join", "adjusted.rand"), 72 | type="independent", 73 | verbose=TRUE, rewire.w.type="Rewire", 74 | #rewire.w.type=c("Rewire","Shuffle","Garlaschelli","Sum"),dist="Other", 75 | BPPARAM=BiocParallel::bpparam()) 76 | { 77 | 78 | methods <- c(method1, method2) 79 | 80 | # Weigthed version 81 | if ( is_weighted(graph) ) 82 | { 83 | print("Weighted Network Parallel Function") 84 | output <- robinCompareFastWeight(graph=graph, method1=method1, args1=args1, 85 | method2=method2, args2=args2, FUN1=FUN1, FUN2=FUN2, measure=measure, 86 | verbose=verbose,rewire.w.type=rewire.w.type, BPPARAM=BPPARAM) #dist=dist 87 | } else { 88 | if(type=="dependent") 89 | { 90 | 91 | print("Unweighted Network No Parallel Function") 92 | output <- robinCompareNoParallel(graph=graph, method1=method1, args1=args1, 93 | method2=method2, args2=args2, measure=measure, 94 | type=type) 95 | }else{ 96 | print("Unweighted Network Parallel Function") 97 | output <- robinCompareFast(graph=graph, method1=method1, args1=args1, 98 | method2=method2, args2=args2, 99 | FUN1=FUN1, FUN2=FUN2, measure=measure, 100 | verbose=verbose,BPPARAM=BPPARAM) 101 | 102 | } 103 | 104 | } 105 | 106 | 107 | 108 | 109 | outputRobin <- c(output, Method=methods, list(graph=graph)) 110 | 111 | class(outputRobin) <- "robin" 112 | return(outputRobin) 113 | 114 | } 115 | 116 | 117 | ############### ROBUST METHOD ########## 118 | #' robinRobust 119 | #' @description This functions implements a procedure to examine the stability 120 | #' of the partition recovered by some algorithm against random perturbations 121 | #' of the original graph structure. 122 | #' @param graph The output of prepGraph. 123 | #' @param graphRandom The output of random function. 124 | #' @param method The clustering method, one of "walktrap", "edgeBetweenness", 125 | #' "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 126 | #' "leiden","optimal". 127 | #' @param ... other parameters for the community detection methods. 128 | #' @param FUN in case the @method parameter is "other" there is the possibility 129 | #' to use a personal function passing its name through this parameter. 130 | #' The personal parameter has to take as input the @graph and the @weights 131 | #' (that can be NULL), and has to return a community object. 132 | #' @param measure The stability measure, one of "vi", "nmi", "split.join", 133 | #' "adjusted.rand" all normalized and used as distances. 134 | #' "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand. 135 | #' @param type The type of robin construction, dependent or independent. 136 | #' @param rewire.w.type for weighted graph. Option to rewire one of "Rewire", 137 | #' "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 138 | #' "Sum" method only for continuous weights. 139 | # @param dist for weighted graph with "Garlaschelli" @rewire.w.type method. 140 | # Option to rewire in a manner that retains overall graph weight regardless of 141 | # distribution of edge weights. This option is invoked by putting any text into 142 | # this field. Defaults to "Other". See \code{\link[perturbR]{rewireR}} for 143 | # details. 144 | #' @param BPPARAM the BiocParallel object of class \code{bpparamClass} that 145 | #' specifies the back-end to be used for computations. See 146 | #' \code{\link[BiocParallel]{bpparam}} for details. 147 | #' @param verbose flag for verbose output (default as TRUE). 148 | #' 149 | #' @return A robin object a list with: 150 | #' - "Mean" and "MeanRandom" matrices with the means of the procedure for the 151 | #' graph and the random graph respectively. 152 | #' - "Communities" the output communities with the method used. 153 | #' - "graph" the real data graph. 154 | #' @import igraph 155 | #' @export 156 | #' 157 | #' @examples 158 | #' my_file <- system.file("example/football.gml", package="robin") 159 | #' graph <- prepGraph(file=my_file, file.format="gml") 160 | #' graphRandom <- random(graph=graph) 161 | #' robinRobust(graph=graph, graphRandom=graphRandom, method="leiden") 162 | ## Weighted Example: 163 | # E(graph)$weight <- round(runif(ecount(graph),min=1,max=10)) 164 | # graphRandom <- random(graph=graph) 165 | # robinRobust(graph=graph, graphRandom=graphRandom, method="leiden") 166 | 167 | robinRobust <- function(graph, graphRandom, 168 | method=c("walktrap", "edgeBetweenness", 169 | "fastGreedy", "louvain", "spinglass", 170 | "leadingEigen", "labelProp", "infomap", 171 | "optimal", "leiden", "other"), 172 | ..., 173 | FUN=NULL, measure= c("vi", "nmi","split.join", "adjusted.rand"), 174 | type="independent",verbose=TRUE, 175 | rewire.w.type=c("Rewire","Shuffle","Garlaschelli","Sum"), 176 | #dist="Other", 177 | BPPARAM=BiocParallel::bpparam()) 178 | { 179 | 180 | methods <- c("real data", "null model") 181 | 182 | # Weigthed version 183 | if ( is_weighted(graph) ) 184 | { 185 | print("Weighted Network Parallel Function") 186 | output <- robinRobustFastWeighted(graph=graph, graphRandom=graphRandom, 187 | method=method, 188 | ..., 189 | FUN1=FUN, measure=measure, 190 | verbose=verbose, 191 | rewire.w.type=rewire.w.type, 192 | #dist=dist, 193 | BPPARAM=BPPARAM) 194 | } else { 195 | 196 | if(type=="dependent") 197 | { 198 | print("Unweighted Network No Parallel Function") 199 | # No Parallel 200 | output <- robinRobustNoParallel(graph=graph, graphRandom= graphRandom, 201 | method=method, 202 | ..., 203 | FUN=FUN, measure=measure, 204 | type=type, verbose=verbose) 205 | }else{ 206 | print("Unweighted Network Parallel Function") 207 | # Parallel version: 208 | output <- robinRobustFast(graph=graph, graphRandom=graphRandom, 209 | method=method, 210 | ..., 211 | FUN1=FUN, measure=measure, 212 | verbose=verbose,BPPARAM=BPPARAM) 213 | } 214 | } 215 | outputRobin <- c(output, Method=methods, list(graph=graph)) 216 | 217 | class(outputRobin) <- "robin" 218 | return(outputRobin) 219 | } 220 | 221 | ####### GRAPH RANDOM ######### 222 | #' random 223 | #' 224 | #' @description This function randomly rewires the edges while preserving the original graph's 225 | #' degree distribution. 226 | #' @param graph The output of prepGraph. 227 | #' @param rewire.w.type for weighted graph. Option to rewire one of "Rewire", 228 | #' "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 229 | #' "Sum" method only for continuous weights. 230 | # @param dist for weighted graph with "Garlaschelli" @rewire.w.type method. 231 | # Option to rewire in a manner that retains overall graph weight regardless of 232 | # distribution of edge weights. This option is invoked by putting any text into 233 | # this field. Defaults to "Other". See \code{\link[perturbR]{rewireR}} for 234 | # details. 235 | #' @param verbose flag for verbose output (default as FALSE) 236 | #' 237 | #' @return An igraph object, a randomly rewired graph. 238 | #' @import igraph 239 | #' @export 240 | #' 241 | #' @examples 242 | #' my_file <- system.file("example/football.gml", package="robin") 243 | #' graph <- prepGraph(file=my_file, file.format="gml") 244 | #' graphRandom <- random(graph=graph) 245 | 246 | random <- function(graph, rewire.w.type="Rewire", verbose=FALSE) 247 | { 248 | # Weigthed version 249 | if ( is_weighted(graph) ) 250 | { 251 | graphRandom <- randomWeight(graph=graph,rewire.w.type=rewire.w.type, 252 | verbose=verbose) 253 | }else{ 254 | graphRandom <- randomNoW(graph=graph, verbose=verbose) 255 | } 256 | return(graphRandom) 257 | } 258 | 259 | -------------------------------------------------------------------------------- /R/ROBIN_plots.R: -------------------------------------------------------------------------------- 1 | ################ PLOT GRAPH ############### 2 | #' plotGraph 3 | #' 4 | #' @description Graphical interactive representation of the network. 5 | #' @param graph The output of prepGraph. 6 | #' 7 | #' @return Creates an interactive plot, a D3 JavaScript network graph. 8 | #' @import networkD3 9 | #' @export 10 | #' 11 | #' @examples 12 | #' my_file <- system.file("example/football.gml", package="robin") 13 | #' graph <- prepGraph(file=my_file, file.format="gml") 14 | #' plotGraph (graph) 15 | plotGraph <- function(graph) 16 | { 17 | graph_d3 <- networkD3::igraph_to_networkD3(g=graph) 18 | plot <- networkD3::simpleNetwork(graph_d3$links, opacity=0.8, zoom=TRUE, 19 | nodeColour = "#2E66AC", 20 | fontSize=12) 21 | return(plot) 22 | } 23 | 24 | 25 | ######################## PLOT COMMUNITIES ############## 26 | #' plotComm 27 | #' 28 | #' @description Graphical interactive representation of the network and its 29 | #' communities. 30 | #' 31 | #' @param graph The output of prepGraph. 32 | #' @param members A membership vector of the community structure, the output of 33 | #' membershipCommunities. 34 | #' 35 | #' @return Creates an interactive plot with colorful communities, a D3 36 | #' JavaScript network graph. 37 | #' @import networkD3 38 | #' @importFrom methods is 39 | #' @export 40 | #' 41 | #' @examples 42 | #' my_file <- system.file("example/football.gml", package="robin") 43 | #' graph <- prepGraph(file=my_file, file.format="gml") 44 | #' members <- membershipCommunities (graph=graph, method="louvain") 45 | #' plotComm(graph, members) 46 | plotComm <- function(graph, members) 47 | { 48 | stopifnot(methods::is(graph, "igraph")) 49 | stopifnot(methods::is(members, "membership")) 50 | graph_d3 <- networkD3::igraph_to_networkD3(g=graph, group=members) 51 | # Create network plot 52 | plot <- networkD3::forceNetwork(Links=graph_d3$links, Nodes=graph_d3$nodes, 53 | Source='source', Target='target', 54 | NodeID='name', Group='group', opacity=0.8, 55 | fontSize=12, legend=TRUE) 56 | return(plot) 57 | } 58 | 59 | 60 | ############PLOT############## 61 | #' plot.robin 62 | #' 63 | #' @description This function plots two curves: the measure of the null model and the measure 64 | #' of the real graph or the measure of the two community detection algorithms. 65 | #' @param x A robin class object. The output of the functions: 66 | #' \code{\link{robinRobust}} and \code{\link{robinCompare}}. 67 | #' @param title The title for the graph. The default is "Robin plot". 68 | #' @param ... other parameter 69 | #' 70 | #' @return A ggplot object. 71 | #' @import ggplot2 igraph 72 | #' @export 73 | #' 74 | #' @examples 75 | #' \dontrun{my_file <- system.file("example/football.gml", package="robin") 76 | #' graph <- prepGraph(file=my_file, file.format="gml") 77 | #' comp <- robinCompare(graph=graph, method1="fastGreedy",method2="louvain") 78 | #' plot(comp)} 79 | #' 80 | plot.robin <- function(x, title="Robin plot", ...) 81 | { 82 | stopifnot(is(object=x, "robin")) 83 | legend <- c(x$Method1, x$Method2) 84 | if (length(x$Mean1)==0) 85 | { 86 | model1 <- x$Mean 87 | model2 <- x$MeanRandom 88 | }else{ 89 | model1 <- x$Mean1 90 | model2 <- x$Mean2 91 | } 92 | 93 | mvimodel1 <- as.vector((apply(model1, 2, mean))) 94 | mvimodel2 <- as.vector((apply(model2, 2, mean))) 95 | 96 | 97 | percPert <- rep((seq(0,60,5)/100), 2) 98 | mvi <- c(mvimodel1, mvimodel2) 99 | model <-c(rep("model1",13),rep("model2",13)) 100 | dataFrame <- data.frame(percPert, mvi, model) 101 | plotModel <- ggplot2::ggplot(dataFrame, aes(x = percPert, 102 | y = as.numeric(as.character(mvi)), 103 | colour = model, 104 | group = factor(model))) + 105 | geom_line() + 106 | geom_point() + 107 | xlab("Percentage of perturbation") + 108 | ylab("Measure") + 109 | ggplot2::ylim(0,1)+ 110 | ggtitle(title) 111 | 112 | cols <- c("model1" = "#00BFC4", "model2" = "#F8766D") 113 | plot <- plotModel+ggplot2::scale_colour_manual(values = cols, 114 | breaks = c("model1", "model2"), 115 | labels=c(legend[1], legend[2])) 116 | 117 | return(plot) 118 | } 119 | 120 | 121 | #' plotMultiCompare 122 | #' @description This function plots the curves of the measure of many community 123 | #' detection algorithms compared. 124 | #' 125 | #' @param ... all robin objects obtained from the comparison between one 126 | #' community detection algorithm and all the others 127 | #' @param title character a title for the plot (default is "Robin plot") 128 | #' @param ylim1 logical for spanning the y axis from 0 to 1 (default is FALSE) 129 | #' 130 | #' @return a ggplot2 object 131 | #' @importFrom reshape2 melt 132 | #' @export 133 | #' 134 | #' @examples 135 | #' \donttest{my_file <- system.file("example/football.gml", package="robin") 136 | #' graph <- prepGraph(file=my_file, file.format="gml") 137 | #' comp1 <- robinCompare(graph=graph, method1="fastGreedy",method2="louvain") 138 | #' comp2 <- robinCompare(graph=graph, method1="fastGreedy",method2="infomap") 139 | #' plotMultiCompare(comp1,comp2)} 140 | plotMultiCompare <- function(..., title="Robin plot", ylim1=FALSE) 141 | { 142 | objs <- list(...) 143 | lapply(objs, function(x){stopifnot(is(object=x, "robin"))}) 144 | modelsl <- lapply(objs, function(x) 145 | { 146 | legend <- c(x$Method1, x$Method2) 147 | if (length(x$Mean1)==0) 148 | { 149 | model1 <- x$Mean 150 | model2 <- x$MeanRandom 151 | }else{ 152 | model1 <- x$Mean1 153 | model2 <- x$Mean2 154 | } 155 | mvimodel1 <- as.vector((apply(model1, 2, mean))) 156 | mvimodel2 <- as.vector((apply(model2, 2, mean))) 157 | l <- list(mvimodel1, mvimodel2) 158 | names(l) <- legend 159 | return(l) 160 | }) 161 | ll <- unlist(lapply(modelsl, function(x){ return(names(x))})) 162 | llt <- table(ll) 163 | notunique <- names(llt)[llt > 1] 164 | l <- lapply(seq_along(modelsl), function(i) 165 | { 166 | x <- modelsl[[i]] 167 | if(i !=1 ) 168 | { 169 | j <- which(names(x)==notunique) 170 | x <- x[-j] 171 | } 172 | return(x) 173 | }) 174 | 175 | m <- matrix(unlist(l), nrow = 13, byrow = FALSE) 176 | colnames(m) <- unlist(lapply(l,names)) 177 | rownames(m) <- (seq(0,60,5)/100) 178 | mm <- reshape2::melt(m) 179 | colnames(mm) <- c("perc", "Model", "measure") 180 | dataFrame <- data.frame(mm) 181 | ggp <- ggplot2::ggplot(dataFrame, aes(x=dataFrame$perc, y=dataFrame$measure, 182 | colour = dataFrame$Model, 183 | group = dataFrame$Model)) + 184 | geom_line() + 185 | geom_point() + 186 | xlab("Percentage of perturbation") + 187 | ylab("Measure") + 188 | ggtitle(title) 189 | 190 | 191 | # ggp <- ggplot2::ggplot(mm, aes(x=Var1, y=value, 192 | # colour = Var2, 193 | # group = Var2)) + 194 | # geom_line() + 195 | # geom_point() + 196 | # xlab("Percentage of perturbation") + 197 | # ylab("Measure")+ 198 | # labs(colour = "Model") + 199 | # ggtitle(title) 200 | 201 | if(ylim1) ggp <- ggp+ggplot2::ylim(0,1) 202 | return(ggp) 203 | } 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | -------------------------------------------------------------------------------- /R/gpregeFunctions.R: -------------------------------------------------------------------------------- 1 | #AGPL-3 License 2 | .gprege <- function(data, inputs, gpregeOptions) { 3 | 4 | ## GPREGE Gaussian process ranking and estimation of gene expression time-series. 5 | ## FORMAT 6 | ## DESC Fit two GPs with the an RBF (+ noise diagonal) kernel on each 7 | ## profile. One GP kernel is initialised wih a short lengthscale 8 | ## hyperparameter, signal variance as the observed variance and a zero noise 9 | ## variance. It is optimised via scaled conjugate gradients (netlab). The 10 | ## other GP has fixed hyperparameters with a zero inverse-width, zero signal 11 | ## variance and noise variance as the observed variance. The log-ratio of 12 | ## marginal likelihoods of the two hypotheses acts as a score of 13 | ## differential expression for the profile. Comparison via ROC curves is 14 | ## performed against BATS (Angelini et.al, 2007). 15 | ## See Kalaitzis & Lawrence (2011) for a detailed discussion of the 16 | ## ranking algorithm and dataset used. 17 | ## ARG data : The matrix of gene expression profiles; one profile per row. 18 | ## ARG inputs : Inputs to the GP. 19 | ## ARG gpregeOptions$explore: (LOGICAL) Operate in a user interactive mode. 20 | ## Used for examining individual gene expression profiles. 21 | ## ARG gpregeOptions$labels : Contains flags that specify whether the 22 | ## corresponding profile comes from a differentially expressed gene 23 | ## (usually from a ground truth). 24 | ## ARG gpregeOptions$indexRange : Range of indices of profiles on which the 25 | ## function should operate. Useful for selective exploration of specific 26 | ## profiles, e.g. only genes marked as differentially expressed in a ground 27 | ## truth list. 28 | ## ARG gpregeOptions$interpolatedT : New timepoints to interpolate for each 29 | ## profile, based on the estimated function values. 30 | ## ARG gpregeOptions$iters : The number of iterations for scaled-conjugate 31 | ## gradients (SCG) optimisation. 32 | ## ARG gpregeOptions$display : Display gradient and LML information on each 33 | ## SCG iteration. 34 | ## ARG gpregeOptions$inithypers : The matrix of hyperparameter 35 | ## configurations as its rows: 36 | ## [inverse-lengthscale percent-signal-variance percent-noise-variance] 37 | ## The first row corresponds to a (practically constant) function 38 | ## with a very large lengthscale. Such a function will account for 0 percent 39 | ## of the observed variance in the expression profile (hence 0 for signal) 40 | ## and explain it as noise (hence 1 for noise). Subsequent rows 41 | ## (initialisations for SCG optimisation) correspond to functions of various 42 | ## lengthscales that explain all the observed variance as signal. A 43 | ## reasonable lengthscale would be roughly in line with the time-point 44 | ## sampling intervals. 45 | ## ARG gpregeOptions$exhaustPlotRes : The search resolution. Used for 46 | ## interactive mode (explore == 1). 47 | ## ARG gpregeOptions$exhaustPlotLevels : # Exhaustive plot contour levels. 48 | ## Used for interactive mode (explore == 1). 49 | ## ARG gpregeOptions$exhaustPlotMaxWidth : maximum lengthscale to search 50 | ## for. Used for interactive mode (explore == 1). 51 | ## RETURN gpregeOutput$signalvar : The vertical lengthscales of the 52 | ## optimised RBF kernel for each profile. 53 | ## RETURN gpregeOutput$noisevar : Same, for the noise hyperparameter. 54 | ## RETURN gpregeOutput$width : Same, for the horizontal lengthscales of the RBF. 55 | ## RETURN gpregeOutput$LMLs : Log-marginal likelihood of the GP for each profile. 56 | ## RETURN gpregeOutput$interpolatedData : extended dataset with interpolated values. 57 | ## RETURN gpregeOutput$rankingScores : the ranking scores based on the 58 | ## log-ratio of marginal likelihoods. 59 | ## 60 | ## USAGE: gpregeOutput <- gprege(exprs_tp63_RMA, seq(0,240,by=20), gpregeOptions) 61 | ## 62 | ## SEEALSO : gpOptions, gpCreate, gpExpandParam, gpOptimise, gpExtractParam, 63 | ## gpLogLikelihood, gpPosteriorMeanVar 64 | ## 65 | ## COPYRIGHT: Alfredo A. Kalaitzis, 2010, 2011 66 | ## 67 | ## GPREGE 68 | 69 | ## 70 | 71 | if (missing(data)) 72 | stop('Missing data.') 73 | if (missing(inputs)) { 74 | stop('Missing inputs.') 75 | } 76 | if (is.null(gpregeOptions$indexRange)) { 77 | gpregeOptions$indexRange <- 1:dim(data)[1] 78 | } 79 | n = length(gpregeOptions$indexRange) 80 | if (is.null(gpregeOptions$explore)) { 81 | gpregeOptions$explore <- FALSE 82 | } else { 83 | if ((gpregeOptions$explore) && is.null(gpregeOptions$exhaustPlotRes)) { 84 | gpregeOptions$exhaustPlotRes <- 20 85 | } 86 | if ((gpregeOptions$explore) && is.null(gpregeOptions$exhaustPlotMaxWidth)) { 87 | gpregeOptions$exhaustPlotMaxWidth <- 30 88 | } 89 | } 90 | if (is.null(gpregeOptions$iters)) { 91 | gpregeOptions$iters <- 100 92 | } 93 | if (is.null(gpregeOptions$display)) { 94 | gpregeOptions$display <- FALSE 95 | } 96 | gpregeOutput <- list() 97 | if (!is.null(gpregeOptions$interpolatedT)) { 98 | interpolate <- TRUE 99 | newLength = dim(data)[2] + length(gpregeOptions$interpolatedT) 100 | gpregeOutput$interpolatedData <- matrix(0,newLength, n) 101 | } else { 102 | interpolate <- FALSE 103 | } 104 | if (is.null(gpregeOptions$inithypers)) { 105 | gpregeOptions$inithypers <- matrix( c(1/1000, 0, 1, 1/8, 0.999, 1e-3), ncol=3, byrow=TRUE) 106 | } 107 | npsets <- dim(gpregeOptions$inithypers)[1] ## Number of hparams sets. 108 | if (is.null(gpregeOptions$labels)) { 109 | gpregeOptions$labels <- rep(0,n) 110 | } 111 | 112 | options <- .gpOptions() ## Set up model. 113 | options$kern$comp <- list("rbf","white") 114 | x <- inputs 115 | xstar <- matrix(seq(min(x)-(2*(max(x)-min(x))/100), max(x)+((max(x)-min(x))/100), length=100), ncol=1) 116 | 117 | models <- list() ## Allocate space for vectors. 118 | loghypers <- matrix(0, 3, npsets) 119 | LMLs <- matrix(0, n, npsets) 120 | signalvar <- matrix(0, n, 1); noisevar <- matrix(0, n, 1); width <- matrix(0, n, 1) 121 | 122 | ## Remove mean across timepoints. Dataset should not be standardized; Must 123 | ## look to the signal variance in the context of all signal variances. 124 | data <- t(as.matrix(scale(t(data), scale=FALSE))) 125 | 126 | datamax <- max(data); datamin <- min(data) ## Data min/max for plotting limits. 127 | 128 | if (gpregeOptions$explore) { 129 | # graphics.off() 130 | # dev.new(width=5,height=12); 131 | # plot.new() ## Close all devices, open new device, new plot. 132 | # dev.new(width=5,height=5); 133 | # plot.new(); 134 | # dev.new(width=5,height=5); 135 | # plot.new() 136 | } 137 | 138 | for (ix in 1:n) { 139 | i <- gpregeOptions$indexRange[ix] 140 | y <- matrix(data[i,], ncol=1) ## Column vector. 141 | 142 | if (sum(is.nan(y)) > (length(y)/2)) { 143 | cat('Majority of points in profile are NaN.\n') 144 | next 145 | } 146 | 147 | options$isMissingData <- any(is.nan(y)) 148 | options$isSpherical <- !any(is.nan(y)) 149 | stdy = sd(c(y[!is.nan(y)])) ## Profile variance. 150 | 151 | ## Hyperparameters: inverse-lengthscale, signal-variance, noise-variance. 152 | ## Use 1e-3 instead of 0, or R might coerse them into NaN. 153 | # inithypers = t(2 * log(gpregeOptions$inithypers %*% diag(c(1, stdy, stdy)))) 154 | inithypers = t( log( gpregeOptions$inithypers %*% diag(c(1, stdy^2, stdy^2)) ) ) 155 | # lles = c(1000,8,20) 156 | # inithypers = matrix(2*log(c(1e-3, 1e-3, stdy # 1/1.0 (stdy*1e-3) (stdy*0.999) 157 | # , 1/8.0, (stdy*0.999), (stdy*1e-3) 158 | # , 1/20.0, (stdy*0.999), (stdy*1e-3) 159 | # )), nrow=3) 160 | 161 | if (gpregeOptions$explore) { 162 | # dev.set(2) 163 | pdf(file=paste('gpPlot',ix,'.pdf',sep=''), paper="special", width=6, height=4*npsets) 164 | close.screen(all.screens = TRUE) 165 | split.screen(c(dim(inithypers)[2],1)) ## Reset any existing sub-figures setup. 166 | #nf = layout(matrix(c(1:dim(inithypers)[2]), 1:dim(inithypers)[2], 1)); layout.show(nf) 167 | } 168 | 169 | ## Optimise GP log likelihoods. 170 | for (h in 1:npsets) { 171 | models[[h]] <- .gpCreate(dim(x)[2], dim(y)[2], x, y, options) 172 | models[[h]] <- .gpExpandParam(models[[h]], inithypers[, h]) ## This forces kernel computation. 173 | if (h != 1) { 174 | models[[h]] <- .gpOptimise(models[[h]], gpregeOptions$display, gpregeOptions$iters) 175 | loghypers[, h] <- .gpExtractParam(models[[h]], only.values=FALSE) 176 | } 177 | LMLs[ix, h] <- .gpLogLikelihood(models[[h]]) ## GP log-marginal likelihood for model h. 178 | 179 | if (gpregeOptions$explore) { ## Plot the regression... 180 | screen(h); erase.screen(h) ## ...in sub-figure #h. Clear screen. 181 | .gpPlot(models[[h]], xstar, col='blue', xlim=range(xstar), ylim=c(datamin, datamax), 182 | title=paste("Init. length-scale = ", as.character(1/exp(inithypers[1,h]/2)), sep=""), 183 | xlab='time(mins)', ylab=bquote(paste(log[2]~expression~(centred)))) 184 | } 185 | } 186 | 187 | ## Save maximum log-marginal likelihood and respective hyper-parameters. 188 | maxLML <- max(LMLs[ix, ]); mi <- which.max(LMLs[ix, ]) 189 | bestLoghypers <- loghypers[, mi] 190 | width[ix] <- 1/exp(bestLoghypers[1]/2) 191 | signalvar[ix] <- exp(bestLoghypers[2]/2) 192 | noisevar[ix] <- exp(bestLoghypers[3]/2) 193 | 194 | if (interpolate) { 195 | meanVar <- .gpPosteriorMeanVar(models[[mi]], gpregeOptions$interpolatedT, varsigma.return=TRUE) 196 | mu <- meanVar$mu; S <- meanVar$varsigma 197 | ## Add noise sampled from a Gaussian distribution with zero 198 | ## mean and variance equal to the predictive variance on new inputs. 199 | mu <- mu + matrix(rnorm(length(mu)), ncol=1) * noisevar[ix] 200 | gpregeOutput$interpolatedData[, ix] <- c(y, mu) 201 | sortedInputs = sort(c(x, gpregeOutput$interpolatedT)) 202 | idx = sortedInputs$ix #sortedInputs = sortedInputs$x 203 | gpregeOutput$interpolatedData[, ix] = gpregeOutput$interpolatedData[idx, ix] ## Order by augmented inputs. 204 | } 205 | 206 | if (gpregeOptions$explore) { 207 | if (interpolate) { 208 | points(gpregeOutput$interpolatedT, mu, pch = 4, cex = .5, lwd=2, col = 'blue') 209 | } 210 | cat('\n========================================================\n') 211 | cat(' Profile ', as.character(i), '\t\t\t\tLabel: ', as.character(as.numeric(gpregeOptions$labels[i]))) 212 | cat('\n========================================================\n') 213 | cat(sprintf('%-20s %-20s %s\n', 'Length-scale', 'Signal', 'Noise')) 214 | cat(sprintf('% -20.5f % -20.5f % .5f\n\n', width[ix], signalvar[ix], noisevar[ix])) 215 | cat(sprintf('%-20s %-20s %s\n', 'Init.le', 'LML', 'Best')) 216 | best = replace(rep("",npsets), which(LMLs[ix,]==maxLML), " <--") 217 | for (j in 1:npsets) { 218 | cat(sprintf('% -20.0f % -20.8f %s\n', 1/exp(inithypers[1,j]/2), LMLs[ix, j], best[j], '\n', sep='\t\t')) 219 | } 220 | cat(sprintf('\n%-20s %-20s\n','Total st.dev.','Estim.sig + noise')) 221 | cat(sprintf('% -20f % -20f\n\n', sd(c(y)), sum(exp(bestLoghypers[2:3]/2)))) 222 | ## We express the profile-ranking metric through a log-ratio of marginal likelihoods. 223 | cat('Log-ratio (max(LML[2:end]) - LML[1])\n ',max(LMLs[ix,2:npsets])-LMLs[ix,1],'\n') 224 | 225 | # dev.copy(pdf, file = paste('gpPlot',ix,'.pdf', sep='')) 226 | # dev.set(3) 227 | dev.off() 228 | pdf(file=paste('exhaustivePlot',ix,'.pdf',sep=''), paper="special", width=6, height=6) 229 | C = .exhaustivePlot(y, x, xstar, options, gpregeOptions$exhaustPlotMaxWidth, gpregeOptions$exhaustPlotRes, gpregeOptions$exhaustPlotLevels) 230 | dev.off() 231 | # dev.copy(pdf, file = paste('exhaustivePlot',ix,'.pdf', sep='')) 232 | readline(prompt='ENTER to continue') 233 | } else{ 234 | cat(' Profile ', as.character(i), '\n') 235 | } 236 | } 237 | 238 | gpregeOutput$signalvar <- signalvar 239 | gpregeOutput$noisevar <- noisevar 240 | gpregeOutput$width <- width 241 | gpregeOutput$LMLs <- LMLs 242 | gpregeOutput$rankingScores = apply(as.matrix(LMLs[,2:npsets]),1,max) - LMLs[,1] 243 | 244 | return(gpregeOutput) 245 | } -------------------------------------------------------------------------------- /R/gptk_CGoptim.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .CGoptim <- 31 | function (x, fn, grad, options, ...) { 32 | ## option[1] : number of iterations 33 | ## option[2] : interval for the line search 34 | ## option[3] : tolerence for x to terminate the loop 35 | ## option[4] : tolerence for fn to terminate the loop 36 | ## option$display : option of showing the details of optimisaton 37 | 38 | ## y = fn (x) 39 | func <- function(x, ...) fn(x, ...) 40 | 41 | ## gradient function = gr (x) 42 | gradfunc <- function(x, ...) grad(x, ...) 43 | 44 | fn_new <- func(x, ...) 45 | #if ( display ) 46 | # cat ("fn0 :",fn_new, "\n") 47 | 48 | grad_new <- gradfunc(x, ...) 49 | #if ( options$display ) 50 | # cat ("grad0 :",grad_new, "\n\n") 51 | 52 | direction <- -grad_new 53 | lnSchFail <- FALSE 54 | for ( ind in 1:options[[1]] ) { 55 | 56 | x_old <- x 57 | fn_old <- fn_new 58 | grad_old <- grad_new 59 | 60 | grad2 <- crossprod(grad_old) 61 | 62 | if ( grad2 == 0 ) { 63 | objective <- fn_new 64 | xmin <- x 65 | ans <- list(xmin=xmin, objective=objective, lnSchFail=lnSchFail) 66 | return (ans) 67 | } 68 | 69 | dnorm <- sqrt(sum(direction*direction)) 70 | line_dir <- direction / dnorm 71 | ## cat ("\n line_dir :", line_dir, "\n\n") 72 | lnSch <- try( optimize(.fn_line, options[[2]], para0=x_old, direction=line_dir, fun=fn, ...) ) 73 | 74 | if ( is.list(lnSch) ) { 75 | x <- x_old + lnSch$minimum * line_dir 76 | fn_new <- lnSch$objective 77 | fnmin <- min(fn_old, fn_new) 78 | if ( fnmin==fn_new ) { 79 | xnmin <- x 80 | } else { 81 | xnmin <- x_old 82 | } 83 | } else { 84 | warning("Line search failed! \n") 85 | x <- xnmin 86 | fn_new <- fnmin 87 | lnSchFail <- TRUE 88 | 89 | xmin <- xnmin 90 | objective <- fnmin 91 | ans <- list(xmin=xmin, objective=objective, lnSchFail=lnSchFail) 92 | return (ans) 93 | } 94 | 95 | if ( max(abs(x-x_old))=0 ) { 41 | d <- -gradnew 42 | mu <- crossprod(d, gradnew) 43 | } 44 | kappa <- crossprod(d, d) 45 | if ( kappa=0 ) { 88 | success <- 1 89 | nsuccess <- nsuccess+1 90 | x <- xnew 91 | fnow <- fnew 92 | } else { 93 | success <- 0 94 | fnow <- fold 95 | } 96 | if (display) 97 | cat("Cycle ", j, "Error ", round(fnow, digits=4), "Scale ", beta, "\n") 98 | 99 | if ( success == 1 ) 100 | if ( (max(abs(alpha*d)) 0.75 ) 121 | beta <- max(0.5*beta, betamin) 122 | 123 | if ( nsuccess == nparams ) { 124 | d <- -gradnew 125 | nsuccess <- 0 126 | } else { 127 | if ( success==1 ) { 128 | gamma <- (crossprod(gradold-gradnew, gradnew)/mu)[1] 129 | d <- gamma*d-gradnew 130 | } 131 | } 132 | 133 | j <- j+1 134 | } 135 | 136 | xmin <- x 137 | objective <- fold 138 | ans <- list(xmin=xmin, objective=objective) 139 | warning("Maximum number of iterations has been exceeded.\n") 140 | return (ans) 141 | } 142 | -------------------------------------------------------------------------------- /R/gptk_boundedTransform.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | 31 | 32 | .boundedTransform <- 33 | function (x, transform="atox", bounds) { 34 | 35 | eps <- 2.2204e-16 36 | 37 | thre <- 36 ## threshold 38 | y <- array(0, dim(as.array(x))) 39 | 40 | if ( "atox" == transform ) { 41 | for ( ind in seq_along(as.array(x)) ) { 42 | if ( x[ind] > thre ) 43 | y[ind] <- 1-eps 44 | else if ( x[ind] < -thre ) 45 | y[ind] <- eps 46 | else 47 | y[ind] <- 1/(1+exp(-x[ind])) 48 | } 49 | y <- (bounds[2] - bounds[1])*y + bounds[1] 50 | } else if ( "xtoa" == transform ) { 51 | x <- (x - bounds[1]) / (bounds[2] - bounds[1]) 52 | for ( ind in seq_along(as.array(x)) ) { 53 | y[ind] <- .complexLog(x[ind]/(1-x[ind])) 54 | } 55 | } else if ( "gradfact" == transform ) { 56 | y <- (x-bounds[1])*(1-(x-bounds[1])/(bounds[2] - bounds[1])) 57 | } 58 | 59 | return (y) 60 | } 61 | -------------------------------------------------------------------------------- /R/gptk_cmpndKernCompute.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .cmpndKernCompute <- 31 | function (kern, x, x2) { 32 | if ( nargs()>2 ) { 33 | i <- 1 34 | if ( !is.na(kern$comp[[i]]$index) ) { 35 | k <- .kernCompute(kern$comp[[i]], x[,kern$comp[[i]]$index], x2[,kern$comp[[i]]$index]) 36 | } else { 37 | k <- .kernCompute(kern$comp[[i]], x, x2) 38 | } 39 | for ( i in seq(2, length.out=(length(kern$comp)-1)) ) 40 | if ( !is.na(kern$comp[[i]]$index) ) { 41 | k <- k+.kernCompute(kern$comp[[i]], x[,kern$comp[[i]]$index], x2[,kern$comp[[i]]$index]) 42 | } else { 43 | k <- k+.kernCompute(kern$comp[[i]], x, x2) 44 | } 45 | } else { 46 | i <- 1 47 | if ( !is.na(kern$comp[[i]]$index) ) { 48 | k <- .kernCompute(kern$comp[[i]], x[,kern$comp[[i]]$index]) 49 | } else { 50 | k <- .kernCompute(kern$comp[[i]], x) 51 | } 52 | for ( i in seq(2, length.out=(length(kern$comp)-1)) ) 53 | if ( !is.na(kern$comp[[i]]$index) ) { 54 | k <- k+.kernCompute(kern$comp[[i]], x[,kern$comp[[i]]$index]) 55 | } else { 56 | k <- k+.kernCompute(kern$comp[[i]], x) 57 | } 58 | } 59 | return (k) 60 | } 61 | -------------------------------------------------------------------------------- /R/gptk_cmpndKernExpandParam.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .cmpndKernExpandParam <- 31 | function (kern, params) { 32 | if ( is.list(params) ) 33 | params <- params$values 34 | params <- params %*% Matrix::Matrix(t(kern$paramGroups)) ## Params still log-transformed at this point. 35 | startVal <- 1 36 | endVal <- 0 37 | kern$whiteVariance <- 0 38 | for ( i in seq(along=kern$comp) ) { 39 | endVal <- endVal+kern$comp[[i]]$nParams 40 | kern$comp[[i]] <- .kernExpandParam(kern$comp[[i]], params[seq(startVal,len=kern$comp[[i]]$nParams)]) 41 | ## Used to be: kern$comp[[i]] <- kernExpandParam(kern$comp[[i]], params[startVal:endVal]) 42 | startVal <- endVal+1 43 | if ( "white" %in% kern$comp[[i]]$type ) { 44 | kern$whiteVariance <- kern$whiteVariance+kern$comp[[i]]$variance 45 | } else if ( "whiteVariance" %in% names(kern$comp[[i]]) ) { 46 | kern$whiteVariance <- kern$whiteVariance+kern$comp[[i]]$whiteVariance 47 | } 48 | } 49 | 50 | return (kern) 51 | } 52 | -------------------------------------------------------------------------------- /R/gptk_cmpndKernExtractParam.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .cmpndKernExtractParam <- 31 | function (kern, only.values=TRUE, 32 | untransformed.values=FALSE) { 33 | 34 | startVal <- 1 35 | endVal <- 0 36 | 37 | if ( only.values ) { 38 | params <- c() 39 | 40 | for ( i in seq(along=kern$comp) ) 41 | params <- c(params, .kernExtractParam(kern$comp[[i]], 42 | untransformed.values=untransformed.values)) 43 | 44 | } else { 45 | storedTypes <- c() 46 | params <- c() 47 | paramNames <- c() 48 | origNames <- c() 49 | for ( i in seq(along=kern$comp) ) { 50 | paramsList <- .kernExtractParam(kern$comp[[i]], only.values=only.values, 51 | untransformed.values=untransformed.values) 52 | params <- c(params, paramsList) 53 | kernName <- paste(kern$comp[[i]]$type, length(grep(kern$comp[[i]]$type, storedTypes))+1, sep="") 54 | paramName <- paste(kernName, names(paramsList), sep="_") 55 | origNames <- c(origNames, paramName) 56 | storedTypes <- c(storedTypes, kern$comp[[i]]$type) 57 | } 58 | } 59 | 60 | paramNames <- array() 61 | if ( "paramGroups" %in% names(kern) ) { 62 | paramGroups <- kern$paramGroups 63 | for ( i in seq(length.out=dim(paramGroups)[2]) ) { 64 | ind <- grep(1, paramGroups[,i]) 65 | if ( !only.values ) { 66 | paramNames[i] <- origNames[ind[1]] 67 | for ( j in seq(2, length.out=length(ind)-1) ) 68 | paramNames[i] <- paste(paramNames[i], origNames[ind[j]],sep="/") 69 | } 70 | 71 | paramGroups[ind[seq(2,length(ind),length=length(ind)-1)], i] <- 0 72 | } 73 | } 74 | 75 | params <- params%*%paramGroups 76 | if ( !only.values ) 77 | names(params) <- paramNames 78 | 79 | return (params) 80 | } 81 | -------------------------------------------------------------------------------- /R/gptk_cmpndKernGradient.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .cmpndKernGradient <- 31 | function (kern, x, x2, covGrad) { 32 | if ( nargs()<4 ) 33 | covGrad <- x2 34 | 35 | g <- array(0, dim(kern$paramGroups)[1]) 36 | startVal <- 1 37 | endVal <- 0 38 | 39 | for ( i in seq(along=kern$comp) ) { 40 | endVal <- endVal + kern$comp[[i]]$nParams 41 | if ( !is.na(kern$comp[[i]]$index) ) { 42 | if ( nargs() < 4 ) { 43 | g[seq(startVal,len=kern$comp[[i]]$nParams)] <- .kernGradient(kern$comp[[i]], x[,kern$comp[[i]]$index], covGrad) 44 | ## Used to be: g[startVal:endVal] <- kernGradient(kern$comp[[i]], x[,kern$comp[[i]]$index], covGrad) 45 | } else { 46 | g[seq(startVal,len=kern$comp[[i]]$nParams)] <- .kernGradient(kern$comp[[i]], x[,kern$comp[[i]]$index], x2[,kern$comp[[i]]$index], covGrad) 47 | ## Used to be: g[startVal:endVal] <- kernGradient(kern$comp[[i]], x[,kern$comp[[i]]$index], x2[,kern$comp[[i]]$index], covGrad) 48 | } 49 | } else { 50 | if ( nargs() < 4 ) { 51 | g[seq(startVal,len=kern$comp[[i]]$nParams)] <- .kernGradient(kern$comp[[i]], x, covGrad) 52 | ## Used to be: g[startVal:endVal] <- kernGradient(kern$comp[[i]], x, covGrad) 53 | } else { 54 | g[seq(startVal,len=kern$comp[[i]]$nParams)] <- .kernGradient(kern$comp[[i]], x, x2, covGrad) 55 | ## Used to be: g[startVal:endVal] <- kernGradient(kern$comp[[i]], x, x2, covGrad) 56 | } 57 | } 58 | startVal <- endVal + 1 59 | } 60 | 61 | g <- g %*% kern$paramGroups 62 | 63 | return (g) 64 | } 65 | -------------------------------------------------------------------------------- /R/gptk_cmpndKernParamInit.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .cmpndKernParamInit <- 31 | function (kern) { 32 | 33 | kern$nParams <- 0 34 | kern$transforms <- list() 35 | 36 | if ( ! ("comp" %in% names(kern)) ) 37 | kern$comp <- list() 38 | 39 | for ( i in seq(along=kern$comp) ) { 40 | 41 | kern$comp[[i]] <- .kernParamInit(kern$comp[[i]]) 42 | kern$nParams <- kern$nParams + kern$comp[[i]]$nParams 43 | kern$comp[[i]]$index <- array() 44 | 45 | if ( "numBlocks" %in% names(kern$comp[[i]]) ) { 46 | if ( i==1 ) { 47 | kern$numBlocks <- kern$comp[[i]]$numBlocks 48 | } else { 49 | if ( (!("numBlocks" %in% names(kern))) | (kern$numBlocks!=kern$comp[[i]]$numBlocks) ) { 50 | stop("Compound of multi kernels with different numbers of blocks.") 51 | } 52 | } 53 | } else { 54 | if ( "numBlocks" %in% names(kern) ) 55 | stop("Attempt to combine multi-kernel with non multi-kernel.") 56 | } 57 | } 58 | 59 | kern$paramGroups <- diag(1, nrow=kern$nParams, ncol=kern$nParams) 60 | 61 | kern$whiteVariance <- 0 62 | kern$isStationary <- TRUE 63 | 64 | for ( i in seq(along=kern$comp) ) { 65 | if ( !kern$comp[[i]]$isStationary ) 66 | kern$isStationary <- FALSE 67 | 68 | if ( kern$comp[[i]]$type == "white" ) { 69 | kern$whiteVariance <- kern$whiteVariance + kern$comp[[i]]$variance 70 | } else { 71 | if ( "whiteVariance" %in% names(kern$comp[[i]]) ) { 72 | kern$whiteVariance <- kern$whiteVariance + kern$comp[[i]]$whiteVariance 73 | } 74 | } 75 | } 76 | 77 | return (kern) 78 | 79 | } 80 | -------------------------------------------------------------------------------- /R/gptk_exhaustivePlot.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | .exhaustivePlot <- 31 | function(y, x, xstar, options, maxwidth, res, nlevels) { 32 | 33 | ## EXHAUSTIVEPLOT Plot of the LML function by exhaustive search. 34 | ## FORMAT 35 | ## DESC Exhaustively searches the hyperparameter space by a grid, whose 36 | ## resolution is given, and plots the LML function for every point in the 37 | ## space. 38 | ## ARG y : the target (output) data. 39 | ## ARG x : the input data matrix. 40 | ## ARG xstar : the points to predict function values. 41 | ## ARG options : options structure as defined by gpOptions.m. 42 | ## ARG maxWidth : maximum lengthscale to search for. 43 | ## ARG res : The search resolution. Number of points to plot for in the 44 | ## search range. 45 | ## ARG nlevels : Number of contour levels. 46 | ## RETURN C : Matrix of function values from the search. 47 | ## 48 | ## USAGE : exhaustivePlot(y, x, xstar, options, 30, 100); 49 | ## 50 | ## SEEALSO : gpCreate, gpExpandParam, gpLogLikelihood, gpPosteriorMeanVar 51 | ## 52 | ## COPYRIGHT : Alfredo Kalaitzis, 2010, 2011 53 | ## 54 | ## GPREGE 55 | 56 | y = y[!is.nan(y)] 57 | y = matrix(y-mean(y)) 58 | 59 | y_sd = sd(c(y)) 60 | if (y_sd == 0) { 61 | C <- NULL 62 | warning('Data variance is zero. No figure produced.') 63 | } else { 64 | model = .gpCreate(dim(x)[2], dim(y)[2], x, y, options) 65 | 66 | ## search GP log likelihood 67 | signal = seq(y_sd*1e-3, y_sd*.999, length=res) 68 | width = seq(1, maxwidth, length=res) 69 | results = matrix(0, length(signal)*length(width), 5) 70 | 71 | index = 0 72 | for (w in width) { 73 | for (sig in signal) { 74 | noise = y_sd - sig 75 | snr = sig/noise 76 | model = .gpExpandParam(model, matrix(2*log(c(1/w, sig, noise)), ncol=1) ) 77 | LML = .gpLogLikelihood(model) 78 | index = index + 1 79 | results[index, ] = c(w, sig, noise, snr, LML) 80 | } 81 | } 82 | 83 | C = matrix(results[, 5], length(signal), length(width)) 84 | # lbound = max(C) - ((max(C)-min(C))/10) 85 | lbound = -20; 86 | C[C < lbound] = lbound ## Put a lower bound on the LML plot. 87 | maxLML = max(results[,5]); mi = which.max(results[,5]) 88 | v = seq(min(C)+10, maxLML, length=nlevels) 89 | w = results[mi,1]; sig = results[mi,2]; noise = results[mi,3]; snr = results[mi,4] 90 | # screen(1); erase.screen(1) ## Subfigure 1; Clear screen. 91 | ## Plot contour of log-marginal likelihood function wrt s/n ratio. 92 | ## NOTE: filled.contour maps the transpose of the matrix to the image, hence the t(C). 93 | filled.contour(x=width, y=log10(signal/(y_sd-signal)), z=t(C), 94 | # filled.contour(x=width, y=(signal/(sd(y)-signal)), z=C, 95 | color.palette=gray.colors, #terrain.colors, 96 | xlab='Lengthscale', ylab=bquote(paste(log[10]~SNR)), 97 | # levels = v, 98 | nlevels = nlevels, 99 | # plot.title=title(main='Log-marginal likelihood function\n lengthscale vs. log10(SNR)'), 100 | main='Log-marginal likelihood function', 101 | plot.axes={axis(1); axis(2); 102 | points(w, log10(snr), pch=20)} 103 | ) 104 | 105 | 106 | ## plot GP regression with maxLML hyperparameters 107 | loghyper = matrix(2*log(c(1/w, sig, noise)), ncol=1) 108 | model = .gpExpandParam(model, loghyper) 109 | dev.set(4) # screen(2); erase.screen(2) 110 | .gpPlot(model, xstar, col='blue', # xlim=range(xstar), ylim=c(min(y), max(y)), 111 | title=paste("max LML length-scale = ", as.character(round(w,1)), sep=''), 112 | xlab='time(mins)', ylab=bquote(paste(log[2]~expression~(centred)))) 113 | 114 | ## Hyperparameter info. 115 | cat('============= EXHAUSTIVE LML SEARCH =====================\n') 116 | cat( sprintf('%-20s %-20s %s\n', 'Length-scale', 'Signal', 'Noise') ) 117 | cat( sprintf('%-20.5f %-20.5f %.5f\n\n', w, sig, noise) ) 118 | cat( sprintf('%-20s %-20s\n', 'Max LML', 'Estim. sig + noise') ) 119 | cat( sprintf('%-20.8f %-20f\n\n', .gpLogLikelihood(model), sum(exp(loghyper[2:3]/2))) ) 120 | } 121 | return(C) 122 | } 123 | -------------------------------------------------------------------------------- /R/gptk_expTransform.R: -------------------------------------------------------------------------------- 1 | .expTransform <- 2 | function (x, transform="atox") { 3 | 4 | eps <- 2.2204e-16 5 | maxVal <- 4.3112e+15 6 | 7 | thre <- 36 ## threshold 8 | y <- array(0, dim(as.array(x))) 9 | 10 | if ( "atox" == transform ) { 11 | for ( ind in seq_along(as.array(x)) ) { 12 | if ( x[ind] > thre ) y[ind] <- maxVal else 13 | if ( x[ind] < -thre ) y[ind]<- eps else 14 | y[ind] <- exp(x[ind]) 15 | } 16 | } else if ( "xtoa" == transform ) { 17 | for ( ind in seq_along(as.array(x)) ) { 18 | y[ind] <- .complexLog(x[ind]) 19 | } 20 | } else if ( "gradfact" == transform ) 21 | y <- x 22 | 23 | return (y) 24 | } 25 | -------------------------------------------------------------------------------- /R/gptk_gpBlockIndices.R: -------------------------------------------------------------------------------- 1 | .gpBlockIndices <- 2 | function(model, blockNo) { 3 | if (model$approx != "pitc") 4 | stop("Block number only relevant for pitc approximation.") 5 | else { 6 | if (blockNo == 1) 7 | startVal = 1 8 | else 9 | startVal = model$blockEnd[blockNo-1]+1 10 | 11 | endVal = model$blockEnd[blockNo] 12 | ind = startVal:endVal 13 | } 14 | 15 | return(ind) 16 | } 17 | -------------------------------------------------------------------------------- /R/gptk_gpComputeAlpha.R: -------------------------------------------------------------------------------- 1 | # Based on http://opensource.org/licenses/BSD-2-Clause 2 | # 3 | # YEAR: 2013 4 | # COPYRIGHT HOLDER: Alfredo Kalaitzis 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are 8 | # met: 9 | # 10 | # Redistributions of source code must retain the above copyright 11 | # notice, this list of conditions and the following disclaimer. 12 | # 13 | # Redistributions in binary form must reproduce the above copyright 14 | # notice, this list of conditions and the following disclaimer in 15 | # the documentation and/or other materials provided with the 16 | # distribution. 17 | # 18 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | #'@importFrom grDevices dev.off dev.set gray.colors pdf rgb 31 | #'@importFrom stats optim optimize qgamma qnorm rnorm 32 | #'@importFrom utils tail 33 | #'@importFrom graphics image 34 | 35 | .gpComputeAlpha <- 36 | function(model, m) { 37 | 38 | if (nargs() < 2) 39 | m = model$m 40 | 41 | model$alpha = matrix(0, model$k, model$d) 42 | if (model$approx == "ftc") { 43 | # browser() ## m = y-mean(y) 44 | if (!"isSpherical" %in% names(model) || model$isSpherical) 45 | model$alpha = model$invK_uu %*% m 46 | else { 47 | for (i in 1:model$d) { 48 | ind = .gpDataIndices(model, i) 49 | model$alpha[ind, i] = model$invK_uu[[i]] %*% m[ind, i,drop=FALSE] 50 | } 51 | } 52 | } 53 | else if (model$approx %in% c("dtc","dtcvar")) { 54 | if (!("isSpherical" %in% names(model)) || model$isSpherical) 55 | model$alpha = model$Ainv %*% model$K_uf %*% m 56 | else { 57 | for (i in 1:model$d) { 58 | ind = .gpDataIndices(model, i) 59 | model$alpha[,i] = model$Ainv[[i]] %*% model$K_uf[,ind,drop=FALSE] %*% m[ind,i,drop=FALSE] 60 | } 61 | } 62 | } 63 | else if (model$approx == "fitc") { 64 | if (!("isSpherical" %in% names(model)) || model$isSpherical) 65 | model$alpha = model$Ainv %*% model$K_uf %*% model$Dinv %*% m 66 | else { 67 | for (i in 1:model$d) { 68 | ind = .gpDataIndices(model, i) 69 | model$alpha[,i] = model$Ainv[[i]] %*% 70 | model$K_uf[,ind,drop=FALSE] %*% model$Dinv[[i]] %*% m[ind,i,drop=FALSE] 71 | } 72 | } 73 | } else if (model$approx == "pitc") { 74 | if (!("isSpherical" %in% names(model)) || model$isSpherical) 75 | for (i in seq(along=model$blockEnd)) { 76 | ind = .gpBlockIndices(model, i) 77 | model$alpha = model$alpha + model$Ainv%*%model$K_uf[,ind,drop=FALSE]%*%model$Dinv[[i]]%*%m[ind, ,drop=FALSE] 78 | } 79 | else { 80 | for (i in seq(along=model$blockEnd)) { 81 | for (j in 1:model$d) { 82 | ind = .gpDataIndices(model, j, i) 83 | model$alpha[,j] = model$alpha[,j,drop=FALSE] + model$Ainv[[j]]%*%model$K_uf[,ind,drop=FALSE]%*% 84 | model$Dinv[[i]][[j]]%*%m[ind,j,drop=FALSE] 85 | } 86 | } 87 | } 88 | } 89 | 90 | return(model) 91 | } 92 | -------------------------------------------------------------------------------- /R/gptk_gpComputeM.R: -------------------------------------------------------------------------------- 1 | .gpComputeM <- 2 | function(model) { 3 | ## Remove mean function value from m (if mean function present). 4 | if ("meanFunction" %in% names(model) && length(model$meanFunction)>0) 5 | m = model$y - .modelOut(model$meanFunction, model$X) 6 | else 7 | m = model$y 8 | 9 | ## Remove bias and apply scale. 10 | for (i in 1:model$d) { 11 | m[,i] = m[,i] - model$bias[i] 12 | if (model$scale[i]>0) { 13 | m[,i] = m[,i]/model$scale[i] 14 | } 15 | } 16 | 17 | return(m) 18 | } 19 | -------------------------------------------------------------------------------- /R/gptk_gpCovGrads.R: -------------------------------------------------------------------------------- 1 | .gpCovGrads <- 2 | function(model, M) { 3 | 4 | if (model$approx %in% list('dtc', 'dtcvar')) { 5 | ## Deterministic training conditional. 6 | if (model$approx == 'dtcvar') 7 | dtcvar = TRUE 8 | else 9 | dtcvar = FALSE 10 | 11 | if (!'isSpherical' %in% names(model) || model$isSpherical) { 12 | E = model$K_uf%*%M 13 | EET = E%*%t(E) 14 | AinvEET = model$Ainv%*%EET 15 | AinvEETAinv = AinvEET%*%model$Ainv 16 | gK_uu = 0.5*(model$d*(model$invK_uu-(1/model$beta)*model$Ainv) - AinvEETAinv) 17 | if (dtcvar) { 18 | K_uuInvK_uf = model$invK_uu%*%model$K_uf 19 | gK_uu = gK_uu - 0.5*model$d*model$beta*(K_uuInvK_uf%*%t(K_uuInvK_uf)) 20 | } 21 | AinvK_uf = model$Ainv%*%model$K_uf 22 | gK_uf = -model$d*AinvK_uf - model$beta*(AinvEET%*%AinvK_uf - (model$Ainv%*%E%*%t(M))) 23 | if (dtcvar) 24 | gK_uf = gK_uf + model$d*model$beta*K_uuInvK_uf 25 | 26 | gBeta = 0.5*(model$d*((model$N-model$k)/model$beta 27 | +sum(model$Ainv * model$K_uu)/(model$beta*model$beta)) 28 | +sum(AinvEETAinv * model$K_uu)/model$beta 29 | +(sum(diag(AinvEET))-sum(M * M))) 30 | if (dtcvar) 31 | gBeta = gBeta -0.5*model$d*sum(model$diagD)/model$beta 32 | 33 | fhandle = get(model$betaTransform$func, mode="function") 34 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 35 | if (dtcvar) 36 | g_Lambda = matrix(-0.5*model$beta*model$d, 1, model$N) 37 | else 38 | g_Lambda = matrix() 39 | } else { 40 | gK_uu = matrix(0, model$k, model$k) 41 | gK_uf = matrix(0, model$k, model$N) 42 | gBeta = 0 43 | for (i in 1:model$d) { 44 | ind = .gpDataIndices(model, i) 45 | e = model$K_uf[, ind,drop=FALSE]%*%M[ind, i,drop=FALSE] 46 | Ainve = model$Ainv[[i]]%*%e 47 | AinveeT = Ainve%*%t(e) 48 | AinveeTAinv = Ainve%*%t(Ainve) 49 | gK_uu = gK_uu + 0.5*((model$invK_uu - (1/model$beta)*model$Ainv[[i]]) - AinveeTAinv) 50 | 51 | AinvK_uf = model$Ainv[[i]]%*%model$K_uf[, ind,drop=FALSE] 52 | gK_uf[, ind] = gK_uf[, ind,drop=FALSE] - AinvK_uf 53 | - model$beta*(AinveeT%*%AinvK_uf - (Ainve%*%t(M[ind, i, drop=FALSE]))) 54 | 55 | gBeta = gBeta + 0.5*(((model$N - model$k)/model$beta 56 | +sum(model$Ainv[[i]] * model$K_uu)/(model$beta*model$beta)) 57 | +sum(AinveeTAinv * model$K_uu)/model$beta 58 | +(sum(diag(AinveeT))-sum(M[ind, i,drop=FALSE] * M[ind, i,drop=FALSE]))) 59 | } 60 | fhandle = get(model$betaTransform$func, mode="function") 61 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 62 | g_Lambda = matrix() 63 | } 64 | } else if (model$approx == 'fitc') { 65 | ## Fully independent training conditonal. 66 | if (!'isSpherical' %in% names(model) || model$isSpherical) { 67 | E = model$K_uf %*% model$Dinv %*% M 68 | EET = E%*%t(E) 69 | AinvE = model$Ainv%*%E 70 | diagK_fuAinvEMT = t(colSums(model$K_uf * (model$Ainv%*%E%*%t(M)))) 71 | AinvEETAinv = AinvE%*%t(AinvE) 72 | diagK_ufdAinvplusAinvEETAinvK_fu = 73 | t(colSums(model$K_uf * ((model$d*model$Ainv + model$beta*AinvEETAinv)%*%model$K_uf))) 74 | invK_uuK_uf = model$invK_uu%*%model$K_uf 75 | if (TRUE) 76 | invK_uuK_ufDinv = invK_uuK_uf%*%model$Dinv 77 | else 78 | invK_uuK_ufDinv = solve(t(model$L), model$V) 79 | 80 | diagMMT = rowSums(M * M) 81 | diagQ = - model$d*model$diagD + model$beta*diagMMT 82 | + diagK_ufdAinvplusAinvEETAinvK_fu - 2*model$beta*diagK_fuAinvEMT 83 | gK_uu = 0.5*(model$d*(model$invK_uu - model$Ainv/model$beta) - AinvEETAinv 84 | + model$beta*invK_uuK_ufDinv%*%spam::diag.spam(drop(diagQ))%*%t(invK_uuK_ufDinv)) 85 | gK_uf = -model$beta*invK_uuK_ufDinv%*%spam::diag.spam(drop(diagQ))%*%model$Dinv 86 | -model$d*model$Ainv%*%model$K_uf%*%model$Dinv 87 | -model$beta*AinvEETAinv%*%model$K_uf%*%model$Dinv 88 | +model$beta*model$Ainv%*%E%*%t(M)%*%model$Dinv 89 | g_Lambda = (0.5*diagQ*model$beta) / (model$diagD * model$diagD) 90 | gBeta = -sum(g_Lambda)/(model$beta*model$beta) 91 | fhandle = get(model$betaTransform$func, mode="function") 92 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 93 | } else { 94 | gK_uu = matrix(0, model$k, model$k) 95 | gK_uf = matrix(0, model$k, model$N) 96 | g_Lambda = matrix(0, model$N, 1) 97 | gBeta = 0 98 | for (i in 1:model$d) { 99 | ind = .gpDataIndices(model, i) 100 | K_ufDinvK_uf = model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]]%*%t(model$K_uf[, ind,drop=FALSE]) 101 | e = model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]]%*%M[ind, i,drop=FALSE] 102 | Ainve = model$Ainv[[i]]%*%e 103 | AinveeTAinv = Ainve%*%t(Ainve) 104 | diagK_fuAinveyT = t(colSums(model$K_uf[, ind,drop=FALSE] * (Ainve%*%t(M[ind, i,drop=FALSE])))) 105 | diagK_ufdAinvplusAinveeTAinvK_fu = 106 | t(colSums(model$K_uf[,ind,drop=FALSE] * ((model$Ainv[[i]] 107 | + model$beta*AinveeTAinv)%*%model$K_uf[, ind,drop=FALSE]))) 108 | invK_uuK_uf = model$invK_uu%*%model$K_uf[, ind,drop=FALSE] 109 | invK_uuK_ufDinv = invK_uuK_uf%*%model$Dinv[[i]] 110 | diagyyT = M[ind, i,drop=FALSE] * M[ind, i,drop=FALSE] 111 | diagQ = -model$diagD[[i]] + model$beta*diagyyT 112 | + diagK_ufdAinvplusAinveeTAinvK_fu - 2*model$beta*diagK_fuAinveyT 113 | gK_uu = gK_uu + 0.5*(model$invK_uu - model$Ainv[[i]]/model$beta - AinveeTAinv 114 | + model$beta*invK_uuK_ufDinv%*%spam::diag.spam(drop(diagQ))%*%t(invK_uuK_ufDinv)) 115 | gK_uf[, ind] = gK_uf[, ind,drop=FALSE] 116 | -model$beta*invK_uuK_ufDinv%*%spam::diag.spam(drop(diagQ))%*%model$Dinv[[i]] 117 | -model$Ainv[[i]]%*%model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]] 118 | -model$beta*AinveeTAinv%*%model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]] 119 | +model$beta*Ainve%*%t(M[ind, i,drop=FALSE])%*%model$Dinv[[i]] 120 | g_Lambda[ind] = g_Lambda[ind] 121 | + 0.5*model$beta*diagQ / (model$diagD[[i]] * model$diagD[[i]]) 122 | } 123 | gBeta = gBeta - sum(g_Lambda)/(model$beta*model$beta) 124 | fhandle = get(model$betaTransform$func, mode="function") 125 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 126 | } 127 | } else if (model$approx == 'pitc') { 128 | ## Partially independent training conditional. 129 | if (!'isSpherical' %in% names(model) || model$isSpherical) { 130 | E = matrix(0, model$k, model$d) 131 | for (i in 1:length(model$blockEnd)) { 132 | ind = .gpBlockIndices(model, i) 133 | E = E + model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]]%*%M[ind, ,drop=FALSE] 134 | } 135 | AinvE = model$Ainv%*%E 136 | AinvEET = AinvE%*%t(E) 137 | AinvEETAinv = AinvEET%*%model$Ainv 138 | blockQ = list() 139 | for (i in 1:length(model$blockEnd)) { 140 | ind = .gpBlockIndices(model, i) 141 | K_fuAinvEMT = model$beta*t(model$K_uf[, ind,drop=FALSE])%*%AinvE%*%t(M[ind, ,drop=FALSE]) 142 | blockQ[[i]] = -model$d*model$D[[i]] + model$beta*M[ind, ,drop=FALSE]%*%t(M[ind, ,drop=FALSE]) 143 | + t(model$K_uf[, ind,drop=FALSE])%*%(model$d*model$Ainv + model$beta*AinvEETAinv)%*% 144 | model$K_uf[, ind,drop=FALSE] - K_fuAinvEMT - t(K_fuAinvEMT) 145 | } 146 | gK_uu = model$d*model$invK_uu - model$d*model$Ainv/model$beta - AinvEETAinv 147 | gBeta = 0 148 | gK_ufBase = -(model$d*model$Ainv + model$beta*AinvEETAinv)%*%model$K_uf 149 | + model$beta*AinvE%*%t(M) 150 | 151 | g_Lambda = list() 152 | gK_uf = matrix(0, dim(gK_ufBase)[1], model$N) 153 | for (i in 1:length(model$blockEnd)) { 154 | ind = .gpBlockIndices(model, i) 155 | invK_uuK_ufDinv = model$invK_uu%*%model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]] 156 | gK_uu = gK_uu + model$beta*invK_uuK_ufDinv%*%blockQ[[i]]%*%t(invK_uuK_ufDinv) 157 | 158 | gK_uf[, ind] = (gK_ufBase[,ind,drop=FALSE]-model$beta*invK_uuK_ufDinv%*%blockQ[[i]])%*%model$Dinv[[i]] 159 | 160 | g_Lambda[[i]] = 0.5*model$Dinv[[i]]%*%blockQ[[i]]%*%model$Dinv[[i]]*model$beta 161 | gBeta = gBeta - sum(diag((g_Lambda[[i]]))) / (model$beta*model$beta) 162 | } 163 | gK_uu = gK_uu*0.5 164 | fhandle = get(model$betaTransform$func, mode="function") 165 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 166 | } else { 167 | gK_uu = matrix(0, model$k, model$k) 168 | gK_uf = matrix(0, model$k, model$N) 169 | g_Lambda = list() 170 | for (i in 1:length(model$blockEnd)) { 171 | if (i == 1) 172 | indLen = model$blockEnd[1] 173 | else 174 | indLen = model$blockEnd[i] - model$blockEnd[i-1] 175 | 176 | g_Lambda[[i]] = matrix(0, indLen, indLen) 177 | } 178 | gBeta = 0 179 | for (j in 1:model$d) { 180 | e = matrix(0, model$k, 1) 181 | for (i in 1:length(model$blockEnd)) { 182 | ind = .gpDataIndices(model, j, i) 183 | e = e + model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]][[j]]%*%M[ind, j,drop=FALSE] 184 | } 185 | Ainve = model$Ainv[[j]]%*%e 186 | AinveeT = Ainve%*%t(e) 187 | AinveeTAinv = AinveeT%*%model$Ainv[[j]] 188 | blockQ = list() 189 | for (i in 1:length(model$blockEnd)) { 190 | ind = .gpDataIndices(model, j, i) 191 | K_fuAinveyT = model$beta*t(model$K_uf[, ind,drop=FALSE])%*%Ainve%*%t(M[ind, j,drop=FALSE]) 192 | blockQ[[i]] = -model$D[[i]][[j]] + model$beta*M[ind, j,drop=FALSE]%*%t(M[ind, j,drop=FALSE]) 193 | + t(model$K_uf[, ind,drop=FALSE])%*%(model$Ainv[[j]] + model$beta*AinveeTAinv)%*% 194 | model$K_uf[, ind,drop=FALSE] - K_fuAinveyT - t(K_fuAinveyT) 195 | } 196 | gK_uu = gK_uu + model$invK_uu - model$Ainv[[j]]/model$beta - AinveeTAinv 197 | 198 | for (i in 1:length(model$blockEnd)) { 199 | ind = .gpDataIndices(model, j, i) 200 | gK_ufBase = -(model$Ainv[[i]] + model$beta*AinveeTAinv)%*%model$K_uf[, ind,drop=FALSE] 201 | + model$beta*Ainve%*%t(M[ind, j,drop=FALSE]) 202 | invK_uuK_ufDinv = model$invK_uu%*%model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]][[j]] 203 | gK_uu = gK_uu + model$beta*invK_uuK_ufDinv%*%blockQ[[i]]%*%t(invK_uuK_ufDinv) 204 | 205 | gK_uf[, ind] = gK_uf[, ind,drop=FALSE] + (gK_ufBase 206 | -model$beta*invK_uuK_ufDinv%*%blockQ[[i]])%*%model$Dinv[[i]][[j]] 207 | 208 | if (i == 1) 209 | localInd = ind 210 | else 211 | localInd = ind - (model$blockEnd[i-1]) 212 | 213 | g_Lambda[[i]][localInd, localInd] = g_Lambda[[i]][localInd, localInd] 214 | + 0.5*model$Dinv[[i]][[j]]%*%blockQ[[i]]%*%model$Dinv[[i]][[j]]*model$beta 215 | } 216 | } 217 | 218 | for (i in 1:length(model$blockEnd)) 219 | gBeta = gBeta - sum(diag((g_Lambda[[i]])))/(model$beta*model$beta) 220 | 221 | gK_uu = gK_uu*0.5 222 | fhandle = get(model$betaTransform$func, mode="function") 223 | gBeta = gBeta*fhandle(model$beta, 'gradfact') 224 | } 225 | } else 226 | stop("Unknown approximation type") 227 | 228 | return (list(gK_uu=gK_uu, gK_uf=gK_uf, g_Lambda=g_Lambda, gBeta=gBeta)) 229 | } 230 | -------------------------------------------------------------------------------- /R/gptk_gpCreate.R: -------------------------------------------------------------------------------- 1 | .gpCreate <- 2 | function(q, d, X, y, options) { 3 | 4 | if (dim(X)[2]!=q) 5 | stop("Input matrix X does not have dimension ",q) 6 | if (dim(y)[2]!=d) 7 | stop("Input matrix y does not have dimension ",d) 8 | 9 | if (any(is.nan(y)) && !options$isMissingData) 10 | stop("NaN values in y, but no missing data declared.") 11 | if (options$isMissingData && options$isSpherical) 12 | stop("If there is missing data, spherical flag cannot be set.") 13 | 14 | y = as.matrix(y); X = as.matrix(X) 15 | 16 | model <- list(type="gp", y=y, X=X, approx=options$approx, beta = options$beta, 17 | learnScales=options$learnScales, scaleTransform=.optimiDefaultConstraint("positive"), 18 | optimiseBeta=options$optimiseBeta, betaTransform=.optimiDefaultConstraint("positive"), 19 | q=dim(X)[2], d=dim(y)[2], N=dim(y)[1]) 20 | 21 | # ## Set up a mean function if one is given. 22 | # if (("meanFunction" %in% names(options)) && length(options$meanFunction)>0) { 23 | # if (is.list(options$meanFunction)) 24 | # model$meanFunction = options$meanFunction 25 | # else 26 | # model$meanFunction = modelCreate(options$meanFunction, model$q, model$d, 27 | # options$meanFunctionOptions) 28 | # } 29 | 30 | model$optimiser = options$optimiser 31 | model$isSpherical = options$isSpherical 32 | model$isMissingData = options$isMissingData 33 | 34 | model$scale = matrix(1, 1, model$d) 35 | if (!model$isMissingData) { 36 | model$bias = colMeans(y) 37 | } else { 38 | for (i in 1:model$d) { 39 | model$indexPresent[[i]] = which(!is.nan(y[,i])) 40 | if (length(model$indexPresent[[i]])==0) { 41 | model$bias[i] = 0 42 | # model$scale[i] = 1 43 | } else { 44 | model$bias[i] = mean(model$y[model$indexPresent[[i]], i]) 45 | # model$scale[i] = 1 46 | } 47 | } 48 | } 49 | 50 | if (("scale2var1" %in% names(options)) && (options$scale2var1)) { 51 | model$scale = sd(model$y) 52 | model$scale[which(model$scale == 0)] = 1 53 | if (model$learnScales) 54 | warning("Both learn scales and scale2var1 set for GP") 55 | if ("scaleVal" %in% names(options)) 56 | warning("Both scale2var1 and scaleVal set for GP") 57 | } 58 | 59 | if("scaleVal" %in% names(options)) 60 | model$scale = kronecker(matrix(1,1,model$d), options$scaleVal) 61 | # repmat(options$scaleVal, 1, model$d) 62 | 63 | model$m = .gpComputeM(model) 64 | model$computeS = FALSE 65 | if (options$computeS) { 66 | model$computeS = TRUE 67 | model$S = model$m %*% t(model$m) 68 | if (model$approx != "ftc") # !strcmp(model.approx, 'ftc') 69 | stop("If compute S is set, approximation type must be 'ftc'.") 70 | } 71 | 72 | ## nParams is a sure way to tell if the kernel structure has been initialized 73 | if (is.list(options$kern) && ("nParams" %in% options$kern)) 74 | model$kern = options$kern 75 | else 76 | # browser() 77 | model$kern = .kernCreate(model$X, options$kern) 78 | 79 | 80 | # if ("noise" %in% names(options)) { 81 | # if (is.list(options$noise)) #isstruct(options.noise) 82 | # model$noise = options$noise 83 | # else 84 | # model$noise = noiseCreate(options$noise, y) 85 | # 86 | # ## Set up noise model gradient storage. 87 | # model$nu = matrix(0, dim(y)[1], dim(y)[2]) 88 | # model$g = matrix(0, dim(y)[1], dim(y)[2]) 89 | # model$gamma = matrix(0, dim(y)[1], dim(y)[2]) 90 | # 91 | # ## Initate noise model 92 | # model$noise = noiseCreate(noiseType, y) ## bug: noiseType has no value 93 | # 94 | # ## Set up storage for the expectations 95 | # model$expectations$f = model$y 96 | # model$expectations$ff = matrix(1, dim(model$y)[1], dim(model$y)[2]) 97 | # model$expectations$fBar = matrix(1, dim(model$y)[1], dim(model$y)[2]) 98 | # ## bug: numData has no value 99 | # model$expectations$fBarfBar = array(1,dim=(c(numData, numData, dim(model$y)[2]))) 100 | # } 101 | 102 | 103 | if (options$approx == "ftc") { 104 | model$k = 0 105 | model$X_u = list() 106 | if (model$optimiseBeta && length(options$beta)==0) 107 | stop("options.beta cannot be empty if it is being optimised.") 108 | } else if (options$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) { 109 | ## Sub-sample inducing variables. 110 | model$k = options$numActive 111 | model$fixInducing = options$fixInducing 112 | if (options$fixInducing) { 113 | if (length(options$fixIndices) != options$numActive) { 114 | stop(paste("Length of indices for fixed inducing variables must ", 115 | "match number of inducing variables")) 116 | } 117 | model$X_u = model$X[options$fixIndices, ] 118 | model$inducingIndices = options$fixIndices 119 | } else { 120 | ind = sample(1:model$N, size=model$N) #randperm(model$N) 121 | ind = ind[1:model$k] 122 | model$X_u = model$X[ind, ,drop=FALSE] 123 | } 124 | } 125 | 126 | if (model$k > model$N) 127 | stop("Number of active points cannot be greater than number of data.") 128 | 129 | if (model$approx == "pitc") { #strcmp(model.approx, 'pitc') 130 | numBlocks = ceiling(model$N/model$k) 131 | numPerBlock = ceiling(model$N/numBlocks) 132 | startVal = 1 133 | endVal = model$k 134 | model$blockEnd = matrix(0, 1, numBlocks) 135 | for (i in 1:numBlocks) { 136 | model$blockEnd[i] = endVal 137 | endVal = numPerBlock + endVal 138 | if (endVal > model$N) 139 | endVal = model$N 140 | } 141 | } 142 | 143 | initParams = .gpExtractParam(model) 144 | 145 | ## This forces kernel computation. 146 | # browser() 147 | model = .gpExpandParam(model, initParams) 148 | 149 | return (model) 150 | } 151 | -------------------------------------------------------------------------------- /R/gptk_gpDataIndices.R: -------------------------------------------------------------------------------- 1 | .gpDataIndices <- 2 | function(model, dimNo, blockNo) { 3 | if (nargs() > 2) { 4 | if (model$approx != "pitc") 5 | stop("Block number only relevant for pitc approximation.") 6 | else { 7 | if (blockNo == 1) 8 | startVal = 1 9 | else 10 | startVal = model$blockEnd[blockNo-1]+1 11 | endVal = model$blockEnd[blockNo] 12 | if (model$isMissingData) { 13 | st = min(which(model$indexPresent[[dimNo]] >= startVal)) 14 | fi = max(which(model$indexPresent[[dimNo]] <= endVal)) 15 | ind = t(model$indexPresent[[dimNo]][st:fi]) 16 | } else 17 | ind = startVal:endVal 18 | } 19 | } else { 20 | if (model$approx == "pitc") 21 | stop("Must give block number with PITC approximation.") 22 | else { 23 | if (model$isMissingData) 24 | ind = t(model$indexPresent[[dimNo]]) 25 | else 26 | ind = 1:model$N 27 | } 28 | } 29 | 30 | return(ind) 31 | } 32 | -------------------------------------------------------------------------------- /R/gptk_gpExpandParam.R: -------------------------------------------------------------------------------- 1 | .gpExpandParam <- 2 | function (model, params) { 3 | 4 | if (is.list(params)) { 5 | model$params = params 6 | params = params$xmin 7 | } 8 | 9 | if (model$approx == "ftc" || model$fixInducing) 10 | endVal = 0 11 | else { 12 | startVal = 1 13 | endVal = model$k * model$q 14 | model$X_u = matrix(params[startVal:endVal], model$k, model$q) 15 | } 16 | startVal = endVal + 1 17 | endVal = endVal + model$kern$nParams 18 | model$kern = .kernExpandParam(model$kern, params[startVal:endVal]) 19 | 20 | ## Check if there is a mean function. 21 | if ("meanFunction" %in% names(model) && length(model$meanFunction)>0) { 22 | startVal = endVal + 1 23 | endVal = endVal + model$meanFunction$numParams 24 | model$meanFunction = .modelExpandParam(model$meanFunction, params[startVal:endVal]) 25 | } 26 | 27 | ## Check if the output scales are being learnt. 28 | if (model$learnScales) { 29 | startVal = endVal + 1 30 | endVal = endVal + model$d 31 | fhandle <- get(model$scaleTransform$func, mode="function") 32 | model$scale = fhandle(params[startVal:endVal], "atox") 33 | model$m = .gpComputeM(model) 34 | } 35 | 36 | ## Check if beta is being optimised. 37 | if (model$optimiseBeta) { 38 | startVal = endVal + 1 39 | endVal = endVal + prod(dim(as.matrix(model$beta))) 40 | fhandle <- get(model$betaTransform$func, mode="function") 41 | model$beta = fhandle(params[startVal:endVal], "atox") 42 | } 43 | 44 | ## Record the total number of parameters. 45 | model$nParams = endVal 46 | 47 | ## Update the kernel representations. 48 | if (model$approx == "ftc") { 49 | # browser() 50 | model = .gpUpdateKernels(model, model$X, model$X_u) 51 | } else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) { 52 | model = .gpUpdateKernels(model, model$X, model$X_u) 53 | } else 54 | stop("Unknown approximation type.") 55 | 56 | ## Update the vector 'alpha' for computing posterior mean. 57 | if ("alpha" %in% names(model)) 58 | model = .gpComputeAlpha(model) 59 | 60 | return (model) 61 | } 62 | -------------------------------------------------------------------------------- /R/gptk_gpExtractParam.R: -------------------------------------------------------------------------------- 1 | .gpExtractParam <- 2 | function(model, only.values=TRUE, ...) { 3 | 4 | ## Check if the output scales are being learnt. 5 | scaleParams = list() 6 | scaleParamNames = list() 7 | if (model$learnScales) { 8 | fhandle <- get(model$scaleTransform$func, mode="function") 9 | scaleParams = fhandle(model$scale, "xtoa") 10 | if (!only.values) 11 | for (i in 1:length(scaleParams)) 12 | scaleParamNames[[i]] = paste("Output Scale ", as.character(i), sep="") 13 | } 14 | 15 | ## Check if there is a mean function. 16 | meanFuncParams = list() 17 | if (("meanFunction" %in% names(model)) && length(model$meanFunction)>0) 18 | meanFuncParams = .modelExtractParam(model$meanFunction, only.values) 19 | 20 | kernParams <- .kernExtractParam(model$kern, only.values) 21 | 22 | if (model$approx == "ftc") { 23 | params = unlist(c(kernParams, meanFuncParams, scaleParams)) 24 | 25 | if (model$optimiseBeta) { 26 | fhandle <- get(model$betaTransform$func, mode="function") 27 | betaParam = fhandle(model$beta, "xtoa") 28 | params = c(params, betaParam) 29 | } 30 | } else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) { 31 | paramPart = unlist(c(kernParams, meanFuncParams, scaleParams)) 32 | if (model$optimiseBeta) { 33 | fhandle <- get(model$betaTransform$func, mode="function") 34 | betaParam = fhandle(model$beta, "xtoa") 35 | paramPart = c(paramPart, betaParam) 36 | } 37 | if (model$fixInducing) 38 | params = paramPart 39 | else 40 | params = c(model$X_u, paramPart) 41 | } 42 | 43 | params <- Re(params) 44 | 45 | return (params) 46 | } 47 | -------------------------------------------------------------------------------- /R/gptk_gpGradient.R: -------------------------------------------------------------------------------- 1 | .gpGradient <- 2 | function(params, model) { 3 | 4 | model = .gpExpandParam(model, params) 5 | ## only necessary parts from gpLogLikeGradients implemented! 6 | 7 | # if (model$optimiseBeta && !model$fixInducing) 8 | # browser() 9 | 10 | g = - .gpLogLikeGradients(model) 11 | 12 | return (g) 13 | } 14 | -------------------------------------------------------------------------------- /R/gptk_gpLogLikeGradients.R: -------------------------------------------------------------------------------- 1 | .gpLogLikeGradients <- 2 | function(model, X=model$X, M, X_u, gX_u.return=FALSE, gX.return=FALSE, g_beta.return=FALSE) { 3 | 4 | if (missing(X_u)) { #if (nargs() < 4) 5 | X_u = list() 6 | if ("X_u" %in% names(model)) 7 | X_u = model$X_u 8 | 9 | if (missing(M) && (!"S" %in% names(model))) #if (nargs()< 3 && (!"S" %in% names(model))) 10 | M = model$m 11 | } 12 | 13 | gX_u = list() 14 | gX = list() 15 | 16 | g_scaleBias = .gpScaleBiasGradient(model) 17 | g_meanFunc = list() 18 | if ("meanFunction" %in% names(model) && length(model$meanFunction)>0) 19 | g_meanFunc = .gpMeanFunctionGradient(model) 20 | 21 | if (model$approx == "ftc") { 22 | ## Full training conditional. 23 | if (gX_u.return && gX.return) { 24 | ## Prepare to Compute Gradients with respect to X 25 | gKX = .kernGradX(model$kern, X, X) 26 | gKX = gKX*2 27 | dgKX = .kernDiagGradX(model$kern, X) 28 | for (i in 1:model$N) 29 | gKX[i, , i] = dgKX[i, ] 30 | gX = matrix(0, model$N, model$q) 31 | } 32 | 33 | ## Gradients of Kernel Parameters 34 | g_param = matrix(0, 1, model$kern$nParams) 35 | g_beta = list() 36 | if ("beta" %in% names(model)) 37 | g_beta = 0 38 | 39 | ## For very high D, we use the matrix S which is M%*%M' 40 | if ("S" %in% names(model)) { 41 | gK = .localSCovarianceGradients(model) 42 | if (gX_u.return && gX.return) { 43 | ## Compute Gradients with respect to X 44 | counter = 0 45 | for (i in 1:model$N) { 46 | counter = counter + 1 47 | for (j in 1:model$q) 48 | gX[i, j] = gX[i, j] + t(gKX[, j, i,drop=FALSE]) %*% gK[, counter,drop=FALSE] 49 | } 50 | } 51 | ## Compute Gradients of Kernel Parameters 52 | g_param = g_param + .kernGradient(model$kern, X, gK) 53 | } else { 54 | for (k in 1:model$d) { 55 | gK = .localCovarianceGradients(model, M[, k], k) 56 | if (gX_u.return && gX.return) { 57 | ## Compute Gradients with respect to X 58 | ind = .gpDataIndices(model, k) 59 | counter = 0 60 | for (i in ind) { 61 | counter = counter + 1 62 | for (j in 1:model$q) 63 | gX[i, j] = gX[i, j] + gKX[ind, j, i,drop=FALSE]%*%gK[, counter,drop=FALSE] 64 | } 65 | } 66 | ## Compute Gradients of Kernel Parameters 67 | if (model$isMissingData){ 68 | g_param = g_param 69 | + .kernGradient(model$kern, X[model$indexPresent[[k]], ], gK) 70 | } else 71 | g_param = g_param + .kernGradient(model$kern, X, gK) 72 | } 73 | 74 | if ("beta" %in% names(model) && model$optimiseBeta) { 75 | model$beta = as.matrix(model$beta) 76 | if (dim(model$beta)[1] == 1) 77 | g_beta = g_beta + sum(diag(gK)) 78 | else if (dim(model$beta)[2]==1 && dim(model$beta)[1]==model$N) 79 | g_beta = g_beta + diag(gK) 80 | else if (dim(model$beta)[2]==model$d && dim(model$beta)[1]==model$N) 81 | g_beta[, k] = diag(gK) 82 | else 83 | stop('Unusual dimensions for model$beta.') 84 | } 85 | } 86 | } else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) { 87 | ## Sparse approximations. 88 | gK = .gpCovGrads(model, M) #[gK_uu, gK_uf, gK_star, g_beta] = gpCovGrads(model, M) 89 | gK_uu=gK$gK_uu; gK_uf=gK$gK_uf; gK_star=gK$g_Lambda; g_beta=gK$gBeta 90 | 91 | ## Compute Gradients of Kernel Parameters 92 | gParam_u = .kernGradient(model$kern, X_u, gK_uu) 93 | gParam_uf = .kernGradient(model$kern, X_u, X, gK_uf) 94 | 95 | g_param = gParam_u + gParam_uf 96 | 97 | ## Compute Gradients with respect to X_u 98 | gKX = .kernGradX(model$kern, X_u, X_u) 99 | 100 | ## The 2 accounts for the fact that covGrad is symmetric 101 | gKX = gKX*2 102 | dgKX = .kernDiagGradX(model$kern, X_u) 103 | for (i in 1:model$k) 104 | gKX[i, , i] = dgKX[i, ] 105 | 106 | if (!model$fixInducing || gX_u.return || gX.return || g_beta.return) { #nargout > 1 107 | ## Allocate space for gX_u 108 | gX_u = matrix(0, model$k, model$q) 109 | ## Compute portion associated with gK_uu 110 | for (i in 1:model$k) { 111 | for (j in 1:model$q) 112 | gX_u[i, j] = t(gKX[, j, i]) %*% gK_uu[, i,drop=FALSE] 113 | } 114 | 115 | ## Compute portion associated with gK_uf 116 | gKX_uf = .kernGradX(model$kern, X_u, X) 117 | for (i in 1:model$k) { 118 | for (j in 1:model$q) 119 | gX_u[i, j] = gX_u[i, j] + t(gKX_uf[, j, i]) %*% t(gK_uf[i, ,drop=FALSE]) 120 | } 121 | } 122 | 123 | if (gX_u.return && gX.return) { #nargout > 2 124 | ## Compute gradients with respect to X 125 | ## Allocate space for gX 126 | gX = matrix(0, model$N, model$q) 127 | 128 | ## this needs to be recomputed so that it is wrt X not X_u 129 | gKX_uf = .kernGradX(model$kern, X, X_u) 130 | 131 | for (i in 1:model$N) { 132 | for (j in 1:model$q) 133 | gX[i, j] = t(gKX_uf[, j, i,drop=FALSE]) %*% gK_uf[, i,drop=FALSE] 134 | } 135 | } 136 | } else 137 | stop("Unknown model approximation.") 138 | 139 | if (model$approx == "ftc") { 140 | ## Full training conditional. Nothing required here. 141 | } else if (model$approx == "dtc") { 142 | ## Deterministic training conditional. 143 | } else if (model$approx %in% c("fitc","dtcvar")) { 144 | ## Fully independent training conditional. 145 | ## Variational sparse approximation. 146 | 147 | if (gX_u.return && gX.return) { #nargout > 2 148 | ## deal with diagonal term's effect on X gradients. 149 | gKXdiag = .kernDiagGradX(model$kern, X) ## !!! 150 | for (i in 1:model$N) 151 | gX[i, ] = gX[i, ] + gKXdiag[i, ]%*%gK_star[i] 152 | } 153 | 154 | ## deal with diagonal term's affect on kernel parameters. 155 | g_param = g_param + .kernDiagGradient(model$kern, X, gK_star) 156 | } else if (model$approx == "pitc") { 157 | ## Partially independent training conditional. 158 | if (gX_u.return && gX.return) { #nargout > 2 159 | ## deal with block diagonal term's effect on X gradients. 160 | startVal = 1 161 | for (i in 1:length(model$blockEnd)) { 162 | endVal = model$blockEnd[i] 163 | ind = startVal:endVal 164 | gKXblock = .kernGradX(model$kern, X[ind, ,drop=FALSE], X[ind, ,drop=FALSE]) 165 | ## The 2 accounts for the fact that covGrad is symmetric 166 | gKXblock = gKXblock*2 167 | 168 | ## fix diagonal 169 | dgKXblock = .kernDiagGradX(model$kern, X[ind, ,drop=FALSE]) 170 | for (j in 1:length(ind)) 171 | gKXblock[j, , j] = dgKXblock[j, ] 172 | 173 | for (j in ind) { 174 | for (k in 1:model$q) { 175 | subInd = j - startVal + 1 176 | gX[j, k] = gX[j, k] + t(gKXblock[, k, subInd,drop=FALSE]) %*% gK_star[[i]][, subInd,drop=FALSE] 177 | } 178 | } 179 | startVal = endVal + 1 180 | } 181 | } 182 | ## deal with block diagonal's effect on kernel parameters. 183 | for (i in 1:length(model$blockEnd)) { 184 | ind = .gpBlockIndices(model, i) 185 | g_param = g_param + .kernGradient(model$kern, X[ind, ,drop=FALSE], gK_star[[i]]) 186 | } 187 | } else 188 | stop("Unrecognised model approximation") 189 | 190 | if (!(gX_u.return && gX.return && g_beta.return)) { #if (nargout < 4) 191 | if ((!"optimiseBeta" %in% names(model) && model$approx!="ftc") || model$optimiseBeta) 192 | ## append beta gradient to end of parameters 193 | gParam = unlist(c(g_param, g_meanFunc, g_scaleBias, g_beta)) 194 | else 195 | gParam = unlist(c(g_param, g_meanFunc, g_scaleBias)) 196 | } else 197 | gParam = unlist(c(g_param, g_meanFunc, g_scaleBias)) 198 | 199 | ## if there is only one output argument, pack gX_u and gParam into it. 200 | if (!(gX_u.return || gX.return || g_beta.return)) #(nargout == 1) 201 | gParam = c(gX_u, gParam) 202 | 203 | return (as.numeric(gParam)) 204 | } 205 | -------------------------------------------------------------------------------- /R/gptk_gpLogLikelihood.R: -------------------------------------------------------------------------------- 1 | .gpLogLikelihood <- 2 | function(model) { 3 | 4 | if (model$approx == "ftc") { 5 | ## No approximation, just do a full computation on K. 6 | ## For very high D, we use the matrix S which is M%*%M' 7 | if ("S" %in% names(model)) { 8 | ll = -0.5*(model$d*model$logDetK_uu + sum(model$invK_uu * model$S)) 9 | return (ll) 10 | } 11 | ll = 0 12 | for (i in 1:dim(model$m)[2]) { 13 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) 14 | ll = ll -.5*model$logDetK_uu - .5*t(model$m[, i,drop=FALSE])%*%model$invK_uu%*%model$m[, i,drop=FALSE] 15 | else { 16 | if (model$isMissingData) 17 | m = model$m[model$indexPresent[[i]], i] 18 | else 19 | m = model$m[, i] 20 | 21 | ll = ll - .5*model$logDetK_uu[i] - .5*t(m)%*%model$invK_uu[[i]]%*%m 22 | } 23 | } 24 | } else if (model$approx %in% c("dtc", "dtcvar")) { 25 | ## Deterministic training conditional 26 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 27 | E = model$K_uf%*%model$m 28 | EET = E %*% t(E) 29 | if (length(model$beta)==1) { 30 | ll = -0.5*(model$d*(-(model$N-model$k)*log(model$beta) 31 | - model$logDetK_uu + model$logDetA) - (sum(model$Ainv*EET) 32 | -sum(model$m * model$m))*model$beta) 33 | if (model$approx == "dtcvar") 34 | ll = ll - model$d * 0.5*sum(model$diagD) 35 | } else 36 | stop("Not implemented variable length beta yet.") 37 | } else { 38 | ll = 0 39 | for (i in 1:model$d) { 40 | ind = .gpDataIndices(model, i) 41 | e = model$K_uf[, ind,drop=FALSE]%*%model$m[ind, i,drop=FALSE] 42 | if (length(model$beta)==1) { 43 | ll = ll - 0.5*((-(model$N-model$k)*log(model$beta) 44 | - model$logDetK_uu + model$logDetA[i]) - (t(e)%*%model$Ainv[[i]]%*%e 45 | - t(model$m[ind, i,drop=FALSE])%*%model$m[ind, i,drop=FALSE])*model$beta) 46 | if(is.nan(ll)) 47 | stop("Log likelihood is NaN") 48 | 49 | if (model$approx == "dtcvar") 50 | stop("Not implemented dtcvar for non-spherical yet.") 51 | 52 | } else 53 | stop("Not implemented variable length beta yet.") 54 | } 55 | } 56 | } else if (model$approx == "fitc") { 57 | ## Fully independent training conditional. 58 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 59 | if (length(model$beta)==1) { 60 | if (FALSE) { ## ಠ_ಠ ? 61 | ## This is the original objective 62 | Dinvm = model$Dinv %*% model$m 63 | K_ufDinvm = model$K_uf %*% Dinvm 64 | ll = -0.5*(model$d * (sum(log(model$diagD)) 65 | -(model$N-model$k)*log(model$beta) + model$detDiff) 66 | + (sum(Dinvm * model$m) 67 | - sum((model$Ainv%*%K_ufDinvm) * K_ufDinvm))*model$beta) 68 | ll = ll - 0.5*model$N*model$d*log(2*pi) 69 | } else { 70 | ## This is objective to match Ed Snelson's code 71 | ll = - model$d*(sum(log(diag(model$Lm))) 72 | + 0.5*(-(model$N - model$k)*log(model$beta) 73 | +(model$N*log(2*pi) + sum(log(model$diagD))))) 74 | for (i in 1:model$d) 75 | ll = ll - 0.5*model$beta*(t(model$scaledM[, i,drop=FALSE])%*%model$scaledM[, i,drop=FALSE] 76 | - t(model$bet[, i,drop=FALSE])%*%model$bet[, i,drop=FALSE]) 77 | } 78 | } else 79 | stop("Variable length Beta not implemented yet.") 80 | } else { 81 | if (length(model$beta)==1) { 82 | if (FALSE) { 83 | ll = 0 84 | for (i in 1:model$d) { 85 | ind = .gpDataIndices(model, i) 86 | Dinvm = model$Dinv[[i]]%*%model$m[ind, i,drop=FALSE] 87 | K_ufDinvm = model$K_uf[, ind,drop=FALSE]%*%Dinvm 88 | ll = ll -0.5*(sum(log(model$diagD[[i]])) 89 | - (length(ind) - model$k)*log(model$beta) 90 | + model$detDiff[i] + (sum(Dinvm * model$m[ind, i,drop=FALSE]) 91 | - sum((model$Ainv[[i]]%*%K_ufDinvm) * K_ufDinvm))*model$beta 92 | + length(ind)*log(2*pi)) 93 | } 94 | } else { 95 | ## This is objective to match Ed Snelson's code 96 | ll = 0 97 | for (i in 1:model$d) { 98 | ind = .gpDataIndices(model, i) 99 | ll = ll - (sum(log(diag(model$Lm[[i]]))) 100 | + 0.5*(-(length(ind) - model$k)*log(model$beta) 101 | +(length(ind)*log(2*pi)+sum(log(model$diagD[[i]]))))) 102 | ll = ll - 0.5*model$beta*(t(model$scaledM[[i]])%*%model$scaledM[[i]] 103 | - t(model$bet[[i]])%*%model$bet[[i]]) 104 | } 105 | } 106 | } else 107 | stop("Variable length Beta not implemented yet.") 108 | } 109 | } else if (model$approx == "pitc") { 110 | ## Partially independent training conditional. 111 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 112 | if (length(model$beta)==1) { 113 | ll = model$d*(model$logDetA-model$logDetK_uu + model$k*log(model$beta)) 114 | ## Loop through the blocks computing each part to be added. 115 | K_ufDinvm = matrix(0, model$k, model$d) 116 | Dinvm = list() 117 | for (i in 1:length(model$blockEnd)) { 118 | ind = .gpBlockIndices(model, i) 119 | Dinvm[[i]] = model$Dinv[[i]]%*%model$m[ind, ,drop=FALSE] 120 | K_ufDinvm = K_ufDinvm + model$K_uf[, ind,drop=FALSE]%*%Dinvm[[i]] 121 | } 122 | ll = ll - model$beta*sum((model$Ainv%*%K_ufDinvm) * K_ufDinvm) 123 | 124 | for (i in 1:length(model$blockEnd)) { 125 | ind = .gpBlockIndices(model, i) 126 | ll = ll + model$d*(model$logDetD[i] - length(ind)*log(model$beta)) 127 | + model$beta*sum(Dinvm[[i]] * model$m[ind, ,drop=FALSE]) 128 | } 129 | ll = -0.5*ll 130 | ll = ll - 0.5*model$N*model$d*log(2*pi) 131 | } else 132 | stop("Variable Length Beta not implemented yet.") 133 | } else { 134 | if (length(model$beta)==1) { 135 | ll = 0 136 | Dinvm = matrix(0, model$blockEnd, model$d) 137 | Dinvm = lapply(split(Dinvm,row(Dinvm)), split, 1:model$d) 138 | for (j in 1:model$d) { 139 | ll = ll + model$logDetA[j]-model$logDetK_uu + model$k*log(model$beta) 140 | ## Loop through the blocks computing each part to be added. 141 | K_ufDinvm = matrix(0, model$k, 1) 142 | for (i in 1:length(model$blockEnd)) { 143 | ind = .gpDataIndices(model, j, i) 144 | Dinvm[[i]][[j]] = model$Dinv[[i]][[j]]%*%model$m[ind, j,drop=FALSE] 145 | K_ufDinvm = K_ufDinvm + model$K_uf[, ind]%*%Dinvm[[i]][[j]] 146 | } 147 | ll = ll - model$beta*sum((model$Ainv[[i]]%*%K_ufDinvm) * K_ufDinvm) 148 | 149 | for (i in 1:length(model$blockEnd)) { 150 | ind = .gpDataIndices(model, j, i) 151 | ll = ll + model$logDetD[i, j] - length(ind)*log(model$beta) 152 | + model$beta*sum(Dinvm[[i]][[j]] * model$m[ind, j,drop=FALSE]) 153 | ll = ll + length(ind)*log(2*pi) 154 | } 155 | } 156 | ll = -0.5*ll 157 | } else 158 | stop("Variable Length Beta not implemented yet.") 159 | } 160 | } 161 | 162 | if (model$learnScales) 163 | ll = ll - sum(log(model$scale)) 164 | 165 | ll = ll - model$d * model$N/2 * log(2*pi) 166 | 167 | return (ll) 168 | } 169 | -------------------------------------------------------------------------------- /R/gptk_gpMeanFunctionGradient.R: -------------------------------------------------------------------------------- 1 | .gpMeanFunctionGradient <- 2 | function(model) { 3 | 4 | if ("isSpherical" %in% names(model) && !model$isSpherical) 5 | stop("Currently only implemented for spherical") 6 | else 7 | if (model$isMissingData) 8 | stop("Currently not implemented for missing data.") 9 | 10 | if ("meanunction" %in% names(model) && length(model$meanFunction)>0) { 11 | g = matrix(0, 1, model$meanFunction$numParams) 12 | ## compute gradients here. 13 | if (model$approx == "ftc") 14 | gmu = model$invK_uu%*%model$m 15 | else if (model$approx %in% c("dtc", "dtcvar")) 16 | gmu = (model$m - t(model$K_uf)%*%model$Ainv%*%(model$K_uf%*%model$m))*model$beta 17 | else if (model$approx == "fitc") { 18 | Dinvm = model$Dinv%*%model$m 19 | gmu = (Dinvm-(model$Dinv %*% t(model$K_uf)) 20 | %*%(model$Ainv%*%model$K_uf)%*%Dinvm)*model$beta 21 | } else if (model$approx == "pitc") { 22 | ## Loop through the blocks computing each part to be added. 23 | gmu = matrix(0, model$N, model$d) 24 | K_ufDinvm = matrix(0,model$k, model$d) 25 | K_ufDinv = matrix(0,model$k, model$N) 26 | for (i in 1:length(model$blockEnd)) { 27 | ind = .gpBlockIndices(model, i) 28 | Dinvm[[i]] = model$Dinv[[i]]%*%model$m[ind, ,drop=FALSE] 29 | K_ufDinvm = K_ufDinvm + model$K_uf[, ind,drop=FALSE]%*%Dinvm[[i]] 30 | } 31 | for (i in 1:length(model$blockEnd)) { 32 | ind = .gpBlockIndices(model, i) 33 | gmu[ind, ] = (Dinvm[[i]] - model$Dinv[[i]] 34 | %*%t(model$K_uf[, ind,drop=FALSE])%*%(model$Ainv%*%K_ufDinvm))*model$beta 35 | } 36 | } 37 | 38 | gmu = gmu/kronecker(matrix(1,model$N, 1),model$scale) 39 | goutputDparam = .modelOutputGrad(model$meanFunction, model$X) 40 | for (i in 1:model$meanFunction$numParams) 41 | g[1, i] = sum(gmu * drop(goutputDparam[, i, ])) # drop=squeeze 42 | } else 43 | g = list() 44 | 45 | return (g) 46 | } 47 | -------------------------------------------------------------------------------- /R/gptk_gpObjective.R: -------------------------------------------------------------------------------- 1 | .gpObjective <- 2 | function(params, model) { 3 | 4 | model = .gpExpandParam(model, params) 5 | f = - .gpLogLikelihood(model) 6 | 7 | return (f) 8 | } 9 | -------------------------------------------------------------------------------- /R/gptk_gpOptimise.R: -------------------------------------------------------------------------------- 1 | .gpOptimise <- 2 | function(model, display=TRUE, iters=2000, gradcheck=FALSE) { 3 | 4 | params = .gpExtractParam(model) 5 | ## options = list(maxit=3000, ln=c(0,2), xtol=1e-4, fnTol=1e-4, optimiser="SCG", 6 | ## gradcheck=FALSE, display=TRUE) 7 | options = .optimiDefaultOptions() 8 | options$display = FALSE 9 | if (display) { 10 | options$display = TRUE 11 | if ((length(params) <= 100) && gradcheck) 12 | options$gradcheck = TRUE 13 | } 14 | options$maxit = iters 15 | 16 | if ("optimiser" %in% names(model)) 17 | optim = get(paste(".", model$optimiser, "optim", sep=""), mode="function") 18 | else 19 | optim = get(".CGoptim", mode="function") 20 | 21 | fn = get('.gpObjective', mode="function") 22 | grad = get('.gpGradient', mode="function") 23 | 24 | # strcmp(func2str(optim), 'optimiMinimize') 25 | # ## Carl Rasmussen's minimize function 26 | # params = optim('gpObjectiveGradient', params, options, model); 27 | # else 28 | ## R version of NETLAB function 29 | params = optim(params, fn, grad, options, model) ## log-transformed params passed into optimiser 30 | 31 | model = .gpExpandParam(model, params) 32 | 33 | return (model) 34 | } 35 | -------------------------------------------------------------------------------- /R/gptk_gpOptions.R: -------------------------------------------------------------------------------- 1 | .gpOptions <- 2 | function (approx="ftc") { 3 | 4 | options = list() 5 | 6 | options$approx = approx 7 | 8 | ## Select type of optimiser. 9 | options$optimiser = "SCG" 10 | 11 | ## Set to true to learn output scales. 12 | options$learnScales = FALSE 13 | 14 | ## Set to true to scale outputs to variance 1. 15 | options$scale2var1 = FALSE 16 | 17 | ## Set to true to optimise beta. 18 | options$optimiseBeta = FALSE 19 | if (approx != "ftc") 20 | options$optimiseBeta = TRUE 21 | 22 | ## Set to a given mean function to have a mean function. 23 | options$meanFunction = list() 24 | ## Options structure for mean function options. 25 | options$meanFunctionOptions = list() 26 | 27 | ## Set to 1 if output processes have a shared variance. 28 | options$isSpherical = TRUE 29 | 30 | ## Set to 1 if there is data missing in the target matrix. 31 | options$isMissingData = FALSE 32 | 33 | if (options$approx == "ftc") { 34 | ## bog-standard kernel. 35 | ## R version of the kern field is a more structured than in MATLAB. 36 | options$kern = list(type="cmpnd",comp=list("rbf", "bias", "white")) 37 | options$numActive = 0 38 | options$beta = list() 39 | } else if (options$approx %in% c('fitc', 'pitc', 'dtc', 'dtcvar')) { 40 | options$kern = list(type="cmpnd",comp=list("rbf", "bias", "white")) 41 | options$numActive = 100 42 | options$beta = 1e+3 43 | ## Option to fix the inducing variables to other latent points. 44 | options$fixInducing = 0 45 | options$fixIndices = list() 46 | } 47 | 48 | options$computeS = FALSE 49 | return (options) 50 | } 51 | -------------------------------------------------------------------------------- /R/gptk_gpPlot.R: -------------------------------------------------------------------------------- 1 | .gpPlot <- 2 | function(model,Xstar,mu,S,simpose=NULL,xlim=NULL,ylim=NULL,xlab='',ylab='',col='blue',title='') { 3 | ## GPPLOT Plots the GP mean and variance. 4 | 5 | ## COPYRIGHT : Alfredo Kalaitzis 2010 6 | 7 | ## GP 8 | 9 | if (missing(model) || missing(Xstar)) { 10 | stop('Missing GP model or points of prediction Xstar.') 11 | } else { 12 | if (missing(mu) || missing(S)) { 13 | # browser() 14 | meanVar = .gpPosteriorMeanVar(model, Xstar, varsigma.return=TRUE) 15 | mu = meanVar$mu; S = meanVar$varsigma 16 | } 17 | } 18 | 19 | f = c(mu+2*sqrt(abs(S)), rev(mu-2*sqrt(abs(S)))) 20 | 21 | if (is.null(xlim)) 22 | xlim = range(rbind(model$X, Xstar)) 23 | if (is.null(ylim)) 24 | ylim = range(f) 25 | 26 | # par(pty="s") 27 | plot(0, type="n", xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, main=title, new=TRUE) ## Empty plot basis. 28 | 29 | if (col=='blue') shade = rgb(0,0,1,alpha=.1) 30 | else if (col=='red') shade = rgb(255,0,0,alpha=.1) 31 | else shade = 'gray' 32 | 33 | polygon(c(Xstar, rev(Xstar)), f, col = shade, border = shade) ## Confidence intervals. 34 | points(model$X, model$y, pch = 3, cex = .5, lwd=2, col = col) ## Training points. 35 | lines(Xstar, mu, col=col, lwd=2) ## Mean function. 36 | 37 | if (!is.null(simpose)) { 38 | y = mu[simpose] + rnorm(6, 0, exp(model$params$xmin[3]/2)) 39 | points(simpose, y, pch = 4, cex = 1.5, lwd=3, col = col) 40 | } 41 | 42 | .zeroAxes() 43 | } 44 | -------------------------------------------------------------------------------- /R/gptk_gpPosteriorMeanVar.R: -------------------------------------------------------------------------------- 1 | .gpPosteriorMeanVar <- 2 | function(model, X, varsigma.return=FALSE) { 3 | # browser() 4 | if (!"alpha" %in% names(model)) 5 | model = .gpComputeAlpha(model) 6 | 7 | maxMemory = 1000000 8 | 9 | if (model$approx == "ftc") 10 | chunkSize = ceiling(maxMemory/model$N) 11 | else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) 12 | chunkSize = ceiling(maxMemory/model$k) 13 | 14 | mu = matrix(0, dim(X)[1], model$d) 15 | # if (varsigma.return) #if (nargout > 1) 16 | # varsigma = matrix(0, dim(X)[1], model$d) 17 | 18 | startVal = 1 19 | endVal = chunkSize 20 | if (endVal > dim(X)[1]) 21 | endVal = dim(X)[1] 22 | 23 | while (startVal <= dim(X)[1]) { 24 | indices = startVal:endVal 25 | 26 | ## Compute kernel for new point. 27 | if (model$approx == "ftc") { 28 | # browser() 29 | KX_star = .kernCompute(model$kern, model$X, X[indices, ,drop=FALSE]) 30 | } 31 | else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) 32 | KX_star = .kernCompute(model$kern, model$X_u, X[indices, ,drop=FALSE]) 33 | 34 | ## Compute mean, using precomputed alpha vector. 35 | if ((!"isMissingData" %in% names(model)) || !model$isMissingData || model$approx != "ftc") 36 | mu[indices, ] = t(KX_star) %*% model$alpha 37 | else { 38 | for (i in 1:model$d) 39 | mu[indices, i] = t(KX_star[model$indexPresent[[i]], ,drop=FALSE]) %*% 40 | model$alpha[model$indexPresent[[i]], i,drop=FALSE] 41 | } 42 | 43 | ## Compute variances if required. 44 | if (varsigma.return) { #if (nargout > 1) 45 | varsigma = matrix(0, dim(X)[1], model$d) 46 | if (!("isSpherical" %in% names(model)) || model$isSpherical) { 47 | ## Compute diagonal of kernel for new point. 48 | diagK = .kernDiagCompute(model$kern, X[indices, ,drop=FALSE]) 49 | if (model$approx == "ftc") 50 | # browser() 51 | Kinvk = model$invK_uu %*% KX_star 52 | else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) 53 | Kinvk = (model$invK_uu - drop(1/model$beta)*model$Ainv) %*% KX_star 54 | varsig = diagK - colSums(KX_star * Kinvk) 55 | if ("beta" %in% names(model) && length(model$beta)>0) { 56 | varsig = varsig + drop(1/model$beta) 57 | } 58 | varsigma[indices, ] = kronecker(matrix(1,1,model$d), varsig) 59 | } else { 60 | diagK = .kernDiagCompute(model$kern, X[indices, ,drop=FALSE]) 61 | for (i in 1:model$d) { 62 | ind = model$indexPresent[[i]] 63 | if (model$approx == "ftc") 64 | Kinvk = model$invK_uu[[i]] %*% KX_star[ind, ,drop=FALSE] 65 | else { 66 | stop(c("Non-spherical not yet implemented for any approximation", 67 | "other than 'ftc'.")) 68 | } 69 | varsigma[indices, i] = diagK - colSums(KX_star[ind, ,drop=FALSE] * Kinvk) 70 | } 71 | } 72 | } 73 | 74 | 75 | ## Rescale the mean 76 | #browser() 77 | mu[indices,] = mu[indices, ,drop=FALSE] * kronecker(matrix(1,length(indices),1), model$scale) 78 | ## Add the bias back in. 79 | mu[indices,] = mu[indices, ,drop=FALSE] + kronecker(matrix(1,length(indices),1), model$bias) 80 | ## If the mean function is present, add it it. 81 | if (("meanFunction" %in% names(model)) && length(model$meanFunction)>0) { 82 | mu[indices,] = mu[indices, ,drop=FALSE] + .modelOut(model$meanFunction, X[indices, ,drop=FALSE]) 83 | } 84 | ## rescale the variances 85 | if (varsigma.return) { #if (nargout > 1) 86 | varsigma[indices,] = varsigma[indices, ,drop=FALSE] * 87 | kronecker(matrix(1,length(indices),1), model$scale * model$scale) 88 | } 89 | 90 | ## Prepare for the next chunk. 91 | startVal = endVal + 1 92 | endVal = endVal + chunkSize 93 | if (endVal > dim(X)[1]) 94 | endVal = dim(X)[1] 95 | } #while 96 | 97 | if (varsigma.return) 98 | return (list(mu=mu, varsigma=varsigma)) 99 | else 100 | return (mu) 101 | } 102 | -------------------------------------------------------------------------------- /R/gptk_gpScaleBiasGradient.R: -------------------------------------------------------------------------------- 1 | .gpScaleBiasGradient <- 2 | function(model) { 3 | g = list() 4 | if (model$learnScales) { 5 | ## 'drop' converts row matrix to column vector by default. 6 | g = 1/model$scale * drop(model$innerProducts-1) 7 | fhandle <- get(model$scaleTransform$func, mode="function") 8 | g = g * fhandle(model$scale, "gradfact") 9 | } 10 | 11 | return (g) 12 | } 13 | -------------------------------------------------------------------------------- /R/gptk_gpUpdateAD.R: -------------------------------------------------------------------------------- 1 | .gpUpdateAD <- 2 | function (model, X=model$X) { 3 | 4 | model$beta = drop(model$beta) 5 | if (model$approx == "ftc") { 6 | ## Compute the inner product values. 7 | if (!"S" %in% names(model)) { 8 | model$innerProducts = matrix(0, 1, model$d) 9 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 10 | for (i in 1:model$d) { 11 | model$innerProducts[1, i] = t(model$m[, i,drop=FALSE])%*%model$invK_uu%*%model$m[, i,drop=FALSE] 12 | } 13 | } else { 14 | for (i in 1:model$d) { 15 | ind = .gpDataIndices(model, i) 16 | model$innerProducts[1, i] = t(model$m[ind, i,drop=FALSE])%*%model$invK_uu[[i]]%*%model$m[ind, i,drop=FALSE] 17 | } 18 | } 19 | } 20 | } else if (model$approx %in% c("dtc", "dtcvar")) { 21 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 22 | ## Compute A = invBetaK_uu + K_uf%*%K_uf' 23 | K_uf2 = model$K_uf %*% t(model$K_uf) 24 | model$A = 1/model$beta * model$K_uu + K_uf2 25 | ## This can become unstable when K_uf2 is low rank. 26 | invA = .jitCholInv(model$A, silent=TRUE) 27 | model$Ainv = invA$invM 28 | model$logDetA = 2* sum(log(diag(invA$chol))) 29 | 30 | ## compute inner products 31 | model$innerProducts = matrix(0, 1, model$d) 32 | for (i in 1:model$d) { 33 | E = model$K_uf %*% model$m[, i] 34 | model$innerProducts[1, i] = model$beta * 35 | (t(model$m[, i,drop=FALSE])%*%model$m[, i,drop=FALSE] - t(E)%*%model$Ainv%*%E) 36 | } 37 | 38 | if (model$approx == "dtcvar") { 39 | model$diagD = model$beta * 40 | (model$diagK - colSums(model$K_uf * (model$invK_uu%*%model$K_uf))) 41 | } 42 | } else { 43 | model$A=list(); model$logDetA=matrix(0,1,model$d) 44 | if (!model$isMissingData) 45 | K_uf2 = model$K_uf%*%t(model$K_uf) 46 | 47 | model$innerProducts = matrix(0, 1, model$d) 48 | for (i in 1:model$d) { 49 | ind = .gpDataIndices(model, i) 50 | ## Compute A = invBetaK_uu + K_uf%*%K_uf' 51 | if (model$isMissingData) 52 | K_uf2 = model$K_uf[, ind,drop=FALSE]%*%t(model$K_uf[, ind,drop=FALSE]) 53 | 54 | model$A[[i]]= (1/model$beta) * model$K_uu+K_uf2 55 | ## This can become unstable when K_uf2 is low rank. 56 | invA = .jitCholInv(model$A[[i]], silent=TRUE) 57 | model$Ainv[[i]] = invA$invM 58 | model$logDetA[i] = 2* sum( log ( diag(invA$chol) ) ) 59 | ## compute inner products 60 | E = model$K_uf[, ind,drop=FALSE]%*%model$m[ind, i,drop=FALSE] 61 | model$innerProducts[1, i] = (model$beta) * 62 | (t(model$m[ind, i,drop=FALSE])%*%model$m[ind, i,drop=FALSE] - t(E)%*%model$Ainv[[i]]%*%E) 63 | } 64 | 65 | if (model$approx == "dtcvar") 66 | stop("Non spherical implementation for dtcvar not yet done.") 67 | } 68 | } else if (model$approx == "fitc") { 69 | model$L = t(.jitChol(model$K_uu)$chol) 70 | 71 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 72 | model$diagD = 1 + (model$beta)*model$diagK 73 | - model$beta*t(colSums(model$K_uf * (model$invK_uu%*%model$K_uf))) 74 | 75 | model$Dinv = spam::diag.spam(drop(1/model$diagD)) #sparseDiag(1/model$diagD) 76 | K_ufDinvK_uf = model$K_uf%*%model$Dinv%*%t(model$K_uf) 77 | model$A = 1/model$beta*model$K_uu + K_ufDinvK_uf 78 | ## This can become unstable when K_ufDinvK_uf is low rank. 79 | invA = .jitCholInv(model$A, silent=TRUE) 80 | model$Ainv = invA$invM 81 | model$logDetA = 2*sum(log(diag(invA$chol))) 82 | model$detDiff = - log(model$beta)*model$k + 83 | log(det(diag(model$k) + model$beta*K_ufDinvK_uf%*%model$invK_uu)) 84 | ## compute inner products 85 | model$innerProducts = matrix(0, 1, model$d) 86 | for (i in 1:model$d) { 87 | Dinvm = model$Dinv %*% model$m[, i] 88 | K_ufDinvm = model$K_uf%*%Dinvm 89 | model$innerProducts[1, i] = model$beta * 90 | (t(Dinvm)%*%model$m[, i,drop=FALSE] - t(K_ufDinvm)%*%model$Ainv%*%K_ufDinvm) 91 | } 92 | 93 | ## Computations from Ed's implementation. 94 | model$V = solve(model$L, model$K_uf) #model$L \ model$K_uf 95 | model$V = model$V / kronecker(matrix(1,model$k,1), t(sqrt(model$diagD))) #repmat(sqrt(model$diagD)', model$k, 1) 96 | model$Am = 1/model$beta*diag(model$k) + model$V%*%t(model$V) 97 | model$Lm = t(.jitChol(model$Am)$chol) 98 | model$invLmV = solve(model$Lm, model$V) 99 | model$scaledM = model$m / kronecker(matrix(1,1,model$d), sqrt(model$diagD)) 100 | model$bet = model$invLmV%*%model$scaledM 101 | } else { 102 | model$innerProducts = matrix(0, 1, model$d) 103 | model$logDetA=matrix(0,1,model$d); model$detDiff=matrix(0,1,model$d) 104 | model$diagD=list(); model$Dinv=list(); model$A=list(); model$Ainv=list() 105 | model$V=list(); model$Am=list(); model$Lm=list(); model$invLmV=list() 106 | model$scaledM=list(); model$bet=list() 107 | for (i in 1:model$d) { 108 | ind = .gpDataIndices(model, i) 109 | model$diagD[[i]] = 1 + model$beta*model$diagK[ind] 110 | - model$beta*t(colSums(model$K_uf[, ind,drop=FALSE] * (model$invK_uu%*%model$K_uf[, ind,drop=FALSE]))) 111 | model$Dinv[[i]] = spam::diag.spam(drop(1/model$diagD[[i]])) 112 | K_ufDinvK_uf = model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]]%*%t(model$K_uf[, ind,drop=FALSE]) 113 | model$A[[i]] = 1 / model$beta*model$K_uu + K_ufDinvK_uf 114 | ## This can become unstable when K_ufDinvK_uf is low rank. 115 | invA = .jitCholInv(model$A[[i]], silent=TRUE) 116 | model$Ainv[[i]] = invA$invM 117 | model$logDetA[i] = 2*sum(log(diag(invA$chol))) 118 | model$detDiff[i] = - log(model$beta)*model$k 119 | + log(det(diag(model$k) + model$beta*K_ufDinvK_uf%*%model$invK_uu)) 120 | 121 | ## compute inner products 122 | Dinvm = model$Dinv[[i]]%*%model$m[ind, i,drop=FALSE] 123 | K_ufDinvm = model$K_uf[, ind,drop=FALSE]%*%Dinvm 124 | model$innerProducts[1, i] = model$beta*(t(Dinvm)%*%model$m[ind, i,drop=FALSE] - t(K_ufDinvm)%*%model$Ainv[[i]]%*%K_ufDinvm) 125 | 126 | ## Computations from Ed's implementation. 127 | model$V[[i]] = solve(model$L, model$K_uf[, ind,drop=FALSE]) 128 | model$V[[i]] = model$V[[i]] / kronecker(matrix(1,model$k,1), t(sqrt(model$diagD[[i]]))) 129 | model$Am[[i]] = 1/model$beta * diag(model$k) + model$V[[i]]%*%t(model$V[[i]]) 130 | model$Lm[[i]] = t(.jitChol(model$Am[[i]])$chol) 131 | model$invLmV[[i]] = solve(model$Lm[[i]], model$V[[i]]) 132 | model$scaledM[[i]] = model$m[ind, i,drop=FALSE] / sqrt(model$diagD[[i]]) 133 | model$bet[[i]] = model$invLmV[[i]]%*%model$scaledM[[i]] 134 | } 135 | } 136 | } else if (model$approx == "pitc") { 137 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 138 | model$A = 1/model$beta*model$K_uu 139 | K_ufDinvm = matrix(0,model$k, model$d) 140 | model$logDetD = matrix(0, 1, length(model$blockEnd)) 141 | Dinvm = list(); model$Dinv = list(); model$D = list() 142 | for (i in 1:length(model$blockEnd)) { 143 | ind = .gpBlockIndices(model, i) 144 | model$D[[i]] = diag(length(ind)) + model$beta*model$K[[i]] - 145 | model$beta*t(model$K_uf[, ind,drop=FALSE])%*%model$invK_uu%*%model$K_uf[, ind,drop=FALSE] 146 | invD = .jitCholInv(model$D[[i]], silent=TRUE) 147 | model$Dinv[[i]] = invD$invM 148 | model$logDetD[i] = 2* sum( log ( diag(invD$chol) ) ) 149 | K_ufDinvK_uf = model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]]%*%t(model$K_uf[, ind,drop=FALSE]) 150 | model$A = model$A + K_ufDinvK_uf 151 | Dinvm[[i]] = model$Dinv[[i]]%*%model$m[ind, ,drop=FALSE] 152 | K_ufDinvm = K_ufDinvm + model$K_uf[, ind,drop=FALSE]%*%Dinvm[[i]] 153 | } 154 | ## This can become unstable when K_ufDinvK_uf is low rank. 155 | invA = .jitCholInv(model$A, silent=TRUE) 156 | model$Ainv = invA$invM 157 | model$logDetA = 2* sum(log(diag(invA$chol))) 158 | ## compute inner products 159 | model$innerProducts = matrix(0, 1, model$d) 160 | for (i in 1:model$d) 161 | model$innerProducts[1, i] = - model$beta*t(K_ufDinvm[, i,drop=FALSE])%*%model$Ainv%*%K_ufDinvm[, i,drop=FALSE] 162 | 163 | for (i in 1:length(model$blockEnd)) { 164 | ind = .gpBlockIndices(model, i) 165 | for (j in 1:model$d) 166 | model$innerProducts[1, j] = model$innerProducts[1, j] 167 | + model$beta*t(Dinvm[[i]][, j,drop=FALSE])%*%model$m[ind, j,drop=FALSE] 168 | } 169 | } else { 170 | model$A = list(); model$Ainv = list() 171 | model$D = matrix(0, length(model$blockEnd), model$d) 172 | model$D = lapply(split(model$D,row(model$D)), split, 1:model$d) 173 | model$Dinv = model$D 174 | model$logDetD = matrix(0, length(model$blockEnd), model$d) 175 | model$logDetA = matrix(0, 1, model$d) 176 | Dinvm = as.list(matrix(0,1,length(model$blockEnd))) 177 | Dinvm = lapply(Dinvm, function(x) x=matrix(0,model$N,model$d)) 178 | for (j in 1:model$d) { 179 | model$A[[j]] = 1/model$beta*model$K_uu 180 | K_ufDinvm = matrix(0, model$k, model$d) 181 | for (i in 1:length(model$blockEnd)) { 182 | ind = .gpDataIndices(model, j, i) 183 | model$D[[i]][[j]] = diag(length(ind)) + model$beta*model$K[[i]][[j]] - 184 | model$beta*t(model$K_uf[, ind,drop=FALSE])%*%model$invK_uu%*%model$K_uf[, ind,drop=FALSE] 185 | invD = .jitCholInv(model$D[[i]][[j]], silent=TRUE) 186 | model$Dinv[[i]][[j]] = invD$invM 187 | model$logDetD[i,j] = 2* sum( log ( diag(invD$chol) ) ) 188 | K_ufDinvK_uf = model$K_uf[, ind,drop=FALSE]%*%model$Dinv[[i]][[j]]%*%t(model$K_uf[, ind,drop=FALSE]) 189 | model$A[[j]] = model$A[[j]] + K_ufDinvK_uf 190 | Dinvm[[i]][ind, j] = model$Dinv[[i]][[j]]%*%model$m[ind, j,drop=FALSE] 191 | K_ufDinvm[, j] = K_ufDinvm[, j,drop=FALSE] + model$K_uf[, ind,drop=FALSE]%*%Dinvm[[i]][ind, j,drop=FALSE] 192 | } 193 | ## This can become unstable when K_ufDinvK_uf is low rank. 194 | invA = .jitCholInv(model$A[[j]], silent=TRUE) 195 | model$Ainv[[j]] = invA$invM 196 | model$logDetA[j] = 2* sum( log ( diag(invA$chol) ) ) 197 | } 198 | 199 | model$innerProducts = matrix(0, 1, model$d) 200 | ## compute inner products 201 | for (j in 1:model$d) 202 | model$innerProducts[1, j] = - model$beta*t(K_ufDinvm[, j,drop=FALSE])%*%model$Ainv[[j]]%*%K_ufDinvm[, j,drop=FALSE] 203 | 204 | for (i in 1:length(model$blockEnd)) { 205 | for (j in 1:model$d) { 206 | ind = .gpDataIndices(model, j, i) 207 | model$innerProducts[1, j] = model$innerProducts[1, j] 208 | + model$beta*t(Dinvm[[i]][ind, j,drop=FALSE])%*%model$m[ind, j,drop=FALSE] 209 | } 210 | } 211 | } 212 | } else 213 | stop("Unknown approximating criterion.") 214 | 215 | return (model) 216 | } 217 | -------------------------------------------------------------------------------- /R/gptk_gpUpdateKernels.R: -------------------------------------------------------------------------------- 1 | .gpUpdateKernels <- 2 | function (model, X, X_u) { 3 | jitter = 1e-6 4 | 5 | if (model$approx == "ftc") { 6 | ## (dev note) In the long term, we should allow different kernels in each dimension here. 7 | # browser() 8 | model$K_uu = .kernCompute(model$kern, X) 9 | 10 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 11 | ## Add inverse beta to diagonal if it exists. 12 | if ("beta" %in% names(model) && length(model$beta)>0) { 13 | model$K_uu[seq(1,length(model$K_uu),by= dim(model$K_uu)[1]+1)] = 14 | model$K_uu[seq(1,length(model$K_uu),by= dim(model$K_uu)[1]+1)] + 1/model$beta 15 | } 16 | # browser() 17 | invK = .jitCholInv(model$K_uu, silent=TRUE) ## pdinv + jitChol combined 18 | model$invK_uu = invK$invM 19 | model$logDetK_uu = 2* sum( log ( diag(invK$chol) ) ) 20 | 21 | 22 | } else { 23 | model$invK_uu=list(); model$logDetK_uu=matrix(0,1,model$d) 24 | for (i in 1:model$d) { 25 | if ("beta" %in% names(model) && length(model$beta)>0) { 26 | if (dim(as.matrix(model$beta))[2] == model$d) 27 | betaAdd = model$beta[, i] 28 | else 29 | betaAdd = model$beta 30 | 31 | model$K_uu[seq(1,length(model$K_uu),by= dim(model$K_uu)[1]+1)] = 32 | model$K_uu[seq(1,length(model$K_uu),by= dim(model$K_uu)[1]+1)] + 1/betaAdd 33 | } 34 | ind = .gpDataIndices(model, i) 35 | invK = .jitCholInv(model$K_uu[ind,ind], silent=TRUE) ## pdinv + jitChol combined 36 | model$invK_uu[[i]] = invK$invM 37 | model$logDetK_uu[i] = 2* sum( log ( diag(invK$chol) ) ) 38 | } 39 | } 40 | } else if (model$approx %in% c("dtc", "dtcvar", "fitc", "pitc")) { 41 | model$K_uu = .kernCompute(model$kern, X_u) 42 | 43 | if ((!"whiteVariance" %in% names(model$kern)) || model$kern$whiteVariance == 0) { 44 | ## There is no white noise term so add some jitter. 45 | model$K_uu = model$K_uu + spam::diag.spam(jitter, dim(model$K_uu)[1]) ## need 'spam' 46 | #sparseDiag(matrix(jitter, dim(model$K_uu)[1], 1)) 47 | } 48 | model$K_uf = .kernCompute(model$kern, X_u, X) 49 | invK = .jitCholInv(model$K_uu, silent=TRUE) ## pdinv + jitChol combined 50 | model$invK_uu = invK$invM 51 | model$logDetK_uu = 2* sum( log ( diag(invK$chol) ) ) 52 | } 53 | 54 | if (model$approx %in% c("dtcvar", "fitc")) 55 | model$diagK = .kernDiagCompute(model$kern, X) 56 | else if (model$approx == "pitc") { 57 | if ((!"isSpherical" %in% names(model)) || model$isSpherical) { 58 | model$K=list() 59 | for (i in 1:length(model$blockEnd)) { 60 | ind = .gpBlockIndices(model, i) 61 | model$K[[i]] = .kernCompute(model$kern, X[ind, ,drop=FALSE]) 62 | } 63 | } else { 64 | model$K = matrix(0, length(model$blockEnd), model$d) 65 | model$K = lapply(split(model$K,row(model$K)), split, 1:model$d) 66 | for (j in 1:model$d) { 67 | for (i in 1:length(model$blockEnd)) { 68 | ind = .gpDataIndices(model, j, i) 69 | model$K[[i]][[j]] = .kernCompute(model$kern, X[ind, ,drop=FALSE]) 70 | } 71 | } 72 | } 73 | } 74 | 75 | model = .gpUpdateAD(model, X) 76 | 77 | return (model) 78 | } 79 | -------------------------------------------------------------------------------- /R/gptk_gptk-internal.R: -------------------------------------------------------------------------------- 1 | .complexLog <- 2 | function (x) { 3 | if ( is.double(x) & x>0 ) { 4 | y <- log(x) 5 | } else { 6 | if ( is.double(x) & x<0 ) 7 | warning("Log of negative real number, using complex log!") 8 | y <- log(x+0i) 9 | } 10 | return ( y ) 11 | } 12 | .dist2 <- 13 | function (x, x2) { 14 | xdim <- dim(as.matrix(x)) 15 | x2dim <- dim(as.matrix(x2)) 16 | 17 | xMat <- array(apply(as.matrix(x*x),1,sum), c(xdim[1], x2dim[1])) 18 | x2Mat <- t(array(apply(as.matrix(x2*x2),1,sum), c(x2dim[1], xdim[1]))) 19 | 20 | if ( xdim[2] != x2dim[2] ) 21 | stop("Data dimensions are not matched.") 22 | 23 | n2 <- xMat+x2Mat-2*tcrossprod(x, x2) 24 | 25 | return (n2) 26 | } 27 | .distfit <- 28 | function(data, dist = "normal") { 29 | if (dist == "gamma") { 30 | cdf <- qgamma 31 | } 32 | 33 | else if (dist == "normal") { 34 | cdf <- qnorm 35 | } 36 | 37 | else { 38 | stop("Unknown distribution.") 39 | } 40 | 41 | t <- optim(c(1, 1), fn=.distfit_obj, gr=NULL, data, cdf) 42 | 43 | return (t) 44 | } 45 | .distfit_obj <- 46 | function(theta, y, cdf) { 47 | p <- c(.05, .25, .50, .75, .95) 48 | x <- cdf(p, theta[1], theta[2]) 49 | r <- .5 * sum((x - y)^2) 50 | 51 | return (r) 52 | } 53 | .fn_line <- 54 | function (linemin, fun, para0, direction, ...) { 55 | ## y = fn (x) 56 | func <- function(x, ...) fun(x, ...) 57 | 58 | para <- para0 + linemin * direction 59 | 60 | ans <- func(para, ...) 61 | 62 | return (ans) 63 | } 64 | .gradLnDiffErfs <- 65 | function(x1, x2, fact1, fact2) { 66 | m <- pmin(as.matrix(x1)^2, as.matrix(x2)^2) 67 | dlnPart <- 2/sqrt(pi) * (exp(-x1^2 + m) * fact1 - exp(-x2^2 + m) * fact2) 68 | 69 | g <- list(dlnPart=dlnPart, m=m) 70 | return (g) 71 | 72 | } 73 | .jitChol <- 74 | function ( M, Num=10, silent=FALSE ) { 75 | jitter <- 0 76 | jitter1 <- abs(mean(diag(M)))*1e-6 77 | eyeM <- diag( 1, nrow=length(M[,1]), ncol=length(M[1,]) ) 78 | 79 | for ( i in 1:Num ) { 80 | ## clear the last error message 81 | try(stop(""),TRUE) 82 | 83 | Ch <- try( chol( M + jitter*eyeM ), silent=TRUE ) 84 | 85 | nPos <- grep("not positive definite", geterrmessage()) 86 | 87 | if ( length(nPos) != 0 ) { 88 | jitter1 <- jitter1*10 89 | jitter <- jitter1 90 | 91 | if (! silent) { 92 | warnmsg <- paste("Matrix is not positive definite, adding", 93 | signif(jitter,digits=4), "jitter!") 94 | warning(warnmsg) 95 | } 96 | } 97 | else break 98 | } 99 | 100 | return (list(chol=Ch, jitter=jitter)) 101 | } 102 | .jitCholInv <- 103 | function ( M, Num=10, silent=FALSE ) { 104 | jitter <- 0 105 | jitter1 <- abs(mean(diag(M)))*1e-6 106 | eyeM <- diag( 1, nrow=length(M[,1]), ncol=length(M[1,]) ) 107 | 108 | for ( i in 1:Num ) { 109 | 110 | ## clear the last error message 111 | try(stop(""),TRUE) 112 | 113 | Ch <- try( chol( M + jitter*eyeM ), silent=TRUE ) 114 | 115 | nPos <- grep("not positive definite", geterrmessage()) 116 | 117 | if ( length(nPos) != 0 ) { 118 | jitter1 <- jitter1*10 119 | jitter <- jitter1 120 | 121 | if (! silent) { 122 | warnmsg <- paste("Matrix is not positive definite, adding", 123 | signif(jitter,digits=4), "jitter!") 124 | warning(warnmsg) 125 | } 126 | } 127 | else break 128 | } 129 | 130 | invCh <- try (solve( Ch, eyeM ), silent=TRUE) 131 | 132 | if ( "try-error" %in% class(invCh) ) { 133 | return (NaN) 134 | } 135 | else { 136 | invM <- invCh %*% t(invCh) 137 | 138 | if ( jitter == 0 ) { 139 | ans <- list(invM=invM, jitter=jitter, chol=Ch) 140 | } 141 | else ans <- list(invM=invM, jitM=M+jitter*eyeM , jitter=jitter, chol=Ch) 142 | 143 | return (ans) 144 | } 145 | } 146 | .kernFactors <- 147 | function (kern, factorType) { 148 | factors <- list() 149 | 150 | if ( length(kern$transforms) > 0 ) { 151 | funcName <- paste(".", kern$type, "KernExtractParam", sep="") 152 | func <- get(funcName, mode="function") 153 | params <- func(kern) 154 | 155 | for (i in seq(along=kern$transforms)) { 156 | factors[[i]] <- list() 157 | factors[[i]]$index <- kern$transforms[[i]]$index 158 | funcName <- .optimiDefaultConstraint(kern$transforms[[i]]$type) 159 | func <- get(funcName$func, mode="function") 160 | if (funcName$hasArgs) 161 | factors[[i]]$val <- func(params[factors[[i]]$index], factorType, kern$transformArgs[[i]]) 162 | else 163 | factors[[i]]$val <- func(params[factors[[i]]$index], factorType) 164 | } 165 | } 166 | return (factors) 167 | } 168 | .kernTestCombinationFunction <- 169 | function (kern1, kern2) { 170 | if (kern1$type == "selproj" && kern2$type == "selproj") 171 | funcName <- paste(".", kern1$comp[[1]]$type, "X", kern2$comp[[1]]$type, "KernCompute", sep="") 172 | else 173 | funcName <- paste(".", kern1$type, "X", kern2$type, "KernCompute", sep="") 174 | 175 | if ( !exists(funcName, mode="function") ) { 176 | return (FALSE) 177 | } else { 178 | return (TRUE) 179 | } 180 | } 181 | .multiKernCacheBlock <- 182 | function(kern, fhandle, i, j, x1, x2=NULL, arg1, arg2=NULL) { 183 | 184 | global_cache <- get("cache", envir = kern$cache) 185 | if ((length(global_cache) >= i) && (length(global_cache[[i]]) >= j)) 186 | cache <- global_cache[[i]][[j]] 187 | else 188 | cache <- list() 189 | key <- c(x1, x2) 190 | 191 | for (k in seq(along=cache)) { 192 | if (length(key) == length(cache[[k]]$key) && all(key == cache[[k]]$key)) { 193 | #cat("multiKernCacheBlock: cache hit ", i, j, x1, x2, "\n") 194 | return (cache[[k]]$value) 195 | } 196 | } 197 | 198 | #cat("multiKernCacheBlock: cache miss ", i, j, x1, x2, "\n") 199 | # No match if we get all the way here 200 | if (is.null(arg2)) { 201 | if (is.null(x2)) 202 | K <- fhandle(arg1, x1) 203 | else 204 | K <- fhandle(arg1, x1, x2) 205 | } 206 | else { 207 | if (is.null(x2)) 208 | K <- fhandle(arg1, arg2, x1) 209 | else 210 | K <- fhandle(arg1, arg2, x1, x2) 211 | } 212 | cache <- append(cache, list(list(key=key, value=K))) 213 | if (length(global_cache) < i) 214 | global_cache[[i]] <- list() 215 | global_cache[[i]][[j]] <- cache 216 | assign("cache", global_cache, envir=kern$cache) 217 | return(K) 218 | } 219 | .multiKernComputeBlock <- 220 | function (kern, i, j, x1, x2=NULL) { 221 | if ( i==j ) { 222 | funcName <- paste(".", kern$comp[[i]]$type, "KernCompute", sep="") 223 | transpose <- 0 224 | arg1 <- kern$comp[[i]] 225 | 226 | func <- get(funcName, mode="function") 227 | if (kern$fixBlocks[[i]] && kern$fixBlocks[[j]]) { 228 | K <- .multiKernCacheBlock(kern, func, i, j, arg1=arg1, x1=x1, x2=x2) 229 | } 230 | else { 231 | if (is.null(x2)) 232 | K <- func(arg1, x1) 233 | else 234 | K <- func(arg1, x1, x2) 235 | } 236 | } else { 237 | 238 | if ( j 0) 8 | && !untransformed.values ) 9 | for ( i in seq(along=kern$transforms) ) { 10 | index <- kern$transforms[[i]]$index 11 | funcName <- .optimiDefaultConstraint(kern$transforms[[i]]$type) 12 | func <- get(funcName$func, mode="function") 13 | if (funcName$hasArgs) 14 | params[index] <- func(params[index], "atox", kern$transformArgs[[i]]) ## log-transformed params just been exp-transformed 15 | else { 16 | params[index] <- func(params[index], "atox") 17 | } 18 | } 19 | 20 | funcName <- paste(".", kern$type, "KernExpandParam", sep="") 21 | func <- get(funcName, mode="function") 22 | # browser() 23 | kern <- func(kern, params) 24 | 25 | return (kern) 26 | 27 | } 28 | -------------------------------------------------------------------------------- /R/gptk_kernExtractParam.R: -------------------------------------------------------------------------------- 1 | .kernExtractParam <- 2 | function (kern, only.values=TRUE, untransformed.values=FALSE) { 3 | funcName <- paste(".", kern$type, "KernExtractParam", sep="") 4 | func <- get(funcName, mode="function") 5 | 6 | params <- func(kern, only.values=only.values, untransformed.values=untransformed.values) 7 | 8 | if ( any(is.nan(params)) ) 9 | warning("Parameter has gone to NaN.") 10 | 11 | if ( "transforms" %in% names(kern) && (length(kern$transforms) > 0) 12 | && !untransformed.values ) 13 | for ( i in seq(along=kern$transforms) ) { 14 | index <- kern$transforms[[i]]$index 15 | funcName <- .optimiDefaultConstraint(kern$transforms[[i]]$type) 16 | func <- get(funcName$func, mode="function") 17 | if (funcName$hasArgs) 18 | params[index] <- func(params[index], "xtoa", kern$transformArgs[[i]]) 19 | else 20 | params[index] <- func(params[index], "xtoa") 21 | } 22 | 23 | return (params) 24 | } 25 | -------------------------------------------------------------------------------- /R/gptk_kernGradX.R: -------------------------------------------------------------------------------- 1 | .kernGradX <- 2 | function (kern, x1, x2) { 3 | funcName <- paste(".",kern$type, "KernGradX", sep="") 4 | func <- get(funcName, mode="function") 5 | k <- func(kern, x1, x2) 6 | return (k) 7 | } 8 | -------------------------------------------------------------------------------- /R/gptk_kernGradient.R: -------------------------------------------------------------------------------- 1 | .kernGradient <- 2 | function (kern, x, ...) { 3 | funcName <- paste(".",kern$type, "KernGradient", sep="") 4 | func <- get(funcName, mode="function") 5 | 6 | g <- func(kern, x, ...) 7 | 8 | factors <- .kernFactors(kern, "gradfact") 9 | for (i in seq(along=factors)) 10 | g[factors[[i]]$index] <- g[factors[[i]]$index]*factors[[i]]$val 11 | 12 | return (g) 13 | } 14 | -------------------------------------------------------------------------------- /R/gptk_kernParamInit.R: -------------------------------------------------------------------------------- 1 | .kernParamInit <- 2 | function (kern) { 3 | 4 | funcName <- paste(".", kern$type, "KernParamInit", sep="") 5 | kern$transforms = list() 6 | 7 | func <- get(funcName, mode="function") 8 | kern <- func(kern) 9 | 10 | return (kern) 11 | } 12 | -------------------------------------------------------------------------------- /R/gptk_localCovarianceGradients.R: -------------------------------------------------------------------------------- 1 | .localCovarianceGradients <- 2 | function(model, y, dimension) { 3 | if (!"isSpherical" %in% names(model) || model$isSpherical) { 4 | invKy = model$invK_uu %*% y 5 | gK = -model$invK_uu + invKy%*%t(invKy) 6 | } else { 7 | if (model$isMissingData) 8 | m = y[model$indexPresent[[dimension]]] 9 | else 10 | m = y 11 | 12 | invKy = model$invK_uu[[dimension]] %*% m 13 | gK = -model$invK_uu[[dimension]] + invKy%*%t(invKy) 14 | } 15 | gK = gK * .5 16 | return (gK) 17 | } 18 | -------------------------------------------------------------------------------- /R/gptk_localSCovarianceGradients.R: -------------------------------------------------------------------------------- 1 | .localSCovarianceGradients <- 2 | function(model) { 3 | gK = -model$d*model$invK_uu + model$invK_uu%*%model$S%*%model$invK_uu 4 | gK = gK * .5 5 | return (gK) 6 | } 7 | -------------------------------------------------------------------------------- /R/gptk_modelExpandParam.R: -------------------------------------------------------------------------------- 1 | .modelExpandParam <- 2 | function (model, params) { 3 | # if (is.GPModel(model)) 4 | # return (modelExpandParam(modelStruct(model), params)) 5 | 6 | if ( is.list(params) ) 7 | params <- params$values 8 | 9 | if ( "paramGroups" %in% names(model) ) 10 | params <- params %*% t(model$paramGroups) 11 | 12 | funcName <- paste(".", model$type, "ExpandParam", sep="") 13 | func <- get(funcName, mode="function") 14 | model <- func(model, params) 15 | 16 | return (model) 17 | } 18 | -------------------------------------------------------------------------------- /R/gptk_modelExtractParam.R: -------------------------------------------------------------------------------- 1 | .modelExtractParam <- 2 | function (model, only.values=TRUE, untransformed.values=FALSE) { 3 | # if (any(.packages(all.available=TRUE)=="tigre") && is.GPModel(model)) 4 | # model <- modelStruct(model) 5 | 6 | funcName <- paste(".", model$type, "ExtractParam", sep="") 7 | func <- get(funcName, mode="function") 8 | params <- func(model, only.values=only.values, untransformed.values=untransformed.values) 9 | 10 | if ( !only.values ) { 11 | origNames <- names(params) 12 | if ( "paramGroups" %in% names(model) ) { 13 | paramGroups <- model$paramGroups 14 | for ( i in seq(length.out=dim(paramGroups)[2]) ) { 15 | ind <- grep(1, paramGroups[,i]) 16 | if ( is.list(params) ) { 17 | names(params)[i] <- origNames[ind[1]] 18 | for ( j in seq(2, length.out=length(ind)-1) ) 19 | names(params)[i] <- paste(names(params)[i], origNames[ind[j]],sep="/") 20 | } 21 | 22 | paramGroups[ind[seq(2,length(ind),length=length(ind)-1)], i] <- 0 23 | } 24 | 25 | params <- params%*%paramGroups 26 | } 27 | } 28 | return (params) 29 | } 30 | -------------------------------------------------------------------------------- /R/gptk_modelOut.R: -------------------------------------------------------------------------------- 1 | .modelOut <- 2 | function(model, X, Phi.return=FALSE, ...) { 3 | fhandle <- get(paste(model$type, "Out", sep=""), mode="function") 4 | #fhandle = str2func(paste(model$type,"Out",sep="")) 5 | 6 | if (Phi.return) { 7 | temp = fhandle(model, X, ...) #[Y, Phi] = fhandle(model, X, varargin{:}) 8 | Y=temp$Y; Phi=temp$Phi 9 | } else 10 | Y = fhandle(model, X, ...) 11 | 12 | if ("indexOut" %in% names(model) && length(model$indexOut)>0) 13 | Y[,setdiff(c(1:dim(Y)[2]),model$indexOut)] = NaN 14 | 15 | if (Phi.return) 16 | return(list(Y=Y, Phi=Phi)) 17 | else 18 | return(Y) 19 | } 20 | -------------------------------------------------------------------------------- /R/gptk_modelOutputGrad.R: -------------------------------------------------------------------------------- 1 | .modelOutputGrad <- 2 | function(model, X, dim) { 3 | 4 | if (nargs() > 2) { 5 | fhandle = get(paste(model$type, "OutputGrad", sep=""), mode="function") 6 | g = fhandle(model, X, dim) 7 | } else { 8 | fhandle = get(paste(model$type, "OutputGrad", sep=""), mode="function") 9 | gtemp = fhandle(model, X) 10 | if ("paramGroups" %in% names(model)) { 11 | g = matrix(0, dim(X)[1], dim(model$paramGroups)[2], dim(gtemp)[3]) 12 | for (i in 1:dim(gtemp)[3]) 13 | g = gtemp[, , i]%*%model$paramGroups 14 | } else 15 | g = gtemp 16 | } 17 | 18 | return (g) 19 | } 20 | -------------------------------------------------------------------------------- /R/gptk_optimiDefaultConstraint.R: -------------------------------------------------------------------------------- 1 | .optimiDefaultConstraint <- 2 | function (constraint) { 3 | if ( constraint == "positive" ) { 4 | return (list(func=".expTransform", hasArgs=FALSE)) 5 | } else if ( constraint == "zeroone" ) { 6 | return (list(func=".sigmoidTransform", hasArgs=FALSE)) 7 | } else if ( constraint == "bounded" ) { 8 | return (list(func=".boundedTransform", hasArgs=TRUE)) 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /R/gptk_optimiDefaultOptions.R: -------------------------------------------------------------------------------- 1 | .optimiDefaultOptions <- 2 | function() { 3 | ## options: trace, maximum iteration, fnscale, reltol, default optimiser 4 | ## return (list(trace=TRUE, maxit=1000, fnscale=1e1, reltol=1e-4, optimiser="CG", gradcheck=FALSE, hessian=FALSE)) 5 | return (list(maxit=3000, ln=c(0,2), xtol=1e-4, fnTol=1e-4, optimiser="SCG", gradcheck=FALSE, display=TRUE)) 6 | } 7 | -------------------------------------------------------------------------------- /R/gptk_rbfKernCompute.R: -------------------------------------------------------------------------------- 1 | .rbfKernCompute <- 2 | function (kern, x, x2=NULL) { 3 | if ( nargs() < 3 ) { 4 | n2 <- .dist2(x,x) 5 | } else { 6 | n2 <- .dist2(x,x2) 7 | } 8 | 9 | wi2 <- 0.5*kern$inverseWidth 10 | k <- kern$variance*exp(-n2*wi2) 11 | 12 | if ("isNormalised" %in% names(kern) && kern$isNormalised) 13 | k <- k * sqrt(kern$inverseWidth/(2*pi)) 14 | 15 | return (k) 16 | } 17 | -------------------------------------------------------------------------------- /R/gptk_rbfKernExpandParam.R: -------------------------------------------------------------------------------- 1 | .rbfKernExpandParam <- 2 | function (kern, params) { 3 | if ( is.list(params) ) 4 | params <- params$values 5 | 6 | kern$inverseWidth <- params[1] ## linear domain params, i.e. untransformed inverse-width and signal variance 7 | kern$variance <- params[2] 8 | 9 | return (kern) 10 | } 11 | -------------------------------------------------------------------------------- /R/gptk_rbfKernExtractParam.R: -------------------------------------------------------------------------------- 1 | .rbfKernExtractParam <- 2 | function (kern, only.values=TRUE, 3 | untransformed.values=TRUE) { 4 | params <- c(kern$inverseWidth, kern$variance) 5 | 6 | if ( !only.values ) 7 | names(params) <- c("inverseWidth", "variance") 8 | 9 | return (params) 10 | } 11 | -------------------------------------------------------------------------------- /R/gptk_rbfKernGradient.R: -------------------------------------------------------------------------------- 1 | .rbfKernGradient <- 2 | function (kern, x, x2, covGrad) { 3 | if ( nargs()==3 ) { 4 | k <- .rbfKernCompute(kern, x) 5 | dist2xx <- .dist2(x, x) 6 | covGrad <- x2 7 | } else if ( nargs()==4 ) { 8 | k <- .rbfKernCompute(kern, x, x2) 9 | dist2xx <- .dist2(x, x2) 10 | } 11 | 12 | g <- array() 13 | if ("isNormalised" %in% names(kern) && kern$isNormalised) { 14 | g[1] <- -0.5*sum(covGrad*k*dist2xx) + 15 | 0.5 * sum(covGrad*k)/kern$inverseWidth 16 | } 17 | else { 18 | g[1] <- -0.5*sum(covGrad*k*dist2xx) 19 | } 20 | g[2] <- sum(covGrad*k)/kern$variance 21 | 22 | if ( any(is.nan(g)) ) 23 | warning("g is NaN.") 24 | 25 | return (g) 26 | } 27 | -------------------------------------------------------------------------------- /R/gptk_rbfKernParamInit.R: -------------------------------------------------------------------------------- 1 | .rbfKernParamInit <- 2 | function (kern) { 3 | kern$inverseWidth <- 1 4 | kern$variance <- 1 5 | kern$nParams <- 2 6 | kern$paramNames <- c("inverseWidth", "variance") 7 | 8 | kern$isStationary <- TRUE 9 | 10 | if ("options" %in% names(kern) && "isNormalised" %in% names(kern$options) && kern$options$isNormalised) 11 | kern$isNormalised <- TRUE 12 | else 13 | kern$isNormalised <- FALSE 14 | 15 | if ("options" %in% names(kern) && "inverseWidthBounds" %in% names(kern$options)) { 16 | kern$transforms <- list(list(index=1, type="bounded"), 17 | list(index=2, type="positive")) 18 | kern$transformArgs <- list() 19 | kern$transformArgs[[1]] <- kern$options$inverseWidthBounds 20 | kern$inverseWidth <- mean(kern$options$inverseWidthBounds) 21 | } 22 | else { 23 | kern$transforms <- list(list(index=c(1,2), type="positive")) 24 | } 25 | 26 | return (kern) 27 | } 28 | -------------------------------------------------------------------------------- /R/gptk_sigmoidTransform.R: -------------------------------------------------------------------------------- 1 | .sigmoidTransform <- 2 | function (x, transform="atox") { 3 | 4 | eps <- 2.2204e-16 5 | 6 | thre <- 36 ## threshold 7 | y <- array(0, dim(as.array(x))) 8 | 9 | if ( "atox" == transform ) { 10 | for ( ind in seq_along(as.array(x)) ) { 11 | if ( x[ind] > thre ) 12 | y[ind] <- 1-eps 13 | else if ( x[ind] < -thre ) 14 | y[ind]<- eps 15 | else 16 | y[ind] <- 1/(1+exp(-x[ind])) 17 | } 18 | } else if ( "xtoa" == transform ) { 19 | for ( ind in seq_along(as.array(x)) ) { 20 | y[ind] <- .complexLog(x[ind]/(1-x[ind])) 21 | } 22 | } else if ( "gradfact" == transform ) 23 | y <- x*(1-x) 24 | 25 | return (y) 26 | } 27 | -------------------------------------------------------------------------------- /R/gptk_whiteKernCompute.R: -------------------------------------------------------------------------------- 1 | .whiteKernCompute <- 2 | function (kern, x, x2) { 3 | if ( nargs()<3 ) { 4 | xdim <- dim(as.array(x))[1] 5 | k <- kern$variance*diag(1, nrow=xdim, ncol=xdim) 6 | } else { 7 | x1dim <- dim(as.array(x))[1] 8 | x2dim <- dim(as.array(x2))[1] 9 | k <- matrix(0, nrow=x1dim, ncol=x2dim) 10 | } 11 | return (k) 12 | } 13 | -------------------------------------------------------------------------------- /R/gptk_whiteKernExpandParam.R: -------------------------------------------------------------------------------- 1 | .whiteKernExpandParam <- 2 | function (kern, params) { 3 | if ( is.list(params) ) 4 | params <- params$values 5 | 6 | kern$variance <- params[1] ## linear domain param, i.e. the untransformed noise variance 7 | 8 | return (kern) 9 | } 10 | -------------------------------------------------------------------------------- /R/gptk_whiteKernExtractParam.R: -------------------------------------------------------------------------------- 1 | .whiteKernExtractParam <- 2 | function (kern, only.values=TRUE, 3 | untransformed.values=TRUE) { 4 | params <- c(kern$variance) 5 | 6 | if ( !only.values ) { 7 | names(params) <- c("variance") 8 | } 9 | 10 | return (params) 11 | } 12 | -------------------------------------------------------------------------------- /R/gptk_whiteKernGradient.R: -------------------------------------------------------------------------------- 1 | .whiteKernGradient <- 2 | function (kern, x, x2, covGrad) { 3 | if ( nargs()==3 ) { 4 | covGrad <- x2 5 | g <- sum(diag(as.matrix(covGrad))) 6 | } else { 7 | g <- 0 8 | } 9 | 10 | return (g) 11 | } 12 | -------------------------------------------------------------------------------- /R/gptk_whiteKernParamInit.R: -------------------------------------------------------------------------------- 1 | .whiteKernParamInit <- 2 | function (kern) { 3 | 4 | kern$variance <- exp(-2) 5 | kern$nParams <- 1 6 | kern$paramNames <- c("variance") 7 | 8 | kern$transforms <- list(list(index=c(1), type="positive")) 9 | 10 | kern$isStationary <- TRUE 11 | 12 | return (kern) 13 | } 14 | -------------------------------------------------------------------------------- /R/gptk_zeroAxes.R: -------------------------------------------------------------------------------- 1 | .zeroAxes <- 2 | function(col='blue') { 3 | abline(v = 0, h = 0, col=col, lwd=.5) ## Axes 4 | # scx = (max(xy[,1])-min(xy[,1]))/100 5 | # scy = (max(xy[,2])-min(xy[,2]))/100 6 | # lines(scx*cos(seq(0, 2*pi, l=100)), (scx)*sin(seq(0, 2*pi, l=100)),col=col,lwd=.5) 7 | } 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # robin 2 | 3 | Available on CRAN

4 | 5 | install.packages("robin") 6 | 7 | For the installation of the updated github version: 8 | 9 | devtools::install_github("ValeriaPolicastro/robin") 10 | 11 | 12 | 13 | ***ROBIN (ROBustness In Network)*** is an R package for the validation of community detection. It has a double aim: it **studies the robustness** of a community detection algorithm and it **compares** the robustness of **two community detection algorithms**. 14 | 15 |

16 | 17 | 18 | 19 |

20 | 21 | The package implements a methodology that detects if the community structure found by a detection algorithm is statistically significant or is a result of chance, merely due to edge positions in the network. 22 | 23 | ###### The package: 24 | 25 | 1) **Examine the robustness** of a community detection algorithm against random perturbations of the original graph 26 | 27 | 2) **Tests the statistical difference** between the stability measure curves created 28 | 29 | 3) Makes a **comparison between different community detection algorithms** to choose the one that better fits the network of interest 30 | 31 | 4) Gives a graphical **interactive representation** 32 | 33 | ------------------------------------------------------------------------ 34 | 35 | ## Example 1: "Robustness of a community detection algorithm" 36 | 37 | ```{r} 38 | my_network <- system.file("example/football.gml", package="robin") 39 | graph <- prepGraph(file=my_network, file.format="gml") 40 | graphRandom <- random(graph=graph) 41 | proc <- robinRobust(graph=graph, graphRandom=graphRandom, method="louvain") 42 | plot(proc) 43 | ``` 44 | 45 |

46 | 47 |

48 | 49 | ```{r} 50 | #For the testing: 51 | robinFDATest(proc) 52 | robinGPTest(proc) 53 | ``` 54 | 55 | ## Example 2: "Comparison of two community detection algorithms" 56 | 57 | ```{r} 58 | my_network <- system.file("example/football.gml", package="robin") 59 | graph <- prepGraph(file=my_network, file.format="gml") 60 | comp <- robinCompare(graph=graph, method1="fastGreedy", method2="louvain") 61 | plot(comp) 62 | ``` 63 | 64 |

65 | 66 |

67 | 68 | In this example, the Louvain algorithm fits better the network of interest, as the curve of the stability measure varies less than the one obtained by the Fast greedy method. Lower the curve more stable is the community detection method. 69 | 70 | ```{r} 71 | #For the testing: 72 | robinFDATest(comp) 73 | robinGPTest(comp) 74 | ``` 75 | 76 | ## Reference 77 | 78 | ROBustness In Network (robin): an R package for Comparison and Validation of communities Valeria Policastro, Dario Righelli, Annamaria Carissimo, Luisa Cutillo, Italia De Feis. The R Journal (2021) 79 | 80 | ## License 81 | 82 | [Copyright (c) 2019 V. Policastro, A. Carissimo, L. Cutillo, I. De Feis and D. Righelli.](https://github.com/ValeriaPolicastro/robin/blob/master/LICENSE) 83 | -------------------------------------------------------------------------------- /inst/NEWS: -------------------------------------------------------------------------------- 1 | robin v2.1.0 2 | - implemented weighted network method 3 | robin v2.0.0 4 | - implementing robin class 5 | - adding plotMultiCompare function, to plot multiple community detection algorithms 6 | - new parallelization method with BiocParallel::bpparam() 7 | - implemented the possibility to have different arguments for different community detection algorithms 8 | - created one function for robinRobust with inside parallelized version 9 | - created one function for robinCompare with inside parallelized version 10 | - from igraph added Leiden new community detection algorithm 11 | - vignette updated 12 | robin v1.1.2 13 | - fixed Note CRAN 14 | robin v1.1.1 15 | -imported gptk and gprege functions for dependency problems 16 | robin v1.1.0 17 | -robinCompareFast parallelized function 18 | robin v1.0.3 19 | -changed reference 20 | robin v1.0.2 21 | -pvalue inserted in FDATest 22 | robin v1.0.1 23 | -verbose added and changes in GPTest input 24 | robin v1.0.0 25 | - Clarifications and documentation improvements 26 | robin v0.99.1 27 | - minor fixing 28 | -------------------------------------------------------------------------------- /man/createITPSplineResult.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{createITPSplineResult} 4 | \alias{createITPSplineResult} 5 | \title{createITPSplineResult} 6 | \usage{ 7 | createITPSplineResult( 8 | graph, 9 | model1, 10 | model2, 11 | muParam = 0, 12 | orderParam = 4, 13 | nKnots = 7, 14 | BParam = 10000, 15 | isPaired = TRUE 16 | ) 17 | } 18 | \arguments{ 19 | \item{graph}{The output of prepGraph.} 20 | 21 | \item{model1}{The Mean output of the robinRobust function (or the Mean1 22 | output of the comparison function).} 23 | 24 | \item{model2}{The MeanRandom output of the robinRobust function (or the 25 | Mean2 output of the comparison function).} 26 | 27 | \item{muParam}{the mu parameter for ITP2bspline (default 0).} 28 | 29 | \item{orderParam}{the order parameter for ITP2bspline (default 4).} 30 | 31 | \item{nKnots}{the nknots parameter for ITP2bspline (default 7).} 32 | 33 | \item{BParam}{the B parameter for ITP2bspline (default 10000).} 34 | 35 | \item{isPaired}{the paired parameter for ITP2bspline (default TRUE).} 36 | } 37 | \description{ 38 | creates an fdatest::ITP2 class object 39 | } 40 | \keyword{internal} 41 | -------------------------------------------------------------------------------- /man/img/logoRobin.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ValeriaPolicastro/robin/c8976e9904349c367f0a637b7074fbc6f9a66595/man/img/logoRobin.png -------------------------------------------------------------------------------- /man/membershipCommunities.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{membershipCommunities} 4 | \alias{membershipCommunities} 5 | \title{membershipCommunities} 6 | \usage{ 7 | membershipCommunities( 8 | graph, 9 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 10 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | ..., 12 | FUN = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{graph}{The output of prepGraph.} 17 | 18 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 19 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 20 | "optimal", "leiden","other".} 21 | 22 | \item{...}{additional parameters to use with any of the previous described 23 | methods (see igraph package community detection methods for more details 24 | i.e. \link[igraph]{cluster_walktrap})} 25 | 26 | \item{FUN}{in case the @method parameter is "other" there is the possibility 27 | to use a personal function passing its name through this parameter. 28 | The personal parameter has to take as input the @graph and the @weights 29 | (that can be NULL), and has to return a community object.} 30 | } 31 | \value{ 32 | Returns a numeric vector, one number for each vertex in the graph; 33 | the membership vector of the community structure. 34 | } 35 | \description{ 36 | This function computes the membership vector of the community 37 | structure. To detect the community structure the user can choose one of the methods implemented 38 | in igraph. 39 | } 40 | \examples{ 41 | my_file <- system.file("example/football.gml", package="robin") 42 | graph <- prepGraph(file=my_file, file.format="gml") 43 | membershipCommunities (graph=graph, method="louvain") 44 | } 45 | -------------------------------------------------------------------------------- /man/methodCommunity.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{methodCommunity} 4 | \alias{methodCommunity} 5 | \title{methodCommunity} 6 | \usage{ 7 | methodCommunity( 8 | graph, 9 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 10 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | leiden_objective_function = c("modularity", "CPM"), 12 | ..., 13 | FUN = NULL, 14 | verbose = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{graph}{The output of prepGraph.} 19 | 20 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 21 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 22 | "optimal", "leiden","other".} 23 | 24 | \item{leiden_objective_function}{objective_function parameter for leiden only 25 | for method} 26 | 27 | \item{...}{additional parameters to use with any of the previous described 28 | methods (see igraph package community detection methods for more details 29 | i.e. \link[igraph]{cluster_walktrap})} 30 | 31 | \item{FUN}{in case the @method parameter is "other" there is the possibility 32 | to use a personal function passing its name through this parameter. 33 | The personal parameter has to take as input the @graph and the @weights 34 | (that can be NULL), and has to return a community object.} 35 | 36 | \item{verbose}{flag for verbose output (default as FALSE)} 37 | } 38 | \value{ 39 | A Communities object. 40 | } 41 | \description{ 42 | This function detects the community structure of a graph. 43 | To detect the community structure the user can choose one of the methods implemented 44 | in igraph. 45 | } 46 | \examples{ 47 | my_file <- system.file("example/football.gml", package="robin") 48 | graph <- prepGraph(file=my_file, file.format="gml") 49 | methodCommunity (graph=graph, method="louvain") 50 | } 51 | -------------------------------------------------------------------------------- /man/plot.robin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_plots.R 3 | \name{plot.robin} 4 | \alias{plot.robin} 5 | \title{plot.robin} 6 | \usage{ 7 | \method{plot}{robin}(x, title = "Robin plot", ...) 8 | } 9 | \arguments{ 10 | \item{x}{A robin class object. The output of the functions: 11 | \code{\link{robinRobust}} and \code{\link{robinCompare}}.} 12 | 13 | \item{title}{The title for the graph. The default is "Robin plot".} 14 | 15 | \item{...}{other parameter} 16 | } 17 | \value{ 18 | A ggplot object. 19 | } 20 | \description{ 21 | This function plots two curves: the measure of the null model and the measure 22 | of the real graph or the measure of the two community detection algorithms. 23 | } 24 | \examples{ 25 | \dontrun{my_file <- system.file("example/football.gml", package="robin") 26 | graph <- prepGraph(file=my_file, file.format="gml") 27 | comp <- robinCompare(graph=graph, method1="fastGreedy",method2="louvain") 28 | plot(comp)} 29 | 30 | } 31 | -------------------------------------------------------------------------------- /man/plotComm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_plots.R 3 | \name{plotComm} 4 | \alias{plotComm} 5 | \title{plotComm} 6 | \usage{ 7 | plotComm(graph, members) 8 | } 9 | \arguments{ 10 | \item{graph}{The output of prepGraph.} 11 | 12 | \item{members}{A membership vector of the community structure, the output of 13 | membershipCommunities.} 14 | } 15 | \value{ 16 | Creates an interactive plot with colorful communities, a D3 17 | JavaScript network graph. 18 | } 19 | \description{ 20 | Graphical interactive representation of the network and its 21 | communities. 22 | } 23 | \examples{ 24 | my_file <- system.file("example/football.gml", package="robin") 25 | graph <- prepGraph(file=my_file, file.format="gml") 26 | members <- membershipCommunities (graph=graph, method="louvain") 27 | plotComm(graph, members) 28 | } 29 | -------------------------------------------------------------------------------- /man/plotGraph.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_plots.R 3 | \name{plotGraph} 4 | \alias{plotGraph} 5 | \title{plotGraph} 6 | \usage{ 7 | plotGraph(graph) 8 | } 9 | \arguments{ 10 | \item{graph}{The output of prepGraph.} 11 | } 12 | \value{ 13 | Creates an interactive plot, a D3 JavaScript network graph. 14 | } 15 | \description{ 16 | Graphical interactive representation of the network. 17 | } 18 | \examples{ 19 | my_file <- system.file("example/football.gml", package="robin") 20 | graph <- prepGraph(file=my_file, file.format="gml") 21 | plotGraph (graph) 22 | } 23 | -------------------------------------------------------------------------------- /man/plotMultiCompare.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_plots.R 3 | \name{plotMultiCompare} 4 | \alias{plotMultiCompare} 5 | \title{plotMultiCompare} 6 | \usage{ 7 | plotMultiCompare(..., title = "Robin plot", ylim1 = FALSE) 8 | } 9 | \arguments{ 10 | \item{...}{all robin objects obtained from the comparison between one 11 | community detection algorithm and all the others} 12 | 13 | \item{title}{character a title for the plot (default is "Robin plot")} 14 | 15 | \item{ylim1}{logical for spanning the y axis from 0 to 1 (default is FALSE)} 16 | } 17 | \value{ 18 | a ggplot2 object 19 | } 20 | \description{ 21 | This function plots the curves of the measure of many community 22 | detection algorithms compared. 23 | } 24 | \examples{ 25 | \donttest{my_file <- system.file("example/football.gml", package="robin") 26 | graph <- prepGraph(file=my_file, file.format="gml") 27 | comp1 <- robinCompare(graph=graph, method1="fastGreedy",method2="louvain") 28 | comp2 <- robinCompare(graph=graph, method1="fastGreedy",method2="infomap") 29 | plotMultiCompare(comp1,comp2)} 30 | } 31 | -------------------------------------------------------------------------------- /man/prepGraph.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{prepGraph} 4 | \alias{prepGraph} 5 | \title{prepGraph} 6 | \usage{ 7 | prepGraph( 8 | file, 9 | file.format = c("edgelist", "pajek", "ncol", "lgl", "graphml", "dimacs", "graphdb", 10 | "gml", "dl", "igraph"), 11 | numbers = FALSE, 12 | directed = FALSE, 13 | header = FALSE, 14 | verbose = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{file}{The input file containing the graph.} 19 | 20 | \item{file.format}{Character constant giving the file format. Edgelist, 21 | pajek, graphml, gml, ncol, lgl, dimacs, graphdb and igraph are 22 | supported.} 23 | 24 | \item{numbers}{A logical value indicating if the names of the nodes are 25 | values.This argument is settable for the edgelist format. 26 | The default is FALSE.} 27 | 28 | \item{directed}{A logical value indicating if is a directed graph. The 29 | default is FALSE.} 30 | 31 | \item{header}{A logical value indicating whether the file contains 32 | the names of the variables as its first line.This argument is settable} 33 | 34 | \item{verbose}{flag for verbose output (default as FALSE). 35 | for the edgelist format.The default is FALSE.} 36 | } 37 | \value{ 38 | An igraph object, which do not contain loop and multiple edges. 39 | } 40 | \description{ 41 | This function reads graphs from a file and 42 | prepares them for the analysis. 43 | } 44 | \examples{ 45 | #install.packages("robin") 46 | 47 | #If there are problems with the installation try: 48 | # if (!requireNamespace("BiocManager", quietly = TRUE)) 49 | # install.packages("BiocManager") 50 | # BiocManager::install("gprege") 51 | # install.packages("robin") 52 | 53 | my_file <- system.file("example/football.gml", package="robin") 54 | graph <- prepGraph(file=my_file, file.format="gml") 55 | } 56 | -------------------------------------------------------------------------------- /man/random.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_external_function.R 3 | \name{random} 4 | \alias{random} 5 | \title{random} 6 | \usage{ 7 | random(graph, rewire.w.type = "Rewire", verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{graph}{The output of prepGraph.} 11 | 12 | \item{rewire.w.type}{for weighted graph. Option to rewire one of "Rewire", 13 | "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 14 | "Sum" method only for continuous weights.} 15 | 16 | \item{verbose}{flag for verbose output (default as FALSE)} 17 | } 18 | \value{ 19 | An igraph object, a randomly rewired graph. 20 | } 21 | \description{ 22 | This function randomly rewires the edges while preserving the original graph's 23 | degree distribution. 24 | } 25 | \examples{ 26 | my_file <- system.file("example/football.gml", package="robin") 27 | graph <- prepGraph(file=my_file, file.format="gml") 28 | graphRandom <- random(graph=graph) 29 | } 30 | -------------------------------------------------------------------------------- /man/randomNoW.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{randomNoW} 4 | \alias{randomNoW} 5 | \title{randomNoW} 6 | \usage{ 7 | randomNoW(graph, verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{graph}{The output of prepGraph.} 11 | 12 | \item{verbose}{flag for verbose output (default as FALSE)} 13 | } 14 | \value{ 15 | An igraph object, a randomly rewired graph. 16 | } 17 | \description{ 18 | This function randomly rewires the edges while preserving the original graph's 19 | degree distribution. 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /man/randomWeight.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINWeighted.R 3 | \name{randomWeight} 4 | \alias{randomWeight} 5 | \title{randomWeight} 6 | \usage{ 7 | randomWeight(graph, rewire.w.type = "Rewire", verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{graph}{The output of prepGraph.} 11 | 12 | \item{verbose}{flag for verbose output (default as FALSE)} 13 | } 14 | \value{ 15 | An igraph object, a randomly rewired graph. 16 | } 17 | \description{ 18 | This function randomly rewires the edges while preserving the original graph's 19 | degree distribution. 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /man/rewireCompl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{rewireCompl} 4 | \alias{rewireCompl} 5 | \title{rewireCompl} 6 | \usage{ 7 | rewireCompl( 8 | data, 9 | number, 10 | community, 11 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 12 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 13 | ..., 14 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 15 | FUN = NULL 16 | ) 17 | } 18 | \arguments{ 19 | \item{data}{The output of prepGraph} 20 | 21 | \item{number}{Number of rewiring trials to perform.} 22 | 23 | \item{community}{Community to compare with.} 24 | 25 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 26 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap".} 27 | 28 | \item{...}{additional parameters to use with any of the previous described 29 | methods (see igraph package community detection methods for more details 30 | i.e. \link[igraph]{cluster_walktrap})} 31 | 32 | \item{measure}{The measure for the comparison of the communities "vi", "nmi", 33 | "split.join", "adjusted.rand"} 34 | 35 | \item{FUN}{see \code{\link{methodCommunity}}.} 36 | } 37 | \description{ 38 | rewires the graph, creates the communities and 39 | compares the communities through different measures. 40 | } 41 | \keyword{internal} 42 | -------------------------------------------------------------------------------- /man/rewireOnl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{rewireOnl} 4 | \alias{rewireOnl} 5 | \title{rewireOnl} 6 | \usage{ 7 | rewireOnl(data, number) 8 | } 9 | \arguments{ 10 | \item{data}{The output of prepGraph} 11 | 12 | \item{number}{Number of rewiring trials to perform.} 13 | } 14 | \description{ 15 | makes the rewire function of igraph 16 | } 17 | \keyword{internal} 18 | -------------------------------------------------------------------------------- /man/rewireWeight.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINWeighted.R 3 | \name{rewireWeight} 4 | \alias{rewireWeight} 5 | \title{rewireWeight} 6 | \usage{ 7 | rewireWeight(data, number, rewire.w.type = "Rewire") 8 | } 9 | \arguments{ 10 | \item{data}{The output of prepGraph} 11 | 12 | \item{number}{Number of rewiring trials to perform.} 13 | 14 | \item{rewire.w.type}{method to rewire weighted graphs one of "Rewire", 15 | "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 16 | "Sum" method only for continuous weights.} 17 | } 18 | \description{ 19 | makes the rewire for weighted networks 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /man/robinAUC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{robinAUC} 4 | \alias{robinAUC} 5 | \title{robinAUC} 6 | \usage{ 7 | robinAUC(x, verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{A robin class object. The output of the functions: 11 | \code{\link{robinRobust}} and \code{\link{robinCompare}}.} 12 | 13 | \item{verbose}{flag for verbose output (default as FALSE).} 14 | } 15 | \value{ 16 | A list 17 | } 18 | \description{ 19 | This function calculates the area under two curves with a spline approach. 20 | } 21 | \examples{ 22 | my_file <- system.file("example/football.gml", package="robin") 23 | graph <- prepGraph(file=my_file, file.format="gml") 24 | graphRandom <- random(graph=graph) 25 | proc <- robinRobust(graph=graph, graphRandom=graphRandom, method="louvain", 26 | measure="vi") 27 | robinAUC(proc) 28 | } 29 | -------------------------------------------------------------------------------- /man/robinCompare.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_external_function.R 3 | \name{robinCompare} 4 | \alias{robinCompare} 5 | \title{robinCompare} 6 | \usage{ 7 | robinCompare( 8 | graph, 9 | method1 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 10 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | args1 = list(), 12 | method2 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 13 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 14 | args2 = list(), 15 | FUN1 = NULL, 16 | FUN2 = NULL, 17 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 18 | type = "independent", 19 | verbose = TRUE, 20 | rewire.w.type = "Rewire", 21 | BPPARAM = BiocParallel::bpparam() 22 | ) 23 | } 24 | \arguments{ 25 | \item{graph}{The output of prepGraph.} 26 | 27 | \item{method1}{The first clustering method, one of "walktrap", 28 | "edgeBetweenness", "fastGreedy", "louvain", "spinglass", "leadingEigen", 29 | "labelProp", "infomap","leiden","optimal","other".} 30 | 31 | \item{args1}{A \code{list} of arguments to be passed to the \code{method1} 32 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 33 | 34 | \item{method2}{The second custering method one of "walktrap", 35 | "edgeBetweenness","fastGreedy", "louvain", "spinglass", "leadingEigen", 36 | "labelProp", "infomap","leiden","optimal","other".} 37 | 38 | \item{args2}{A \code{list} of arguments to be passed to the \code{method2} 39 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 40 | 41 | \item{FUN1}{personal designed function when \code{method1} is "other". 42 | see \code{\link{methodCommunity}}.} 43 | 44 | \item{FUN2}{personal designed function when \code{method2} is "other". 45 | see \code{\link{methodCommunity}}.} 46 | 47 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 48 | "adjusted.rand" all normalized and used as distances. 49 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 50 | 51 | \item{type}{The type of robin construction, dependent or independent.} 52 | 53 | \item{verbose}{flag for verbose output (default as TRUE).} 54 | 55 | \item{rewire.w.type}{for weighted graph. Option to rewire one of "Rewire", 56 | "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 57 | "Sum" method only for continuous weights.} 58 | 59 | \item{BPPARAM}{the BiocParallel object of class \code{bpparamClass} that 60 | specifies the back-end to be used for computations. See 61 | \code{\link[BiocParallel]{bpparam}} for details.} 62 | } 63 | \value{ 64 | A robin object a list with: 65 | - "Mean1" and "Mean2" matrices with the means of the procedure for the first 66 | and the second method respectively. 67 | - "Communities1" and "Communities2" output communities with the first and 68 | second method respectively. 69 | - "Method1" and "Method2" the two community detection algorithm used 70 | - "graph" the input graph. 71 | } 72 | \description{ 73 | This function compares the robustness of two community 74 | detection algorithms. 75 | } 76 | \examples{ 77 | my_file <- system.file("example/football.gml", package="robin") 78 | graph <- prepGraph(file=my_file, file.format="gml") 79 | robinCompare(graph=graph, method1="louvain", args1 = list(resolution=0.8), 80 | method2="leiden") 81 | } 82 | -------------------------------------------------------------------------------- /man/robinCompareFast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINFast.R 3 | \name{robinCompareFast} 4 | \alias{robinCompareFast} 5 | \title{robinCompareFast} 6 | \usage{ 7 | robinCompareFast( 8 | graph, 9 | method1 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 10 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | args1 = list(), 12 | method2 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 13 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 14 | args2 = list(), 15 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 16 | FUN1 = NULL, 17 | FUN2 = NULL, 18 | verbose = TRUE, 19 | BPPARAM = BiocParallel::bpparam() 20 | ) 21 | } 22 | \arguments{ 23 | \item{graph}{The output of prepGraph.} 24 | 25 | \item{method1}{The first clustering method, one of "walktrap", 26 | "edgeBetweenness", "fastGreedy", "louvain", "spinglass", "leadingEigen", 27 | "labelProp", "infomap","optimal".} 28 | 29 | \item{args1}{A \code{list} of arguments to be passed to the \code{method1} 30 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 31 | 32 | \item{method2}{The second custering method one of "walktrap", 33 | "edgeBetweenness","fastGreedy", "louvain", "spinglass", "leadingEigen", 34 | "labelProp", "infomap","optimal".} 35 | 36 | \item{args2}{A \code{list} of arguments to be passed to the \code{method2} 37 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 38 | 39 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 40 | "adjusted.rand" all normalized and used as distances. 41 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 42 | 43 | \item{FUN1}{personal designed function when \code{method1} is "others". 44 | see \code{\link{methodCommunity}}.} 45 | 46 | \item{FUN2}{personal designed function when \code{method2} is "others". 47 | see \code{\link{methodCommunity}}.} 48 | 49 | \item{verbose}{flag for verbose output (default as TRUE).} 50 | 51 | \item{BPPARAM}{the BiocParallel object of class \code{bpparamClass} that 52 | specifies the back-end to be used for computations. See 53 | \code{\link[BiocParallel]{bpparam}} for details.} 54 | } 55 | \value{ 56 | A list object with two matrices: 57 | - the matrix "Mean1" with the means of the procedure for the first method 58 | - the matrix "Mean2" with the means of the procedure for the second method 59 | } 60 | \description{ 61 | This function compares two community detection algorithms. 62 | Is the parallelized and faster version of \code{\link{robinCompare}} 63 | } 64 | \keyword{internal} 65 | -------------------------------------------------------------------------------- /man/robinCompareFastWeight.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINWeighted.R 3 | \name{robinCompareFastWeight} 4 | \alias{robinCompareFastWeight} 5 | \title{robinCompareFastWeight} 6 | \usage{ 7 | robinCompareFastWeight( 8 | graph, 9 | method1 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 10 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | args1 = list(), 12 | method2 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 13 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 14 | args2 = list(), 15 | FUN1 = NULL, 16 | FUN2 = NULL, 17 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 18 | rewire.w.type = "Rewire", 19 | verbose = TRUE, 20 | BPPARAM = BiocParallel::bpparam() 21 | ) 22 | } 23 | \arguments{ 24 | \item{graph}{The output of prepGraph.} 25 | 26 | \item{method1}{The first clustering method, one of "walktrap", 27 | "edgeBetweenness", "fastGreedy", "louvain", "spinglass", "leadingEigen", 28 | "labelProp", "infomap","optimal","leiden".} 29 | 30 | \item{args1}{A \code{list} of arguments to be passed to the \code{method1} 31 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 32 | 33 | \item{method2}{The second custering method one of "walktrap", 34 | "edgeBetweenness","fastGreedy", "louvain", "spinglass", "leadingEigen", 35 | "labelProp", "infomap","optimal","leiden".} 36 | 37 | \item{args2}{A \code{list} of arguments to be passed to the \code{method2} 38 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 39 | 40 | \item{FUN1}{personal designed function when method1 is "others". 41 | see \code{\link{methodCommunity}}.} 42 | 43 | \item{FUN2}{personal designed function when method2 is "others". 44 | see \code{\link{methodCommunity}}.} 45 | 46 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 47 | "adjusted.rand" all normalized and used as distances. 48 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 49 | 50 | \item{rewire.w.type}{for weighted graph. Option to rewire one of "Rewire", 51 | "Shuffle","Garlaschelli","Sum"} 52 | 53 | \item{verbose}{flag for verbose output (default as TRUE).} 54 | 55 | \item{BPPARAM}{the BiocParallel object of class \code{bpparamClass} that 56 | specifies the back-end to be used for computations. See 57 | \link[BiocParallel]{bpparam} for details.} 58 | } 59 | \value{ 60 | A list object with two matrices: 61 | - the matrix "Mean1" with the means of the procedure for the first method 62 | - the matrix "Mean2" with the means of the procedure for the second method 63 | } 64 | \description{ 65 | This function compares two community detection algorithms, from 66 | weighted networks. Is the parallelized and faster version. 67 | } 68 | \keyword{internal} 69 | -------------------------------------------------------------------------------- /man/robinCompareNoParallel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{robinCompareNoParallel} 4 | \alias{robinCompareNoParallel} 5 | \title{robinCompareNoParallel} 6 | \usage{ 7 | robinCompareNoParallel( 8 | graph, 9 | method1 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 10 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 11 | args1 = list(), 12 | method2 = c("walktrap", "edgeBetweenness", "fastGreedy", "leadingEigen", "louvain", 13 | "spinglass", "labelProp", "infomap", "optimal", "leiden", "other"), 14 | args2 = list(), 15 | FUN1 = NULL, 16 | FUN2 = NULL, 17 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 18 | type = c("independent", "dependent"), 19 | verbose = TRUE 20 | ) 21 | } 22 | \arguments{ 23 | \item{graph}{The output of prepGraph.} 24 | 25 | \item{method1}{The first clustering method, one of "walktrap", 26 | "edgeBetweenness", "fastGreedy", "louvain", "spinglass", "leadingEigen", 27 | "labelProp", "infomap","leiden","optimal","other".} 28 | 29 | \item{args1}{A \code{list} of arguments to be passed to the \code{method1} 30 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 31 | 32 | \item{method2}{The second custering method one of "walktrap", 33 | "edgeBetweenness","fastGreedy", "louvain", "spinglass", "leadingEigen", 34 | "labelProp", "infomap","leiden","optimal","other".} 35 | 36 | \item{args2}{A \code{list} of arguments to be passed to the \code{method2} 37 | (see i.e. \link[igraph]{cluster_leiden} for a list of possible method parameters).} 38 | 39 | \item{FUN1}{personal designed function when \code{method1} is "other". 40 | see \code{\link{methodCommunity}}.} 41 | 42 | \item{FUN2}{personal designed function when \code{method2} is "other". 43 | see \code{\link{methodCommunity}}.} 44 | 45 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 46 | "adjusted.rand" all normalized and used as distances. 47 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 48 | 49 | \item{type}{The type of robin construction, dependent or independent.} 50 | 51 | \item{verbose}{flag for verbose output (default as TRUE).} 52 | } 53 | \value{ 54 | A list object with two matrices: 55 | - the matrix "Mean1" with the means of the procedure for the first method 56 | - the matrix "Mean2" with the means of the procedure for the second method 57 | } 58 | \description{ 59 | This function compares the robustness of two community 60 | detection algorithms. 61 | } 62 | \keyword{internal} 63 | -------------------------------------------------------------------------------- /man/robinFDATest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{robinFDATest} 4 | \alias{robinFDATest} 5 | \title{robinFDATest} 6 | \usage{ 7 | robinFDATest(x, verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{A robin class object. The output of the functions: 11 | \code{\link{robinRobust}} and \code{\link{robinCompare}}.} 12 | 13 | \item{verbose}{flag for verbose output (default as FALSE).} 14 | } 15 | \value{ 16 | Two plots: the fitted curves and the adjusted p-values. A vector of the adjusted p-values. 17 | } 18 | \description{ 19 | The function implements the Interval Testing Procedure to 20 | test the difference between two curves. 21 | } 22 | \examples{ 23 | my_file <- system.file("example/football.gml", package="robin") 24 | graph <- prepGraph(file=my_file, file.format="gml") 25 | comp <- robinCompare(graph=graph, method1="fastGreedy",method2="infomap") 26 | \donttest{robinFDATest(comp)} 27 | } 28 | -------------------------------------------------------------------------------- /man/robinGPTest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{robinGPTest} 4 | \alias{robinGPTest} 5 | \title{robinGPTest} 6 | \usage{ 7 | robinGPTest(x, verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{A robin class object. The output of the functions: 11 | \code{\link{robinRobust}} and \code{\link{robinCompare}}.} 12 | 13 | \item{verbose}{flag for verbose output (default as FALSE).} 14 | } 15 | \value{ 16 | A numeric value, the Bayes factor 17 | } 18 | \description{ 19 | This function implements the GP testing procedure and calculates the 20 | Bayes factor. 21 | } 22 | \examples{ 23 | my_file <- system.file("example/football.gml", package="robin") 24 | graph <- prepGraph(file=my_file, file.format="gml") 25 | comp <- robinCompare(graph=graph, method1="fastGreedy",method2="infomap") 26 | \donttest{robinGPTest(comp)} 27 | } 28 | -------------------------------------------------------------------------------- /man/robinRobust.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN_external_function.R 3 | \name{robinRobust} 4 | \alias{robinRobust} 5 | \title{robinRobust} 6 | \usage{ 7 | robinRobust( 8 | graph, 9 | graphRandom, 10 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 11 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 12 | ..., 13 | FUN = NULL, 14 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 15 | type = "independent", 16 | verbose = TRUE, 17 | rewire.w.type = c("Rewire", "Shuffle", "Garlaschelli", "Sum"), 18 | BPPARAM = BiocParallel::bpparam() 19 | ) 20 | } 21 | \arguments{ 22 | \item{graph}{The output of prepGraph.} 23 | 24 | \item{graphRandom}{The output of random function.} 25 | 26 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 27 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 28 | "leiden","optimal".} 29 | 30 | \item{...}{other parameters for the community detection methods.} 31 | 32 | \item{FUN}{in case the @method parameter is "other" there is the possibility 33 | to use a personal function passing its name through this parameter. 34 | The personal parameter has to take as input the @graph and the @weights 35 | (that can be NULL), and has to return a community object.} 36 | 37 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 38 | "adjusted.rand" all normalized and used as distances. 39 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 40 | 41 | \item{type}{The type of robin construction, dependent or independent.} 42 | 43 | \item{verbose}{flag for verbose output (default as TRUE).} 44 | 45 | \item{rewire.w.type}{for weighted graph. Option to rewire one of "Rewire", 46 | "Shuffle","Garlaschelli","Sum". "Garlaschelli" method only for count weights, 47 | "Sum" method only for continuous weights.} 48 | 49 | \item{BPPARAM}{the BiocParallel object of class \code{bpparamClass} that 50 | specifies the back-end to be used for computations. See 51 | \code{\link[BiocParallel]{bpparam}} for details.} 52 | } 53 | \value{ 54 | A robin object a list with: 55 | - "Mean" and "MeanRandom" matrices with the means of the procedure for the 56 | graph and the random graph respectively. 57 | - "Communities" the output communities with the method used. 58 | - "graph" the real data graph. 59 | } 60 | \description{ 61 | This functions implements a procedure to examine the stability 62 | of the partition recovered by some algorithm against random perturbations 63 | of the original graph structure. 64 | } 65 | \examples{ 66 | my_file <- system.file("example/football.gml", package="robin") 67 | graph <- prepGraph(file=my_file, file.format="gml") 68 | graphRandom <- random(graph=graph) 69 | robinRobust(graph=graph, graphRandom=graphRandom, method="leiden") 70 | } 71 | -------------------------------------------------------------------------------- /man/robinRobustFast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINFast.R 3 | \name{robinRobustFast} 4 | \alias{robinRobustFast} 5 | \title{robinRobustFast} 6 | \usage{ 7 | robinRobustFast( 8 | graph, 9 | graphRandom, 10 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 11 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 12 | ..., 13 | FUN1 = NULL, 14 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 15 | verbose = TRUE, 16 | BPPARAM = BiocParallel::bpparam() 17 | ) 18 | } 19 | \arguments{ 20 | \item{graph}{The output of prepGraph.} 21 | 22 | \item{graphRandom}{The output of random function.} 23 | 24 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 25 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 26 | "leiden","optimal".} 27 | 28 | \item{...}{other parameter} 29 | 30 | \item{FUN1}{in case the @method parameter is "other" there is the possibility 31 | to use a personal function passing its name through this parameter. 32 | The personal parameter has to take as input the @graph and the @weights 33 | (that can be NULL), and has to return a community object.} 34 | 35 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 36 | "adjusted.rand" all normalized and used as distances. 37 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 38 | 39 | \item{verbose}{flag for verbose output (default as TRUE)} 40 | 41 | \item{BPPARAM}{the BiocParallel object of class \code{bpparamClass} that 42 | specifies the back-end to be used for computations. See 43 | \code{\link[BiocParallel]{bpparam}} for details.} 44 | } 45 | \value{ 46 | A list object with two matrices: 47 | - the matrix "Mean" with the means of the procedure for the graph 48 | - the matrix "MeanRandom" with the means of the procedure for the random graph. 49 | } 50 | \description{ 51 | This functions implements a procedure to examine the stability 52 | of the partition recovered by some algorithm against random perturbations 53 | of the original graph structure. 54 | } 55 | \keyword{internal} 56 | -------------------------------------------------------------------------------- /man/robinRobustFastWeighted.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBINWeighted.R 3 | \name{robinRobustFastWeighted} 4 | \alias{robinRobustFastWeighted} 5 | \title{robinRobustFastWeighted} 6 | \usage{ 7 | robinRobustFastWeighted( 8 | graph, 9 | graphRandom, 10 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 11 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 12 | ..., 13 | FUN1 = NULL, 14 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 15 | verbose = TRUE, 16 | rewire.w.type = c("Rewire", "Shuffle", "Garlaschelli", "Sum"), 17 | BPPARAM = BiocParallel::bpparam() 18 | ) 19 | } 20 | \arguments{ 21 | \item{graph}{The output of prepGraph.} 22 | 23 | \item{graphRandom}{The output of random function.} 24 | 25 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 26 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 27 | "leiden","optimal".} 28 | 29 | \item{...}{other parameter} 30 | 31 | \item{FUN1}{in case the @method parameter is "other" there is the possibility 32 | to use a personal function passing its name through this parameter. 33 | The personal parameter has to take as input the @graph and the @weights 34 | (that can be NULL), and has to return a community object.} 35 | 36 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 37 | "adjusted.rand" all normalized and used as distances. 38 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 39 | 40 | \item{verbose}{flag for verbose output (default as TRUE).} 41 | 42 | \item{rewire.w.type}{for weighted graph. Option to rewire one of "Rewire", 43 | "Shuffle","Garlaschelli","Sum"."Garlaschelli" method only for count weights, 44 | "Sum" method only for continuous weights.} 45 | 46 | \item{BPPARAM}{the BiocParallel object of class bpparamClass that 47 | specifies the back-end to be used for computations. See 48 | \link[BiocParallel]{bpparam} for details.} 49 | } 50 | \value{ 51 | A list object with two matrices: 52 | - the matrix "Mean" with the means of the procedure for the graph 53 | - the matrix "MeanRandom" with the means of the procedure for the random graph. 54 | } 55 | \description{ 56 | This functions implements a procedure to examine the stability 57 | of the partition recovered by some algorithm against random perturbations 58 | of the original graph structure for weighted network. 59 | } 60 | \keyword{internal} 61 | -------------------------------------------------------------------------------- /man/robinRobustNoParallel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ROBIN.R 3 | \name{robinRobustNoParallel} 4 | \alias{robinRobustNoParallel} 5 | \title{robinRobustNoParallel} 6 | \usage{ 7 | robinRobustNoParallel( 8 | graph, 9 | graphRandom, 10 | method = c("walktrap", "edgeBetweenness", "fastGreedy", "louvain", "spinglass", 11 | "leadingEigen", "labelProp", "infomap", "optimal", "leiden", "other"), 12 | ..., 13 | FUN = NULL, 14 | measure = c("vi", "nmi", "split.join", "adjusted.rand"), 15 | type = c("independent", "dependent"), 16 | verbose = TRUE 17 | ) 18 | } 19 | \arguments{ 20 | \item{graph}{The output of prepGraph.} 21 | 22 | \item{graphRandom}{The output of random function.} 23 | 24 | \item{method}{The clustering method, one of "walktrap", "edgeBetweenness", 25 | "fastGreedy", "louvain", "spinglass", "leadingEigen", "labelProp", "infomap", 26 | "leiden","optimal".} 27 | 28 | \item{...}{other parameter} 29 | 30 | \item{FUN}{in case the @method parameter is "other" there is the possibility 31 | to use a personal function passing its name through this parameter. 32 | The personal parameter has to take as input the @graph and the @weights 33 | (that can be NULL), and has to return a community object.} 34 | 35 | \item{measure}{The stability measure, one of "vi", "nmi", "split.join", 36 | "adjusted.rand" all normalized and used as distances. 37 | "nmi" refers to 1- nmi and "adjusted.ran" refers to 1-adjusted.rand.} 38 | 39 | \item{type}{The type of robin construction, dependent or independent 40 | procedure.} 41 | 42 | \item{verbose}{flag for verbose output (default as TRUE).} 43 | } 44 | \value{ 45 | A list object with two matrices: 46 | - the matrix "Mean" with the means of the procedure for the graph 47 | - the matrix "MeanRandom" with the means of the procedure for the random graph. 48 | } 49 | \description{ 50 | This functions implements a procedure to examine the stability 51 | of the partition recovered by some algorithm against random perturbations 52 | of the original graph structure. 53 | } 54 | \keyword{internal} 55 | -------------------------------------------------------------------------------- /robin.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: 25d4c4f4-0e68-4eef-bb6a-a21f3f001c1a 3 | 4 | RestoreWorkspace: Default 5 | SaveWorkspace: Default 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 4 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | 16 | BuildType: Package 17 | PackageUseDevtools: Yes 18 | PackageInstallArgs: --no-multiarch --with-keep.source 19 | PackageCheckArgs: --as-cran 20 | PackageRoxygenize: rd,collate,namespace 21 | -------------------------------------------------------------------------------- /vignettes/robin.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "robin" 3 | subtitle: "ROBustness In Network" 4 | author: "Valeria Policastro" 5 | date: "`r Sys.Date()`" 6 | vignette: > 7 | %\VignetteIndexEntry{robin} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | output: 11 | knitr:::html_vignette: 12 | toc: yes 13 | toc_depth: 2 14 | --- 15 | 16 | 17 | # robin 18 | 19 | In network analysis, many community detection algorithms have been developed. 20 | However,their applications leave unaddressed one important question: 21 | **the statistical validation of the results**. 22 | 23 | 24 | *robin* (ROBustness in Network) has a double aim: **tests the robustness** of a community detection algorithm to detect if the community structure found is statistically significant and **compares two detection algorithms** to choose the one that better fits the network of interest. 25 | 26 | **Reference in Policastro V., Righelli D., Carissimo A., Cutillo L., De Feis I. (2021) .** 27 | 28 | 29 | It provides:
30 | **1)** a procedure to examine the robustness of a community detection algorithm against a random graph;
31 | **2)** a procedure to choose among different community detection algorithms the one that better fits the network of interest;
32 | **3)** two tests to determine the statistical difference between the curves;
33 | **4)** a graphical interactive representation. 34 | 35 | # Installation 36 | ```{r} 37 | #install.packages("robin") 38 | ``` 39 | 40 | If there are problems with the installation try: 41 | ```{r} 42 | # if (!requireNamespace("BiocManager", quietly = TRUE)) 43 | # install.packages("BiocManager") 44 | # BiocManager::install("gprege") 45 | # 46 | # install.packages("robin") 47 | ``` 48 | 49 | # Loading package 50 | ```{r message=FALSE, warning=FALSE, paged.print=TRUE} 51 | library("robin") 52 | ``` 53 | 54 | # Input 55 | 56 | **prepGraph** function creates an *igraph* object from the input file. This step is necessary for *robin* execution 57 | 58 | The *unweighted* graph can be read from different 59 | format: edgelist, pajek, graphml, gml, ncol, lgl, dimacs, graphdb and igraph 60 | graphs. 61 | 62 | ```{r} 63 | my_network <- system.file("example/football.gml", package="robin") 64 | # downloaded from: http://www-personal.umich.edu/~mejn/netdata/ 65 | graph <- prepGraph(file=my_network, file.format="gml") 66 | graph 67 | ``` 68 | 69 | 70 | # Network visualization 71 | **plotGraph** function offers a graphical representation of the network with the aid of *networkD3* package. 72 | 73 | ```{r} 74 | plotGraph(graph) 75 | ``` 76 | 77 | ## Community detection 78 | **methodCommunity** function detects communities using all the algorithms implemented in *igraph* package: "walktrap", "edgeBetweenness", "fastGreedy", "spinglass", "leadingEigen", 79 | "labelProp", "infomap", "optimal", "other". 80 | 81 | ```{r} 82 | methodCommunity(graph=graph, method="fastGreedy") 83 | ``` 84 | **membershipCommunities** function detects the community membership. 85 | ```{r} 86 | membershipCommunities(graph=graph, method="fastGreedy") 87 | ``` 88 | 89 | ## Community visualization 90 | 91 | **plotComm** function produces an interactive 3D plot of the communites detected by the chosen algorithm. 92 | 93 | ```{r} 94 | members <- membershipCommunities(graph=graph, method="fastGreedy") 95 | plotComm(graph=graph, members=members) 96 | ``` 97 | 98 | # Robustness of a community detection algorithm 99 | 100 | ## Null model 101 | 102 | *robin* offers two choices for the null model: 103 | 104 | 1) it can be generated by using the function **random** 105 | 106 | 2) it can be built externally and passed directly to the argument *graphRandom* of the **robinRobust** function. 107 | 108 | 109 | The function **random** creates a random graph with the same degree distribution of the 110 | original graph, but with completely random edges. The *graph* argument must be the same returned by **prepGraph** function. 111 | 112 | ```{r} 113 | graphRandom <- random(graph=graph) 114 | graphRandom 115 | ``` 116 | 117 | ## robinRobust 118 | 119 | **robinRobust** function implements the validation of the community robustness. 120 | In this example we used "vi" distance as stability measure, "independent" 121 | type procedure and "louvain" as community detection algorithm. 122 | 123 | Users can choose also different measures as: "nmi","split.join", "adjusted.rand". 124 | 125 | The *graph* argument must be the one returned by **prepGraph** function. 126 | The *graphRandom* must be the one returned by **random** function or own random graph. 127 | 128 | ```{r} 129 | proc <- robinRobust(graph=graph, graphRandom=graphRandom, method="louvain") 130 | ``` 131 | As output **robinRobust** will give all the measures at different level of perturbation from 0% to 60% for the real and random graph. 132 | 133 | 134 | **plotRobin** function plots the curves. 135 | The (x,y)-axes represents the percentage of perturbation and the average of the stability measure, respectively. 136 | The arguments of *model1* and *model2* must be the measures for the real graph and the random graph that are the outputs of the **robinRobust** function. 137 | 138 | 139 | *We will expect that with a robust algorithm the behavior of the two curves is different. We expect that the curve of the real graph vary less than the curve of the random graph, this visually means that the curve of the real graph is lower than the one of the random graph, so it is more stable than a random graph.* 140 | 141 | ```{r} 142 | plot(proc) 143 | ``` 144 |
145 | The procedure implemented depends on the network of interest. In this example, the Louvain algorithm fits good the network of interest,as the curve of the stability measure assumes lower values than the one obtained by the null model. 146 | 147 | 148 | ## Statistical tests 149 | The differences between the stability measure curves are tested using: 150 | 151 | 1) Functional Data Analysis (FDA); 152 | 153 | 2) Gaussian Process (GP). 154 | 155 | Moreover to quantify the differences between the curves when they are 156 | very close the Area Under the Curves (AUC) are evaluated. 157 | 158 | 159 | **robinFDATest** function implements a test giving a p-value for different intervals of the curves. It tests in which interval the two curves are different. 160 | 161 | ```{r message=FALSE, warning=FALSE} 162 | robinFDATest(proc) 163 | ``` 164 | 165 | The first figure represents the stability measure plot using Louvain algorithm for detecting communities. The second one represents the corresponding p-values and adjusted p-values of the Interval Testing procedure. Horizontal red line corresponds to the critical value 0.05. 166 | 167 | 168 | **robinGPTest** function implements the GP testing. 169 | ```{r message=FALSE, warning=FALSE} 170 | robinGPTest(proc) 171 | ``` 172 | It tests the two curves globally. The null hypothesis claims that the two curves come from the same process, the alternative hypothesis that they come from two different processes. 173 | The output is the Bayes Factor. 174 | One of the most common interpretations is the one proposed by Harold Jeffereys (1961) and slightly modified by Lee and Wagenmakers in 2013:
175 | **IF B10 IS… THEN YOU HAVE…
** 176 | ° > 100 Extreme evidence for H1
177 | ° 30 – 100 Very strong evidence for H1
178 | ° 10 – 30 Strong evidence for H1
179 | ° 3 – 10 Moderate evidence for H1
180 | ° 1 – 3 Anecdotal evidence for H0
181 | ° 1 No evidence
182 | ° 1/3 – 1 Anecdotal evidence for H0
183 | ° 1/3 – 1/10 Moderate evidence for H0
184 | ° 1/10 – 1/30 Strong evidence for H0
185 | ° 1/30 – 1/100 Very strong evidence for H0
186 | ° < 1/100 Extreme evidence for H0
187 | 188 | 189 | **robinAUC** function implements the AUC. 190 | 191 | ```{r} 192 | robinAUC(proc) 193 | ``` 194 | The outputs are the area under the two curves. 195 | 196 | 197 | # Comparison of two community detection algorithms 198 | 199 | In this example we want to compare the "Fast Greedy" and the "Louvain" algorithms to see which is the best algorithm. 200 | 201 | We firstly plot the communities detected by both algorithms. 202 | 203 | ```{r} 204 | membersFast <- membershipCommunities(graph=graph, method="fastGreedy") 205 | membersLouv <- membershipCommunities(graph=graph, method="louvain") 206 | plotComm(graph=graph, members=membersFast) 207 | plotComm(graph=graph, members=membersLouv) 208 | ``` 209 | 210 | Secondly, we compare them with **robinCompare** function. 211 | 212 | **robinCompare** function compares two detection algorithms on the same network to choose the one that better fits the network of interest. 213 | 214 | ```{r} 215 | comp <- robinCompare(graph=graph, method1="fastGreedy", method2="louvain") 216 | ``` 217 | 218 | 219 | Thirdly, we plot the curves of the compared methods. 220 | 221 | ```{r} 222 | plot(comp) 223 | ``` 224 | 225 | In this example, the Louvain algorithm fits better the network of interest, 226 | as the curve of the stability measure assumes lower values than the one obtained by 227 | the Fast greedy method. 228 | 229 | Fourthly we test the statistical differences between these two curves that now are created on two different community detection algorithm. 230 | The tests are already explained with more detail above. 231 | ```{r message=FALSE, warning=FALSE} 232 | robinFDATest(comp) 233 | 234 | ``` 235 | 236 | ```{r message=FALSE, warning=FALSE} 237 | robinGPTest(comp) 238 | ``` 239 | 240 | 241 | ```{r} 242 | robinAUC(comp) 243 | ``` 244 | 245 | # Robin plot with different algorithms 246 | ```{r setup, warning=FALSE} 247 | comp1 <- robinCompare(graph=graph, method1="fastGreedy",method2="louvain") 248 | comp2 <- robinCompare(graph=graph, method1="fastGreedy",method2="infomap") 249 | plotMultiCompare(comp1,comp2) 250 | ``` 251 | 252 | --------------------------------------------------------------------------------