├── .gitignore ├── DESCRIPTION ├── INDEX ├── NAMESPACE ├── R ├── data_processing.R ├── plot_calls.R ├── prep_objects.R └── trig_functions.R ├── README.md └── man ├── circleplot.Rd ├── circleplot_fun.Rd ├── draw.circle.Rd ├── make.circle.Rd ├── offset.circleplot.Rd └── point_attr.Rd /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | man/.DS_Store 3 | R/.DS_Store -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: circleplot 2 | Version: 0.4.1 3 | Date: 2016-02-03 4 | Title: Circular plots of distance and association matrices 5 | Author: Martin J. Westgate 6 | Maintainer: Martin J. Westgate 7 | Description: Tools for plotting numeric or binary matrices. 8 | Depends: R (>= 3.1.0), RColorBrewer, cluster 9 | License: GPL-2 10 | -------------------------------------------------------------------------------- /INDEX: -------------------------------------------------------------------------------- 1 | circleplot Draw a plot 2 | draw.circle Add a circle to an existing plot 3 | make.circle Return a set of points on the circumference of a circle 4 | offset.circleplot Change the size and origin of circleplot objects 5 | point.attr Generate point colours -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | export(circleplot, draw.circle, make.circle, offset.circleplot, point.attr) -------------------------------------------------------------------------------- /R/data_processing.R: -------------------------------------------------------------------------------- 1 | ## FUNCTIONS TO PROCESS DATA 2 | # Note: these are currently identical to functions in sppairs, but are duplicated here to reduce dependencies. 3 | 4 | # function to make a square matrix from a data.frame 5 | make.wide.format<-function( 6 | input # result from spaa() 7 | ){ 8 | if(class(input)!="data.frame"){stop("make.wide.format only works for class(input)=='data.frame'")} 9 | # work out properties of the input 10 | spp.names<-unique(c(input[, 1], input[, 2])) 11 | n.spp<-length(spp.names) 12 | if(nrow(input)==choose(n.spp, 2)){asymmetric<-FALSE}else{asymmetric<-TRUE} 13 | # create a matrix 14 | result<-matrix(data=NA, nrow= n.spp, ncol= n.spp) 15 | colnames(result)<-spp.names 16 | rownames(result)<-spp.names 17 | # fill with a loop 18 | for(i in 1:nrow(input)){ 19 | sp1<-input[i, 1] 20 | sp2<-input[i, 2] 21 | row.i<-which(spp.names==sp2) 22 | col.i<-which(spp.names==sp1) 23 | if(asymmetric){ 24 | result[row.i, col.i]<-input[i, 3] 25 | }else{ 26 | result[row.i, col.i]<-input[i, 3] 27 | result[col.i, row.i]<-input[i, 3]} 28 | } 29 | rownames(result)<-spp.names 30 | colnames(result)<-spp.names 31 | return(result) 32 | } 33 | 34 | 35 | # function to make a 3-column data.frame from a square matrix (i.e. inverse of make.wide.format) 36 | make.long.format<-function(input){ 37 | if(class(input)!="matrix"){stop("make.wide.format only works for class(input)=='matrix'")} 38 | # get basic summaries 39 | asymmetric<-any(c(input==t(input))==FALSE, na.rm=TRUE) 40 | if(length(colnames(input))==0){spp.names<-paste("V", c(1:ncol(input)), sep="") 41 | }else{spp.names<-colnames(input)} 42 | n.spp<-ncol(input) 43 | # generate an appropriately-sized data.frame for the matrix in question, fill with data 44 | if(asymmetric){ 45 | line.list<-rbind(t(combn(spp.names, 2)), t(combn(spp.names, 2))[, c(2, 1)], 46 | matrix(rep(spp.names, each=2), nrow= n.spp, ncol=2, byrow=TRUE)) 47 | order.list<-rbind( 48 | t(combn(c(1: n.spp), 2)), 49 | t(combn(c(1: n.spp), 2))[, c(2, 1)], 50 | matrix(rep(c(1: n.spp), each=2), nrow= n.spp, ncol=2, byrow=TRUE)) 51 | line.list<-as.data.frame(line.list[order(order.list[, 1], order.list[, 2]), ], stringsAsFactors=FALSE) 52 | line.list$value<-as.numeric(input) 53 | }else{ 54 | line.list<-data.frame(t(combn(spp.names, 2)), stringsAsFactors=FALSE) 55 | line.list$value<-as.numeric(as.dist(input))} 56 | # clean results 57 | colnames(line.list)[1:2]<-c("sp1", "sp2") # good colnames 58 | line.list<-line.list[which(c(line.list$sp1!=line.list$sp2)), ] # remove diagonals 59 | line.list<-line.list[order(line.list$sp1, line.list$sp2), ] # consistent order 60 | return(line.list) # export 61 | } 62 | 63 | 64 | # function to take an input (preferably in long format) and return a sensible distance matrix 65 | make.dist.format<-function(input){ 66 | # get objects 67 | if(any(c("matrix", "data.frame")==class(input))==FALSE){ 68 | stop("make.dist.format only accepts class matrix or data.frame")} 69 | if(class(input)=="matrix"){ 70 | wide<-input 71 | long<-make.long.format(input)} 72 | if(class(input)=="data.frame"){ 73 | wide<-make.wide.format(input) 74 | long<-input} 75 | if(all(is.na(long[, 3]))){ 76 | result<-as.dist(wide) 77 | result[1:length(result)]<-0 78 | asymmetric<-FALSE 79 | }else{ # i.e. if this column contains any information at all 80 | # remove infinite values 81 | if(any(long[, 3]==Inf, na.rm=TRUE)){ 82 | replace.locs<-which(long[, 3]==Inf) 83 | replace.vals<-max(long[-replace.locs, 3], na.rm=TRUE)*2 84 | long[replace.locs, 3]<-replace.vals} 85 | if(any(input[, 3]==-Inf, na.rm=TRUE)){ 86 | replace.locs<-which(long[, 3]==-Inf) 87 | replace.vals<-min(long[-replace.locs, 3], na.rm=TRUE) 88 | if(replace.vals<0){replace.vals<-replace.vals*2}else{replace.vals<-replace.vals*0.5} 89 | long[replace.locs, 3]<-replace.vals} 90 | # make +ve definite 91 | if(min(long[, 3], na.rm=TRUE)<0){ 92 | long[, 3]<-long[, 3]-min(long[, 3], na.rm=TRUE)} 93 | # invert to make into a distance 94 | long[, 3]<-max(long[, 3], na.rm=TRUE)-long[, 3] 95 | # convert to matrix, check for asymmetry 96 | asymmetric<-all(wide==t(wide), na.rm=TRUE)==FALSE 97 | if(asymmetric){ 98 | wide.array<-array(data=NA, dim=c(dim(wide), 2)) 99 | wide.array[,,1]<-wide 100 | wide.array[,,2]<-t(wide) 101 | wide.array<-apply(wide.array, c(1, 2), sum) 102 | colnames(wide.array)<-colnames(wide) 103 | rownames(wide.array)<-rownames(wide) 104 | result<-as.dist(wide.array) 105 | }else{ 106 | result<-as.dist(wide)} 107 | # set na values to the mean (i.e. no effect on clustering) 108 | if(any(is.na(result))){result[which(is.na(result))]<-mean(result, na.rm=TRUE)} 109 | } 110 | return(list(asymmetric= asymmetric, dist.matrix=result)) 111 | } 112 | 113 | 114 | # take a list containing co-occurrence data, and return a list of the same length, 115 | # but with only those species shared among all datasets (type="AND") 116 | # or all species present in any dataset (type="OR", the default) 117 | clean.list<-function(x, reduce=FALSE){ 118 | # first ensure that data are in the same (wide) format 119 | x<-lapply(x, function(y){ 120 | if(class(y)=="data.frame"){y<-make.wide.format(y)}else{y<-as.matrix(y)}}) 121 | n<-length(x) 122 | comparison<-calc.overlap(x) 123 | if(reduce){ 124 | and.test<-apply(comparison, 1, FUN=function(y){any(y==FALSE)==FALSE}) 125 | keep.rows<-which(and.test) 126 | if(length(keep.rows)==0){stop("No species are present in all datasets; try reduce=FALSE")} 127 | all.species<-rownames(comparison)[keep.rows] 128 | }else{all.species<-rownames(comparison)} 129 | 130 | # set up a matrix that will be filled with data for entry in x 131 | nspp<-length(all.species) 132 | empty.matrix<-matrix(data=NA, nspp, nspp) 133 | colnames(empty.matrix)<-all.species; rownames(empty.matrix)<-all.species 134 | 135 | # return a list of matrices, each containing all.species in the same order. 136 | result<-lapply(x, function(y, fill){ 137 | spp<-rownames(fill) 138 | locations<-sapply(spp, function(z, comp){ 139 | if(any(comp==z)){return(which(comp==z))}else{return(NA)}}, 140 | comp=rownames(y)) 141 | initial.list<-as.list(as.data.frame(y)) 142 | filled.list<-lapply(initial.list, function(z, lookup){z[lookup]}, lookup=locations) 143 | empty.list <-as.list(as.data.frame(fill)) 144 | final.list<-append(filled.list, empty.list[which(is.na(locations))]) 145 | order.final<-sapply(names(final.list), function(z, lookup){ 146 | which(lookup==z)}, lookup=colnames(fill)) 147 | final.matrix<-as.matrix(as.data.frame(final.list[order.final])) 148 | rownames(final.matrix)<-spp 149 | colnames(final.matrix)<-spp 150 | return(final.matrix) 151 | }, fill= empty.matrix) 152 | 153 | # clustering stage to go here - if turned off, test for identical rownames, and if missing, switch to alphabetical 154 | # perhaps convert list to array, use apply(result, c(1, 2), sum) to get clustering 155 | result.array<-array(unlist(result), dim=c(nspp, nspp, length(result)), 156 | dimnames=list(all.species, all.species, names(result))) 157 | result.sum<-apply(result.array, c(1, 2), function(z){sum(z, na.rm=TRUE)}) 158 | result.dist<-make.dist.format(result.sum) 159 | # return in correct format 160 | return(list( 161 | wide=result, 162 | long=lapply(result, make.long.format), 163 | distance= result.dist$dist.matrix, 164 | asymmetric= result.dist$asymmetric)) 165 | } 166 | 167 | 168 | # calculate which species are present in each dataset within a list, and return the result as a data.frame 169 | calc.overlap<-function(x){ 170 | # first ensure that data are in the same (wide) format 171 | x<-lapply(x, function(y){ 172 | if(class(y)=="data.frame"){y<-make.wide.format(y)}else{y<-as.matrix(y)}}) 173 | # get list of species names 174 | species.lists<-lapply(x, FUN=function(x){colnames(x)}) 175 | all.species<-unique(unlist(species.lists)) 176 | # calculate which species are present in each dataset 177 | result<-lapply(x, FUN=function(y, comp){ 178 | sapply(comp, FUN=function(z, this.list){ 179 | if(any(this.list ==z)){return(TRUE)}else{return(FALSE)}}, this.list =colnames(y)) 180 | }, comp=all.species) 181 | as.data.frame(result) 182 | } -------------------------------------------------------------------------------- /R/plot_calls.R: -------------------------------------------------------------------------------- 1 | # plot functions - called by user 2 | 3 | # function to draw a figure, if supplied with a data.frame or matrix 4 | circleplot<-function( 5 | input, # a distance matrix (class 'dist') or square matrix (class matrix) 6 | cluster=TRUE, # should points be rearranged using hclust? Defaults to TRUE 7 | reduce=FALSE, # should nodes with no connections be removed? 8 | draw=TRUE, # should the figure be drawn? 9 | add=FALSE, # should this figure be added to an existing plot? 10 | style="classic", # "pie" or "clock" are current alternatives 11 | plot.control, # a list containing plot attributes. See ?circleplot 12 | ... 13 | ) 14 | { 15 | # catch errors 16 | if(any(c("classic", "pie", "clock")==style)==FALSE){ 17 | warning(paste("style = '", style, "' not recognised: switched to style = 'classic'", sep="")) 18 | style<-"classic"} 19 | 20 | # test whether the object given was calculated by circleplot 21 | check.names<-function(x){ 22 | if(length(x)==3){ 23 | test<-names(x)==c("locations", "plot.control", "line.data") 24 | if(length(test)==0){return(FALSE) 25 | }else{all(test)} 26 | }else{FALSE}} 27 | add.existing.plot<-class(input)=="list" & check.names(input) 28 | 29 | # if input was calculated by circleplot, extract relevant information 30 | if(add.existing.plot){ 31 | plot.options<-input$plot.control 32 | circleplot.object<-input$locations 33 | line.object<-input$line.data 34 | style<-plot.options$style 35 | 36 | # if not, calculate (and plot) node and edge locations as usual 37 | }else{ 38 | dataset<-check.inputs(input, reduce) 39 | plot.options<-set.plot.attributes(dataset, plot.control, reduce, style) # set plot attributes/defaults 40 | circleplot.object<-calc.circleplot(dataset, plot.options, cluster, style) # get line and point attributes 41 | 42 | # calculate inter-point distances 43 | # allows setting of pc.scale (to calculate curvature of lines relative to origin) 44 | point.distance<-dist(circleplot.object$points[, c("x", "y")]) 45 | scale.distance<-point.distance-min(point.distance) 46 | scale.distance<-((scale.distance/max(scale.distance))* 47 | plot.options$line.curvature[2])+ plot.options$line.curvature[1] 48 | scale.distance<-as.matrix(scale.distance) 49 | # loop to calculate and draw lines 50 | line.object <-lapply(circleplot.object$lines, 51 | function(a, add, circleplot.object, scale.distance, plot.options){ 52 | if(nrow(a)>0){ # this may not be sufficient 53 | line.list<-split(a, c(1:nrow(a))) 54 | line.list<-lapply(line.list, function(x, plot.object, distance, options){ 55 | calc.lines(x, plot.object, distance, options)}, 56 | plot.object=circleplot.object, distance=scale.distance, options= plot.options) 57 | } 58 | }, add=add, circleplot.object= circleplot.object, 59 | scale.distance= scale.distance, plot.options= plot.options) 60 | } 61 | 62 | # set plot window attributes 63 | if(draw & class(input)=="list" & check.names(input)==FALSE){ 64 | par(mfrow=panel.dims(length(circleplot.object$lines)))} 65 | 66 | # DRAW 67 | if(draw){ 68 | 69 | # this has to run within lapply, in case lists are supplied to circleplot 70 | # if(is.null(line.object[[1]])==FALSE){ 71 | invisible(lapply(line.object, function(a, add, circleplot.object, plot.options){ 72 | 73 | if(add==FALSE){ 74 | do.call(par, circleplot.object$par) 75 | do.call(plot, circleplot.object$plot)} 76 | 77 | # draw these lines 78 | if(is.null(a)==FALSE){ 79 | invisible(lapply(a, 80 | FUN=function(z, asymmetric, arrow.attr){ 81 | draw.curves(z) 82 | if(asymmetric)draw.arrows(z, arrow.attr)}, 83 | asymmetric=attr(circleplot.object, "asymmetric"), arrow.attr=plot.options$arrows)) 84 | } 85 | 86 | # add points or polygons, depending on style 87 | switch(style, 88 | "classic"={do.call(points, 89 | as.list(circleplot.object$points[, -which(colnames(circleplot.object$points)=="labels")]))}, 90 | "pie"={invisible(lapply(circleplot.object$polygons, function(x){do.call(polygon, x)}))}, 91 | "clock"={ 92 | invisible(lapply(circleplot.object$nodes, function(x){do.call(lines, x)})) 93 | do.call(lines, circleplot.object$border)} 94 | ) 95 | 96 | # label points 97 | label.suppress.test<-is.logical(plot.options$point.labels) & length(plot.options$point.labels)==1 98 | if(label.suppress.test==FALSE){ 99 | labels.list<-split(circleplot.object$labels, 1:nrow(circleplot.object$labels)) 100 | invisible(lapply(labels.list, FUN=function(x){do.call(text, x)}))} 101 | 102 | }, add=add, circleplot.object= circleplot.object, plot.options= plot.options)) 103 | 104 | if(class(input)=="list" & add.existing.plot==FALSE)par(mfrow=c(1, 1)) 105 | } # end if(draw) 106 | 107 | # return information as needed 108 | return(invisible(list(locations= circleplot.object, plot.control=plot.options, line.data= line.object))) 109 | } 110 | 111 | 112 | 113 | # simple code to get pretty point colours 114 | point.attr<-function(distance.matrix) 115 | { 116 | if(length(attr(distance.matrix, "Labels"))==0){ 117 | attr(distance.matrix, "Labels")<-paste("V", c(1:attr(distance.matrix, "Size")), sep="")} 118 | labels<-as.character(attr(distance.matrix, "Labels")) 119 | color.hex<-c(RColorBrewer::brewer.pal(8, "Dark2"), 120 | brewer.pal(9, "Set1"), 121 | brewer.pal(8, "Set2") 122 | )[1:length(labels)] 123 | point.attributes<-data.frame( 124 | labels= labels, 125 | pch=19, 126 | col=color.hex, 127 | cex=3, 128 | stringsAsFactors=FALSE) 129 | return(point.attributes) 130 | } -------------------------------------------------------------------------------- /R/prep_objects.R: -------------------------------------------------------------------------------- 1 | # function to determine input type, and process accordingly 2 | check.inputs<-function( 3 | input, 4 | reduce 5 | ) 6 | { 7 | # set error messages 8 | # incorrect input class 9 | if(any(c("dist", "matrix", "data.frame", "list")==class(input))==FALSE){ 10 | stop('circleplot only accepts inputs from the following classes: dist, matrix data.frame, or a list of the same')} 11 | 12 | # ensure that long and wide versions are returned, regardless of input 13 | switch(class(input), 14 | "matrix"={ 15 | if(dim(input)[1]!=dim(input)[2]){stop('circleplot only accepts square matrices')} 16 | wide<-input; for(i in 1:dim(wide)[1]){wide[i, i]<-NA} # set diagonal values to NA 17 | # if there are no row or column headings, add these now 18 | long<-list(make.long.format(input)) 19 | if(length(colnames(wide))==0){wide<-lapply(long, make.wide.format) 20 | }else{wide<-list(wide)} 21 | check.distance<-make.dist.format(long[[1]]) 22 | distance<-check.distance$dist.matrix 23 | asymmetric<-check.distance$asymmetric 24 | }, 25 | "data.frame"={ 26 | if(ncol(input)<3){stop('input data.frame has too few columns; please supply data with n>=3 columns')}#} 27 | long<-list(input) 28 | wide<-list(make.wide.format(input[, 1:3])) 29 | check.distance<-make.dist.format(input) 30 | distance<-check.distance$dist.matrix 31 | asymmetric<-check.distance$asymmetric 32 | }, 33 | "dist"={ 34 | if(length(attr(input, "Labels"))<1){ 35 | attr(input, "Labels")<-paste("V", c(1:attr(input, "Size")), sep="")} 36 | wide<-list(as.matrix(input)) 37 | long<-lapply(wide, make.long.format) 38 | check.distance<-make.dist.format(long[[1]]) # this is needed to avoid NA values in the distance matrix 39 | distance<-check.distance$dist.matrix 40 | asymmetric<-check.distance$asymmetric 41 | }, 42 | "list"={ 43 | result<-clean.list(input, reduce) 44 | long<-result$long 45 | wide<-result$wide 46 | distance<-result$distance 47 | asymmetric<-result$asymmetric 48 | }) 49 | 50 | # work out if input is binary or continuous 51 | binary.test<-all(unlist(lapply(long, binary.test.fun))) 52 | 53 | # binary matrices may contain rows/columns with no data; remove these before continuing 54 | if(class(input)!="list" & reduce){ 55 | keep.rows<-apply(wide[[1]], 1, function(x){length(which(is.na(x)))!=length(x)}) 56 | keep.cols<-apply(wide[[1]], 2, function(x){length(which(is.na(x)))!=length(x)}) 57 | # both are needed for asymmetric matrices 58 | keep.both<-apply(cbind(keep.rows, keep.cols), 1, function(x){any(x==TRUE)}) 59 | keep.units<-as.numeric(which(keep.both)) 60 | if(length(keep.units)<1){stop("No nodes selected with reduce=TRUE")} 61 | wide<-list(wide[[1]][keep.units, keep.units]) 62 | distance<-as.dist(as.matrix(distance)[keep.units, keep.units]) 63 | # ensure long format matches 64 | keep.text<-colnames(wide[[1]])[keep.units] 65 | keep.test<-lapply(long[[1]][, 1:2], function(x, comp){ 66 | sapply(x, function(y, text){any(text==y)}, text=comp)}, comp=keep.text) 67 | keep.vector<-apply(as.data.frame(keep.test), 1, function(x){all(x)}) 68 | long<-list(long[[1]][which(keep.vector), ]) 69 | } 70 | 71 | # ensure distance matrices do not contain infinite values 72 | for(i in 1:2){distance<-remove.inf.values(c(Inf, -Inf)[i], distance)} 73 | # note that this doesn't affect plotting because all non-clustering code uses wide or long format 74 | 75 | # export these as a list-based S3 object that can be passed to later functions 76 | matrix.properties<-list( 77 | binary=binary.test, 78 | asymmetric= asymmetric, 79 | wide=wide, # point generation/manipulation requires matrices 80 | long=long, # line attr requires a data.frame 81 | distance=distance # clustering requires a distance matrix 82 | ) 83 | 84 | return(matrix.properties) 85 | } # end function 86 | 87 | 88 | # Function to ensure distance matrices do not contain infinite values; called exclusively by check.inputs 89 | remove.inf.values<-function(x, distmat){ 90 | if(any(distmat ==x)){ 91 | overlap.zero<-min(distmat)<0 & max(distmat)>0 92 | vals<-distmat[which(distmat!=x)] 93 | max.val<-max(sqrt(vals^2))*2 94 | distmat[which(distmat==x)]<-(max.val * sign(x))} 95 | return(distmat) 96 | } 97 | 98 | 99 | # Function to determine whether an input is binary or continuous; called exclusively by check.inputs 100 | binary.test.fun<-function(x){ 101 | in.vals<-x[is.na(x[, 3])==FALSE, 3] 102 | n.vals<-length(unique(in.vals)) 103 | if(n.vals>2){n.vals<-3} 104 | switch(as.character(n.vals), 105 | "0"={binary.test<-FALSE}, 106 | "1"={if(unique(in.vals)==1){binary.test<-TRUE}else{binary.test<-FALSE}}, 107 | "2"={if(max(in.vals)==1 & min(in.vals)==0){binary.test<-TRUE 108 | }else{binary.test<-FALSE}}, 109 | "3"={binary.test<-FALSE}) 110 | return(binary.test) 111 | } 112 | 113 | 114 | # function to compare supplied to default values, and return a combined data.frame with all columns 115 | append.missed.columns<-function( 116 | input, # user-supplied values 117 | default # default settings 118 | ){ 119 | if(class(default)=="data.frame"){ 120 | specified.cols<-colnames(input) 121 | available.cols<-colnames(default)} 122 | if(class(default)=="list"){ 123 | specified.cols<-names(input) 124 | available.cols<-names(default)} 125 | 126 | keep.cols<-sapply(available.cols, FUN=function(x){any(specified.cols==x)}) 127 | add.cols<-which(keep.cols==FALSE) 128 | add.names<-names(add.cols) 129 | 130 | if(class(default)=="data.frame"){ 131 | if(length(add.cols)>0){ 132 | input<-merge(input, default[, c(1, add.cols)], by="labels", all.x=FALSE, all.y=TRUE) 133 | } 134 | } 135 | if(class(default)=="list"){ 136 | if(length(add.cols)>0){ 137 | input<-append(input, default[add.cols]) 138 | new.entries<-c((length(input)-length(add.cols)+1):length(input)) 139 | names(input)[new.entries]<-add.names 140 | }} 141 | # export 142 | return(input) 143 | } 144 | 145 | 146 | 147 | # function to set plot defaults, and overwrite if new data is provided 148 | set.plot.attributes<-function( 149 | input, # result from check.inputs 150 | plot.control, 151 | reduce, # should this be here? Or put elsewhere, perhaps with cluster? 152 | style="classic" 153 | ) 154 | { 155 | ## GENERATE AND FILL AN EMPTY LIST FOR PLOT.CONTROL ## 156 | control.names<-c("style", "plot.rotation", "par", "plot", 157 | "points", 158 | "point.labels", 159 | "line.breaks", "line.cols", "line.widths", 160 | "line.gradient", "line.expansion", "line.curvature", 161 | "arrows", 162 | "border", 163 | "na.control") 164 | plot.defaults<-vector("list", length=length(control.names)) 165 | names(plot.defaults)<-control.names 166 | 167 | # overwrite these values where others are provided 168 | if(missing(plot.control)==FALSE){ 169 | # for backwards compatability, allow line.width (singular) instead of line.widths (plural) as input 170 | if(any(names(plot.control)=="line.width")){ 171 | x<-which(names(plot.control)=="line.width") 172 | names(plot.control)[x]<-"line.widths"} 173 | # replace default plot.control info with any user-specified arguments 174 | for(i in 1:length(plot.defaults)){ 175 | if(any(names(plot.control)==names(plot.defaults)[i])){ 176 | entry.thisrun<-which(names(plot.control)==names(plot.defaults)[i]) 177 | plot.defaults[i]<-plot.control[entry.thisrun] 178 | }} 179 | } 180 | 181 | ## FILL IN MISSING DATA WITH DEFAULTS ## 182 | plot.defaults$style<-style 183 | 184 | # 1. plot.rotation 185 | if(is.null(plot.defaults$plot.rotation)){plot.defaults$plot.rotation<-0} 186 | 187 | # 2. par 188 | par.default<-list(mar=rep(0.5, 4), cex=1) 189 | if(is.null(plot.defaults$par)){plot.defaults$par<-par.default} 190 | 191 | # 3. points 192 | matrix.labels<-lapply(input$wide, colnames)[[1]] 193 | if(is.null(plot.defaults$points)){ # | reduce 194 | n.points<-lapply(input$wide, ncol)[[1]] #ncol(input$wide) 195 | label.vals<-matrix.labels 196 | }else{ 197 | n.points<-nrow(plot.defaults$points) 198 | label.vals<-plot.defaults$points$labels 199 | # check these match 200 | if(all(sort(matrix.labels)==sort(label.vals))==FALSE){ 201 | stop("supplied point labels do not match those from the input matrix or data.frame")} 202 | } 203 | # generate a 'null' data.frame 204 | point.defaults<-data.frame( 205 | labels= label.vals, 206 | pch=19, 207 | col=rep(rgb(t(col2rgb("grey30")), maxColorValue=255), n.points), 208 | cex=1, 209 | stringsAsFactors=FALSE) 210 | # rownames(point.defaults)<-point.defaults$labels 211 | # overwrite 212 | if(is.null(plot.defaults$points)){ 213 | plot.defaults$points<-point.defaults 214 | }else{if(class(plot.defaults$points)=="data.frame"){ 215 | plot.defaults$points<-append.missed.columns(plot.defaults$points, point.defaults)} 216 | } 217 | # ensure that any factors are converted to characters 218 | # note this assumes that only character strings (and not numeric values) will be interpreted as factors 219 | factor.test<-rep(FALSE, length(plot.defaults$points)) 220 | for(i in 1:length(plot.defaults$points)){if(is.factor(plot.defaults$points[, i])){factor.test[i]<-TRUE}} 221 | if(any(factor.test)){ 222 | cols<-which(factor.test==TRUE) 223 | plot.defaults$points[, cols]<-apply(plot.defaults$points[, cols], 2, function(x){as.character(x)}) 224 | } 225 | 226 | # 4. point labels 227 | # set behaviour if no information has been given 228 | if(any(colnames(plot.defaults$point.labels)=="offset")==TRUE){ 229 | label.distance<-mean(plot.defaults$point.labels$offset, na.rm=TRUE)+1 230 | }else{label.distance<-1.05} 231 | # create an object to allow proper positioning of labels 232 | point.labels<-data.frame( 233 | labels= label.vals, 234 | cex=0.7, 235 | adj=0, 236 | col="black", 237 | stringsAsFactors=FALSE) 238 | 239 | # if necessary, append to - or overwrite - supplied values 240 | if(class(plot.defaults$point.labels)=="data.frame"){ 241 | plot.defaults$point.labels<-append.missed.columns(plot.defaults$point.labels, point.labels) 242 | # ensure that any factors are converted to characters 243 | factor.test<-rep(FALSE, length(plot.defaults$point.labels)) 244 | for(i in 1:length(plot.defaults$point.labels)){if(is.factor(plot.defaults$point.labels[, i])){factor.test[i]<-TRUE}} 245 | if(any(factor.test)){ 246 | cols<-which(factor.test==TRUE) 247 | plot.defaults$point.labels[, cols]<-apply(plot.defaults$point.labels[, cols], 2, function(x){as.character(x)})} 248 | } 249 | if(is.logical(plot.defaults$point.labels)){ 250 | if(plot.defaults$point.labels){plot.defaults$point.labels<-point.labels}} 251 | if(is.null(plot.defaults$point.labels)){ 252 | plot.defaults$point.labels<-point.labels} 253 | # if(any(colnames(plot.defaults$points)=="order")){plot.defaults$point.labels$order<-plot.defaults$points$order} 254 | 255 | # arrow defaults 256 | arrow.defaults<-list(angle=10, length=0.07, distance=0.75) 257 | if(is.null(plot.defaults$arrows)){plot.defaults$arrows<-arrow.defaults 258 | }else{ 259 | if(length(plot.control$arrows)!=3){ 260 | plot.defaults$arrows<-append.missed.columns(plot.control$arrows, arrow.defaults)}} 261 | 262 | # set line attributes 263 | line.locs<-c( 264 | which(names(plot.defaults)=="line.breaks"): 265 | which(names(plot.defaults)=="line.widths")) 266 | line.attr<-lapply(plot.defaults, function(x){is.null(x)==FALSE})[line.locs] 267 | if(any(line.attr==TRUE)){ 268 | if(line.attr$line.breaks){n.lines<-length(plot.defaults$line.breaks)-1} 269 | if(line.attr$line.cols){n.lines<-length(plot.defaults$line.cols)} 270 | if(line.attr$line.widths){n.lines<-length(plot.defaults$line.widths)} 271 | }else{n.lines=5} 272 | 273 | # ensure brewer.pal returns values for nlines <3 274 | brewer.pal.safe<-function(n, pal, type){ 275 | if(n>=3){brewer.pal(n, pal) 276 | }else{ 277 | if(type=="increasing"){brewer.pal(3, pal)[sort(c(3:1)[c(1:n)])]} 278 | if(type=="diverging"){brewer.pal(3, pal)[c(1, 3)]} # assumes that no-one will be able to call diverging w n=1 279 | }} 280 | 281 | # set defaults for line cuts, colours etc - set all to grey by default 282 | line.vals<-unlist(lapply(input$long, function(x){x[, 3]})) 283 | if(all(is.na(line.vals)) | input$binary){ 284 | cut.vals<-c(-1, 2) ; line.cols<-"grey30" 285 | }else{ # for numeric matrices 286 | line.vals<-line.vals[which(is.na(line.vals)==FALSE)] 287 | line.vals.short<-line.vals 288 | line.vals.short<-line.vals.short[which(line.vals.short!=Inf)] 289 | line.vals.short<-line.vals.short[which(line.vals.short!=-Inf)] 290 | if(length(line.vals.short)==0)stop("circleplot cannot draw matrices that consist entirely of infinite values") 291 | overlap.zero<-min(line.vals)<0 & max(line.vals)>0 292 | if(overlap.zero){ # diverging colour palette 293 | max.val<-max(sqrt(line.vals.short ^2))+0.001 294 | cut.vals<-seq(-max.val, max.val, length.out=n.lines+1) 295 | if(any(line.vals==Inf)){cut.vals[length(cut.vals)]<-Inf} 296 | if(any(line.vals==-Inf)){cut.vals[1]<-(-Inf)} 297 | line.cols<-brewer.pal.safe(n.lines, "RdBu", type="diverging")[c(n.lines:1)] 298 | }else{ # sequential colour palette 299 | cut.vals<-seq(min(line.vals.short - 0.001), max(line.vals.short + 0.001), length.out=n.lines+1) 300 | if(any(line.vals==Inf)){cut.vals[length(cut.vals)]<-Inf} 301 | if(any(line.vals==-Inf)){cut.vals[1]<-(-Inf)} 302 | line.cols<-brewer.pal.safe(n.lines, "Purples", type="increasing") 303 | } 304 | } # end colour selection 305 | 306 | # add to plot.default 307 | if(is.null(plot.defaults$line.gradient)){plot.defaults$line.gradient<-FALSE} 308 | if(is.null(plot.defaults$line.breaks)){plot.defaults$line.breaks<-cut.vals} 309 | if(is.null(plot.defaults$line.cols)){plot.defaults$line.cols<-line.cols} 310 | if(is.null(plot.defaults$line.widths)){plot.defaults$line.widths<-rep(1, length(plot.defaults$line.cols))} 311 | if(is.null(plot.defaults$line.expansion)){plot.defaults$line.expansion<-0} 312 | if(is.null(plot.defaults$line.curvature)){ 313 | if(input$asymmetric){ 314 | plot.defaults$line.curvature <-c(add=0.2, multiply=0.3) 315 | }else{plot.defaults$line.curvature <-c(add=0.25, multiply=0.35)}} 316 | 317 | # set NA values 318 | if(is.null(plot.defaults$na.control)){plot.defaults$na.control<-NA 319 | }else{ 320 | if(length(plot.defaults$na.control)>1 & is.na(plot.defaults$na.control[[1]])==FALSE){ 321 | plot.defaults$na.control<-append.missed.columns( 322 | plot.defaults$na.control, list(lwd=1, lty=2, col="grey50"))} 323 | } 324 | 325 | # set border for style="clock" 326 | border.default<-list(lwd=1, lty=1, col="grey30", tcl=-0.07) 327 | if(is.null(plot.defaults$border)){plot.defaults$border<-border.default 328 | }else{plot.defaults$border <-append.missed.columns( 329 | plot.defaults$border, border.default)} 330 | 331 | 332 | ## ERROR AVOIDANCE ## 333 | # ensure line.breaks incapsulate all values of input 334 | if(all(is.na(line.vals))==FALSE){ 335 | range.input<-range(line.vals, na.rm=TRUE) 336 | range.breaks<-range(plot.defaults$line.breaks) 337 | if(range.breaks[1]>range.input[1] | range.breaks[2]1){ # i.e. if a min and max is given, choose only the max value 356 | plot.defaults$line.widths<-rep(max(plot.defaults$line.widths, na.rm=TRUE), length(line.cols)) 357 | }}} 358 | 359 | # Invert direction of line.expansion 360 | plot.defaults$line.expansion<-1-plot.defaults$line.expansion 361 | # This is a bit pointless, but is included for consistency with earlier versions. 362 | 363 | # if line.curvature is a list, convert to vector 364 | if(is.list(plot.defaults$line.curvature)){ 365 | plot.defaults$line.curvature<-unlist(plot.defaults$line.curvature)} 366 | 367 | # if point.attr are 1){ 472 | row.order<-do.call(order, as.list(point.dframe[, order.cols])) 473 | }else{ 474 | row.order<-order(point.dframe[, order.cols])} 475 | point.dframe<-point.dframe[row.order, -order.cols] 476 | # label.dframe<-label.dframe[row.order, ] 477 | }else{row.order<-c(1:nrow(point.dframe))} 478 | 479 | # add coordinates 480 | point.dframe<-cbind(circle.points, point.dframe) 481 | 482 | # ensure point and label data.frames having matching row orders 483 | label.order<-sapply(point.dframe$labels, function(a, lookup){ 484 | which(lookup$labels==a)}, lookup=label.dframe) 485 | label.dframe<-label.dframe[label.order, ] 486 | 487 | # add labels if needed 488 | label.suppress.test<-is.logical(plot.options$point.labels) & length(plot.options$point.labels)==1 489 | if(label.suppress.test==FALSE){ 490 | label.dframe<-cbind(circle.labels[, c(1, 2, 4)], label.dframe) 491 | # correct label presentation 492 | label.dframe$srt[which(label.dframe$x<0)]<-label.dframe$srt[which(label.dframe$x<0)]+180 493 | label.dframe$adj<-0 494 | label.dframe$adj[which(label.dframe$x<0)]<-1 495 | } 496 | 497 | # export as a list 498 | point.list<-list(point.dframe, label.dframe) 499 | names(point.list)<-c("points", "labels") 500 | 501 | 502 | # Set styles 503 | if(style=="clock"){ 504 | coord.start<-as.data.frame( 505 | make.circle(n.points, alpha= plot.options$plot.rotation, k=(1 + plot.options$border$tcl))[, 2:3]) 506 | x.list<-as.list(as.data.frame(t(cbind(point.list$points$x, coord.start$x)))) 507 | names(x.list)<-rep("x", length(x.list)) 508 | y.list<-as.list(as.data.frame(t(cbind(point.list$points$y, coord.start$y)))) 509 | names(y.list)<-rep("y", length(y.list)) 510 | # data.list<-split(point.data[, -c()], c(1:nrow(point.data))) 511 | border.attr<-plot.options$border[-which(names(plot.options$border)=="tcl")] 512 | data.list<-vector("list", length(x.list)) 513 | for(i in 1:length(data.list)){ 514 | coordinates<-append(x.list[i], y.list[i]) 515 | data.list[[i]]<-append(coordinates, border.attr) 516 | } 517 | point.list$nodes<-data.list 518 | # now add the border itself 519 | border.coords<-make.circle(100, alpha= plot.options$plot.rotation, k=1)[, 2:3] 520 | border.coords<-rbind(border.coords, border.coords[1, ]) 521 | point.list$border<-append(as.list(border.coords), 522 | plot.options$border[-which(names(plot.options$border)=="tcl")]) 523 | } 524 | 525 | if(style=="pie"){ 526 | # use clustering to determine whether which sets of adjacent points have unique attributes 527 | point.attributes<-point.list$points[, -c(1:3)] 528 | # convert any character data to factors 529 | class.list<-lapply(point.attributes, class) 530 | if(any(class.list =="character")){ 531 | select<-which(class.list=="character") 532 | for(i in 1:length(select)){point.attributes[, select[i]]<-as.factor(point.attributes[, select[i]])}} 533 | # use this to calculate groups 534 | point.distance<-daisy(point.attributes, "gower") 535 | point.cluster<-hclust(point.distance) 536 | polygon.attributes<-point.list$points 537 | # attach to initial values 538 | if(any(point.distance>0)){ 539 | initial.vals<-cutree(point.cluster, h=min(point.distance[which(point.distance>0)])*0.5) 540 | initial.vals<-initial.vals - initial.vals[1] + 1 # set 1st value to 1 541 | final.vals<-initial.vals 542 | for(i in 2:length(initial.vals)){ 543 | if(initial.vals[i]==initial.vals[(i-1)]){final.vals[i]<-initial.vals[(i-1)] 544 | }else{final.vals[i]<-initial.vals[(i-1)]+1}} 545 | polygon.attributes$group<-final.vals 546 | }else{ 547 | polygon.attributes$group<-1} 548 | # now go through these and determine which are different from previous 549 | # this works because points are drawn in row order 550 | polygon.group<-rep(0, nrow(polygon.attributes)) 551 | for(i in 2:nrow(polygon.attributes)){ 552 | if(polygon.attributes$group[i]!=polygon.attributes$group[(i-1)]){polygon.group[i]<-1 553 | }else{polygon.group[i]<-0}} 554 | polygon.attributes$group<-cumsum(polygon.group)+1 555 | # at this point it might be worth removing irrelevant columns (i.e. that only work on points, not polygons) 556 | # make a set of polygons for plotting 557 | polygon.list.initial<-split(polygon.attributes, polygon.attributes$group) 558 | n.points<-nrow(point.list$points) 559 | m<-10 # must be an even number 560 | circle.points.offset<-as.data.frame(make.circle(n.points*m, 561 | alpha=plot.options$plot.rotation+(180/(n.points*m)))[, 2:3]) 562 | circle.points.max<-as.data.frame(make.circle(n.points*m, 563 | alpha=plot.options$plot.rotation+(180/(n.points*m)), k= edge.max)[, 2:3]) 564 | colnames(circle.points.max)<-c("x.max", "y.max") 565 | circle.points.offset<-cbind(circle.points.offset, circle.points.max) 566 | circle.points.offset<-rbind(circle.points.offset[nrow(circle.points.offset), ], circle.points.offset)#, circle.points.offset[1, ]) 567 | point.list$polygons<-lapply(polygon.list.initial, function(x, points, options, res){ 568 | make.polygon(x, points, options, res)}, 569 | points= circle.points.offset, options = plot.options, res=m) 570 | } # end pie style 571 | 572 | # LINES 573 | line.list<-lapply(x$long, function(y, binary, options.list){ 574 | colnames(y)[c(1:3)]<-c("sp1", "sp2", "value") 575 | clean.lines(y, binary, options.list)}, binary=x$binary, options.list=plot.options) 576 | 577 | # PLOT 578 | x.lim<-c(min(point.dframe$x), max(point.dframe$x)) 579 | # extra x margins added 580 | # note this works beacuse set.plot.attributes allows FALSE as the only logical operator to point.labels 581 | label.suppress.test<-is.logical(plot.options$point.labels) & length(plot.options$point.labels)==1 582 | if(label.suppress.test==FALSE){ 583 | max.label<-max(nchar(point.dframe$labels)) 584 | x.expansion<-((label.distance[1]-1)*0.5) + (max.label*0.03) 585 | x.lim<-colSums(rbind(x.lim, c(-x.expansion, x.expansion))) 586 | }else{x.lim<-c(-edge.max, edge.max)} 587 | # set plot attributes 588 | plot.list<-list(x= point.dframe$x, y= point.dframe$y, 589 | xlim=x.lim, ylim=x.lim, type="n", ann=FALSE, axes=FALSE, asp=1) 590 | if(is.null(plot.options$plot)==FALSE){ 591 | user.data<-plot.options$plot 592 | attr.list<-names(user.data) 593 | available.attr<-names(plot.list) 594 | keep.cols<-sapply(available.attr, FUN=function(x){any(attr.list==x)}) 595 | add.cols<-which(keep.cols==FALSE) 596 | if(length(add.cols)>0){plot.list<-append(user.data, plot.list[as.numeric(add.cols)]) 597 | }} 598 | 599 | # return all outputs 600 | result.list<-append(list(par=plot.options$par, plot=plot.list), point.list) 601 | result.list<-append(result.list, list(lines=line.list)) 602 | attr(result.list, "binary")<-x$binary 603 | attr(result.list, "asymmetric")<-x$asymmetric 604 | return(result.list) 605 | } 606 | 607 | 608 | 609 | 610 | # function to add get a data.frame in the correct format to draw a key from a circleplot object 611 | get.key.dframe<-function(circleplot.result, exclude.lines, reverse, cex, right){ 612 | 613 | # get info from source object 614 | breaks <- circleplot.result$plot.control$line.breaks 615 | breaks <- format(breaks, digits = 2) 616 | colours <- circleplot.result$plot.control$line.cols 617 | widths <- circleplot.result$plot.control$line.widths 618 | 619 | # sort out col names with and without NA values 620 | na.info<-circleplot.result$plot.control$na.control 621 | na.present<-is.list(circleplot.result$plot.control$na.control) & any(is.na(circleplot.result$lines$value)) 622 | col.names<-c("col", "lty", "lwd") 623 | if(na.present){col.names<-sort(unique(c(col.names, names(na.info))))} 624 | nlines<-length(colours)+1 625 | 626 | # make line data.frame 627 | line.data<-as.data.frame(matrix(data=NA, nrow=nlines, ncol=length(col.names))) 628 | colnames(line.data)<-col.names 629 | line.data$col[1:length(colours)]<-colours 630 | line.data$lty[1:length(colours)]<-1 631 | line.data$lwd[1:length(widths)]<-widths 632 | 633 | # add NA information 634 | if(na.present){for(i in 1:length(na.info)){ 635 | col<-which(colnames(line.data)==names(na.info)[i]) 636 | line.data[nrow(line.data), col]<-na.info[i]}} 637 | 638 | # group data into a single data.frame that can be passed to lines by do.call 639 | line.frame<-cbind(data.frame(x0=0, x1=1, y0=1, y1=1), line.data) 640 | text.labels<-c( 641 | paste(breaks[c(1:(length(breaks)-1))], "-", breaks[c(2:length(breaks))], sep=" "), "NA") 642 | 643 | # exclude lines as requested by user 644 | exclude.na<-c(na.present==FALSE | any(exclude.lines==nrow(line.data))) 645 | if(exclude.na){ 646 | line.frame<-line.frame[-nlines, ] 647 | text.labels<-text.labels[-nlines] 648 | } 649 | if(any(exclude.lines==nlines)){exclude.lines<-exclude.lines[-which(exclude.lines==nlines)]} 650 | exclude.test<-c(length(exclude.lines)>0 & any(exclude.lines==999)==FALSE) 651 | if(exclude.test){ 652 | line.frame<-line.frame[-exclude.lines, ] 653 | text.labels<-text.labels[-exclude.lines] 654 | } 655 | nlines<-nrow(line.frame) 656 | 657 | # sort out y values (in reverse order if requested) 658 | if(reverse){ 659 | if(exclude.na){line.order<-c(nlines:1)}else{line.order<-c((nlines-1):1, nlines)} # NA values always placed last 660 | line.frame<-line.frame[line.order, ] 661 | text.labels <-text.labels[line.order]} 662 | y.vals <- seq(1, 0, length.out = nlines) 663 | line.frame$y0<-y.vals; line.frame$y1<-y.vals 664 | text.list<-list(at=y.vals, labels=text.labels, tick=FALSE, las=1) 665 | 666 | # return object 667 | return(list(lines=line.frame, text=text.list)) 668 | } 669 | 670 | 671 | # function to work out how many panels to include for run.circleplot.multiple 672 | panel.dims<-function(n){ 673 | x<-sqrt(n) 674 | low<-floor(x) 675 | high<-ceiling(x) 676 | if((low*high)>=n){return(c(low, high)) 677 | }else{return(rep(high, 2))} 678 | } 679 | 680 | 681 | # function to offset all data in a figure by a specified amount, and/or scale size of the figure 682 | offset.circleplot<-function(x, 683 | offset.x=0, 684 | offset.y=0, 685 | scale=1 # multiplier 686 | ){ 687 | 688 | # start with point data 689 | # extract information on point locations 690 | point.vals<-x$locations$points 691 | label.vals<-x$locations$labels 692 | 693 | if(any(colnames(label.vals)=="x")){ 694 | # goal is to maintain constant distance of labels from edge - extract these data 695 | delta.x<-label.vals$x-point.vals$x 696 | delta.y<-label.vals$y-point.vals$y 697 | # multiply by scale 698 | point.vals$x<-( point.vals$x * scale ) 699 | point.vals$y<-( point.vals$y * scale ) 700 | label.vals$x<-point.vals$x + delta.x 701 | label.vals$y<-point.vals$y + delta.y 702 | # offset x & y 703 | point.vals$x<-( point.vals$x + offset.x ) 704 | point.vals$y<-( point.vals$y + offset.y ) 705 | label.vals$x<-( label.vals$x + offset.x ) 706 | label.vals$y<-( label.vals$y + offset.y ) 707 | # put back in to original lists 708 | x$locations$points<-point.vals 709 | x$locations$labels<-label.vals 710 | }else{ 711 | # multiply by scale 712 | point.vals$x<-( point.vals$x * scale ) 713 | point.vals$y<-( point.vals$y * scale ) 714 | # offset x & y 715 | point.vals$x<-( point.vals$x + offset.x ) 716 | point.vals$y<-( point.vals$y + offset.y ) 717 | # put back in to original lists 718 | x$locations$points<-point.vals 719 | } 720 | 721 | # internal functions 722 | adjust.locations<-function(y, ax, ay, mu){ 723 | y$x <- y$x * mu 724 | y$y <- y$y * mu 725 | y$x <- y$x + ax 726 | y$y <- y$y + ay 727 | return(y)} 728 | adjust.lines<-function(z, add.x, add.y, multiply){ 729 | lapply(z, function(z, ax, ay, mu){adjust.locations(z, ax, ay, mu)}, 730 | ax= add.x, ay= add.y, mu= multiply)} 731 | 732 | # adjust remaining content 733 | # lines 734 | x$line.data<-lapply(x$line.data, function(z, add.x, add.y, multiply){ 735 | adjust.lines(z, add.x, add.y, multiply)}, 736 | add.x=offset.x, add.y=offset.y, multiply=scale) 737 | 738 | # borders (style="clock") 739 | if(any(names(x$locations)=="border")){ 740 | x$locations$border<-adjust.locations(x$locations$border, offset.x, offset.y, scale)} 741 | 742 | if(any(names(x$locations)=="nodes")){ 743 | x$locations$nodes<-lapply(x$locations$nodes, function(y, ax, ay, mu){ 744 | adjust.locations(y, ax, ay, mu)}, 745 | ax= offset.x, ay= offset.y, mu= scale)} 746 | 747 | # polygons (style="pie") 748 | if(any(names(x$locations)=="polygons")){ 749 | x$locations$polygons<-lapply(x$locations$polygons, function(y, ax, ay, mu){ 750 | adjust.locations(y, ax, ay, mu)}, 751 | ax= offset.x, ay= offset.y, mu= scale)} 752 | 753 | return(x) 754 | } -------------------------------------------------------------------------------- /R/trig_functions.R: -------------------------------------------------------------------------------- 1 | # trigonometric functions for circleplot 2 | 3 | ## CIRCLES 4 | 5 | # make a circle of specified size 6 | make.circle<-function( 7 | n, # number of points, equally spaced around the edge of a circle 8 | alpha, # offset angle, in degrees 9 | k) # scaling value - larger for bigger circles. defaults to 1 10 | { 11 | if(missing(k))k<-1 12 | base.alpha<-(-90-(180/n)) 13 | if(missing(alpha)){alpha<-base.alpha}else{alpha<-alpha+base.alpha} 14 | alpha<-alpha*(pi/180) # convert to radians 15 | # get coordinates 16 | theta<-(2*(pi/n)*seq(0, (n-1)))-alpha 17 | values<-data.frame( 18 | theta=theta, 19 | x=k*cos(theta), 20 | y=k*sin(theta)) 21 | # reorder such that circle is drawn clockwise from the top 22 | values<-values[c(nrow(values):1), ] 23 | rownames(values)<-c(1:nrow(values)) 24 | return(values) 25 | } 26 | 27 | 28 | # draw a circle with specified origin, circumference and attributes 29 | draw.circle<-function(k, x0=0, y0=0, alpha=0, filled=FALSE, n=100, trim=0, ...){ 30 | data<-make.circle(n=n, alpha= alpha, k=k)[, 2:3] 31 | data$x<-data$x + x0 32 | data$y<-data$y + y0 33 | data<-rbind(data, data[1, ]) 34 | if(trim>0){ 35 | trim.start<-c(1:trim) 36 | trim.end<-c((nrow(data)-trim) : nrow(data) ) 37 | data<-data[-c(trim.start, trim.end), ]} 38 | if(filled){polygon(data, ...) 39 | }else{lines(data, ...)} 40 | return(invisible(data)) 41 | } 42 | 43 | 44 | # take a data.frame with cols x and y, and rotate clockwise by a given number of radians 45 | rotate.points<-function(x, rotation){ 46 | new.x<-(x$x * cos(rotation))-(x$y * sin(rotation)) 47 | new.y<-(x$y * cos(rotation))+(x$x * sin(rotation)) 48 | result<-data.frame(x=new.x, y=new.y) 49 | return(result)} 50 | 51 | 52 | # add polygon to edge of circle 53 | make.polygon<-function(x, points, options, res){ #=segment.dframe, point.dframe.total, plot.options){ 54 | min.selector<-cbind(points$x-x$x[1], points$y-x$y[1]) 55 | row.start<-which.min(apply(min.selector, 1, function(x){sum(x^2)})) - (res/2) 56 | a<-nrow(x) 57 | min.selector<-cbind(points$x-x$x[a], points$y-x$y[a]) 58 | row.end<-which.min(apply(min.selector, 1, function(x){sum(x^2)})) + (res/2) 59 | # use this to make a polygon-type data.frame 60 | rows<-c(row.start:row.end); inv.rows<-c(row.end:row.start) 61 | poly.final<-list( 62 | x= c(points$x[rows], points$x.max[inv.rows]), 63 | y= c(points$y[rows], points$y.max[inv.rows]), 64 | border=NA, 65 | col=x$col[1]) 66 | return(poly.final) 67 | } 68 | 69 | 70 | 71 | ## LINES 72 | 73 | # calculate the attributes of a triangle linking two points on the circumference and a point bisecting them, 74 | # pc.scale gives the proportion of the distance between the base line and the origin 75 | # line linking the two points is taken to be horizontal 76 | triangle.coords<-function(coords, pc.scale=0.5) 77 | { 78 | radius<-sqrt(coords$x[1]**2 + coords$y[1]**2) 79 | base.length<-sqrt((coords$x[1]-coords$x[2])**2 + (coords$y[1]-coords$y[2])**2) 80 | adj<-base.length/2 81 | adj.on.radius<-adj/radius 82 | if(adj.on.radius<1){ 83 | angle1<-acos(adj.on.radius) 84 | opp<-tan(angle1)*adj*pc.scale 85 | }else{opp<-0} 86 | coords.adjusted<-data.frame(x=c(-adj, 0, adj), y=c(0, opp, 0)) 87 | return(coords.adjusted) 88 | } 89 | 90 | 91 | # function to calculate locations for each line 92 | calc.lines<-function( 93 | x, # each 'line' to be drawn, in a list 94 | plot.object, # called 'circleplot.object' in function 'circleplot' 95 | distance, # distances between points - affected curvature 96 | options, # plot.options 97 | pc.scale=0.5 # line curvature - check how this is supplied 98 | ){ 99 | 100 | # sort out coords for this row 101 | row1<-which(plot.object$points$labels== x$sp1) 102 | row2<-which(plot.object$points$labels== x$sp2) 103 | coords<-data.frame(x= plot.object$points$x[c(row1, row2)], y= plot.object$points$y[c(row1, row2)]) 104 | 105 | # find basic spatial info on these points 106 | distance.thisrun<-distance[row1, row2] 107 | coords.scaled<-triangle.coords(coords, distance.thisrun) # what coordinates should the curve be fit to? 108 | 109 | if(coords.scaled$y[2]>0.0001){ # coords scaled is a flattened curve: if this condition not met, then a straight line. 110 | # calculate key points to position the parabola 111 | mean.point<-c(x=mean(coords$x), y=mean(coords$y)) 112 | angle<-atan(mean.point[2]/mean.point[1])## angle between 0,0 and mean.point 113 | if(mean.point[1]<0){angle<-pi + angle} 114 | # angle*(180/pi) 115 | hyp<-as.numeric(sqrt(mean.point[1]^2+ mean.point[2]^2)*pc.scale) 116 | adj<-as.numeric(hyp*cos(angle)) 117 | opp<-as.numeric(hyp*sin(angle)) 118 | multiplier<-sign(mean.point[1]) 119 | if(multiplier<0.001 & multiplier>-0.001)multiplier<-1 120 | result<-data.frame( 121 | x=c(mean.point[1], as.numeric(mean.point[1]-(adj*multiplier))), 122 | y=c(mean.point[2], as.numeric(mean.point[2]-(opp*multiplier)))) 123 | # note: *sign() necessary to avoid -ve x vals giving apex(s) that are outside of the circle 124 | rownames(result)<-c("mean", "apex") 125 | # adjust angle to be measured from downward vertical line, not rightwards horizontal as prev. 126 | final.angle<-angle +(pi*0.5) 127 | if(final.angle <0) final.angle <-(2*pi)+ final.angle 128 | apex<-list(angle=as.numeric(final.angle), coordinates=result) 129 | 130 | # fit a parabola to these points 131 | model<-lm(y~x+I(x**2), data= coords.scaled) 132 | curve<-data.frame(x=seq(min(coords.scaled$x), max(coords.scaled$x), length.out=101)) 133 | curve$y<-as.numeric(predict(model, curve, se.fit=FALSE)) 134 | 135 | # set apex =0,0 136 | curve$y<-curve$y-curve$y[51] 137 | 138 | # rotate 139 | result<-data.frame( 140 | x=(curve$x*cos(apex$angle)) - (curve$y*sin(apex$angle)), 141 | y=(curve$x*sin(apex$angle)) + (curve$y*cos(apex$angle))) 142 | 143 | # adjust origin to match initial points 144 | point.locs<-data.frame( 145 | x=c(coords$x, result$x[c(1, 101)]), 146 | y=c(coords$y, result$y[c(1, 101)])) 147 | test.distances<-as.numeric(as.matrix(dist(point.locs))[3:4, 1]) 148 | if(test.distances[1]1){ 161 | result$x<-result$x[101:1] 162 | result$y<-result$y[101:1]} 163 | 164 | # set line colours 165 | if(options$line.gradient){ # for the special case where line colours are set by point colours 166 | # get line colours from input$points 167 | color1<-plot.object$points$col[row1] 168 | color2<-plot.object$points$col[row2] 169 | color.matrix<-col2rgb(c(color1, color2)) 170 | color.matrix.expanded<-apply(color.matrix, 1, function(x){seq(x[1], x[2], length.out=100)}) 171 | colours.final<-rgb(color.matrix.expanded, maxColorValue=255) 172 | # ensure colours are in correct order 173 | distance.pos<-sqrt((result$x[1]-plot.object$points$x[row1])^2) 174 | if(distance.pos>0.001){colours.final<-colours.final[100:1]} 175 | }else{colours.final<-x$col} # in all other cases 176 | 177 | # export 178 | result<-append(result, x[-c(1:3)]) 179 | if(options$line.gradient){result$col<-colours.final} 180 | return(result) 181 | } 182 | 183 | 184 | # add curved connecting lines to circleplot() 185 | draw.curves<-function(x){ 186 | # work out if segments are required 187 | segment.test<-any(length(x$col)>1 | length(x$lwd)>1) 188 | # plot accordingly 189 | if(segment.test){ 190 | segment.list<-append( 191 | list(x0= x$x[1:100], x1= x$x[2:101], y0= x$y[1:100], y1= x$y[2:101]), 192 | x[-c(1:2)]) 193 | segment.list<-segment.list[-which(names(segment.list)=="arrows")] 194 | do.call("segments", segment.list) 195 | }else{ 196 | if(any(names(x)=="arrows")){x<-x[-which(names(x)=="arrows")]} 197 | do.call("lines", x)} 198 | } 199 | 200 | 201 | 202 | ### ARROWS 203 | 204 | # generate coordinates for an arrowhead 205 | get.arrows<-function(input, attr, reverse){ 206 | # set some defaults 207 | angle<-attr$angle #20 # note this gives a total angle of 40 deg. (2*angle) 208 | length<-attr$length # 0.05 209 | centre<-c(0, 0) 210 | angle<-angle*(pi/180) # assume units are in degrees, and convert to radians 211 | 212 | # calculate information on where arrow should be located 213 | arrow.pc<-attr$distance #0.8 214 | arrow.loc<-ceiling(length(input$x)*arrow.pc) 215 | arrow.locs<-c((arrow.loc-1):(arrow.loc+1)) 216 | location<-as.numeric(c(input$x[arrow.loc], input$y[arrow.loc])) 217 | 218 | # calculate angle of line 219 | x.adj<-input$x[arrow.locs[3]]-input$x[arrow.locs[1]] 220 | y.adj<-input$y[arrow.locs[3]]-input$y[arrow.locs[1]] 221 | rotation<-atan(y.adj/x.adj) 222 | if(x.adj>0)rotation<-rotation+pi 223 | 224 | # calculate x and y coordinates of vertices 225 | xlim<-c(centre[1]-(length*0.5), centre[1]+(length*0.5)) 226 | height<-length*tan(angle) 227 | ylim<-c(centre[2]-height, centre[2]+height) 228 | 229 | # arrange for a left-facing arrow 230 | arrow<-data.frame( 231 | x=c(xlim[1], xlim[2], xlim[2], xlim[1]), 232 | y=c(centre[2], ylim[1], ylim[2], centre[2])) 233 | 234 | # adjust position to match location 235 | arrow<-rotate.points(arrow, rotation) 236 | arrow$x<-arrow$x + as.numeric(location[1]) 237 | arrow$y<-arrow$y + as.numeric(location[2]) 238 | 239 | return(arrow) 240 | } 241 | 242 | 243 | # function to determine what kind of arrowhead to draw (if any) and then draw result from get.arrows() 244 | draw.arrows<-function(x, attr){ 245 | if(x$arrows){ 246 | if(length(x$col)>1){col.final<-x$col[ceiling(101*attr$distance)] 247 | }else{col.final<-x$col} 248 | polygon(get.arrows(x, attr, reverse), border=NA, col= col.final)} 249 | } 250 | 251 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | circleplot 2 | ========== 3 | 4 | Tools for exploring distance and association matrices using circular plots. 5 | 6 | # Example: 7 | ``` 8 | # SIMPLE APPLICATIONS 9 | # get circleplot 10 | library(devtools) 11 | install_github('mjwestgate/circleplot') 12 | library(circleplot) 13 | 14 | # create some binary datasets 15 | binary.matrix<-matrix( 16 |   data=cut(rnorm(11**2), breaks=c(-20, 0, 20), labels=FALSE)-1, 17 |   nrow=11, ncol=11) # asymmetric, square matrix 18 | binary.dist<-as.dist(binary.matrix) # symmetric, lower-triangular matrix 19 | 20 | # examples 21 | circleplot(binary.dist) # default settings 22 | circleplot(binary.dist, cluster=FALSE) # change point arrangement 23 | circleplot(binary.dist, style="clock") # change style 24 | 25 | # set point attributes and plot 26 | point.attributes<-point.attr(binary.dist) 27 | point.attributes$cex<-0.7 28 | circleplot(binary.dist, style="pie", cluster=FALSE, plot.control=list( 29 | points=point.attributes, 30 | line.gradient=TRUE)) 31 | 32 | # numeric matrices 33 | numeric.matrix<-matrix(data=rnorm(11**2), nrow=11, ncol=11) # asymmetric, square 34 | numeric.dist<-as.dist(numeric.matrix) # symmetric, lower-triangular 35 | 36 | # examples 37 | circleplot(numeric.dist, style="classic") # default 38 | circleplot(numeric.dist-min(numeric.dist), style="clock", 39 | plot.control=list(border=list(lwd=2))) # version with only positive values 40 | 41 | 42 | # NEW FEATURES AT V0.4 43 | library(sppairs) 44 | library(cooccur) 45 | data(beetles) 46 | 47 | # manually reorder points 48 | point.order<-point.attributes 49 | point.order$order<-c(nrow(point.order):1) 50 | circleplot(binary.matrix, style="pie", cluster=TRUE, plot.control=list( 51 | arrows=list(length=0), 52 | points=point.order, 53 | line.gradient=TRUE)) 54 | 55 | # manually specify line attributes 56 | input<-spaa(beetles) 57 | input$col<-"red"; input$col[which(input$sp1=="V1")]<-"blue" 58 | circleplot(input, cluster=FALSE, style="clock") 59 | 60 | # plot a list of datasets 61 | data.list<-list(beetles[, 1:8], beetles[, 4:12], beetles[, 8:16], beetles[, 10:17]) 62 | names(data.list)<-paste("subset", c(1:4), sep="_") 63 | spaa.list<-lapply(data.list, function(x){spaa(x, method="or.symmetric")}) 64 | circleplot(spaa.list, cluster=FALSE, style="clock") 65 | ``` 66 | -------------------------------------------------------------------------------- /man/circleplot.Rd: -------------------------------------------------------------------------------- 1 | \docType{package} 2 | \name{circleplot} 3 | \alias{circleplot-package} 4 | \title{circleplot} 5 | \description{ 6 | Simple plotting of distance and association matrices 7 | } 8 | 9 | -------------------------------------------------------------------------------- /man/circleplot_fun.Rd: -------------------------------------------------------------------------------- 1 | \name{circleplot_fun} 2 | \alias{circleplot} 3 | \title{Plot a pairwise associations between nodes} 4 | \usage{ 5 | circleplot(x, cluster, reduce, draw, add, style, plot.control) 6 | } 7 | \arguments{ 8 | \item{x}{a data source containing information on pairwise associations. The standard input is a data.frame with 3 columns, where the first two columns specify the identities of the connected nodes, and the third gives a numeric value describing the connection between those node. Alternatively, x can be a matrix of class 'matrix' or 'dist' with identical results, or list containing >1 of the above.} 9 | 10 | \item{cluster}{logical - should points be rearranged using hclust? Defaults to TRUE, unless distance.matrix contains missing values, in which case cluster is set to FALSE and cannot be overwritten.} 11 | 12 | \item{reduce}{logical - should points with no connections be removed from the plot? Defaults to FALSE} 13 | 14 | \item{draw}{logical - should the plot be drawn? Defaults to TRUE. Useful for calculating circleplot objects for later plotting.} 15 | 16 | \item{add}{logical (defaulting to FALSE), with behaviour dependent on class(x). When class(x)=="list", default is to divide the window automatically using par(mfrow), while setting add=TRUE allows you to specify your own mfrow values. When class(x)!="list", asks whether new points and lines be added to the existing plot window.} 17 | 18 | \item{style}{command to change the style of plot presentation, largely interms of how points are drawn on the circumference. style='classic' (the default) uses points, 'pie' uses polygons, and 'clock' uses lines.} 19 | 20 | \item{plot.control}{a list giving information on how the plot should appear. If given, may contain any or all of the named objects given in notes (below).} 21 | 22 | 23 | } 24 | \value{ 25 | Draws a plot showing the labels of the specified object as nodes around the circumference of a circle, with parabolic lines joining them. When a list is supplied as an input, circleplot invisibly returns a list altered by clean.list(); otherwise invisibly returns point and line attributes of a single plot. 26 | } 27 | \description{ 28 | Draws a circular plot of pairwise association values. 29 | } 30 | \note{ 31 | options for plot.control are as follows: 32 | \describe{ 33 | \item{plot.rotation}{a single numeric value, used to set the number of degrees that points are rotated. Default is to arrange points clockwise from vertical.} 34 | \item{plot}{a list of arguments to pass to plot()} 35 | \item{par}{a list of arguments to pass to par()} 36 | \item{points}{a data.frame giving point attributes, where colnames are the names of arguments to be passed to points(), plus an extra column named 'labels' for matching to the labels of the input distance matrix. An example can be seen by calling point.attr(x).} 37 | \item{point.labels}{either a logical term (defaulting to TRUE) stating whether points be labelled; or a data.frame of same nrows as 'points' (above), listing attributes of labels. If the latter, the data.frame must include one column named 'labels'; other column names should be commands to pass to text(). Note that 'offset' is an exception; rather than being passed to text, its average value is used as the absolute distance from points that labels are placed (Defaults to 0.05).} 38 | \item{line.gradient}{logical, default to FALSE; should lines display a colour gradient. This is usually only sensible for binary matrices (i.e. where line width or colour is not meaningful).} 39 | \item{line.breaks}{vector of breaks in distance.matrix used to determine line colours and widths. Note that NA values are ignored, and so are dealt with separately using na.control (below).} 40 | \item{line.cols}{vector containing colours, either named or hexadecimal. Used with 'line.breaks' above; length should equal either 1 or length(breaks)-1.} 41 | \item{line.widths}{vector used to set line widths, passed to lines(lwd) in conjunction with 'line.breaks' above. If length = 1, is the width of all lines; if length=length(breaks)-1, passed directly. Unlike earlier versions, specifying min and max widths may no longer return sensible results.} 42 | \item{line.expansion}{length-1 vector giving the percentage of the line width that is lost as the line approaches a vertex; i.e. one = strong tapering, zero=no tapering. } 43 | \item{line.curvature}{length-2 vector (or optionally, a list) that can be used to alter line straightness (i.e. the proportional curvature of the line). If given, must contain two values; the first is used to add curvature to all lines, the second multiplies the curvature by the distance between both points. Setting line.curvature[1]=0 gives boundary lines that lack any curvature, while setting both values to zero gives straight lines. Defaults to c(add=0.25, multiply=0.35), for consistency with earlier versions. Note that high values (>0.5) make the plot difficult to read, while setting high values for both attributes can cause points and lines to fail to intersect.} 44 | \item{arrows}{list containing up to three named arguments: length gives the length of the arrow; angle the 'sharpness' of the arrowhead (in degrees); and distance is the proportion of line length that the arrow should be placed. Defaults are arrows=list(length=0.07, angle=10, distance=0.75)} 45 | \item{border}{list of line attributes, passed to draw tick labels and border when style="clock" (and ignored otherwise). Note that 'tcl' is treated differently from as given in par, but still sets tick length (defaulting to -0.07).} 46 | \item{na.control}{command to control plotting of missing line values. If supplied, should be a list of commands to pass to lines(), [e.g. list(lwd=1, lty=2, col="grey") ]. Defaults to NA, which suppresses lines with missing values.} 47 | } 48 | } 49 | 50 | -------------------------------------------------------------------------------- /man/draw.circle.Rd: -------------------------------------------------------------------------------- 1 | \name{draw_circle} 2 | \alias{draw.circle} 3 | \title{draw a circle with specified attributes} 4 | \usage{ 5 | draw.circle(k=1, x0=0, y0=0, filled=FALSE, n=100, trim=0, alpha=0, ...) 6 | } 7 | \arguments{ 8 | \item{k}{The radius; defaults to one} 9 | \item{x0}{Location of the center of the circle on the x axis} 10 | \item{y0}{Location of the center of the circle on the y axis} 11 | \item{filled}{If TRUE, the circle is drawn with 'polygons'; if FALSE (the default), lines is used instead} 12 | \item{n}{The number of points to place on the circumference} 13 | \item{trim}{the number of rows to remove from both the start and end of the data.frame, and thereby from the circumference of the circle as well} 14 | \item{alpha}{Angle (in degrees) by which to rotate point coordinates. Only ever sensible if 'trim' is specified} 15 | \item{...}{Any further arguments to pass to lines() or polygon(), depending on the value of the 'filled' argument (see above)} 16 | 17 | } 18 | \value{ 19 | plots the circle as specified; also returns a data.frame with the specified information 20 | } 21 | \description{ 22 | Adds a circle to an existing plot 23 | } -------------------------------------------------------------------------------- /man/make.circle.Rd: -------------------------------------------------------------------------------- 1 | \name{make_circle} 2 | \alias{make.circle} 3 | \title{Generate coordinates of points on the circumference of a circle} 4 | \usage{ 5 | make.circle(n, alpha, k) 6 | } 7 | \arguments{ 8 | \item{n}{The number of points to place on the circumference} 9 | 10 | \item{alpha}{Angle (in degrees) by which to rotate point coordinates. Defaults to 22.91 (0.4 radians)} 11 | 12 | \item{k}{The radius; defaults to one} 13 | } 14 | \value{ 15 | Returns a data.frame with x & y coordinates, as well as the angle (in radians) of that point from the origin. 16 | } 17 | \description{ 18 | This function is used to generate point locations in circleplot; but can also be useful for adding furter points and labels to an existing plot. 19 | } -------------------------------------------------------------------------------- /man/offset.circleplot.Rd: -------------------------------------------------------------------------------- 1 | \name{offset.circleplot} 2 | \alias{offset.circleplot} 3 | \title{Change the origin and scale of an object returned by circleplot} 4 | \usage{ 5 | offset.circleplot(x, offset.x, offset.y, scale) 6 | } 7 | \arguments{ 8 | \item{x}{an object returned by circleplot} 9 | \item{offset.x}{new location of the origin on the x axis} 10 | \item{offset.y}{new location of the origin on the y axis} 11 | \item{scale}{how much larger should the new plot be?} 12 | } 13 | \value{ 14 | Returns a list with the same components as that returned from circleplot, but relocated as specified by the user 15 | } 16 | \description{ 17 | Move a circleplot - useful for adding many plots to the same region 18 | } 19 | 20 | -------------------------------------------------------------------------------- /man/point_attr.Rd: -------------------------------------------------------------------------------- 1 | \name{point_attr} 2 | \alias{point.attr} 3 | \title{List of point colours} 4 | \usage{ 5 | point.attr(distance.matrix) 6 | } 7 | \arguments{ 8 | \item{distance.matrix}{a distance matrix (class dist) containing either continuous or binary data} 9 | } 10 | \value{ 11 | Returns a data.frame of the approriate format for the plot.control$points command in circleplot(). 12 | } 13 | \description{ 14 | Selects some pretty colours for point vertices from RColorBrewer. Not a sophisticated function by any means. 15 | } 16 | 17 | --------------------------------------------------------------------------------