web-dev-qa-db-fra.com

Diagramme d'accords en R

Existe-t-il un package dans cran qui pourrait tracer une disposition d'accords comme ceci: (cette visualisation est également appelée diagramme d'accords )

Chrod Diagramm

36
FUD

J'ai écrit ce qui suit il y a plusieurs années, mais je ne l'ai jamais vraiment utilisé: n'hésitez pas à l'adapter à vos besoins, ou même à le transformer en un package à part entière.

# Return a line in the Poincare disk, i.e.,
# a circle arc, perpendicular to the unit circle, through two given points.
poincare_segment <- function(u1, u2, v1, v2) {
    # Check that the points are sufficiently different
    if( abs(u1-v1) < 1e-6 && abs(u2-v2) < 1e-6 )
        return( list(x=c(u1,v1), y=c(u2,v2)) )
    # Check that we are in the circle
    stopifnot( u1^2 + u2^2 - 1 <= 1e-6 )
    stopifnot( v1^2 + v2^2 - 1 <= 1e-6 )
    # Check it is not a diameter
    if( abs( u1*v2 - u2*v1 ) < 1e-6 )
        return( list(x=c(u1,v1), y=c(u2,v2)) )
    # Equation of the line: x^2 + y^2 + ax + by + 1 = 0 (circles orthogonal to the unit circle)
    a <- ( u2 * (v1^2+v2^2) - v2 * (u1^2+u2^2) + u2 - v2 ) / ( u1*v2 - u2*v1 )
    b <- ( u1 * (v1^2+v2^2) - v1 * (u1^2+u2^2) + u1 - v1 ) / ( u2*v1 - u1*v2 ) # Swap 1's and 2's
    # Center and radius of the circle
    cx <- -a/2
    cy <- -b/2
    radius <- sqrt( (a^2+b^2)/4 - 1 )
    # Which portion of the circle should we draw?
    theta1 <- atan2( u2-cy, u1-cx )
    theta2 <- atan2( v2-cy, v1-cx )
    if( theta2 - theta1 > pi )
        theta2 <- theta2 - 2 * pi
    else if( theta2 - theta1 < - pi )
        theta2 <- theta2 + 2 * pi
    theta <- seq( theta1, theta2, length=100 )
    x <- cx + radius * cos( theta )
    y <- cy + radius * sin( theta )
    list( x=x, y=y )
}

# Sample data
n <- 10
m <- 7
segment_weight <- abs(rnorm(n))
segment_weight <- segment_weight / sum(segment_weight)
d <- matrix(abs(rnorm(n*n)),nr=n, nc=n)
diag(d) <- 0 # No loops allowed
# The weighted graph comes from two quantitative variables
d[1:m,1:m] <- 0
d[(m+1):n,(m+1):n] <- 0
ribbon_weight <- t(d) / apply(d,2,sum) # The sum of each row is 1; use as ribbon_weight[from,to]
ribbon_order <- t(apply(d,2,function(...)sample(1:n))) # Each row contains sample(1:n); use as ribbon_order[from,i]
segment_colour <- Rainbow(n)
segment_colour <- brewer.pal(n,"Set3")
transparent_segment_colour <- rgb(t(col2rgb(segment_colour)/255),alpha=.5)
ribbon_colour <- matrix(Rainbow(n*n), nr=n, nc=n) # Not used, actually...
ribbon_colour[1:m,(m+1):n] <- transparent_segment_colour[1:m]
ribbon_colour[(m+1):n,1:m] <- t(ribbon_colour[1:m,(m+1):n])

# Plot
gap <- .01
x <- c( segment_weight[1:m], gap, segment_weight[(m+1):n], gap )
x <- x / sum(x)
x <- cumsum(x)
segment_start <- c(0,x[1:m-1],x[(m+1):n])
segment_end   <- c(x[1:m],x[(m+2):(n+1)])
start1 <- start2 <- end1 <- end2 <- ifelse(is.na(ribbon_weight),NA,NA)
x <- 0
for (from in 1:n) {
  x <- segment_start[from]
  for (i in 1:n) {
    to <- ribbon_order[from,i]
    y <- x + ribbon_weight[from,to] * ( segment_end[from] - segment_start[from] )
    if( from < to ) {
      start1[from,to] <- x
      start2[from,to] <- y
    } else if( from > to ) {
      end1[to,from] <- x
      end2[to,from] <- y
    } else {
      # no loops allowed
    }
    x <- y
  }
}

par(mar=c(1,1,2,1))
plot(
  0,0, 
  xlim=c(-1,1),ylim=c(-1,1), type="n", axes=FALSE, 
  main="Two qualitative variables in polar coordinates", xlab="", ylab="")
for(from in 1:n) {
  for(to in 1:n) {
    if(from<to) {
      u <- start1[from,to]
      v <- start2[from,to]
      x <- end1  [from,to]
      y <- end2  [from,to]
      if(!is.na(u*v*x*y)) {
            r1 <- poincare_segment( cos(2*pi*v), sin(2*pi*v), cos(2*pi*x), sin(2*pi*x) )
            r2 <- poincare_segment( cos(2*pi*y), sin(2*pi*y), cos(2*pi*u), sin(2*pi*u) )
            th1 <- 2*pi*seq(u,v,length=20)
            th2 <- 2*pi*seq(x,y,length=20)
            polygon(
                c( cos(th1), r1$x, rev(cos(th2)), r2$x ),
                c( sin(th1), r1$y, rev(sin(th2)), r2$y ),
                col=transparent_segment_colour[from], border=NA
            )
      }
    }
  }
}
for(i in 1:n) {
  theta <- 2*pi*seq(segment_start[i], segment_end[i], length=100)
  r1 <- 1
  r2 <- 1.05
  polygon( 
    c( r1*cos(theta), rev(r2*cos(theta)) ),
    c( r1*sin(theta), rev(r2*sin(theta)) ),
    col=segment_colour[i], border="black"
  )
}

Two quantitative variables in polar coordinates

26
Vincent Zoonekynd

Le paquet chorddiag (toujours en développement) fournit un D3 la mise en oeuvre

Le package chorddiag permet de créer des diagrammes d'accords interactifs en utilisant la bibliothèque de visualisation JavaScript D3 ( http://d3js.org ) à partir de R en utilisant le cadre d'interface htmlwidgets.

Exemple

devtools::install_github("mattflor/chorddiag")
library(chorddiag)

## example taken from the github site
m <- matrix(c(11975,  5871, 8916, 2868,
              1951, 10048, 2060, 6171,
              8010, 16145, 8090, 8045,
              1013,   990,  940, 6907),
            byrow = TRUE,
            nrow = 4, ncol = 4)
haircolors <- c("black", "blonde", "brown", "red")
dimnames(m) <- list(have = haircolors,
                    prefer = haircolors)
m
#             prefer
#   have     black blonde brown  red
#     black  11975   5871  8916 2868
#     blonde  1951  10048  2060 6171
#     brown   8010  16145  8090 8045
#     red     1013    990   940 6907

groupColors <- c("#000000", "#FFDD89", "#957244", "#F26223")
chorddiag(m, groupColors = groupColors, groupnamePadding = 40)

screenshot

15
SymbolixAU

Dans le cas où vous ne cherchez pas à tracer particulièrement des données génomiques, mais des données de n'importe quel domaine, je pense que le package récemment publié circule: Visualisation circulaire en R fournit une approche plus simple que RCircos .

circlize example

10
leo9r

Cela ressemble beaucoup à un tracé Circos . Circos est implémenté en Perl, mais vous pouvez utiliser R pour façonner vos données afin de les alimenter dans Circos. Il existe cependant une question connexe chez BioStar: http://www.biostars.org/p/17728/

3
wint3rschlaefer

si vous connaissez ggplot, alors ggbio est le chemin à parcourir.

La documentation est disponible ici: http://www.tengfei.name/ggbio/

La fonction pour tracer des tracés circulaires est layout_circle (). Layout_karyogram () est une autre fonction très utile pour tracer des données génomiques.

2
Matahi