R/viz_art_backend.R
86474139
 ._Figure_out_genomic_scale <- function(positions){
625325f1
     axis.labels <- vapply(positions,function(x){
         if(x > 1000000){
             return(paste(round(x/1000000,1), "mb", sep = ""))
         }
         if(x > 1000){
             return(paste(round(x/1000,1), "kb", sep = ""))
         }
         if(x >= 1){
             return(paste(x/1, "bp", sep = ""))
         }
     }, "")
     return(axis.labels)
86474139
 }
 ._Parse_genomic_coordinates <- function(a.list = NULL){
625325f1
     Reference.object <- GenomicMatrix$new()
     parsed.string.list <- lapply(a.list,function(x){
         Split.string <- Split_genomic_coordinates(Coordinate=x)
         a.vector <- c(Split.string[[1]][1], Split.string[[1]][2], 
             Split.string[[1]][3])
         names(a.vector) <- Reference.object$NonStrandedColNames
         a.vector
     })
     return(parsed.string.list)
86474139
 }
 
af47efdf
 Get_one_or_two_brick_regions <- function(Bricks = NULL, resolution = NULL, 
     x_coords = NULL, y_coords = NULL, distance = NULL, value_cap = NULL, 
     FUN = NULL){
625325f1
     Reference.object <- GenomicMatrix$new()
632a1a64
     if(length(Bricks) > 2){
af47efdf
         stop("Higher order polygon layouts have not been implemented yet! 
625325f1
             So for now we can only do two matrices at a time.\n")
     }
6a22d578
     if(!is.null(value_cap)){
         if(value_cap > 1 | value_cap < 0){
             stop("value_cap must be a value between 0,1 ",
625325f1
                 "representing the quantiles.\n")
         }
     }
     # require(reshape2)
     Matrix.df.list <- list()
632a1a64
     for(i in seq_along(Bricks)){
af47efdf
         Brick <- Bricks[[i]]
632a1a64
         Matrix <- Brick_get_matrix_within_coords(Brick = Brick, 
af47efdf
             x_coords = x_coords, y_coords = y_coords, 
             resolution = resolution, force = TRUE, FUN = FUN)
         Region.position.x <- Brick_return_region_position(Brick = Brick,
             region = x_coords, resolution = resolution)
         Region.position.y <- Brick_return_region_position(Brick = Brick,
             region = y_coords, resolution = resolution)
625325f1
         if(dim(Matrix)[1] != length(Region.position.x) | 
             dim(Matrix)[2] != length(Region.position.y)){
             stop("Matrix dimensions do not match the expected ",
                 "dimensions of the matrix! Please check the ",
                 "value transformation!\n")
         }
         Matrix[is.nan(Matrix) | is.infinite(Matrix) | is.na(Matrix)] <- 0
         rownames(Matrix) <- Region.position.x
         colnames(Matrix) <- Region.position.y
         Matrix.df <- melt(Matrix)
         colnames(Matrix.df) <- c("row","col","val")
86474139
 
6a22d578
         if(!is.null(value_cap)){
             capped.val <- quantile(Matrix.df$val,value_cap)
625325f1
             Matrix.df$val[Matrix.df$val > capped.val] <- capped.val
         }
         Matrix.df$dist <- Matrix.df$col - Matrix.df$row
         Matrix.df$keep <- FALSE
         if(i == 1){
             Matrix.df$keep[Matrix.df$dist >= 0] <- TRUE
         }else{
             Matrix.df$keep[Matrix.df$dist <= 0] <- TRUE
         }
         Matrix.df.list[[i]] <- Matrix.df
     }
86474139
 
625325f1
     Matrix.df <- do.call(rbind,Matrix.df.list)
632a1a64
     if(length(Bricks)==2){
625325f1
         Matrix.df <- Matrix.df[Matrix.df$keep,]
         Matrix.df$val[Matrix.df$dist == 0] <- 0
     }
     if(!is.null(distance)){
         Matrix.df <- Matrix.df[Matrix.df$dist <= distance & 
         Matrix.df$dist >= -distance,]
     }
     return(Matrix.df)
86474139
 }
 
af47efdf
 Make_axis_labels = function(Brick = NULL, chr = NULL, resolution = NULL, 
     positions = NULL){
     Bintable <- Brick_get_bintable(Brick = Brick, chr = chr, 
         resolution = resolution)
86474139
     breaks <- end(Bintable[positions])
     breaks[1] <- start(Bintable[positions[1]])
     coord.labs <- ._Figure_out_genomic_scale(breaks)
     return(coord.labs)
 }
 
6a22d578
 Make_colours <- function(palette = NULL, extrapolate_on = NULL, direction = 1){
86474139
     # require(RColorBrewer)
     # require(viridis)
625325f1
     viridis.cols <- list("plasma" = plasma, "inferno" = inferno, 
         "magma" = magma, "viridis" = viridis, "cividis" = cividis)
86474139
     brewer.names <- rownames(brewer.pal.info)
     brewer.pals <- brewer.pal.info$category 
     brewer.names <- brewer.names[brewer.pals %in% c("div","seq")]
     if(length(palette)!=1){
625325f1
         stop("palette must be a string of length 1\n")
86474139
     }
625325f1
     if(!(palette %in% brewer.names) & 
         !(palette %in% names(viridis.cols))){
         stop("palette must be a palette from RColorBrewer ",
             "diverging or sequential or Viridis.\n")
86474139
     }
     if(palette %in% rownames(brewer.pal.info)){
625325f1
         Category <- brewer.pal.info$category[
         rownames(brewer.pal.info) == palette]
         Colours <- brewer.pal(name = palette, 
             n = brewer.pal.info$maxcolors[rownames(brewer.pal.info) == palette])
         if(direction == -1){
             Colours <- rev(Colours)
         }
86474139
     }else{
625325f1
         viridis.col.breaks <- 12
         Do.viridis <- TRUE
         viridis.fun <- viridis.cols[[palette]]
         Colours <- viridis.fun(n = viridis.col.breaks, direction = direction)
86474139
     }
6a22d578
     if(!is.null(extrapolate_on)){
         if(extrapolate_on > 100){
625325f1
             stop("I don't think you can actually differentiate ",
                 "between more than 100 shades.")
         }
6a22d578
         Colours <- colorRampPalette(Colours)(extrapolate_on)
625325f1
     }
     return(Colours)
86474139
 }
 
625325f1
 RotatePixels <- function(shift = NULL, plot.order = NULL, vector = NULL, 
     distance = NULL, upper = TRUE){
86474139
     leftmost.x <- seq((0+shift),length.out=length(vector),by=1)
     leftmost.y <- rep((0+shift),length(vector))
     Order<-seq(plot.order,length.out=length(leftmost.x),by=4)
 
     uppermid.x <- seq((0.5+shift),length.out=length(vector),by=1)
     uppermid.y <- rep((0.5+shift),length.out=length(vector),by=1)
     Order<-c(Order,seq(min(Order)+1,length.out=length(uppermid.y),by=4))
625325f1
 
86474139
     rightmost.x <- seq((1+shift),length.out=length(vector),by=1)   
     rightmost.y <- rep((0+shift),length(vector))
     Order<-c(Order,seq(min(Order)+2,length.out=length(uppermid.y),by=4))
 
     lowermid.x <- leftmost.x + 0.5
     lowermid.y <- leftmost.y - 0.5
     Order <- c(Order,seq(min(Order)+3,length.out=length(uppermid.y),by=4))
 
625325f1
     IDs <- factor(paste("Pixel",rightmost.x,distance+1,sep="."),
         levels=paste("Pixel",rightmost.x,distance+1,sep="."))
86474139
 
     if(!upper){
625325f1
         IDs <- factor(paste("Pixel",rightmost.x,(distance+1)*-1,sep="."),
             levels=paste("Pixel",rightmost.x,(distance+1)*-1,sep="."))
86474139
     }
 
     IDsRep <- rep(IDs,4)
 
625325f1
     horizontal.coords <- data.frame(xcoords = c(leftmost.x, uppermid.x, 
         rightmost.x, lowermid.x),
         ycoords = c(leftmost.y, uppermid.y, rightmost.y, lowermid.y), 
         ids = IDs, Distance = distance, Order=Order)
86474139
     if(!upper){
625325f1
         horizontal.coords[,"ycoords"] <- horizontal.coords[,"ycoords"] * -1
86474139
     }
 
     horizontal.values <- data.frame(ids=IDs,values=vector)
     horizontal.data <- merge(horizontal.values, horizontal.coords, by=c("ids"))
     horizontal.data <- horizontal.data[order(horizontal.data$Order),]
     return(horizontal.data)
 }
 
 RotateHeatmap = function(Matrix=NULL, value.var=NULL, upper = FALSE){
625325f1
     rotated.distance <- max(Matrix$dist)
     Rotated.df.list <- lapply(seq_len(rotated.distance),function(x){
         Distance <- x - 1
         Vector <- Matrix[Matrix$dist==x,value.var]
         Shift <- 0.5 * Distance
         Dataframe <- RotatePixels(shift = Shift, plot.order = 1, 
             vector = Vector, distance = Distance, upper = upper)
     })
     Rotated.df <- do.call(rbind,Rotated.df.list)
     return(Rotated.df)
86474139
 }
 
 make_boundaries_for_heatmap <- function(Object = NULL, region.start = NULL, 
6a22d578
     region.end = NULL, distance = NULL, cut_corners = FALSE){
625325f1
     if(is.null(distance)){
         distance <- region.end - region.start
     }
     Unique.groups <- unique(Object[,"groups"])
8ebacdac
     Object_split <- split(Object, paste(Object$groups, Object$dom.names, 
         Object$colours, sep = ":"))
     Group.list <- lapply(Object_split,function(current_domain){
         current_domain <- unique(current_domain)
         Brick.x <- unique(current_domain$groups)
         colours <- current_domain$colours[
         current_domain[,"type"] == "start"]
         domain_name <- current_domain$dom.names[
         current_domain[,"type"] == "start"]
         Start <- current_domain[
         current_domain[,"type"] == "start", "position"]
         End <- current_domain[
         current_domain[,"type"] == "end", "position"]
         if(Start < region.start & End >= region.start){
             # message("Here")
             Start <- region.start
             if((End - Start) > distance){
                 Start <- Start + distance
625325f1
             }
8ebacdac
             Coord.list <- list(x1 = c(Start,End),
                 y1 = c(End,End))
             Groups <- rep(paste(domain_name,Brick.x,c(1,2),sep = "."), 
                 each = 2)
         }else if(Start >= region.start & End <= region.end){
             # message("2nd Here")
             Coord.list <- list(x1 = c(Start - 1,Start - 1,End), 
                 y1 = c(Start - 1,End,End))
             Groups <- rep(paste(domain_name,Brick.x,sep = "."), 
                 each = 3)
             My.end <- End
             My.Start <- Start
             if((End - Start) > distance){
                 My.end <- Start + distance
                 My.Start <- End - distance
625325f1
             }
8ebacdac
             Coord.list <- list(x1 = c(Start - 1,Start - 1,
                 My.Start - 1,End), 
                 y1 = c(Start - 1,My.end,End,End))
             Groups <- rep(paste(domain_name,Brick.x,
                 c(1,2),
                 sep = "."), each = 2)
         }else if(Start <= region.end & End > region.end){
             # message("3rd Here")
             End <- region.end
             if((End - Start) > distance){
                 End <- Start + distance
625325f1
             }
8ebacdac
             Coord.list <- list(x1 = c(Start - 1,Start - 1),
             y1 = c(Start - 1,End))
             Groups <- rep(paste(domain_name,Brick.x,sep = "."),2)
         }
         if(Brick.x == 2){
             Coord.list <- rev(Coord.list)
         }
         Line <- data.frame(x = Coord.list[[1]], 
             y = Coord.list[[2]], colours = colours,
             line.group = Groups, group = paste("Group",Brick.x,sep = "."))
         if(length(Unique.groups)==1){
             Coord.list <- rev(Coord.list)
             Line.2 <- data.frame(x = Coord.list[[1]],
             y = Coord.list[[2]], colours = colours,
             line.group = Groups, group = paste("Group",Brick.x+1,sep = "."))
             Line <- rbind(Line,Line.2)
         }
         Line
625325f1
     })
     Group.df <- do.call(rbind,Group.list)
86474139
 }
 
625325f1
 make_boundaries_for_rotated_heatmap <- function(Object = NULL, 
     region.start = NULL, region.end = NULL, distance = NULL, 
6a22d578
     cut_corners = FALSE){
625325f1
     if(is.null(distance)){
         distance <- region.end - region.start
     }
     Shift.seed <- 0.5
     Span <- region.end - region.start
     Unique.groups <- unique(Object[,"groups"])
8ebacdac
     Object_split <- split(Object, paste(Object$groups, Object$dom.names, 
         Object$colours, sep = ":"))
     Group.list <- lapply(Object_split,function(current_domain){
528b5b15
         current_domain <- unique(current_domain)
         domain_name <- unique(current_domain[,"dom.names"])
         Brick.x <- unique(current_domain[,"groups"])
         colours <- current_domain$colours[
         current_domain[,"type"] == "start"]
         Start <- current_domain[
         current_domain[,"type"] == "start", "position"]
         End <- current_domain[
         current_domain[,"type"] == "end", "position"]
625325f1
 
528b5b15
         Normalised.start.bin <- Start - region.start
         Normalised.end.bin <- End - region.start
625325f1
 
528b5b15
         if(cut_corners){
             Max.dist <- (End - Start)/2
             if(Max.dist > distance){
625325f1
                 Max.dist <- distance/2
             }
528b5b15
         }else{
             Max.dist <- distance/2
         }
         Dist.up <- Max.dist
         if((Normalised.end.bin - (Max.dist*2)) < 0){
             Dist.up <- abs(0 - Normalised.end.bin)/2
         }
         x1.start <- Normalised.end.bin - Dist.up
         y1.start <- ifelse(Brick.x == 1, Dist.up, Dist.up*-1)
         x2.start <- Normalised.end.bin
         y2.start <- 0
         End.line <- data.frame(x=c(x1.start,x2.start),
         y=c(y1.start,y2.start), colours = colours,
         line.group = paste(Brick.x, domain_name, "end", sep = "."), 
         group = paste("Group",Brick.x,sep = "."),
         row.names = NULL)
625325f1
 
528b5b15
         Dist.down <- Max.dist
         if((Normalised.start.bin + (Max.dist*2)) > Span){
             Dist.down <- (Span - Normalised.start.bin)/ 2
         }
         x1.end <- Normalised.start.bin
         y1.end <- 0
         x2.end <- Normalised.start.bin + Dist.down
         y2.end <- ifelse(Brick.x == 1, Dist.down, Dist.down*-1)
         Start.line <- data.frame(x=c(x1.end,x2.end),
                 y=c(y1.end,y2.end), colours=colours,
                 line.group = paste(Brick.x, domain_name, 
                     "start", sep = "."),
                 group=paste("Group",Brick.x,sep = "."),row.names = NULL)
         Lines <- rbind(End.line,Start.line)
625325f1
     })
     Group.df <- do.call(rbind,Group.list)
     return(Group.df)
86474139
 }
 
af47efdf
 Format_boundaries_normal_heatmap <- function(Bricks = NULL, resolution, 
     Ranges = NULL, group_col = NULL, cut_corners = FALSE, colour.col = NULL, 
6a22d578
     colours = NULL, colours_names = NULL, region.chr = NULL, 
625325f1
     region.start = NULL, region.end = NULL, distance = NULL, 
     rotate = FALSE){
     Reference.object <- GenomicMatrix$new()
6a22d578
     if(!is.null(group_col)){
         Col.values <- unique(elementMetadata(Ranges)[[group_col]])
92e87bab
         if(length(Col.values) > 2 | !is.numeric(Col.values)){
6a22d578
             stop("group_col values must be numeric ",
92e87bab
                 "values corresponding to ",
                 "the number of Brick objects ",
                 "(max. 2) specified.\n")
625325f1
         }
     }else{
6a22d578
         group_col <- "pseudogroups"
625325f1
         Ranges.too <- Ranges
6a22d578
         elementMetadata(Ranges)[[group_col]] <- 1
         elementMetadata(Ranges.too)[[group_col]] <- 2
625325f1
         Ranges <- c(Ranges,Ranges.too)
     }
     
52b1400b
     if(is.null(colours)){
         stop("colours expects a vector of colours of at least length 1")
     }
     if(is.null(colour.col)){
625325f1
         colour.col <- "pseudo.colour.col"
         elementMetadata(Ranges)[[colour.col]] <- "My_Group"
     }
52b1400b
     Unique.colour.cols <- unique(elementMetadata(Ranges)[[colour.col]])
     if(length(Unique.colour.cols) != length(colours)){
         stop("colours length must be equal to ",
             "number of unique values present in ",
7e614c98
             colour.col,"\n",
             "Length of colours: ",length(colours),"\n",
             "Length of colour names: ",length(Unique.colour.cols),"\n",
             "Names: ",paste(Unique.colour.cols,collapse=","))
52b1400b
     }
6a22d578
     if(is.null(colours_names)){
         colours_names <- Unique.colour.cols
         names(colours) <- colours_names
625325f1
     }else{
6a22d578
         if(any(!(Unique.colour.cols %in% colours_names))){
             stop("Provided colours_names had differing values ",
52b1400b
                 "from unique values present in colour.cols")
         }
6a22d578
         names(colours) <- colours_names
625325f1
     }
86474139
 
8f8c5c6e
     chr.ranges <- Ranges[seqnames(Ranges) == region.chr]
625325f1
     chr.ranges <- chr.ranges[end(chr.ranges) >= region.start & 
     start(chr.ranges) <= region.end]
     region <- paste(region.chr, region.start, region.end, 
         sep = Reference.object$Ranges.separator)
af47efdf
     Region.positions <- Brick_return_region_position(Brick = Bricks[[1]], 
         resolution = resolution, 
625325f1
         region = region)
632a1a64
     Range.to.df.list <- lapply(seq_along(Bricks),function(Brick.x){
625325f1
         pos.ranges <- chr.ranges[
6a22d578
         elementMetadata(chr.ranges)[[group_col]] == Brick.x]
625325f1
         chrs <- as.vector(seqnames(pos.ranges))
         start <- start(pos.ranges)
         end <- end(pos.ranges)
af47efdf
         A.ranges <- Brick_fetch_range_index(Brick = Bricks[[Brick.x]], 
             chr = chrs, start = start, end = end, resolution = resolution)
8f8c5c6e
         Position.list <- A.ranges[seqnames(A.ranges) == region.chr]
625325f1
         check_if_only_one_ranges <- function(x){
             all(!is.na(Position.list$Indexes[[x]]))
         }
         if(!all(vapply(seq_along(Position.list), 
             check_if_only_one_ranges, TRUE))){
             stop("All ranges did not overlap with the bintable.\n")
         }
         Range.positions.start <- vapply(seq_along(Position.list),
             function(x){(min(Position.list$Indexes[[x]]))},1)
         Range.positions.end <- vapply(seq_along(Position.list),
             function(x){(max(Position.list$Indexes[[x]]))},1)
         Range.positions.names <- vapply(seq_along(Position.list),
             function(x){names(Position.list[x])},"")
         Start.df <- data.frame(dom.names = Range.positions.names, 
             position = Range.positions.start, 
632a1a64
             groups = Brick.x, type = "start", 
625325f1
             colours = elementMetadata(pos.ranges)[[colour.col]])
         End.df <- data.frame(dom.names = Range.positions.names, 
             position = Range.positions.end, 
632a1a64
             groups = Brick.x, type = "end", 
625325f1
             colours = elementMetadata(pos.ranges)[[colour.col]])
         All.df <- rbind(Start.df,End.df)
         All.df$dom.names <- as.character(All.df$dom.names)
         All.df
     })
     Range.to.df <- do.call(rbind, Range.to.df.list)
     if(rotate){
         Normal.heatmap.lines <- make_boundaries_for_rotated_heatmap(
6a22d578
             Object = Range.to.df, cut_corners = cut_corners,
625325f1
             region.start = min(Region.positions), 
             region.end = max(Region.positions), distance = distance)      
     }else{
         Normal.heatmap.lines <- make_boundaries_for_heatmap(
             Object = Range.to.df, region.start = min(Region.positions), 
             region.end = max(Region.positions), distance = distance)       
     }
     return(Normal.heatmap.lines)
86474139
 }
 
6a22d578
 Get_heatmap_theme <- function(x_axis=TRUE, y_axis=TRUE, 
     x_axis.text = NULL, y_axis.text = NULL, text_size = 10, 
     x_axis_text_size = 10, y_axis_text_size = 10,
     legend_title_text_size = 8, legend_text_size = 8, title_size = 10,
     legend_key_width = unit(3,"cm"), legend_key_height = unit(0.5,"cm")){
     if(!x_axis){
         x_axis.ticks <- element_blank()
         x_axis.text <- element_blank()
625325f1
     }else{
6a22d578
         x_axis.ticks <-element_line(colour = "#000000")
         x_axis.text <- element_text(colour = "#000000", size = x_axis_text_size)
625325f1
     }
6a22d578
     if(!y_axis){
         y_axis.ticks <- element_blank()
         y_axis.text <- element_blank()
625325f1
     }else{
6a22d578
         y_axis.ticks <-element_line(colour = "#000000")
         y_axis.text <- element_text(colour = "#000000", size = y_axis_text_size)
625325f1
     }
6a22d578
     Brick_theme <- theme_bw() + theme(text = element_text(size=text_size),
625325f1
                 plot.background=element_blank(),
                 panel.grid.minor=element_blank(),
                 panel.grid.major=element_blank(),
                 panel.background = element_blank(),
6a22d578
                 axis.title.x=x_axis.text,
                 axis.title.y=y_axis.text,
                 axis.text.x = x_axis.text,
                 axis.text.y = x_axis.text,
                 axis.ticks.x = x_axis.ticks,
                 axis.ticks.y = y_axis.ticks,
625325f1
                 legend.position="bottom",
af47efdf
                 legend.key.height = legend_key_height,
                 legend.key.width = legend_key_width,
                 legend.title=element_text(size=legend_title_text_size),
6a22d578
                 legend.text=element_text(size=legend_text_size),
                 plot.title=element_text(size=title_size))
632a1a64
     return(Brick_theme)
86474139
 }
 
6a22d578
 Get_heatmap_titles <- function(title = NULL, x_axis_title = NULL, 
     y_axis_title = NULL, legend_title = NULL, x_coords = NULL, 
     y_coords = NULL, rotate = NULL){
     if(is.null(legend_title)){
         legend_title <- "Signal"
625325f1
     }
6a22d578
     if(is.null(x_axis_title)){
         x_axis_title <- paste("Genomic position",x_coords,sep = " ")
625325f1
     }
6a22d578
     if(is.null(y_axis_title)){
         y_axis_title <- paste("Genomic position",y_coords,sep = " ")
625325f1
     }
     if(is.null(title)){
6a22d578
         title <- paste(x_coords,y_coords,sep = "-")
625325f1
     }
     if(rotate){
6a22d578
         y_axis_title <- "distance in bins"
625325f1
     }
6a22d578
     Labels <- c(x_axis_title, y_axis_title, title, legend_title)
     names(Labels) <- c("x_axis","y_axis","title","legend")
625325f1
     return(Labels)
86474139
 }
 
625325f1
 make_axis_coord_breaks <- function(from = NULL, to = NULL, 
     how.many = NULL, two.sample = FALSE){
     Breaks <- round(seq(from,to, length.out = how.many))
     if(two.sample){
         Breaks <- unique(c(rev(Breaks)*-1,Breaks))
     }
     return(Breaks)
86474139
 }
 
 rescale_values_for_colours <- function(Object = NULL, two.sample = FALSE){
     # require(scales)
625325f1
     Object$rescale <- 0
     if(two.sample){
         Object$rescale[Object$dist >= 0] <- rescale(
             Object$val[Object$dist >= 0]*-1,c(0,0.5))
         Object$rescale[Object$dist <= 0] <- rescale(
             (Object$val[Object$dist <= 0]),c(0.5,1))
     }else{
         Object$rescale <- rescale(Object$val,c(0,1))
     }
     return(Object$rescale)
86474139
 }
 
625325f1
 make_colour_breaks <- function(Object = NULL, how.many = NULL, 
     two.sample = NULL){
     values <- Object[,'rescale']
     distances <- Object[,'dist']
     if(two.sample){
         Value.dist.1 <- seq(min(values[distances >= 0]), 
             max(values[distances >= 0]), length.out = how.many)
         Value.dist.2 <- seq(min(values[distances <= 0]), 
             max(values[distances <= 0]), length.out = how.many)
         Value.dist <- unique(c(Value.dist.1,Value.dist.2))
86474139
 
625325f1
     }else{
         Value.dist <- seq(min(values),max(values),length.out = how.many)
     }
     return(Value.dist)
86474139
 }
 
625325f1
 get_legend_breaks <- function(Object = NULL, mid.val = 0.5, 
6a22d578
     how.many = 5, value_cap = NULL, colours = NULL, two.sample = NULL){
625325f1
     Len <- length(values)
     values <- Object[,'rescale']
     distances <- Object[,'dist']
     original.values <- Object[,'val']
     Upper.tri <- distances >= 0
     Lower.tri <- distances <= 0
     if(two.sample){
         Colour.breaks.1 <- seq(min(values),mid.val,length.out = 3)
         Colour.labs.1 <- round(seq(max(original.values[Upper.tri]), 
             min(original.values[Upper.tri]), length.out = 3), 2)
         Colour.breaks.2 <- seq(mid.val,max(values),length.out = 3)
         Colour.labs.2 <- round(seq(min(original.values[Lower.tri]), 
             max(original.values[Lower.tri]),length.out = 3),2)
         Colour.labs <- round(
             c(
                 Colour.labs.1, 
                 Colour.labs.2[2:length(Colour.labs.2)]),2)
         Colour.breaks <- unique(
             c(Colour.breaks.1,Colour.breaks.2))
         Colours <- c(rev(colours),colours)
6a22d578
         if(!is.null(value_cap)){
625325f1
             Colour.labs[1] <- paste(">",Colour.labs[1],sep = "")
             Colour.labs[length(Colour.labs)] <- paste(">",
                 Colour.labs[length(Colour.labs)],sep = "")
         }
60fdd192
         # message(Colour.labs,"\n")
625325f1
     }else{
         Colour.breaks <- seq(min(values),max(values),length.out = 5)
677a1a92
         Colour.labs <- format(seq(min(original.values),
             max(original.values),length.out = 5), scientific = TRUE)
6a22d578
         if(!is.null(value_cap)){
625325f1
             Colour.labs[length(Colour.labs)] <- paste(">",
                 Colour.labs[length(Colour.labs)], sep = "")
         }
         Colours <- colours
     }
     return(list("cols" = Colours, 
         "col.breaks" = Colour.breaks, "col.labs" = Colour.labs))
892eefaa
 }